X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=33dc00d359210c34b90d164375e78e22af8b05f8;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=7e30c7bf121eca20198238b6a0f7e22a61520903;hpb=f43f136f9b3ff6cae501e850fa67b2183317e212;p=sbcl.git diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp index 7e30c7b..33dc00d 100644 --- a/src/code/target-defstruct.lisp +++ b/src/code/target-defstruct.lisp @@ -140,7 +140,11 @@ (setf (%instance-layout result) layout) result)) -;;;; target-only parts of the DEFSTRUCT top-level code +;;;; target-only parts of the DEFSTRUCT top level code + +;;; A list of hooks designating functions of one argument, the +;;; classoid, to be called when a defstruct is evaluated. +(defvar *defstruct-hooks* nil) ;;; Catch attempts to mess up definitions of symbols in the CL package. (defun protect-cl (symbol) @@ -177,19 +181,22 @@ (dolist (dsd (dd-slots dd)) (/show0 "doing FDEFINITION for slot accessor") (let ((accessor-name (dsd-accessor-name dsd))) - (/show0 "ACCESSOR-NAME=..") - (/hexstr accessor-name) - (protect-cl accessor-name) - (/hexstr "getting READER-FUN and WRITER-FUN") - (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd) - (declare (type function reader-fun writer-fun)) - (/show0 "got READER-FUN and WRITER-FUN=..") - (/hexstr reader-fun) - (setf (symbol-function accessor-name) reader-fun) - (unless (dsd-read-only dsd) - (/show0 "setting FDEFINITION for WRITER-FUN=..") - (/hexstr writer-fun) - (setf (fdefinition `(setf ,accessor-name)) writer-fun))))) + ;; We mustn't step on any inherited accessors + (unless (accessor-inherited-data accessor-name dd) + (/show0 "ACCESSOR-NAME=..") + (/hexstr accessor-name) + (protect-cl accessor-name) + (/hexstr "getting READER-FUN and WRITER-FUN") + (multiple-value-bind (reader-fun writer-fun) + (slot-accessor-funs dd dsd) + (declare (type function reader-fun writer-fun)) + (/show0 "got READER-FUN and WRITER-FUN=..") + (/hexstr reader-fun) + (setf (symbol-function accessor-name) reader-fun) + (unless (dsd-read-only dsd) + (/show0 "setting FDEFINITION for WRITER-FUN=..") + (/hexstr writer-fun) + (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))) ;; Set FDEFINITION for copier. (when (dd-copier-name dd) @@ -213,11 +220,12 @@ ((structure funcallable-structure) (/show0 "with-LAYOUT case") (lambda (object) - (declare (optimize (speed 3) (safety 0))) - (/noshow0 "in with-LAYOUT structure predicate closure, OBJECT,LAYOUT=..") - (/nohexstr object) - (/nohexstr layout) - (typep-to-layout object layout))) + (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 @@ -232,6 +240,11 @@ (setf (fdocumentation (dd-name dd) 'type) (dd-doc dd))) + ;; the BOUNDP test here is to get past cold-init. + (when (boundp '*defstruct-hooks*) + (dolist (fun *defstruct-hooks*) + (funcall fun (find-classoid (dd-name dd))))) + (/show0 "leaving %TARGET-DEFSTRUCT") (values)) @@ -297,8 +310,7 @@ *raw-slot-data-list*) ;; oops (t - (error "internal error: unexpected DSD-RAW-TYPE ~S" - dsd-raw-type)))))) + (bug "unexpected DSD-RAW-TYPE ~S" dsd-raw-type)))))) ;; code shared between DEFSTRUCT :TYPE LIST and ;; DEFSTRUCT :TYPE VECTOR cases: Handle the "typed ;; structure" case, with no LAYOUTs and no raw slots. @@ -309,13 +321,21 @@ ;; through here. (%slotplace-accessor-funs (slotplace instance-type-check-form) (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form) - `(values (lambda (instance) - (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") - ,instance-type-check-form - (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") - ,slotplace) - (let ((typecheckfun (typespec-typecheckfun dsd-type))) - (lambda (new-value instance) + `(let ((typecheckfun (typespec-typecheckfun dsd-type))) + (values (if (dsd-safe-p dsd) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + ,slotplace) + (lambda (instance) + (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader") + ,instance-type-check-form + (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") + (let ((value ,slotplace)) + (funcall typecheckfun value) + value))) + (lambda (new-value instance) (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer") ,instance-type-check-form (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM") @@ -325,7 +345,7 @@ (let ((dsd-index (dsd-index dsd)) (dsd-type (dsd-type dsd))) - + #+sb-xc (/show0 "got DSD-TYPE=..") #+sb-xc (/hexstr dsd-type) (ecase (dd-type dd) @@ -334,7 +354,7 @@ (structure #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE") (%native-slot-accessor-funs %instance-ref)) - + ;; structures with the :TYPE option ;; FIXME: Worry about these later.. @@ -375,20 +395,38 @@ (when raw-index (let* ((data (%instance-ref structure raw-index)) (raw-len (length data)) - (new (make-array raw-len :element-type '(unsigned-byte 32)))) - (declare (type (simple-array (unsigned-byte 32) (*)) data)) + (new (make-array raw-len :element-type 'sb!vm::word))) + (declare (type (simple-array sb!vm::word (*)) data)) (setf (%instance-ref res raw-index) new) (dotimes (i raw-len) (setf (aref new i) (aref data i)))))) res)) -;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods +;;; default PRINT-OBJECT method (defun %default-structure-pretty-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) + ;; KLUDGE: during the build process with SB-SHOW, we can sometimes + ;; attempt to print out a PCL object (with null LAYOUT-INFO). + #!+sb-show + (when (null dd) + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (prin1 name stream) + (write-char #\space stream) + (write-string "(no LAYOUT-INFO)")) + (return-from %default-structure-pretty-print nil)) + ;; the structure type doesn't count as a component for + ;; *PRINT-LEVEL* processing. We can likewise elide the logical + ;; block processing, since all we have to print is the type name. + ;; -- CSR, 2004-10-05 + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (return-from %default-structure-pretty-print nil)) (pprint-logical-block (stream nil :prefix "#S(" :suffix ")") (prin1 name stream) (let ((remaining-slots (dd-slots dd))) @@ -401,7 +439,7 @@ (pprint-pop) (let ((slot (pop remaining-slots))) (write-char #\: stream) - (output-symbol-name (dsd-%name slot) stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) (write-char #\space stream) (pprint-newline :miser stream) (output-object (funcall (fdefinition (dsd-accessor-name slot)) @@ -413,8 +451,13 @@ (pprint-newline :linear stream)))))))) (defun %default-structure-ugly-print (structure stream) (let* ((layout (%instance-layout structure)) - (name (sb!xc:class-name (layout-class layout))) + (name (classoid-name (layout-classoid layout))) (dd (layout-info layout))) + (when (and dd (null (dd-slots dd))) + (write-string "#S(" stream) + (prin1 name stream) + (write-char #\) stream) + (return-from %default-structure-ugly-print nil)) (descend-into (stream) (write-string "#S(" stream) (prin1 name stream) @@ -431,7 +474,7 @@ (write-char #\space stream) (write-char #\: stream) (let ((slot (first remaining-slots))) - (output-symbol-name (dsd-%name slot) stream) + (output-symbol-name (symbol-name (dsd-name slot)) stream) (write-char #\space stream) (output-object (funcall (fdefinition (dsd-accessor-name slot)) @@ -444,15 +487,9 @@ (*print-pretty* (%default-structure-pretty-print structure stream)) (t - (%default-structure-ugly-print structure-stream)))) + (%default-structure-ugly-print structure stream)))) (def!method print-object ((x structure-object) stream) - (default-structure-print x stream *current-level*)) - -(defun make-load-form-saving-slots (object &key slot-names environment) - (declare (ignore object environment)) - (if slot-names - (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE - :just-dump-it-normally)) + (default-structure-print x stream *current-level-in-print*)) ;;;; testing structure types @@ -461,9 +498,11 @@ ;;; which have a handle on the type's LAYOUT. ;;; ;;; FIXME: This is fairly big, so it should probably become -;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so -;;; that the things which call it are all closures, so that it's -;;; expanded only in a small number of places. +;;; MAYBE-INLINE instead of INLINE, or its inlineness should become +;;; conditional (probably through DEFTRANSFORM) on (> SPEED SPACE). Or +;;; else we could fix things up so that the things which call it are +;;; all closures, so that it's expanded only in a small number of +;;; places. #!-sb-fluid (declaim (inline typep-to-layout)) (defun typep-to-layout (obj layout) (declare (type layout layout) (optimize (speed 3) (safety 0))) @@ -485,7 +524,7 @@ ((layout-invalid obj-layout) (/noshow0 "LAYOUT-INVALID case") (error 'layout-invalid - :expected-type (layout-class obj-layout) + :expected-type (layout-classoid obj-layout) :datum obj)) (t (let ((depthoid (layout-depthoid layout))) @@ -512,7 +551,7 @@ ,x ,(compiler-layout-or-lose class-name))) ((vector) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type vector ,xx)) ,@(when (dd-named dd) @@ -527,7 +566,7 @@ :format-arguments (list ',class-name ,xx))))) (values)))) ((list) - (let ((xx (gensym "X"))) + (with-unique-names (xx) `(let ((,xx ,x)) (declare (type list ,xx)) ,@(when (dd-named dd) @@ -547,7 +586,7 @@ (unless (typep-to-layout x layout) (error 'type-error :datum x - :expected-type (class-name (layout-class layout)))) + :expected-type (classoid-name (layout-classoid layout)))) (values)) (/show0 "target-defstruct.lisp end of file")