From 7b9a9f98d89c0d36f3f8b521a632e4894416557d Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Fri, 22 Dec 2006 17:39:41 +0000 Subject: [PATCH] Fix issue reported by Albert Reiner, cmucl-help, 2006/10/20, and fix another issue with uninitialized &aux variables. (defstruct (foobar (:constructor make-foobar (xxx &key (aaa nil) (bbb nil) &aux (foobar-data xxx) (aaa (or aaa (getf foobar-data :aaa) 1)) (bbb (or bbb (getf foobar-data :bbb) (1+ aaa)))))) (aaa (required-argument) :type fixnum) (bbb (required-argument) :type fixnum)) (make-foobar nil) -> #<foobar :aaa 1 :bbb 2> But CMUCL gives type errors. To fix Albert's issue, modify CREATE-BOA-CONSTRUCTOR to keep track of the &aux vars separately from the other arglist vars. Adjust CREATE-VECTOR-CONSTRUCTOR, CREATE-LIST-CONSTRUCTOR, CREATE-STRUCTURE-CONSTRUCTOR, and CREATE-FIN-CONSTRUCTOR to take an extra arg for the &aux vars. For CREATE-STRUCTURE-CONSTRUCTOR, we only put declarations for the other arglist vars. To make sure we store the right kinds of objects into the slots, we also wrap (the <type> init) for each initial value. Also CLHS 3.4.6 has an example of a boa constructor using an aux variable without an initializer. CMUCL was not handling that right. Modify CREATE-BOA-CONSTRUCTOR to change the initializer to use (or <aux> slot-default-value) to get the correct default value into the slot if the aux variable doesn't. --- code/defstruct.lisp | 46 +++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index e4018cb15..58c04e234 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)))))) -- GitLab