Skip to content
Snippets Groups Projects
Commit 7b9a9f98 authored by rtoy's avatar rtoy
Browse files

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.
parent dd7132b7
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -878,12 +878,12 @@
;;; 4] funcallable structures are weird. ;;; 4] funcallable structures are weird.
;;; ;;;
(defun create-vector-constructor (defun create-vector-constructor
(defstruct cons-name arglist vars types values) (defstruct cons-name arglist vars aux-vars types values)
(let ((temp (gensym)) (let ((temp (gensym))
(etype (dd-element-type defstruct))) (etype (dd-element-type defstruct)))
`(defun ,cons-name ,arglist `(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
vars types)) (append vars aux-vars) types))
(let ((,temp (make-array ,(dd-length defstruct) (let ((,temp (make-array ,(dd-length defstruct)
:element-type ',(dd-element-type defstruct)))) :element-type ',(dd-element-type defstruct))))
,@(mapcar #'(lambda (x) ,@(mapcar #'(lambda (x)
...@@ -895,7 +895,7 @@ ...@@ -895,7 +895,7 @@
,temp)))) ,temp))))
;;; ;;;
(defun create-list-constructor (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))) (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
(dolist (x (find-name-indices defstruct)) (dolist (x (find-name-indices defstruct))
(setf (elt vals (cdr x)) `',(car x))) (setf (elt vals (cdr x)) `',(car x)))
...@@ -904,17 +904,21 @@ ...@@ -904,17 +904,21 @@
`(defun ,cons-name ,arglist `(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
vars types)) (append vars aux-vars) types))
(list ,@vals)))) (list ,@vals))))
;;; ;;;
(defun create-structure-constructor (defun create-structure-constructor
(defstruct cons-name arglist vars types values) (defstruct cons-name arglist vars aux-vars types values)
(let* ((temp (gensym)) (let* ((temp (gensym))
(raw-index (dd-raw-index defstruct)) (raw-index (dd-raw-index defstruct))
(n-raw-data (when raw-index (gensym)))) (n-raw-data (when raw-index (gensym))))
`(defun ,cons-name ,arglist `(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) (declare ,@(remove nil
vars types)) (mapcar #'(lambda (var type)
(unless (member var aux-vars)
`(type ,type ,var)))
vars types)))
(let ((,temp (truly-the ,(dd-name defstruct) (let ((,temp (truly-the ,(dd-name defstruct)
(%make-instance ,(dd-length defstruct)))) (%make-instance ,(dd-length defstruct))))
,@(when n-raw-data ,@(when n-raw-data
...@@ -929,17 +933,21 @@ ...@@ -929,17 +933,21 @@
(multiple-value-bind (multiple-value-bind
(accessor index data) (accessor index data)
(slot-accessor-form defstruct dsd temp n-raw-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) (dd-slots defstruct)
values) values)
,temp)))) ,temp))))
;;; ;;;
(defun create-fin-constructor (defun create-fin-constructor
(defstruct cons-name arglist vars types values) (defstruct cons-name arglist vars aux-vars types values)
(let ((temp (gensym))) (let ((temp (gensym)))
`(defun ,cons-name ,arglist `(defun ,cons-name ,arglist
(declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
vars types)) (append vars aux-vars) types))
(let ((,temp (truly-the (let ((,temp (truly-the
,(dd-name defstruct) ,(dd-name defstruct)
(%make-funcallable-instance (%make-funcallable-instance
...@@ -970,7 +978,7 @@ ...@@ -970,7 +978,7 @@
(vals dum))) (vals dum)))
(funcall creator (funcall creator
defstruct (dd-default-constructor defstruct) defstruct (dd-default-constructor defstruct)
(arglist) (vals) (types) (vals)))) (arglist) (vals) nil (types) (vals))))
;;; CREATE-BOA-CONSTRUCTOR -- Internal ;;; CREATE-BOA-CONSTRUCTOR -- Internal
...@@ -983,6 +991,7 @@ ...@@ -983,6 +991,7 @@
(kernel:parse-lambda-list (second boa)) (kernel:parse-lambda-list (second boa))
(collect ((arglist) (collect ((arglist)
(vars) (vars)
(aux-vars)
(types)) (types))
(labels ((get-slot (name) (labels ((get-slot (name)
(let ((res (find name (dd-slots defstruct) :test #'string= (let ((res (find name (dd-slots defstruct) :test #'string=
...@@ -1050,14 +1059,19 @@ ...@@ -1050,14 +1059,19 @@
(let* ((arg (if (consp arg) arg (list arg))) (let* ((arg (if (consp arg) arg (list arg)))
(var (first arg))) (var (first arg)))
(arglist arg) (arglist arg)
(vars var) (aux-vars var)
(types (get-slot var)))))) (types (get-slot var))))))
(funcall creator defstruct (first boa) (funcall creator defstruct (first boa)
(arglist) (vars) (types) (arglist) (vars) (aux-vars) (types)
(mapcar #'(lambda (slot) (mapcar #'(lambda (slot)
(or (find (dsd-name slot) (vars) :test #'string=) (let ((v (find (dsd-name slot) (vars) :test #'string=)))
(dsd-default slot))) (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)))))) (dd-slots defstruct))))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment