From 9c0c32bf94b510ea0f7bed34a91d0ddf3ea909fc Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Fri, 5 Apr 2013 12:24:37 +0200 Subject: [PATCH] Evaluate condition default initargs once, even after redefinition There were two causes of this failure * %DEFINE-CONDITION did not clear CONDITION-CLASSOID-HAIRY-SLOTS when a condition was redefined. This led to multiple copies of slots in CONDITION-CLASSOID-HAIRY-SLOTS and thus to initforms being evaluated multiple times. %DEFINE-CONDITION now clears CONDITION-CLASSOID-HAIRY-SLOTS before populating it again. * (MAKE-INSTANCE CONDITION-CLASS) produced the call tree MAKE-INSTANCE + ALLOCATE-INSTANCE SLOT-OBJECT + MAKE-CONDITION + INITIALIZE-INSTANCE SLOT-OBJECT + SHARED-INITIALIZE SLOT-OBJECT MAKE-CONDITION and SHARED-INITIALIZE both called initfunctions leading to multiple evaluations A test case has been added. fixes lp#1164969 --- NEWS | 2 ++ package-data-list.lisp-expr | 2 ++ src/code/condition.lisp | 48 ++++++++++++++++++++------------- src/pcl/slots.lisp | 6 ++--- tests/condition.impure.lisp | 63 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 98 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index b0fc7b6..fcba506 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.6 + * bug fix: redefining conditions does not lead to multiple evaluations of + hairy slot initfunctions anymore (lp#1164969) * bug fix: CLASS-DIRECT-DEFAULT-INITARGS now works for condition classes (lp#1164970) * bug fix: function constants now work as initforms and default initarg diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 4a88b7f..00c4dec 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1925,6 +1925,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET" "DESCRIBE-CONDITION" "MAKE-RESTART" "COERCE-TO-CONDITION" + "ALLOCATE-CONDITION" + "CONDITION-READER-FUNCTION" "CONDITION-WRITER-FUNCTION" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index c1dc599..a6ccb12 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -59,9 +59,6 @@ :metaclass-constructor make-condition-classoid :dd-type structure) -(defun make-condition-object (actual-initargs) - (%make-condition-object actual-initargs nil)) - (defstruct (condition-slot (:copier nil)) (name (missing-arg) :type symbol) ;; list of all applicable initargs @@ -239,19 +236,15 @@ ;;;; MAKE-CONDITION -(defun make-condition (type &rest args) - #!+sb-doc - "Make an instance of a condition object using the specified initargs." - ;; Note: ANSI specifies no exceptional situations in this function. - ;; signalling simple-type-error would not be wrong. - (let* ((type (or (and (symbolp type) (find-classoid type nil)) - type)) +(defun allocate-condition (type &rest initargs) + (let* ((type (if (symbolp type) + (find-classoid type nil) + type)) (class (typecase type (condition-classoid type) (class - ;; Punt to CLOS. - (return-from make-condition - (apply #'make-instance type args))) + (return-from allocate-condition + (apply #'allocate-condition (class-name type) initargs))) (classoid (error 'simple-type-error :datum type @@ -265,23 +258,37 @@ :format-control "~s does not designate a condition class." :format-arguments (list type))))) - (res (make-condition-object args))) - (setf (%instance-layout res) (classoid-layout class)) + (condition (%make-condition-object initargs '()))) + (setf (%instance-layout condition) (classoid-layout class)) + (values condition class))) + +(defun make-condition (type &rest initargs) + #!+sb-doc + "Make an instance of a condition object using the specified initargs." + ;; Note: ANSI specifies no exceptional situations in this function. + ;; signalling simple-type-error would not be wrong. + (multiple-value-bind (condition class) + (apply #'allocate-condition type initargs) + ;; Set any class slots with initargs present in this call. (dolist (cslot (condition-classoid-class-slots class)) (dolist (initarg (condition-slot-initargs cslot)) - (let ((val (getf args initarg *empty-condition-slot*))) + (let ((val (getf initargs initarg *empty-condition-slot*))) (unless (eq val *empty-condition-slot*) (setf (car (condition-slot-cell cslot)) val))))) + ;; Default any slots with non-constant defaults now. (dolist (hslot (condition-classoid-hairy-slots class)) (when (dolist (initarg (condition-slot-initargs hslot) t) - (unless (eq (getf args initarg *empty-condition-slot*) + (unless (eq (getf initargs initarg *empty-condition-slot*) *empty-condition-slot*) (return nil))) - (setf (getf (condition-assigned-slots res) (condition-slot-name hslot)) + (setf (getf (condition-assigned-slots condition) + (condition-slot-name hslot)) (find-slot-default class hslot)))) - res)) + + condition)) + ;;;; DEFINE-CONDITION @@ -415,6 +422,7 @@ ;; Compute effective slots and set up the class and hairy slots ;; (subsets of the effective slots.) + (setf (condition-classoid-hairy-slots class) '()) (let ((eslots (compute-effective-slots class)) (e-def-initargs (reduce #'append @@ -438,6 +446,8 @@ (dolist (initarg (condition-slot-initargs slot) nil) (when (functionp (third (assoc initarg e-def-initargs))) (return t)))) + ;; TODO temp + (assert (not (member slot (condition-classoid-hairy-slots class)))) (push slot (condition-classoid-hairy-slots class))))))) (when (boundp '*define-condition-hooks*) (dolist (fun *define-condition-hooks*) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 26a8355..71746aa 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -478,7 +478,7 @@ ;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance ;;; if the class is not yet finalized, but we don't seem to be taking -;;; care of this for non-standard-classes.x +;;; care of this for non-standard-classes. (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) @@ -492,11 +492,9 @@ (funcall constructor) (error "Don't know how to allocate ~S" class)))) -;;; FIXME: It would be nicer to have allocate-instance return -;;; uninitialized objects for conditions as well. (defmethod allocate-instance ((class condition-class) &rest initargs) (declare (ignore initargs)) - (make-condition (class-name class))) + (allocate-condition (class-name class))) (defmethod allocate-instance ((class built-in-class) &rest initargs) (declare (ignore initargs)) diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index ae332c3..2b6303b 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -193,3 +193,66 @@ (assert (functionp (condition-with-constant-function-initform-foo (make-instance 'condition-with-constant-function-initform))))) + +;;; bug- + +(defvar bar-counter 0) + +(defvar baz-counter 0) + +(define-condition condition-with-non-constant-default-initarg () + ((bar :initarg :bar + :reader condition-with-non-constant-default-initarg-bar) + (baz :initarg :baz + :reader condition-with-non-constant-default-initarg-baz + :initform (incf baz-counter))) + (:default-initargs :bar (incf bar-counter))) +(define-condition condition-with-non-constant-default-initarg () + ((bar :initarg :bar + :reader condition-with-non-constant-default-initarg-bar) + (baz :initarg :baz + :reader condition-with-non-constant-default-initarg-baz + :initform (incf baz-counter))) + (:default-initargs :bar (incf bar-counter))) + +(with-test (:name (:redefining-condition-with-non-constant-default-initarg + :bug-1164969)) + ;; Redefining conditions could lead to multiple evaluations of + ;; initfunctions for slots and default initargs. We need all the + ;; combinations of make-condition/instance and eval/compile because + ;; they failed differently. + (macrolet ((test (case &body body) + `(progn + (setf bar-counter 0 + baz-counter 0) + (let ((instance (progn ,@body))) + (assert + (= 1 (condition-with-non-constant-default-initarg-bar + instance)) + nil + ,(format nil "Assertion failed for default initarg initfunction for ~A" + case)) + (assert + (= 1 (condition-with-non-constant-default-initarg-baz + instance)) + nil + ,(format nil "Assertion failed for slot initfunction for ~A" + case))) + (assert (= 1 bar-counter)) + (assert (= 1 baz-counter))))) + + ;; Go through EVAL to avoid optimizations. + (test :eval+make-condition + (eval '(make-condition + 'condition-with-non-constant-default-initarg))) + (test :eval+make-instance + (eval '(make-instance + 'condition-with-non-constant-default-initarg))) + + ;; Allow optimizations. + (test :compile+make-condition + (make-condition + 'condition-with-non-constant-default-initarg)) + (test :compile+make-instance + (make-instance + 'condition-with-non-constant-default-initarg)))) -- 1.7.10.4