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

diff --git a/NEWS b/NEWS
index b0fc7b6..fcba506 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 @@
 \f
 ;;;; 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))
+
 \f
 ;;;; 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 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -478,7 +478,7 @@
 \f
 ;;; 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 (file)
--- 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))))