Handle :ALLOCATION of condition slots correctly

Previously, DEFINE-CONDITION failed to pass the :ALLOCATION slot
option to MAKE-CONDITION-SLOT.

A test case has been added.

fixes lp#1049404

diff --git a/NEWS b/NEWS
index fcba506..881e5b3 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: :allocation slot option works for condition slots
+    (lp#1049404)
   * 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

diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index a6ccb12..89ae144 100644 (file)
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -535,7 +535,8 @@
                      :initform-p ',initform-p
                      :documentation ',documentation
                      :initform ,(when initform-p
-                                  `#'(lambda () ,initform)))))))
+                                  `#'(lambda () ,initform))
+                     :allocation ',allocation)))))
 
       (dolist (option options)
         (unless (consp option)

diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp
index 2b6303b..7eab70a 100644 (file)
--- a/tests/condition.impure.lisp
+++ b/tests/condition.impure.lisp
@@ -256,3 +256,17 @@
     (test :compile+make-instance
       (make-instance
        'condition-with-non-constant-default-initarg))))
+
+;;; bug-1049404
+
+(define-condition condition-with-class-allocation ()
+  ((count :accessor condition-with-class-allocation-count
+          :initform 0
+          :allocation :class)))
+
+(with-test (:name (:condition-with-class-allocation :bug-1049404))
+  (loop repeat 5 do
+           (incf (condition-with-class-allocation-count
+                  (make-condition 'condition-with-class-allocation))))
+  (assert (= 5 (condition-with-class-allocation-count
+                (make-condition 'condition-with-class-allocation)))))