From a110dc1207382adf09d84a49be2381de0c688ec8 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 28 Apr 2003 12:23:44 +0000 Subject: [PATCH] 0.pre8.116: Fix for :DEFAULT-INITARGS with side-effects (detected by Paul Dietz' tests, fix from Gerd Moellmann) ... ctor needed to be smarter about the separation between locations and initarg equality Also really add the hyperobject tests (logically part of sbcl-0.pre8.115) --- NEWS | 3 ++ src/pcl/ctor.lisp | 76 +++++++++++++++++++++++++----------------- tests/clos.impure-cload.lisp | 10 +++++- tests/mop.impure-cload.lisp | 62 ++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 120 insertions(+), 33 deletions(-) create mode 100644 tests/mop.impure-cload.lisp diff --git a/NEWS b/NEWS index 65f9ff5..dfe6b16 100644 --- a/NEWS +++ b/NEWS @@ -1701,6 +1701,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.7.14 ** optimized MAKE-INSTANCE functions no longer cause internal assertion failures in the presence of duplicate initargs; ** SLOT-MAKUNBOUND returns the instance acted upon, not NIL; + ** side-effectful :DEFAULT-INITARGS have their side-effects + propagated even in the ctor optimized implementation of + MAKE-INSTANCE; planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index bd178c2..0e094b5 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -429,26 +429,33 @@ (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 @@ -462,22 +469,24 @@ (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) @@ -487,11 +496,10 @@ 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 @@ -500,7 +508,7 @@ ((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))) @@ -526,12 +534,18 @@ (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 diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index f0a1829..cda6eab 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -71,7 +71,7 @@ ;;; etc., but we should be able to define it). ;;; the ctor MAKE-INSTANCE optimizer used not to handle duplicate -;;; initargs. +;;; initargs... (defclass dinitargs-class1 () ((a :initarg :a))) (assert (= (slot-value (make-instance 'dinitargs-class1 :a 1 :a 2) 'a) 1)) @@ -79,6 +79,14 @@ (defclass dinitargs-class2 () ((b :initarg :b1 :initarg :b2))) (assert (= (slot-value (make-instance 'dinitargs-class2 :b2 3 :b1 4) 'b) 3)) +;;; ... or default-initargs when the location was already initialized +(defvar *definitargs-counter* 0) +(defclass definitargs-class () + ((a :initarg :a :initarg :a2)) + (:default-initargs :a2 (incf *definitargs-counter*))) +(assert (= (slot-value (make-instance 'definitargs-class) 'a) 1)) +(assert (= (slot-value (make-instance 'definitargs-class :a 0) 'a) 0)) +(assert (= *definitargs-counter* 2)) ;;; success (sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp new file mode 100644 index 0000000..56a0ddb --- /dev/null +++ b/tests/mop.impure-cload.lisp @@ -0,0 +1,62 @@ +;;;; 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)) + +;;; success +(sb-ext:quit :unix-status 104) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 52a08f4..e809a9c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.115" +"0.pre8.116" -- 1.7.10.4