[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SET method not defined automatically...
- To: info-macl@cambridge.apple.com
- Subject: SET method not defined automatically...
- From: frege@eecs.umich.edu
- Date: Thu, 13 Aug 1992 14:40:03 -0400
I meant SETF not SET.
In the following file, a customized version of defstruct is defined
but when I use it with MCL 2.0 the SETF methods for each of its slots
seems not to be defined automatically. This was not the case in MACL 1.3.2.
Please help!
(defmacro defxstruct (name-and-options &REST slot-descriptions)
"DEFXSTRUCT name-and-options [doc-string] {slot-description}*
This macro extends the capabilities of the Common Lisp DEFSTRUCT
macro. A new option :EXPORT is provided. It must appear as an
atom in the name and options list, and indicates that all generated
symbol names should be exported (slot accessors can be overridden using
:EXPORT slot keyword--see below). In addition, the options :CONC-NAME,
:CONSTRUCTOR, :COPIER, :INCLUDE, and :PREDICATE can be given an
additional :EXPORT modifier as the last element of their options list.
The :EXPORT modifier causes the symbol names generated by that option
to be exported. Finally, each slot description can also have an
:EXPORT keyword followed by a nil/non-nil value.
Note that the slot name symbols themselves are not exported by defxstruct."
(multiple-value-bind (name-and-options exports export-conc-names conc-name)
(parse-name-and-options name-and-options)
(multiple-value-bind (slot-descriptions conc-name-exports)
(parse-slot-descriptions slot-descriptions
export-conc-names
conc-name)
`(progn
(export ',(nconc exports conc-name-exports))
(defstruct ,name-and-options ,@slot-descriptions)))))
;;;
;;; Helper Functions :::
;;;
(defun parse-name-and-options (name-and-options)
;; Modified version of Spice Lisp parse-name-and-options function ::
(when (atom name-and-options)
(setq name-and-options (list name-and-options)))
(let* ((type-symbol (first name-and-options))
(name (symbol-name type-symbol))
(conc-name (concatenate 'simple-string (string name) "-"))
(constructor (form-function-name "MAKE-" name))
(boa-constructors '())
(copier (form-function-name "COPY-" name))
(predicate (form-function-name name "-P"))
(include nil)
(include-slots '())
(saw-constructor nil)
(export-all nil)
(export-type nil)
(export-conc-names nil)
(export-include-names nil)
(exports '())
(boa-exports '()))
(setf (rest name-and-options)
(mapc-condcons
#'(lambda (option)
(cond ((atom option) ; Atomic options
(case option
(:CONSTRUCTOR
(setq saw-constructor t)
(setq constructor
(form-function-name "MAKE-" name))
option) ; Return the option.
(:EXPORT
(setq export-all t)
nil) ; Return NIL.
(otherwise option))) ; Return the option.
(t ; List'ed option
(let ((option-name (first option))
(args (rest option)))
(case option-name
(:CONC-NAME
(setq conc-name (first args))
(when (eq :EXPORT (second args))
(delete-nth 1 args)
(setq export-conc-names t))
option) ; Return the option.
(:CONSTRUCTOR
(cond ((rest args)
(unless saw-constructor
(setq constructor nil))
(push (first args) boa-constructors)
(when (eq :EXPORT (third args))
(delete-nth 2 args)
(push (first args) boa-exports)))
(t (unless (symbolp (first args))
(error "Constructor symbol ~S is n
ot a symbol."
(first args)))
(setq constructor (first args))))
(when (eq :EXPORT (second args))
(delete-nth 1 args)
(push 'constructor exports))
option) ; Return the option.
(:COPIER
(setq copier (first args))
(when (eq :EXPORT (second args))
(delete-nth 1 args)
(push 'copier exports))
option) ; Return the option.
(:EXPORT
(dolist (arg (rest args))
(case arg
(:ALL (setq export-all t))
(:TYPE (setq export-type t))
(otherwise
(error
"Illegal :EXPORT option ~S."
arg)))))
(:PREDICATE
(setq predicate (first args))
(when (eq :EXPORT (second args))
(delete-nth 1 args)
(push 'predicate exports))
option) ; Return the option.
(:INCLUDE
(setq include (first args))
(setq include-slots
(find-included-slot-names include))
(when (eq :EXPORT (second args))
(delete-nth 1 args)
(setq export-include-names t))
option) ; Return the option.
(otherwise option)))))) ; Return the option.
(rest name-and-options)))
(let ((temp nil))
(cond (export-all
(setq temp boa-constructors)
(push type-symbol temp)
(dolist (slot include-slots)
(push (form-function-name conc-name
(symbol-name slot))
temp))
(when constructor
(push constructor temp))
(when copier
(push copier temp))
(when predicate
(push predicate temp))
(setq export-conc-names t)
(setq export-include-names t))
(t (setq temp boa-exports)
(when export-type
(push type-symbol temp))
(when export-include-names
(dolist (slot include-slots)
(push (form-function-name conc-name
(symbol-name slot))
temp)))
(when (and constructor
(member 'constructor exports :TEST #'eq))
(push constructor temp))
(when (and copier
(member 'copier exports :TEST #'eq))
(push copier temp))
(when (and predicate
(member 'predicate exports :TEST #'eq))
(push predicate temp))))
(values name-and-options temp export-conc-names conc-name))))
(defun find-included-slot-names (symbol)
(structure-slot-names symbol))
(defun parse-slot-descriptions (slots export-conc-names conc-name &AUX exports)
(setq slots
(mapc-condcons
#'(lambda (slot)
(cond ((stringp slot)
slot) ; Assume it is a doc string.
((atom slot)
(when export-conc-names
(push (form-function-name
conc-name
(symbol-name slot))
exports))
slot) ; Return the slot
(t
(let ((new-options '()))
(do ((options (cddr slot) (cddr options))
(slot-name (first slot))
(export-conc-name export-conc-names))
((null options)
(when export-conc-name
(push (form-function-name
conc-name
(symbol-name slot-name))
exports)))
(cond ((eq (first options) :EXPORT)
(setq export-conc-name t))
((and (consp (first options))
(eq (first (first options)) :EXPORT))
(setq export-conc-name (second (first options)
)))
(t (setq new-options
(list* (second options)
(first options)
new-options)))))
(when (cddr slot)
(setf (cddr slot) (nreverse new-options)))
slot)))) ; Return updated slot.
slots))
(values slots exports))
(defun form-function-name (name1 name2)
(intern (string-concatenate (string name1) (string name2))))