,@slot-vars))))))
(declaim (ftype (sfunction (defstruct-description list) function)
- %Make-structure-instance-allocator))
+ %make-structure-instance-allocator))
(defun %make-structure-instance-allocator (dd slot-specs)
(let ((vars (make-gensym-list (length slot-specs))))
(values (compile nil `(lambda (,@vars)
(%make-structure-instance-macro ,dd ',slot-specs ,@vars))))))
+(defun %make-funcallable-structure-instance-allocator (dd slot-specs)
+ (when slot-specs
+ (bug "funcallable-structure-instance allocation with slots unimplemented"))
+ (let ((name (dd-name dd))
+ (length (dd-length dd))
+ (nobject (gensym "OBJECT")))
+ (values
+ (compile nil `(lambda ()
+ (let ((,nobject (%make-funcallable-instance ,length)))
+ (setf (%funcallable-instance-layout ,nobject)
+ (%delayed-get-compiler-layout ,name))
+ ,nobject))))))
+
;;; Delay looking for compiler-layout until the constructor is being
;;; compiled, since it doesn't exist until after the EVAL-WHEN
;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
(alignment 1 :type (integer 1 2) :read-only t))
(defvar *raw-slot-data-list*
- #!+hppa
- nil
- #!-hppa
(let ((double-float-alignment
;; white list of architectures that can load unaligned doubles:
#!+(or x86 x86-64 ppc) 1
:accessor-name '%raw-instance-ref/complex-long
:init-vop 'sb!vm::raw-instance-init/complex-long
:n-words #!+x86 6 #!+sparc 8)))))
+(defun raw-slot-words (type)
+ (let ((rsd (find type *raw-slot-data-list* :key #'raw-slot-data-raw-type)))
+ (if rsd
+ (raw-slot-data-n-words rsd)
+ (error "Invalid raw slot type: ~S" type))))
\f
;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
;;;; close personal friend SB!XC:DEFSTRUCT)
(declare (notinline find-classoid))
,@(let ((pf (dd-print-function defstruct))
(po (dd-print-object defstruct))
- (x (gensym))
- (s (gensym)))
+ (x (sb!xc:gensym "OBJECT"))
+ (s (sb!xc:gensym "STREAM")))
;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
;; leaves PO or PF equal to NIL. The user-level effect is
;; to generate a PRINT-OBJECT method specialized for the type,
(unless (eq (classoid-layout classoid) layout)
(register-layout layout)))
(t
+ (%redefine-defstruct classoid old-layout layout)
(let ((old-dd (layout-info old-layout)))
(when (defstruct-description-p old-dd)
(dolist (slot (dd-slots old-dd))
(fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
- (%redefine-defstruct classoid old-layout layout)
(setq layout (classoid-layout classoid))))
(setf (find-classoid (dd-name dd)) classoid)
,(funcall (nth-value 1 (slot-accessor-transforms dd dsd))
'(dummy new-value instance)))))
+;;; Blow away all the compiler info for the structure CLASS. Iterate
+;;; over this type, clearing the compiler structure type info, and
+;;; undefining all the associated functions. If SUBCLASSES-P, also do
+;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to
+;;; UNDECLARE-FUNCTION-NAME?
+(defun undeclare-structure (classoid subclasses-p)
+ (let ((info (layout-info (classoid-layout classoid))))
+ (when (defstruct-description-p info)
+ (let ((type (dd-name info)))
+ (remhash type *typecheckfuns*)
+ (setf (info :type :compiler-layout type) nil)
+ (undefine-fun-name (dd-copier-name info))
+ (undefine-fun-name (dd-predicate-name info))
+ (dolist (slot (dd-slots info))
+ (let ((fun (dsd-accessor-name slot)))
+ (unless (accessor-inherited-data fun info)
+ (undefine-fun-name fun)
+ (unless (dsd-read-only slot)
+ (undefine-fun-name `(setf ,fun)))))))
+ ;; Clear out the SPECIFIER-TYPE cache so that subsequent
+ ;; references are unknown types.
+ (values-specifier-type-cache-clear)))
+ (when subclasses-p
+ (let ((subclasses (classoid-subclasses classoid)))
+ (when subclasses
+ (collect ((subs))
+ (dohash ((classoid layout)
+ subclasses
+ :locked t)
+ (declare (ignore layout))
+ (undeclare-structure classoid nil)
+ (subs (classoid-proper-name classoid)))
+ ;; Is it really necessary to warn about
+ ;; undeclaring functions for subclasses?
+ (when (subs)
+ (warn "undeclaring functions for old subclasses ~
+ of ~S:~% ~S"
+ (classoid-name classoid)
+ (subs))))))))
+
;;; core compile-time setup of any class with a LAYOUT, used even by
;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
(defun %compiler-set-up-layout (dd
(info :type :compiler-layout (dd-name dd))
(ensure-structure-class dd
inherits
- (if clayout-p "previously compiled" "current")
- "compiled"
+ (if clayout-p
+ "The most recently compiled"
+ "The current")
+ "the most recently loaded"
:compiler-layout clayout))
(cond (old-layout
- (undefine-structure (layout-classoid old-layout))
- (when (and (classoid-subclasses classoid)
- (not (eq layout old-layout)))
- (collect ((subs))
- (dohash ((classoid layout) (classoid-subclasses classoid)
- :locked t)
- (declare (ignore layout))
- (undefine-structure classoid)
- (subs (classoid-proper-name classoid)))
- (when (subs)
- (warn "removing old subclasses of ~S:~% ~S"
- (classoid-name classoid)
- (subs))))))
+ (undeclare-structure (layout-classoid old-layout)
+ (and (classoid-subclasses classoid)
+ (not (eq layout old-layout))))
+ (setf (layout-invalid layout) nil)
+ ;; FIXME: it might be polite to hold onto old-layout and
+ ;; restore it at the end of the file. -- RMK 2008-09-19
+ ;; (International Talk Like a Pirate Day).
+ (warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
+ classoid))
(t
(unless (eq (classoid-layout classoid) layout)
(register-layout layout :invalidate nil))
;; included in that length to guarantee proper alignment of raw double float
;; slots, necessary for (at least) the SPARC backend.
(let ((layout-length (dd-layout-length dd)))
- (declare (index layout-length))
+ (declare (type index layout-length))
(+ layout-length (mod (1+ layout-length) 2))))
;;; This is called when we are about to define a structure class. It
(error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
old-layout)
(values class new-layout old-layout)))))))))
-
-;;; Blow away all the compiler info for the structure CLASS. Iterate
-;;; over this type, clearing the compiler structure type info, and
-;;; undefining all the associated functions.
-(defun undefine-structure (class)
- (let ((info (layout-info (classoid-layout class))))
- (when (defstruct-description-p info)
- (let ((type (dd-name info)))
- (remhash type *typecheckfuns*)
- (setf (info :type :compiler-layout type) nil)
- (undefine-fun-name (dd-copier-name info))
- (undefine-fun-name (dd-predicate-name info))
- (dolist (slot (dd-slots info))
- (let ((fun (dsd-accessor-name slot)))
- (unless (accessor-inherited-data fun info)
- (undefine-fun-name fun)
- (unless (dsd-read-only slot)
- (undefine-fun-name `(setf ,fun)))))))
- ;; Clear out the SPECIFIER-TYPE cache so that subsequent
- ;; references are unknown types.
- (values-specifier-type-cache-clear)))
- (values))
\f
;;; Return a list of pairs (name . index). Used for :TYPE'd
;;; constructors to find all the names that we have to splice in &
(types)
(vals))
(dolist (slot (dd-slots defstruct))
- (let ((dum (gensym))
+ (let ((dum (sb!xc:gensym "DUM"))
(name (dsd-name slot)))
(arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
(types (dsd-type slot))
(loop for slot in (dd-slots defstruct)
for name = (dsd-name slot)
collect (cond ((find name (skipped-vars) :test #'string=)
+ ;; CLHS 3.4.6 Boa Lambda Lists
(setf (dsd-safe-p slot) nil)
'.do-not-initialize-slot.)
((or (find (dsd-name slot) (vars) :test #'string=)
- (dsd-default slot)))))))))
+ (let ((type (dsd-type slot)))
+ (if (eq t type)
+ (dsd-default slot)
+ `(the ,type ,(dsd-default slot))))))))))))
;;; Grovel the constructor options, and decide what constructors (if
;;; any) to create.
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
+(sb!xc:proclaim '(special *defstruct-hooks*))
+
(sb!xc:defmacro !defstruct-with-alternate-metaclass
(class-name &key
(slot-names (missing-arg))
:dd-type dd-type))
(dd-slots (dd-slots dd))
(dd-length (1+ (length slot-names)))
- (object-gensym (gensym "OBJECT"))
- (new-value-gensym (gensym "NEW-VALUE-"))
+ (object-gensym (sb!xc:gensym "OBJECT"))
+ (new-value-gensym (sb!xc:gensym "NEW-VALUE-"))
(delayed-layout-form `(%delayed-get-compiler-layout ,class-name)))
(multiple-value-bind (raw-maker-form raw-reffer-operator)
(ecase dd-type
;; code, which knows how to generate inline type tests
;; for the whole CMU CL INSTANCE menagerie.
`(defun ,predicate (,object-gensym)
- (typep ,object-gensym ',class-name)))))))
+ (typep ,object-gensym ',class-name)))
+
+ (when (boundp '*defstruct-hooks*)
+ (dolist (fun *defstruct-hooks*)
+ (funcall fun (find-classoid ',(dd-name dd)))))))))
\f
;;;; finalizing bootstrapping
projects / sbcl.git / blobdiff