(make-array (layout-length (class-wrapper class))
:initial-element nil))
(class-inits ())
+ (default-inits ())
(default-initargs (class-default-initargs class))
(initarg-locations
(compute-initarg-locations
class (append initkeys (mapcar #'car default-initargs)))))
(labels ((initarg-locations (initarg)
(cdr (assoc initarg initarg-locations :test #'eq)))
-
+ (initializedp (location)
+ (cond
+ ((consp location)
+ (assoc location class-inits :test #'eq))
+ ((integerp location)
+ (not (null (aref slot-vector location))))
+ (t (bug "Weird location in ~S" 'slot-init-forms))))
(class-init (location type val)
(aver (consp location))
- (unless (assoc location class-inits :test #'eq)
+ (unless (initializedp location)
(push (list location type val) class-inits)))
-
(instance-init (location type val)
(aver (integerp location))
- (unless (instance-slot-initialized-p location)
+ (unless (initializedp location)
(setf (aref slot-vector location) (list type val))))
-
- (instance-slot-initialized-p (location)
- (not (null (aref slot-vector location)))))
- ;;
+ (default-init-var-name (i)
+ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
+ (if (array-in-bounds-p ps i)
+ (aref ps i)
+ (intern (format nil ".D~D." i) *the-pcl-package*)))))
;; Loop over supplied initargs and values and record which
;; instance and class slots they initialize.
(loop for (key value) on initargs by #'cddr
(if (consp location)
(class-init location 'param value)
(instance-init location 'param value)))))
- ;;
;; Loop over default initargs of the class, recording
;; initializations of slots that have not been initialized
- ;; above.
- (loop for (key initfn initform) in default-initargs do
- (unless (member key initkeys :test #'eq)
- (if (constantp initform)
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location 'constant initform)
- (instance-init location 'constant initform)))
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location 'initfn initfn)
- (instance-init location 'initfn initfn))))))
- ;;
+ ;; above. Default initargs which are not in the supplied
+ ;; initargs are treated as if they were appended to supplied
+ ;; initargs, that is, their values must be evaluated even
+ ;; if not actually used for initializing a slot.
+ (loop for (key initfn initform) in default-initargs and i from 0
+ unless (member key initkeys :test #'eq) do
+ (let* ((type (if (constantp initform) 'constant 'var))
+ (init (if (eq type 'var) initfn initform)))
+ (when (eq type 'var)
+ (let ((init-var (default-init-var-name i)))
+ (setq init init-var)
+ (push (cons init-var initfn) default-inits)))
+ (dolist (location (initarg-locations key))
+ (if (consp location)
+ (class-init location type init)
+ (instance-init location type init)))))
;; Loop over all slots of the class, filling in the rest from
;; slot initforms.
(loop for slotd in (class-slots class)
as initform = (slot-definition-initform slotd) do
(unless (or (eq allocation :class)
(null initfn)
- (instance-slot-initialized-p location))
+ (initializedp location))
(if (constantp initform)
(instance-init location 'initform initform)
(instance-init location 'initform/initfn initfn))))
- ;;
;; Generate the forms for initializing instance and class slots.
(let ((instance-init-forms
(loop for slot-entry across slot-vector and i from 0
((nil)
(unless before-method-p
`(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
- (param
+ ((param var)
`(setf (clos-slots-ref .slots. ,i) ,value))
(initfn
`(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
(loop for (location type value) in class-inits collect
`(setf (cdr ',location)
,(ecase type
- (constant `',(eval value))
- (param `,value)
- (initfn `(funcall ,value)))))))
- `(progn
- ,@(delete nil instance-init-forms)
- ,@class-init-forms)))))
+ (constant `',(eval value))
+ ((param var) `,value)
+ (initfn `(funcall ,value)))))))
+ (multiple-value-bind (vars bindings)
+ (loop for (var . initfn) in (nreverse default-inits)
+ collect var into vars
+ collect `(,var (funcall ,initfn)) into bindings
+ finally (return (values vars bindings)))
+ `(let ,bindings
+ (declare (ignorable ,@vars))
+ ,@(delete nil instance-init-forms)
+ ,@class-init-forms))))))
;;;
;;; Return an alist of lists (KEY LOCATION ...) telling, for each
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
+
+(defpackage "MOP-TEST"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-TEST")
+
+;;; A distilled test case from cmucl-imp for Kevin Rosenberg's
+;;; hyperobject. Fix from Gerd Moellmann.
+(defclass hyperobject-class (standard-class)
+ ((user-name :initarg :user-name :type string :initform nil
+ :accessor user-name
+ :documentation "User name for class")))
+
+(defclass hyperobject-dsd (standard-direct-slot-definition)
+ ())
+
+(defclass hyperobject-esd (standard-effective-slot-definition)
+ ((vc :initform 42)))
+
+(defmethod validate-superclass ((class hyperobject-class)
+ (superclass standard-class))
+ t)
+
+(defmethod compute-effective-slot-definition :around
+ ((cl hyperobject-class) name dsds)
+ (let ((ia (sb-pcl::compute-effective-slot-definition-initargs cl dsds)))
+ (apply #'make-instance 'hyperobject-esd ia)))
+
+(defmethod (setf slot-value-using-class) :around
+ (new-value (cl hyperobject-class) obj (slot hyperobject-esd))
+ (format t "~s ~s ~s~%" cl obj slot)
+ (slot-value slot 'vc))
+
+(defclass hyperobject ()
+ ()
+ (:metaclass hyperobject-class))
+
+(defclass person (hyperobject)
+ ((name :initarg :name :accessor person-name))
+ (:metaclass hyperobject-class))
+
+
+(eval '(make-instance 'person :name t))
+\f
+;;; success
+(sb-ext:quit :unix-status 104)
\ No newline at end of file
projects / sbcl.git / commitdiff