diff --git a/code/defstruct.lisp b/code/defstruct.lisp index a7bf41ee1c2394759e02c44ad8ec83db61156484..60fdd68460def38b3b0df491975a16281a8c6fb6 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))