From d119bca6cc4e052fe6a043ce76a045713038b06f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 19 Apr 2002 10:50:13 +0000 Subject: [PATCH] 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 --- BUGS | 19 ------------------- NEWS | 3 +++ src/code/defstruct.lisp | 23 ++++++++++++++++++----- tests/defstruct.impure.lisp | 34 +++++++++++++++++++++++++++++----- version.lisp-expr | 2 +- 5 files changed, 51 insertions(+), 30 deletions(-) diff --git a/BUGS b/BUGS index 8d12392..1ddcadc 100644 --- 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 --- 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 --- 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 --- 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) + ;;;; testing raw slots harder ;;;; diff --git a/version.lisp-expr b/version.lisp-expr index 7f9da57..854a2c0 100644 --- 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" -- 1.7.10.4