0.7.2.17:

	Merged MNA "fix for boa-constructor bug" sbcl-devel 2002-04-16
	... copied the fix to &optional arguments handling
	... also test the &optional handling

diff --git a/BUGS b/BUGS
index 8d12392..1ddcadc 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1282,25 +1282,6 @@ WORKAROUND:
             do (foo (svref array i))) (svref array (1+ i)))
   (reported by Eric Marsden sbcl-devel 2002-04-15)
 
-159:
-  * (lisp-implementation-version)
-  "0.7.2.6"
-  * (defstruct (foo
-                (:constructor make-foo (&key (bar nil bar-p)
-                                        &aux (baz (if bar-p bar 2)))))
-
-      bar
-      baz)
-  debugger invoked on condition of type SB-KERNEL::ARG-COUNT-ERROR:
-    error while parsing arguments to DESTRUCTURING-BIND:
-      invalid number of elements in
-        (BAR NIL BAR-P)
-      to satisfy lambda list
-        (SB-KERNEL::WOT &OPTIONAL (SB-KERNEL::DEF NIL SB-KERNEL::DEF-P)):
-      between 1 and 2 expected, but 3 found
-  (reported by Christophe Rhodes and Martin Atzmueller sbcl-devel
-  2002-05-15)
-
 162:
   (reported by Robert E. Brown 2002-04-16) 
   When a function is called with too few arguments, causing the

diff --git a/NEWS b/NEWS
index f3273bb..6edce2a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1096,6 +1096,9 @@ changes in sbcl-0.7.3 relative to sbcl-0.7.2:
     that superficially look like logical namestrings correctly.
   * USER-HOMEDIR-PATHNAME now returns a (physical) pathname that SBCL
     can deal with.
+  * Bugfix in DEFSTRUCT: BOA constructor lambda lists now accept (name
+    default supplied-p) for &optional and &key arguments. (thanks to
+    Martin Atzmueller)
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 26a222e..410759c 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1237,9 +1237,16 @@
          (dolist (arg opt)
            (cond ((consp arg)
                   (destructuring-bind
-                      (name &optional (def (nth-value 1 (get-slot name))))
+                        ;; FIXME: this shares some logic (though not
+                        ;; code) with the &key case below (and it
+                        ;; looks confusing) -- factor out the logic
+                        ;; if possible. - CSR, 2002-04-19
+                        (name
+                         &optional
+                         (def (nth-value 1 (get-slot name)))
+                         (supplied-test nil supplied-test-p))
                       arg
-                    (arglist `(,name ,def))
+                    (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
                     (vars name)
                     (types (get-slot name))))
                  (t
@@ -1254,14 +1261,20 @@
          (arglist '&key)
          (dolist (key keys)
            (if (consp key)
-               (destructuring-bind (wot &optional (def nil def-p)) key
+               (destructuring-bind (wot
+                                     &optional
+                                     (def nil def-p)
+                                     (supplied-test nil supplied-test-p))
+                    key
                  (let ((name (if (consp wot)
                                  (destructuring-bind (key var) wot
                                    (declare (ignore key))
                                    var)
                                  wot)))
-                   (multiple-value-bind (type slot-def) (get-slot name)
-                     (arglist `(,wot ,(if def-p def slot-def)))
+                   (multiple-value-bind (type slot-def)
+                        (get-slot name)
+                     (arglist `(,wot ,(if def-p def slot-def)
+                                 ,@(if supplied-test-p `(,supplied-test) nil)))
                      (vars name)
                      (types type))))
                (do-default key))))

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 1015257..14724d7 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -177,13 +177,26 @@
 ;;; debugger is having a bad day
 (defvar *instance*)
   
-(defmacro test-variant (defstructname &key colontype)
+(defmacro test-variant (defstructname &key colontype boa-constructor-p)
   `(progn
 
      (format t "~&/beginning PROGN for COLONTYPE=~S~%" ',colontype)
 
      (defstruct (,defstructname
-                 ,@(when colontype `((:type ,colontype))))
+                 ,@(when colontype `((:type ,colontype)))
+                  ,@(when boa-constructor-p
+                          `((:constructor ,(symbol+ "CREATE-" defstructname)
+                             (id
+                             &optional
+                             (optional-test 2 optional-test-p)
+                              &key
+                              (home nil home-p)
+                              (no-home-comment "Home package CL not provided.")
+                              (comment (if home-p "" no-home-comment))
+                              (refcount (if optional-test-p optional-test nil))
+                              hash
+                              weight)))))
+       
        ;; some ordinary tagged slots
        id
        (home nil :type package :read-only t)
@@ -197,12 +210,19 @@
      (format t "~&/done with DEFSTRUCT~%")
 
      (let* ((cn (string+ ',defstructname "-")) ; conc-name
-           (ctor (symbol-function (symbol+ "MAKE-" ',defstructname)))
+           (ctor (symbol-function ',(symbol+ (if boa-constructor-p
+                                               "CREATE-"
+                                               "MAKE-")
+                                             defstructname)))
            (*instance* (funcall ctor
-                                :id "some id"
+                                ,@(unless boa-constructor-p
+                                           `(:id)) "some id"
+                                ,@(when boa-constructor-p
+                                        '(1))
                                 :home (find-package :cl)
                                 :hash (+ 14 most-positive-fixnum)
-                                :refcount 1)))
+                                ,@(unless boa-constructor-p
+                                          `(:refcount 1)))))
 
        ;; Check that ctor set up slot values correctly. 
        (format t "~&/checking constructed structure~%")
@@ -273,6 +293,10 @@
 (test-variant vanilla-struct)
 (test-variant vector-struct :colontype vector)
 (test-variant list-struct :colontype list)
+(test-variant vanilla-struct :boa-constructor-p t)
+(test-variant vector-struct :colontype vector :boa-constructor-p t)
+(test-variant list-struct :colontype list :boa-constructor-p t)
+
 \f
 ;;;; testing raw slots harder
 ;;;;

diff --git a/version.lisp-expr b/version.lisp-expr
index 7f9da57..854a2c0 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.2.16"
+"0.7.2.17"