From: Christophe R. <cr...@us...> - 2003-01-28 17:21:18
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv16564/src/code Modified Files: defstruct.lisp Log Message: 0.7.12.9: Fix issue in DEFSTRUCT :NAMED :TYPE structure predicates, which had a tendency to signal errors on #() or dotted lists. Index: defstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v retrieving revision 1.54 retrieving revision 1.55 diff -u -d -r1.54 -r1.55 --- defstruct.lisp 26 Jan 2003 06:38:09 -0000 1.54 +++ defstruct.lisp 28 Jan 2003 17:21:14 -0000 1.55 @@ -426,11 +426,20 @@ (predicate-name (dd-predicate-name defstruct)) (argname (gensym))) (when (and predicate-name (dd-named defstruct)) - (let ((ltype (dd-lisp-type defstruct))) + (let ((ltype (dd-lisp-type defstruct)) + (name-index (cdr (car (last (find-name-indices defstruct)))))) `((defun ,predicate-name (,argname) (and (typep ,argname ',ltype) + ,(cond + ((subtypep ltype 'list) + `(consp (nthcdr ,name-index (the ,ltype ,argname)))) + ((subtypep ltype 'vector) + `(= (length (the ,ltype ,argname)) + ,(dd-length defstruct))) + (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." + ltype))) (eq (elt (the ,ltype ,argname) - ,(cdr (car (last (find-name-indices defstruct))))) + ,name-index) ',name)))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. |