\f
;;;; 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)
(/show0 "entering PROTECT-CL, SYMBOL=..")
(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))
\f
;; 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")
(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)
(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..
(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))
\f
-;;; 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 (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)))
(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))
(let* ((layout (%instance-layout structure))
(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)
(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))
(%default-structure-ugly-print structure stream))))
(def!method print-object ((x structure-object) stream)
(default-structure-print x stream *current-level-in-print*))
-
-(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
- :sb-just-dump-it-normally))
\f
;;;; testing structure types
,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)
: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)
projects / sbcl.git / blobdiff