From b002696f4d26c41ea09fc9af296a2d1f10b2ebb6 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Thu, 11 Feb 2010 22:11:07 +0000 Subject: [PATCH] 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. --- src/code/target-defstruct.lisp | 54 ++++++++++++++++++++++++---------------- tests/defstruct.impure.lisp | 4 +++ version.lisp-expr | 2 +- 3 files changed, 37 insertions(+), 23 deletions(-) diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index a646257..2661f06 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -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) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index e0ab36e..7f2ba08 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -1061,3 +1061,7 @@ redefinition." (type-error (e) (assert (eq 'string (type-error-expected-type e))) (assert (zerop (type-error-datum e)))))) + +(with-test (:name defstruct-copier-typechecks-argument) + (assert (not (raises-error? (copy-person (make-astronaut :name "Neil"))))) + (assert (raises-error? (copy-astronaut (make-person :name "Fred"))))) diff --git a/version.lisp-expr b/version.lisp-expr index dbcf2e2..e2a927a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.35.12" +"1.0.35.13" -- 1.7.10.4