&optional and &key supplied-p arguments in boa-constuctors

  ...can be used to initialize structure slots.

diff --git a/NEWS b/NEWS
index 809b1fe..d5b693f 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ changes relative to sbcl-1.0.49:
     backwards incompatible change in 1.0.48.27)
   * bug fix: occasional debugger errors in when a type-error occured in a
     function with dynamic-extent &rest list.
+  * bug fix: &optional and &key supplied-p arguments in DEFSTRUCT
+    boa-construtors can be used to initialized structure slots.
 
 changes in sbcl-1.0.49 relative to sbcl-1.0.48:
   * minor incompatible change: WITH-LOCKED-HASH-TABLE no longer disables

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0f25b5d..27722b0 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1542,7 +1542,9 @@
                          arg
                        (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
                        (vars name)
-                       (arg-type (get-slot name))))
+                       (arg-type (get-slot name))
+                       (when supplied-test-p
+                         (vars supplied-test))))
                     (t
                      (do-default arg)))))
 
@@ -1573,7 +1575,9 @@
                         (arglist `(,wot ,(if def-p def slot-def)
                                         ,@(if supplied-test-p `(,supplied-test) nil)))
                         (vars name)
-                        (arg-type type key name))))
+                        (arg-type type key name)
+                        (when supplied-test-p
+                          (vars supplied-test)))))
                   (do-default key t))))
 
           (when allowp

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 1354ab6..6fc914d 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1083,3 +1083,29 @@ redefinition."
   ;; So's empty.
   (eval '(defstruct (typed-struct2 (:type list) (:predicate))
           (a 42 :type fixnum))))
+
+(with-test (:name (:boa-supplied-p &optional))
+  (handler-bind ((warning #'error))
+    (eval `(defstruct (boa-supplied-p.1 (:constructor make-boa-supplied-p.1
+                                            (&optional (bar t barp))))
+             bar
+             barp)))
+  (let ((b1 (make-boa-supplied-p.1))
+        (b2 (make-boa-supplied-p.1 t)))
+    (assert (eq t (boa-supplied-p.1-bar b1)))
+    (assert (eq t (boa-supplied-p.1-bar b2)))
+    (assert (eq nil (boa-supplied-p.1-barp b1)))
+    (assert (eq t (boa-supplied-p.1-barp b2)))))
+
+(with-test (:name (:boa-supplied-p &key))
+  (handler-bind ((warning #'error))
+    (eval `(defstruct (boa-supplied-p.2 (:constructor make-boa-supplied-p.2
+                                            (&key (bar t barp))))
+             bar
+             barp)))
+  (let ((b1 (make-boa-supplied-p.2))
+        (b2 (make-boa-supplied-p.2 :bar t)))
+    (assert (eq t (boa-supplied-p.2-bar b1)))
+    (assert (eq t (boa-supplied-p.2-bar b2)))
+    (assert (eq nil (boa-supplied-p.2-barp b1)))
+    (assert (eq t (boa-supplied-p.2-barp b2)))))