From: Tobias R. <tri...@us...> - 2010-02-11 22:11:17
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv10721/src/code Modified Files: target-defstruct.lisp Log Message: 1.0.35.12: Minor cleanup in %TARGET-DEFSTRUCT. * Minor refactoring: split MAKE-DEFSTRUCT-PREDICATE and MAKE-DEFSTRUCT-COPIER out of %TARGET-DEFSTRUCT. * Remove FIXME: MAKE-DEFSTRUCT-COPIER now returns a closure which type checks its argument for proper layout before passing it to COPY-STRUCTURE. Index: target-defstruct.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-defstruct.lisp,v retrieving revision 1.47 retrieving revision 1.48 diff -u -d -r1.47 -r1.48 --- target-defstruct.lisp 20 Jun 2009 13:48:47 -0000 1.47 +++ target-defstruct.lisp 11 Feb 2010 22:11:07 -0000 1.48 @@ -139,6 +139,36 @@ (/show0 "leaving PROTECT-CL") (values)) +(defun make-defstruct-predicate (dd layout) + (ecase (dd-type dd) + ;; structures with LAYOUTs + ((structure funcallable-structure) + (/show0 "with-LAYOUT case") + #'(lambda (object) + (locally ; <- to keep SAFETY 0 from affecting arg count checking + (declare (optimize (speed 3) (safety 0))) + (/noshow0 "in with-LAYOUT structure predicate closure,") + (/noshow0 " OBJECT,LAYOUT=..") + (/nohexstr object) + (/nohexstr layout) + (typep-to-layout object layout)))) + ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) + ;; + ;; FIXME: should handle the :NAMED T case in these cases + (vector + (/show0 ":TYPE VECTOR case") + #'vectorp) + (list + (/show0 ":TYPE LIST case") + #'listp))) + +(defun make-defstruct-copier (dd layout) + (ecase (dd-type dd) + (structure + #'(lambda (instance) + (%check-structure-type-from-layout instance layout) + (copy-structure instance))))) + ;;; the part of %DEFSTRUCT which makes sense only on the target SBCL ;;; ;;; (The "static" in the name is because it needs to be done not only @@ -188,34 +218,14 @@ ;; (And funcallable instances don't need copiers anyway.) (aver (eql (dd-type dd) 'structure)) (setf (symbol-function (dd-copier-name dd)) - ;; FIXME: should use a closure which checks arg type before copying - #'copy-structure)) + (make-defstruct-copier dd layout))) ;; Set FDEFINITION for predicate. (when (dd-predicate-name dd) (/show0 "doing FDEFINITION for predicate") (protect-cl (dd-predicate-name dd)) (setf (symbol-function (dd-predicate-name dd)) - (ecase (dd-type dd) - ;; structures with LAYOUTs - ((structure funcallable-structure) - (/show0 "with-LAYOUT case") - (lambda (object) - (locally ; <- to keep SAFETY 0 from affecting arg count checking - (declare (optimize (speed 3) (safety 0))) - (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") - (/nohexstr object) - (/nohexstr layout) - (typep-to-layout object layout)))) - ;; structures with no LAYOUT (i.e. :TYPE VECTOR or :TYPE LIST) - ;; - ;; FIXME: should handle the :NAMED T case in these cases - (vector - (/show0 ":TYPE VECTOR case") - #'vectorp) - (list - (/show0 ":TYPE LIST case") - #'listp)))) + (make-defstruct-predicate dd layout))) (when (dd-doc dd) (setf (fdocumentation (dd-name dd) 'structure) |