Skip to content
Snippets Groups Projects
Commit efc75ade authored by gerd's avatar gerd
Browse files

For the same problem that SHARED-INITIALIZE.5.1 from Paul Dietz

	shows, except that there is no test case covering this yet.

	* src/pcl/ctor.lisp (slot-init-forms): Generate code for
	initializing unbound shared slots that are not otherwise
	initialized.
parent 0d97bc11
No related branches found
No related tags found
No related merge requests found
...@@ -46,7 +46,7 @@ ...@@ -46,7 +46,7 @@
;;; is called. ;;; is called.
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.6 2003/04/24 13:44:15 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.7 2003/05/02 16:25:51 gerd Exp $")
(in-package "PCL") (in-package "PCL")
...@@ -534,9 +534,16 @@ ...@@ -534,9 +534,16 @@
as allocation = (slot-definition-allocation slotd) as allocation = (slot-definition-allocation slotd)
as initfn = (slot-definition-initfunction slotd) as initfn = (slot-definition-initfunction slotd)
as slot-type = (slot-type-or-t slotd) as slot-type = (slot-type-or-t slotd)
as initform = (slot-definition-initform slotd) do as initform = (slot-definition-initform slotd)
(unless (or (eq allocation :class) if (eq allocation :class) do
(and (not structure-p) (when (and initfn (not (initialized-p location)))
(if (constantp initform)
(class-init location 'constant-if-unbound
initform slot-type)
(class-init location 'initfn-if-unbound
initfn slot-type)))
else do
(unless (or (and (not structure-p)
(null initfn)) (null initfn))
(initialized-p location)) (initialized-p location))
(if (constantp initform) (if (constantp initform)
...@@ -552,14 +559,28 @@ ...@@ -552,14 +559,28 @@
(instance-init-forms slot-vector before-method-p)))) (instance-init-forms slot-vector before-method-p))))
(class-init-forms (class-init-forms
(unless structure-p (unless structure-p
(loop for (location type value slot-type) in class-inits (ext:collect ((forms))
collect (dolist (init class-inits (forms))
`(setf (cdr ',location) (destructuring-bind (location type value slot-type) init
(the ,slot-type (forms
,(ecase type (ecase type
(constant `',(eval value)) (constant
((param var) `,value) `(setf (cdr ',location)
(initfn `(funcall ,value))))))))) (the ,slot-type ',(eval value))))
((param var)
`(setf (cdr ',location)
(the ,slot-type ,value)))
(initfn
`(setf (cdr ',location)
(the ,slot-type (funcall ,value))))
(initfn-if-unbound
`(when (eq +slot-unbound+ (cdr ',location))
(setf (cdr ',location)
(the ,slot-type (funcall ,value)))))
(constant-if-unbound
`(when (eq +slot-unbound+ (cdr ',location))
(setf (cdr ',location)
(the ,slot-type ',(eval value)))))))))))))
(multiple-value-bind (vars bindings) (multiple-value-bind (vars bindings)
(loop for (var . initfn) in (nreverse default-inits) (loop for (var . initfn) in (nreverse default-inits)
collect var into vars collect var into vars
......
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