home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #18 / NN_1992_18.iso / spool / comp / lang / lisp / mcl / 1221 < prev    next >
Encoding:
Text File  |  1992-08-13  |  10.8 KB  |  231 lines
  1. Path: sparky!uunet!elroy.jpl.nasa.gov!ames!data.nas.nasa.gov!taligent!apple!cambridge.apple.com!frege@crim.eecs.umich.edu
  2. From: frege@eecs.umich.edu
  3. Newsgroups: comp.lang.lisp.mcl
  4. Subject: SET method not defined automatically...
  5. Message-ID: <199208131840.AA04384@crim.eecs.umich.edu>
  6. Date: 13 Aug 92 18:40:03 GMT
  7. Sender: info-mcl-request@cambridge.apple.com
  8. Lines: 219
  9. Approved: comp.lang.lisp.mcl@Cambridge.Apple.C0M
  10. Original-To: info-macl@cambridge.apple.com
  11.  
  12.  
  13.    
  14.    I meant SETF not SET.
  15.  
  16.    In the following file, a customized version of defstruct is defined
  17. but when I use it with MCL 2.0 the SETF methods for each of its slots
  18. seems not to be defined automatically. This was not the case in MACL 1.3.2.
  19.  
  20. Please help!
  21.  
  22. (defmacro defxstruct (name-and-options &REST slot-descriptions)
  23.  
  24.   "DEFXSTRUCT name-and-options [doc-string] {slot-description}*
  25.  
  26. This macro extends the capabilities of the Common Lisp DEFSTRUCT
  27. macro.  A new option :EXPORT is provided.  It must appear as an
  28. atom in the name and options list, and indicates that all generated
  29. symbol names should be exported (slot accessors can be overridden using
  30. :EXPORT slot keyword--see below).  In addition, the options :CONC-NAME,
  31. :CONSTRUCTOR, :COPIER, :INCLUDE, and :PREDICATE can be given an
  32. additional :EXPORT modifier as the last element of their options list.
  33. The :EXPORT modifier causes the symbol names generated by that option
  34. to be exported.  Finally, each slot description can also have an
  35. :EXPORT keyword followed by a nil/non-nil value.
  36.  
  37. Note that the slot name symbols themselves are not exported by defxstruct."
  38.  
  39.   (multiple-value-bind (name-and-options exports export-conc-names conc-name)
  40.                        (parse-name-and-options name-and-options)
  41.     (multiple-value-bind (slot-descriptions conc-name-exports)
  42.                          (parse-slot-descriptions slot-descriptions
  43.                                                   export-conc-names
  44.                                                   conc-name)
  45.       `(progn
  46.          (export ',(nconc exports conc-name-exports))
  47.          (defstruct ,name-and-options ,@slot-descriptions)))))
  48.  
  49.  
  50. ;;;
  51. ;;; Helper Functions :::
  52. ;;;
  53.  
  54. (defun parse-name-and-options (name-and-options)
  55.   ;; Modified version of Spice Lisp parse-name-and-options function ::
  56.   (when (atom name-and-options)
  57.     (setq name-and-options (list name-and-options)))
  58.   (let* ((type-symbol (first name-and-options))
  59.          (name (symbol-name type-symbol))
  60.          (conc-name (concatenate 'simple-string (string name) "-"))
  61.          (constructor (form-function-name "MAKE-" name))
  62.          (boa-constructors '())
  63.          (copier (form-function-name "COPY-" name))
  64.          (predicate (form-function-name name "-P"))
  65.          (include nil)
  66.          (include-slots '())
  67.          (saw-constructor nil)
  68.          (export-all nil)
  69.          (export-type nil)
  70.          (export-conc-names nil)
  71.          (export-include-names nil)
  72.          (exports '())
  73.          (boa-exports '()))
  74.     (setf (rest name-and-options)
  75.           (mapc-condcons
  76.               #'(lambda (option)
  77.                   (cond ((atom option)   ; Atomic options
  78.                          (case option
  79.                            (:CONSTRUCTOR
  80.                                (setq saw-constructor t)
  81.                                (setq constructor
  82.                                      (form-function-name "MAKE-" name))
  83.                                option)   ; Return the option.
  84.                            (:EXPORT
  85.                                (setq export-all t)
  86.                                nil)      ; Return NIL.
  87.                            (otherwise option)))   ; Return the option.
  88.                         (t               ; List'ed option
  89.                            (let ((option-name (first option))
  90.                                  (args (rest option)))
  91.                              (case option-name
  92.                                (:CONC-NAME
  93.                                    (setq conc-name (first args))
  94.                                    (when (eq :EXPORT (second args))
  95.                                      (delete-nth 1 args)
  96.                                      (setq export-conc-names t))
  97.                                    option)   ; Return the option.
  98.                                (:CONSTRUCTOR
  99.                                    (cond ((rest args)
  100.                                           (unless saw-constructor
  101.                                             (setq constructor nil))
  102.                                           (push (first args) boa-constructors)
  103.                                           (when (eq :EXPORT (third args))
  104.                                             (delete-nth 2 args)
  105.                                             (push (first args) boa-exports)))
  106.                                          (t (unless (symbolp (first args))
  107.                                               (error "Constructor symbol ~S is n
  108. ot a symbol."
  109.                                                      (first args)))
  110.                                             (setq constructor (first args))))
  111.                                    (when (eq :EXPORT (second args))
  112.                                      (delete-nth 1 args)
  113.                                      (push 'constructor exports))
  114.                                    option)   ; Return the option.
  115.                                (:COPIER
  116.                                    (setq copier (first args))
  117.                                    (when (eq :EXPORT (second args))
  118.                                      (delete-nth 1 args)
  119.                                      (push 'copier exports))
  120.                                    option)   ; Return the option.
  121.                                (:EXPORT
  122.                                    (dolist (arg (rest args))
  123.                                      (case arg
  124.                                        (:ALL (setq export-all t))
  125.                                        (:TYPE (setq export-type t))
  126.                                        (otherwise
  127.                                            (error
  128.                                                "Illegal :EXPORT option ~S."
  129.                                                arg)))))
  130.                                (:PREDICATE
  131.                                    (setq predicate (first args))
  132.                                    (when (eq :EXPORT (second args))
  133.                                      (delete-nth 1 args)
  134.                                      (push 'predicate exports))
  135.                                    option)   ; Return the option.
  136.                                (:INCLUDE
  137.                                    (setq include (first args))
  138.                                    (setq include-slots
  139.                                          (find-included-slot-names include))
  140.                                    (when (eq :EXPORT (second args))
  141.                                      (delete-nth 1 args)
  142.                                      (setq export-include-names t))
  143.                                    option)   ; Return the option.
  144.                                (otherwise option))))))   ; Return the option.
  145.               (rest name-and-options)))
  146.     (let ((temp nil))
  147.             (cond (export-all
  148.                       (setq temp boa-constructors)
  149.                       (push type-symbol temp)
  150.                       (dolist (slot include-slots)
  151.                         (push (form-function-name conc-name
  152.                                                   (symbol-name slot))
  153.                               temp))
  154.                       (when constructor
  155.                         (push constructor temp))
  156.                       (when copier
  157.                         (push copier temp))
  158.                       (when predicate
  159.                         (push predicate temp))
  160.                       (setq export-conc-names t)
  161.                       (setq export-include-names t))
  162.                   (t (setq temp boa-exports)
  163.                      (when export-type
  164.                        (push type-symbol temp))
  165.                      (when export-include-names
  166.                        (dolist (slot include-slots)
  167.                          (push (form-function-name conc-name
  168.                                                    (symbol-name slot))
  169.                                temp)))
  170.                      (when (and constructor
  171.                                 (member 'constructor exports :TEST #'eq))
  172.                        (push constructor temp))
  173.                      (when (and copier
  174.                                 (member 'copier exports :TEST #'eq))
  175.                        (push copier temp))
  176.                      (when (and predicate
  177.                                 (member 'predicate exports :TEST #'eq))
  178.                        (push predicate temp))))
  179.             (values name-and-options temp export-conc-names conc-name))))
  180.  
  181.  
  182. (defun find-included-slot-names (symbol)
  183.   (structure-slot-names symbol))
  184.  
  185.  
  186. (defun parse-slot-descriptions (slots export-conc-names conc-name &AUX exports)
  187.   (setq slots
  188.         (mapc-condcons
  189.             #'(lambda (slot)
  190.                 (cond ((stringp slot)
  191.                        slot)   ; Assume it is a doc string.
  192.                       ((atom slot)
  193.                        (when export-conc-names
  194.                          (push (form-function-name
  195.                                  conc-name
  196.                                  (symbol-name slot))
  197.                                exports))
  198.                        slot)   ; Return the slot
  199.                       (t
  200.                        (let ((new-options '()))
  201.                          (do ((options (cddr slot) (cddr options))
  202.                               (slot-name (first slot))
  203.                               (export-conc-name export-conc-names))
  204.                              ((null options)
  205.                               (when export-conc-name
  206.                                 (push (form-function-name
  207.                                         conc-name
  208.                                         (symbol-name slot-name))
  209.                                       exports)))
  210.                            (cond ((eq (first options) :EXPORT)
  211.                                   (setq export-conc-name t))
  212.                                  ((and (consp (first options))
  213.                                        (eq (first (first options)) :EXPORT))
  214.                                   (setq export-conc-name (second (first options)
  215. )))
  216.                                  (t (setq new-options
  217.                                           (list* (second options)
  218.                                                  (first options)
  219.                                                  new-options)))))
  220.                          (when (cddr slot)
  221.                            (setf (cddr slot) (nreverse new-options)))
  222.                          slot))))      ; Return updated slot.
  223.             slots))
  224.   (values slots exports))
  225.  
  226.  
  227. (defun form-function-name (name1 name2)
  228.   (intern (string-concatenate (string name1) (string name2))))
  229.  
  230.                                        
  231.