X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=eb08e474f14ec4448cbda7b4ac1381cc48f90ce0;hb=a37de74b393a808825585000bb5b2b92218d46c0;hp=2fb05f88f02463bc0def64d6b8714173428b3fa9;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 2fb05f8..eb08e47 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -9,8 +9,7 @@ (in-package "SB!KERNEL") -(file-comment - "$Header$") +(/show0 "target-defstruct.lisp 12") ;;;; structure frobbing primitives @@ -105,7 +104,7 @@ (defun %set-funcallable-instance-info (fin i new-value) (%set-funcallable-instance-info fin i new-value)) -(defun funcallable-instance-function (fin) +(defun funcallable-instance-fun (fin) (%funcallable-instance-lexenv fin)) ;;; The heart of the magic of funcallable instances ("FINs"). The @@ -124,18 +123,18 @@ ;;; both the code pointer and the lexenv, since that code pointer (for ;;; an instance-lambda) is expecting that lexenv to be accessed. This ;;; effectively pre-flattens what would otherwise be a chain of -;;; indirections. Lest this sound like an excessively obscure case, -;;; note that it happens when PCL dispatch functions are -;;; byte-compiled. +;;; indirections. (That used to happen when PCL dispatch functions +;;; were byte-compiled; now that the byte compiler is gone, I can't +;;; think of another example offhand. -- WHN 2001-10-06) ;;; ;;; The only loss is that if someone accesses the -;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This -;;; probably doesn't matter, since PCL only sets the FIN function. And -;;; the only reason that interpreted functions are FINs instead of -;;; bare closures is for debuggability. -(defun (setf funcallable-instance-function) (new-value fin) - (setf (%funcallable-instance-function fin) - (%closure-function new-value)) +;;; FUNCALLABLE-INSTANCE-FUN, then won't get a FIN back. This probably +;;; doesn't matter, since PCL only sets the FIN function. And the only +;;; reason that interpreted functions are FINs instead of bare +;;; closures is for debuggability. +(defun (setf funcallable-instance-fun) (new-value fin) + (setf (%funcallable-instance-fun fin) + (%closure-fun new-value)) (setf (%funcallable-instance-lexenv fin) (if (funcallable-instance-p new-value) (%funcallable-instance-lexenv new-value) @@ -198,9 +197,10 @@ (output-symbol-name (dsd-%name slot) stream) (write-char #\space stream) (pprint-newline :miser stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream) + (output-object + (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream) (when (null slots) (return)) (write-char #\space stream) @@ -212,6 +212,7 @@ (slots (dd-slots dd) (cdr slots))) ((or (null slots) (and (not *print-readably*) + *print-length* (>= index *print-length*))) (if (null slots) (write-string ")" stream) @@ -222,9 +223,10 @@ (let ((slot (first slots))) (output-symbol-name (dsd-%name slot) stream) (write-char #\space stream) - (output-object (funcall (fdefinition (dsd-accessor slot)) - structure) - stream)))))))) + (output-object + (funcall (fdefinition (dsd-accessor-name slot)) + structure) + stream)))))))) (def!method print-object ((x structure-object) stream) (default-structure-print x stream *current-level*)) @@ -250,10 +252,7 @@ ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code. (and (typep obj 'instance) - (let (;; FIXME: Mightn't there be a slight efficiency improvement - ;; by delaying the binding of DEPTHOID 'til it's needed? - (depthoid (layout-depthoid layout)) - (obj-layout (%instance-layout obj))) + (let ((obj-layout (%instance-layout obj))) (cond ((eq obj-layout layout) t) ;; FIXME: Does the test for LAYOUT-INVALID really belong @@ -264,9 +263,10 @@ :expected-type (layout-class obj-layout) :datum obj)) (t - (and (> (layout-depthoid obj-layout) depthoid) - (eq (svref (layout-inherits obj-layout) depthoid) - layout))))))) + (let ((depthoid (layout-depthoid layout))) + (and (> (layout-depthoid obj-layout) depthoid) + (eq (svref (layout-inherits obj-layout) depthoid) + layout)))))))) ;;;; implementing structure slot accessors as closures @@ -305,16 +305,11 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - ;; FIXME: :EXPECTED-TYPE should be something - ;; comprehensible to the user, not this. Perhaps we - ;; could work backwards from the LAYOUT-CLASS slot to - ;; find something. (Note that all four SIMPLE-TYPE-ERROR - ;; calls in this section have the same disease.) - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "Structure for accessor ~S is not a ~S:~% ~S" :format-arguments - (list (dsd-accessor dsd) + (list (dsd-accessor-name dsd) (sb!xc:class-name (layout-class layout)) structure)))) (%instance-ref structure (dsd-index dsd))) @@ -327,7 +322,7 @@ :format-control "The structure for accessor ~S is not a ~S:~% ~S" :format-arguments - (list (dsd-accessor dsd) class + (list (dsd-accessor-name dsd) class structure))) (%instance-ref structure (dsd-index dsd)))))) (defun structure-slot-setter (layout dsd) @@ -342,21 +337,21 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "The structure for setter ~S is not a ~S:~% ~S" :format-arguments - (list `(setf ,(dsd-accessor dsd)) + (list `(setf ,(dsd-accessor-name dsd)) (sb!xc:class-name (layout-class layout)) structure))) (unless (typep-test new-value) (error 'simple-type-error :datum new-value - :expected-type '(satisfies typep-test) + :expected-type (class-name (layout-class layout)) :format-control "The new value for setter ~S is not a ~S:~% ~S" :format-arguments - (list `(setf ,(dsd-accessor dsd)) + (list `(setf ,(dsd-accessor-name dsd)) (dsd-type dsd) new-value)))) (setf (%instance-ref structure (dsd-index dsd)) new-value)) @@ -369,21 +364,23 @@ (unless (structure-test structure) (error 'simple-type-error :datum structure - :expected-type '(satisfies structure-test) + :expected-type (class-name (layout-class layout)) :format-control "The structure for setter ~S is not a ~S:~% ~S" :format-arguments - (list `(setf ,(dsd-accessor dsd)) + (list `(setf ,(dsd-accessor-name dsd)) (sb!xc:class-name class) structure))) (unless (typep-test new-value) (error 'simple-type-error :datum new-value - :expected-type '(satisfies typep-test) + :expected-type (class-name (layout-class layout)) :format-control "The new value for setter ~S is not a ~S:~% ~S" :format-arguments - (list `(setf ,(dsd-accessor dsd)) + (list `(setf ,(dsd-accessor-name dsd)) (dsd-type dsd) new-value)))) (setf (%instance-ref structure (dsd-index dsd)) new-value))))) + +(/show0 "target-defstruct.lisp end of file")