diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 94e77e3c7462b4428426d3a5024714c07b15cd3a..54adf67734fd25c490455e6b7371a00e37955663 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.29 1991/12/14 08:56:10 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.30 1992/03/09 14:55:49 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -138,28 +138,30 @@ (make-load-form-fun nil) (make-load-form-fun-p nil)) ((null options) - (make-defstruct-description - :name name - :conc-name conc-name - :constructors - (if constructor-opt-p - (nreverse constructors) - (list (concat-pnames 'make- name))) - :boa-constructors boa-constructors - :copier copier - :predicate predicate - :include include - :print-function print-function - :type type - :lisp-type (cond ((eq type 'structure) 'simple-vector) - ((eq type 'vector) 'simple-vector) - ((eq type 'list) 'list) - ((and (listp type) (eq (car type) 'vector)) - (cons 'simple-array (cdr type))) - (t (error "~S is a bad :TYPE for Defstruct." type))) - :named (if saw-type saw-named t) - :offset offset - :make-load-form-fun make-load-form-fun)) + (let ((named (if saw-type saw-named t))) + (make-defstruct-description + :name name + :conc-name conc-name + :constructors + (if constructor-opt-p + (nreverse constructors) + (list (concat-pnames 'make- name))) + :boa-constructors boa-constructors + :copier copier + :predicate predicate + :include include + :print-function print-function + :type type + :length (if named 1 0) + :lisp-type (cond ((eq type 'structure) 'simple-vector) + ((eq type 'vector) 'simple-vector) + ((eq type 'list) 'list) + ((and (listp type) (eq (car type) 'vector)) + (cons 'simple-array (cdr type))) + (t (error "~S is a bad :TYPE for Defstruct." type))) + :named named + :offset offset + :make-load-form-fun make-load-form-fun))) (if (atom (car options)) (case (car options) (:constructor @@ -224,6 +226,52 @@ ;;;; Stuff to parse slot descriptions. +;;; PARSE-1-DSD -- Internal +;;; +;;; Parse a slot description for DEFSTRUCT and add it to the description. +;;; If supplied, ISLOT is a pre-initialized DSD that we modify to get the new +;;; slot. This is supplied when handling included slots. If the new accessor +;;; name is EQ to the included name, then set the DSD-ACCESSOR to NIL so that +;;; we don't clobber the more general accessor. +;;; +(defun parse-1-dsd (defstruct spec &optional + (islot (make-defstruct-slot-description + :%name "" :index 0 :type t))) + (multiple-value-bind + (name default default-p type type-p read-only ro-p) + (cond + ((listp spec) + (destructuring-bind (name &optional (default nil default-p) + &key (type nil type-p) (read-only nil ro-p)) + spec + (values name default default-p type type-p read-only ro-p))) + (t + (when (keywordp spec) + (warn "Keyword slot name indicates possible syntax ~ + error in DEFSTRUCT -- ~S." + spec)) + spec)) + (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) + (error "Duplicate slot name ~S." name)) + (setf (dsd-%name islot) (string name)) + (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) + (let ((aname (concat-pnames (dd-conc-name defstruct) name))) + (setf (dsd-accessor islot) + (if (eq aname (dsd-accessor islot)) + nil + aname))) + + (when default-p + (setf (dsd-default islot) default)) + (when type-p + (setf (dsd-type islot) type)) + (when ro-p + (setf (dsd-read-only islot) read-only)) + (setf (dsd-index islot) (dd-length defstruct)) + (incf (dd-length defstruct))) + (undefined-value)) + + ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does ;;; any structure inclusion that needs to be done. ;;; @@ -234,83 +282,30 @@ (setq slots (cdr slots))) ;; Then include stuff. We add unparsed items to the start of the Slots. (when (dd-include defstruct) - (let* ((included-name (car (dd-include defstruct))) - (included-thing (info type structure-info included-name)) - (modified-slots (cdr (dd-include defstruct)))) - (unless included-thing - (error "Cannot find description of structure ~S to use for inclusion." - included-name)) - (setf (dd-includes defstruct) - (cons (dd-name included-thing) (dd-includes included-thing))) - (setf (dd-offset defstruct) (dd-offset included-thing)) - (do* ((islots (mapcar #'(lambda (slot) - `(,(dsd-name slot) ,(dsd-default slot) - :type ,(dsd-type slot) - :read-only ,(dsd-read-only slot))) - (dd-slots included-thing))) - (islots* islots (cdr islots*))) - ((null islots*) - (setq slots (nconc islots slots))) - (let* ((islot (car islots*)) - (modifiee (find (car islot) modified-slots - :key #'(lambda (x) (if (atom x) x (car x))) - :test #'string=))) - (when modifiee - (cond ((symbolp modifiee) - ;; If it's just a symbol, nilify the default. - (setf (cadr islot) nil)) - ((listp modifiee) - ;; If it's a list, parse new defaults and options. - (setf (cadr islot) (cadr modifiee)) - (when (cddr modifiee) - (do ((options (cddr modifiee) (cddr options))) - ((null options)) - (case (car options) - (:type - (setf (cadddr islot) (cadr options))) - (:read-only - (setf (cadr (cddddr islot)) (cadr options))) - (t - (error "Bad option in included slot spec: ~S." - (car options))))))))))))) + (destructuring-bind (included-name &rest modified-slots) + (dd-include defstruct) + (let ((included-thing + (or (info type structure-info included-name) + (error "Cannot find description of structure ~S ~ + to use for inclusion." + included-name)))) + (setf (dd-includes defstruct) + (cons (dd-name included-thing) (dd-includes included-thing))) + (incf (dd-offset defstruct) (dd-offset included-thing)) + (incf (dd-length defstruct) (dd-offset defstruct)) + (dolist (islot (dd-slots included-thing)) + (let* ((iname (dsd-name islot)) + (modified (or (find iname modified-slots + :key #'(lambda (x) (if (atom x) x (car x))) + :test #'string=) + `(,iname)))) + (parse-1-dsd defstruct modified + (copy-defstruct-slot-description islot))))))) + ;; Finally parse the slots into Slot-Description objects. - (do ((slots slots (cdr slots)) - (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) - (1+ index)) - (descriptions ())) - ((null slots) - (setf (dd-length defstruct) index) - (setf (dd-slots defstruct) (nreverse descriptions))) - (let* ((slot (car slots)) - (name (if (atom slot) slot (car slot)))) - (when (keywordp name) - (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~ - -- ~S." - name)) - (push - (if (atom slot) - (make-defstruct-slot-description - :%name (string name) - :index index - :accessor (concat-pnames (dd-conc-name defstruct) name) - :type t) - (do ((options (cddr slot) (cddr options)) - (default (cadr slot)) - (type t) - (read-only nil)) - ((null options) - (make-defstruct-slot-description - :%name (string name) - :index index - :accessor (concat-pnames (dd-conc-name defstruct) name) - :default default - :type type - :read-only read-only)) - (case (car options) - (:type (setq type (cadr options))) - (:read-only (setq read-only (cadr options)))))) - descriptions)))) - + (dolist (slot slots) + (parse-1-dsd defstruct slot)) + (undefined-value)) ;;;; Default structure access and copiers: @@ -403,28 +398,29 @@ (dolist (slot (dd-slots info)) (let ((dsd slot)) - (setf (symbol-function (dsd-accessor slot)) - #'(lambda (structure) - (declare (optimize (speed 3) (safety 0))) - (unless (typep-to-structure structure info) - (error "Structure for accessor ~S is not a ~S:~% ~S" - (dsd-accessor dsd) (dd-name info) structure)) - (structure-ref structure (dsd-index dsd)))) - - (unless (dsd-read-only slot) - (setf (fdefinition `(setf ,(dsd-accessor slot))) - #'(lambda (new-value structure) + (when (dsd-accessor slot) + (setf (symbol-function (dsd-accessor slot)) + #'(lambda (structure) (declare (optimize (speed 3) (safety 0))) (unless (typep-to-structure structure info) - (error "Structure for setter ~S is not a ~S:~% ~S" - `(setf ,(dsd-accessor dsd)) (dd-name info) - structure)) - (unless (typep new-value (dsd-type dsd)) - (error "New-Value for setter ~S is not a ~S:~% ~S." - `(setf ,(dsd-accessor dsd)) (dsd-type dsd) - new-value)) - (setf (structure-ref structure (dsd-index dsd)) - new-value)))))) + (error "Structure for accessor ~S is not a ~S:~% ~S" + (dsd-accessor dsd) (dd-name info) structure)) + (structure-ref structure (dsd-index dsd)))) + + (unless (dsd-read-only slot) + (setf (fdefinition `(setf ,(dsd-accessor slot))) + #'(lambda (new-value structure) + (declare (optimize (speed 3) (safety 0))) + (unless (typep-to-structure structure info) + (error "Structure for setter ~S is not a ~S:~% ~S" + `(setf ,(dsd-accessor dsd)) (dd-name info) + structure)) + (unless (typep new-value (dsd-type dsd)) + (error "New-Value for setter ~S is not a ~S:~% ~S." + `(setf ,(dsd-accessor dsd)) (dsd-type dsd) + new-value)) + (setf (structure-ref structure (dsd-index dsd)) + new-value))))))) (when (dd-predicate info) (setf (symbol-function (dd-predicate info))