From be60f246af511b6d6d1d095f4984d70f1875e465 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Thu, 25 Apr 2002 21:13:45 +0000 Subject: [PATCH] Fix from SBCL: 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 This fixes the handling of supplied-p args for &key and &optional args of boa-constructors. Also did a couple of code cleanups in the process. --- code/defstruct.lisp | 45 ++++++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/code/defstruct.lisp b/code/defstruct.lisp index a7bf41ee1..60fdd6846 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.74 2001/09/21 12:00:43 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.75 2002/04/25 21:13:45 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -971,15 +971,16 @@ (when opt (arglist '&optional) (dolist (arg opt) - (cond ((consp arg) - (destructuring-bind - (name &optional (def (nth-value 1 (get-slot name)))) - arg - (arglist `(,name ,def)) - (vars name) - (types (get-slot name)))) - (t - (do-default arg))))) + (if (consp arg) + (destructuring-bind (name &optional + (def (nth-value 1 (get-slot name))) + (supplied-test nil supplied-test-p)) + arg + (arglist + `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil))) + (vars name) + (types (get-slot name))) + (do-default arg)))) (when restp (arglist '&rest rest) @@ -988,20 +989,26 @@ (when keyp (arglist '&key) - (dolist (key keys) - (if (consp key) - (destructuring-bind (wot &optional (def nil def-p)) - key - (let ((name (if (consp wot) - (destructuring-bind (key var) wot + (dolist (arg keys) + (if (consp arg) + (destructuring-bind + (name-spec &optional + (def nil def-p) + (supplied-test nil supplied-test-p)) + arg + (let ((name (if (consp name-spec) + (destructuring-bind (key var) name-spec (declare (ignore key)) var) - wot))) + name-spec))) (multiple-value-bind (type slot-def) (get-slot name) - (arglist `(,wot ,(if def-p def slot-def))) + (arglist + `(,name + ,(if def-p def slot-def) + ,@(if supplied-test-p `(,supplied-test) nil))) (vars name) (types type)))) - (do-default key)))) + (do-default arg)))) (when allowp (arglist '&allow-other-keys)) -- GitLab