From 37fbb0be837f1d17650c7329469819dd31b762e1 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 10 Jun 2011 23:18:41 +0300 Subject: [PATCH] &optional and &key supplied-p arguments in boa-constuctors ...can be used to initialize structure slots. --- NEWS | 2 ++ src/code/defstruct.lisp | 8 ++++++-- tests/defstruct.impure.lisp | 26 ++++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 809b1fe..d5b693f 100644 --- 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 --- 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 --- 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))))) -- 1.7.10.4