diff --git a/code/defstruct.lisp b/code/defstruct.lisp index e4018cb1598e554e99ff91cc7bcd0d3ec2bb51d6..58c04e234d7c332d5dea06959a0169fe5480582c 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.96 2005/10/21 17:56:07 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.97 2006/12/22 17:39:41 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -878,12 +878,12 @@ ;;; 4] funcallable structures are weird. ;;; (defun create-vector-constructor - (defstruct cons-name arglist vars types values) + (defstruct cons-name arglist vars aux-vars types values) (let ((temp (gensym)) (etype (dd-element-type defstruct))) `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) - vars types)) + (append vars aux-vars) types)) (let ((,temp (make-array ,(dd-length defstruct) :element-type ',(dd-element-type defstruct)))) ,@(mapcar #'(lambda (x) @@ -895,7 +895,7 @@ ,temp)))) ;;; (defun create-list-constructor - (defstruct cons-name arglist vars types values) + (defstruct cons-name arglist vars aux-vars types values) (let ((vals (make-list (dd-length defstruct) :initial-element nil))) (dolist (x (find-name-indices defstruct)) (setf (elt vals (cdr x)) `',(car x))) @@ -904,17 +904,21 @@ `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (append vars aux-vars) types)) (list ,@vals)))) ;;; (defun create-structure-constructor - (defstruct cons-name arglist vars types values) + (defstruct cons-name arglist vars aux-vars types values) (let* ((temp (gensym)) (raw-index (dd-raw-index defstruct)) (n-raw-data (when raw-index (gensym)))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (declare ,@(remove nil + (mapcar #'(lambda (var type) + (unless (member var aux-vars) + `(type ,type ,var))) + vars types))) + (let ((,temp (truly-the ,(dd-name defstruct) (%make-instance ,(dd-length defstruct)))) ,@(when n-raw-data @@ -929,17 +933,21 @@ (multiple-value-bind (accessor index data) (slot-accessor-form defstruct dsd temp n-raw-data) - `(setf (,accessor ,data ,index) ,value))) + (let* ((res (dsd-type dsd)) + (type (if res + `(the ,res ,value) + value))) + `(setf (,accessor ,data ,index) ,type)))) (dd-slots defstruct) values) ,temp)))) ;;; (defun create-fin-constructor - (defstruct cons-name arglist vars types values) + (defstruct cons-name arglist vars aux-vars types values) (let ((temp (gensym))) `(defun ,cons-name ,arglist (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (append vars aux-vars) types)) (let ((,temp (truly-the ,(dd-name defstruct) (%make-funcallable-instance @@ -970,7 +978,7 @@ (vals dum))) (funcall creator defstruct (dd-default-constructor defstruct) - (arglist) (vals) (types) (vals)))) + (arglist) (vals) nil (types) (vals)))) ;;; CREATE-BOA-CONSTRUCTOR -- Internal @@ -983,6 +991,7 @@ (kernel:parse-lambda-list (second boa)) (collect ((arglist) (vars) + (aux-vars) (types)) (labels ((get-slot (name) (let ((res (find name (dd-slots defstruct) :test #'string= @@ -1050,14 +1059,19 @@ (let* ((arg (if (consp arg) arg (list arg))) (var (first arg))) (arglist arg) - (vars var) + (aux-vars var) (types (get-slot var)))))) (funcall creator defstruct (first boa) - (arglist) (vars) (types) + (arglist) (vars) (aux-vars) (types) (mapcar #'(lambda (slot) - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot))) + (let ((v (find (dsd-name slot) (vars) :test #'string=))) + (if v + v + (let ((aux (find (dsd-name slot) (aux-vars) :test #'string=))) + (if aux + `(or ,aux ,(dsd-default slot)) + (dsd-default slot)))))) (dd-slots defstruct))))))