(and layout (typep (layout-info layout) 'defstruct-description))))
(sb!xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
- `(truly-the ,(dd-name dd)
- ,(if (compiler-layout-ready-p (dd-name dd))
- `(%make-structure-instance ,dd ,slot-specs ,@slot-vars)
- ;; Non-toplevel defstructs don't have a layout at compile time,
- ;; so we need to construct the actual function at runtime -- but
- ;; we cache it at the call site, so that we don't perform quite
- ;; so horribly.
- `(let* ((cell (load-time-value (list nil)))
- (fun (car cell)))
- (if (functionp fun)
- (funcall fun ,@slot-vars)
- (funcall (setf (car cell)
- (%make-structure-instance-allocator ,dd ,slot-specs))
- ,@slot-vars))))))
+ (if (compiler-layout-ready-p (dd-name dd))
+ `(truly-the ,(dd-name dd)
+ (%make-structure-instance ,dd ,slot-specs ,@slot-vars))
+ ;; Non-toplevel defstructs don't have a layout at compile time,
+ ;; so we need to construct the actual function at runtime -- but
+ ;; we cache it at the call site, so that we don't perform quite
+ ;; so horribly.
+ `(let* ((cell (load-time-value (list nil)))
+ (fun (car cell)))
+ (if (functionp fun)
+ (funcall fun ,@slot-vars)
+ (funcall (setf (car cell)
+ (%make-structure-instance-allocator ,dd ,slot-specs))
+ ,@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
;;; "A lie can travel halfway round the world while the truth is
;;; putting on its shoes." -- Mark Twain
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-
- ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
- (defstruct raw-slot-data
- ;; the raw slot type, or T for a non-raw slot
- ;;
- ;; (Non-raw slots are in the ordinary place you'd expect, directly
- ;; indexed off the instance pointer. Raw slots are indexed from the end
- ;; of the instance and skipped by GC.)
- (raw-type (missing-arg) :type (or symbol cons) :read-only t)
- ;; What operator is used to access a slot of this type?
- (accessor-name (missing-arg) :type symbol :read-only t)
- (init-vop (missing-arg) :type symbol :read-only t)
- ;; How many words are each value of this type?
- (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
- ;; Necessary alignment in units of words. Note that instances
- ;; themselves are aligned by exactly two words, so specifying more
- ;; than two words here would not work.
- (alignment 1 :type (integer 1 2) :read-only t))
-
- (defvar *raw-slot-data-list*
- #!+hppa
- nil
- #!-hppa
+;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
+(defstruct (raw-slot-data
+ (:copier nil)
+ (:predicate nil))
+ ;; the raw slot type, or T for a non-raw slot
+ ;;
+ ;; (Non-raw slots are in the ordinary place you'd expect, directly
+ ;; indexed off the instance pointer. Raw slots are indexed from the end
+ ;; of the instance and skipped by GC.)
+ (raw-type (missing-arg) :type (or symbol cons) :read-only t)
+ ;; What operator is used to access a slot of this type?
+ (accessor-name (missing-arg) :type symbol :read-only t)
+ (init-vop (missing-arg) :type symbol :read-only t)
+ ;; How many words are each value of this type?
+ (n-words (missing-arg) :type (and index (integer 1)) :read-only t)
+ ;; Necessary alignment in units of words. Note that instances
+ ;; themselves are aligned by exactly two words, so specifying more
+ ;; than two words here would not work.
+ (alignment 1 :type (integer 1 2) :read-only t)
+ (comparer (missing-arg) :type function :read-only t))
+
+(defvar *raw-slot-data-list*
+ (macrolet ((make-comparer (accessor-name)
+ `(lambda (index x y)
+ (declare (optimize speed (safety 0)))
+ (= (,accessor-name x index)
+ (,accessor-name y index)))))
(let ((double-float-alignment
- ;; white list of architectures that can load unaligned doubles:
- #!+(or x86 x86-64 ppc) 1
- ;; at least sparc, mips and alpha can't:
- #!-(or x86 x86-64 ppc) 2))
+ ;; white list of architectures that can load unaligned doubles:
+ #!+(or x86 x86-64 ppc) 1
+ ;; at least sparc, mips and alpha can't:
+ #!-(or x86 x86-64 ppc) 2))
(list
(make-raw-slot-data :raw-type 'sb!vm:word
:accessor-name '%raw-instance-ref/word
:init-vop 'sb!vm::raw-instance-init/word
- :n-words 1)
+ :n-words 1
+ :comparer (make-comparer %raw-instance-ref/word))
(make-raw-slot-data :raw-type 'single-float
:accessor-name '%raw-instance-ref/single
:init-vop 'sb!vm::raw-instance-init/single
;; would really benefit is (UNSIGNED-BYTE
;; 32), but that is a subtype of FIXNUM, so
;; we store it unraw anyway. :-( -- DFL
- :n-words 1)
+ :n-words 1
+ :comparer (make-comparer %raw-instance-ref/single))
(make-raw-slot-data :raw-type 'double-float
:accessor-name '%raw-instance-ref/double
:init-vop 'sb!vm::raw-instance-init/double
:alignment double-float-alignment
- :n-words (/ 8 sb!vm:n-word-bytes))
+ :n-words (/ 8 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/double))
(make-raw-slot-data :raw-type 'complex-single-float
:accessor-name '%raw-instance-ref/complex-single
:init-vop 'sb!vm::raw-instance-init/complex-single
- :n-words (/ 8 sb!vm:n-word-bytes))
+ :n-words (/ 8 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/complex-single))
(make-raw-slot-data :raw-type 'complex-double-float
:accessor-name '%raw-instance-ref/complex-double
:init-vop 'sb!vm::raw-instance-init/complex-double
:alignment double-float-alignment
- :n-words (/ 16 sb!vm:n-word-bytes))
+ :n-words (/ 16 sb!vm:n-word-bytes)
+ :comparer (make-comparer %raw-instance-ref/complex-double))
#!+long-float
(make-raw-slot-data :raw-type long-float
:accessor-name '%raw-instance-ref/long
:init-vop 'sb!vm::raw-instance-init/long
- :n-words #!+x86 3 #!+sparc 4)
+ :n-words #!+x86 3 #!+sparc 4
+ :comparer (make-comparer %raw-instance-ref/long))
#!+long-float
(make-raw-slot-data :raw-type complex-long-float
:accessor-name '%raw-instance-ref/complex-long
:init-vop 'sb!vm::raw-instance-init/complex-long
- :n-words #!+x86 6 #!+sparc 8)))))
+ :n-words #!+x86 6 #!+sparc 8
+ :comparer (make-comparer %raw-instance-ref/complex-long))))))
+
+(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,
((not inherited)
(stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
`((setf ,name))))))
- ;; FIXME: The arguments in the next two DEFUNs should
- ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
- ;; be the name of a special variable, things could get
- ;; weird.)
(stuff `(defun ,name (structure)
(declare (type ,ltype structure))
(the ,slot-type (elt structure ,index))))
;;; Given name and options, return a DD holding that info.
(defun parse-defstruct-name-and-options (name-and-options)
(destructuring-bind (name &rest options) name-and-options
- (aver name) ; A null name doesn't seem to make sense here.
- (let ((dd (make-defstruct-description name)))
+ (let ((dd (make-defstruct-description name))
+ (predicate-named-p nil))
(dolist (option options)
(cond ((eq option :named)
(setf (dd-named dd) t))
((consp option)
+ (when (and (eq (car option) :predicate) (second option))
+ (setf predicate-named-p t))
(parse-1-dd-option option dd))
((member option '(:conc-name :constructor :copier :predicate))
(parse-1-dd-option (list option) dd))
;; make that messy, alas.)
(incf (dd-length dd))))
(t
+ ;; In case we are here, :TYPE is specified.
+ (when (and predicate-named-p (not (dd-named dd)))
+ (error ":PREDICATE cannot be used with :TYPE unless :NAMED is also specified."))
(require-no-print-options-so-far dd)
(when (dd-named dd)
(incf (dd-length dd)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
(typecase spec
(symbol
- (when (keywordp spec)
- (style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
- spec))
+ (typecase spec
+ ((or null (member :conc-name :constructor :copier :predicate :named))
+ (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" spec))
+ (keyword
+ (style-warn "slot name of ~S indicates possible syntax error in DEFSTRUCT" spec)))
spec)
(cons
(destructuring-bind
- (name
- &optional (default nil default-p)
- &key (type nil type-p) (read-only nil ro-p))
+ (name &optional (default nil default-p)
+ &key (type nil type-p) (read-only nil ro-p))
spec
- (values name
- default default-p
+ (when (dd-conc-name defstruct)
+ ;; the warning here is useful, but in principle we cannot
+ ;; distinguish between legitimate and erroneous use of
+ ;; these names when :CONC-NAME is NIL. In the common
+ ;; case (CONC-NAME non-NIL), there are alternative ways
+ ;; of writing code with the same effect, so a full
+ ;; warning is justified.
+ (typecase name
+ ((member :conc-name :constructor :copier :predicate :include
+ :print-function :print-object :type :initial-offset :pure)
+ (warn "slot name of ~S indicates probable syntax error in DEFSTRUCT" name))))
+ (values name default default-p
(uncross type) type-p
read-only ro-p)))
(t (error 'simple-program-error
;;x#-sb-xc-host
;;x(when (and (fboundp accessor-name)
;;x (not (accessor-inherited-data accessor-name defstruct)))
- ;;x (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
+ ;;x (style-warn "redefining ~/sb-impl::print-symbol-with-prefix/ ~
+ ;; in DEFSTRUCT" accessor-name)))
;; which was done until sbcl-0.8.11.18 or so, is wrong: it causes
;; a warning at MACROEXPAND time, when instead the warning should
;; occur not just because the code was constructed, but because it
(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))
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
- (setf (info :function :structure-accessor accessor-name) dd)
(let ((inherited (accessor-inherited-data accessor-name dd)))
(cond
((not inherited)
+ (setf (info :function :structure-accessor accessor-name) dd)
(multiple-value-bind (reader-designator writer-designator)
(slot-accessor-transforms dd dsd)
(sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type)
;; 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 &
;;; SIMPLE-VECTOR.)
;;; * STRUCTURE structures can have raw slots that must also be
;;; allocated and indirectly referenced.
-(defun create-vector-constructor (dd cons-name arglist vars types values)
+(defun create-vector-constructor (dd cons-name arglist ftype-arglist decls values)
(let ((temp (gensym))
- (etype (dd-element-type dd)))
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var))
- vars types))
- (let ((,temp (make-array ,(dd-length dd)
- :element-type ',(dd-element-type dd))))
- ,@(mapcar (lambda (x)
- `(setf (aref ,temp ,(cdr x)) ',(car x)))
- (find-name-indices dd))
- ,@(mapcar (lambda (dsd value)
- (unless (eq value '.do-not-initialize-slot.)
- `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
- (dd-slots dd) values)
- ,temp))))
-(defun create-list-constructor (dd cons-name arglist vars types values)
+ (etype (dd-element-type dd))
+ (len (dd-length dd)))
+ (values
+ `(defun ,cons-name ,arglist
+ ,@(when decls `((declare ,@decls)))
+ (let ((,temp (make-array ,len :element-type ',etype)))
+ ,@(mapcar (lambda (x)
+ `(setf (aref ,temp ,(cdr x)) ',(car x)))
+ (find-name-indices dd))
+ ,@(mapcar (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
+ (dd-slots dd) values)
+ ,temp))
+ `(sfunction ,ftype-arglist (simple-array ,etype (,len))))))
+(defun create-list-constructor (dd cons-name arglist ftype-arglist decls values)
(let ((vals (make-list (dd-length dd) :initial-element nil)))
(dolist (x (find-name-indices dd))
(setf (elt vals (cdr x)) `',(car x)))
(loop for dsd in (dd-slots dd) and val in values do
(setf (elt vals (dsd-index dsd))
(if (eq val '.do-not-initialize-slot.) 0 val)))
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
- (list ,@vals))))
-(defun create-structure-constructor (dd cons-name arglist vars types values)
- ;; The difference between the two implementations here is that on all
- ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
- ;; must be able to deal with immediate values as well -- unlike
- ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
- ;; some additional cleverness we might manage without them and just a single
- ;; implementation here, though -- figure out a way to ensure that on those
- ;; platforms we always still get a non-immediate TN in every case...
- ;;
- ;; Until someone does that, this means that instances with raw slots can be
- ;; DX allocated only on platforms with those additional VOPs.
- #!+raw-instance-init-vops
- (let* ((slot-values nil)
- (slot-specs
- (mapcan (lambda (dsd value)
- (unless (eq value '.do-not-initialize-slot.)
- (push value slot-values)
- (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
- (dd-slots dd)
- values)))
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
- (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
- #!-raw-instance-init-vops
- (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
- (mapc (lambda (dsd value)
- (unless (eq value '.do-not-initialize-slot.)
- (let ((raw-type (dsd-raw-type dsd)))
- (cond ((eq t raw-type)
+ (values
+ `(defun ,cons-name ,arglist
+ ,@(when decls `((declare ,@decls)))
+ (list ,@vals))
+ `(sfunction ,ftype-arglist list))))
+(defun create-structure-constructor (dd cons-name arglist ftype-arglist decls values)
+ (values
+ ;; The difference between the two implementations here is that on all
+ ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
+ ;; must be able to deal with immediate values as well -- unlike
+ ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
+ ;; some additional cleverness we might manage without them and just a single
+ ;; implementation here, though -- figure out a way to ensure that on those
+ ;; platforms we always still get a non-immediate TN in every case...
+ ;;
+ ;; Until someone does that, this means that instances with raw slots can be
+ ;; DX allocated only on platforms with those additional VOPs.
+ #!+raw-instance-init-vops
+ (let* ((slot-values nil)
+ (slot-specs
+ (mapcan (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
(push value slot-values)
- (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
- (t
- (push value raw-values)
- (push dsd raw-slots))))))
- (dd-slots dd)
- values)
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
- ,(if raw-slots
- `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
- ,@(mapcar (lambda (dsd value)
- ;; (Note that we can't in general use the
- ;; ordinary named slot setter function here
- ;; because the slot might be :READ-ONLY, so we
- ;; whip up new LAMBDA representations of slot
- ;; setters for the occasion.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
- raw-slots
- raw-values)
- ,instance)
- `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))))
+ (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
+ (dd-slots dd)
+ values)))
+ `(defun ,cons-name ,arglist
+ ,@(when decls `((declare ,@decls)))
+ (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
+ #!-raw-instance-init-vops
+ (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
+ (mapc (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ (let ((raw-type (dsd-raw-type dsd)))
+ (cond ((eq t raw-type)
+ (push value slot-values)
+ (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
+ (t
+ (push value raw-values)
+ (push dsd raw-slots))))))
+ (dd-slots dd)
+ values)
+ `(defun ,cons-name ,arglist
+ ,@(when decls`((declare ,@decls)))
+ ,(if raw-slots
+ `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
+ ,@(mapcar (lambda (dsd value)
+ ;; (Note that we can't in general use the
+ ;; ordinary named slot setter function here
+ ;; because the slot might be :READ-ONLY, so we
+ ;; whip up new LAMBDA representations of slot
+ ;; setters for the occasion.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+ raw-slots
+ raw-values)
+ ,instance)
+ `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values))))
+ `(sfunction ,ftype-arglist ,(dd-name dd))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
(declare (type function creator))
(collect ((arglist (list '&key))
- (types)
- (vals))
- (dolist (slot (dd-slots defstruct))
- (let ((dum (gensym))
- (name (dsd-name slot)))
- (arglist `((,(keywordicate name) ,dum) ,(dsd-default slot)))
- (types (dsd-type slot))
- (vals dum)))
+ (vals)
+ (decls)
+ (ftype-args))
+ (let ((int-type (if (eq 'vector (dd-type defstruct))
+ (dd-element-type defstruct)
+ t)))
+ (dolist (slot (dd-slots defstruct))
+ (let* ((dum (sb!xc:gensym "DUM"))
+ (name (dsd-name slot))
+ (keyword (keywordicate name))
+ ;; Canonicalize the type for a prettier macro-expansion
+ (type (type-specifier
+ (specifier-type `(and ,int-type ,(dsd-type slot))))))
+ (arglist `((,keyword ,dum) ,(dsd-default slot)))
+ (vals dum)
+ ;; KLUDGE: we need a separate type declaration for for
+ ;; keyword arguments, since default values bypass the
+ ;; checking provided by the FTYPE.
+ (unless (eq t type)
+ (decls `(type ,type ,dum)))
+ (ftype-args `(,keyword ,type)))))
(funcall creator
defstruct (dd-default-constructor defstruct)
- (arglist) (vals) (types) (vals))))
+ (arglist) `(&key ,@(ftype-args)) (decls) (vals))))
;;; Given a structure and a BOA constructor spec, call CREATOR with
;;; the appropriate args to make a constructor.
(parse-lambda-list (second boa))
(collect ((arglist)
(vars)
- (types)
- (skipped-vars))
- (labels ((get-slot (name)
- (let ((res (find name (dd-slots defstruct)
- :test #'string=
- :key #'dsd-name)))
- (if res
- (values (dsd-type res) (dsd-default res))
- (values t nil))))
- (do-default (arg)
- (multiple-value-bind (type default) (get-slot arg)
- (arglist `(,arg ,default))
- (vars arg)
- (types type))))
- (dolist (arg req)
- (arglist arg)
- (vars arg)
- (types (get-slot arg)))
-
- (when opt
- (arglist '&optional)
- (dolist (arg opt)
- (cond ((consp arg)
- (destructuring-bind
- ;; FIXME: this shares some logic (though not
- ;; code) with the &key case below (and it
- ;; looks confusing) -- factor out the logic
- ;; if possible. - CSR, 2002-04-19
- (name
- &optional
- (def (nth-value 1 (get-slot name)))
- (supplied-test nil supplied-test-p))
- arg
- (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
- (vars name)
- (types (get-slot name))))
- (t
- (do-default arg)))))
-
- (when restp
- (arglist '&rest rest)
- (vars rest)
- (types 'list))
-
- (when keyp
- (arglist '&key)
- (dolist (key keys)
- (if (consp key)
- (destructuring-bind (wot
- &optional
- (def nil def-p)
- (supplied-test nil supplied-test-p))
- key
- (let ((name (if (consp wot)
- (destructuring-bind (key var) wot
- (declare (ignore key))
- var)
- wot)))
- (multiple-value-bind (type slot-def)
- (get-slot name)
- (arglist `(,wot ,(if def-p def slot-def)
- ,@(if supplied-test-p `(,supplied-test) nil)))
- (vars name)
- (types type))))
- (do-default key))))
-
- (when allowp (arglist '&allow-other-keys))
-
- (when auxp
- (arglist '&aux)
- (dolist (arg aux)
+ (skipped-vars)
+ (ftype-args)
+ (decls))
+ (let ((int-type (if (eq 'vector (dd-type defstruct))
+ (dd-element-type defstruct)
+ t)))
+ (labels ((get-slot (name)
+ (let* ((res (find name (dd-slots defstruct)
+ :test #'string=
+ :key #'dsd-name))
+ (type (type-specifier
+ (specifier-type
+ `(and ,int-type ,(if res
+ (dsd-type res)
+ t))))))
+ (values type (when res (dsd-default res)))))
+ (do-default (arg &optional keyp)
+ (multiple-value-bind (type default) (get-slot arg)
+ (arglist `(,arg ,default))
+ (vars arg)
+ (if keyp
+ (arg-type type (keywordicate arg) arg)
+ (arg-type type))))
+ (arg-type (type &optional key var)
+ (cond (key
+ ;; KLUDGE: see comment in CREATE-KEYWORD-CONSTRUCTOR.
+ (unless (eq t type)
+ (decls `(type ,type ,var)))
+ (ftype-args `(,key ,type)))
+ (t
+ (ftype-args type)))))
+ (dolist (arg req)
(arglist arg)
- (if (proper-list-of-length-p arg 2)
- (let ((var (first arg)))
- (vars var)
- (types (get-slot var)))
- (skipped-vars (if (consp arg) (first arg) arg))))))
+ (vars arg)
+ (arg-type (get-slot arg)))
+
+ (when opt
+ (arglist '&optional)
+ (ftype-args '&optional)
+ (dolist (arg opt)
+ (cond ((consp arg)
+ (destructuring-bind
+ ;; FIXME: this shares some logic (though not
+ ;; code) with the &key case below (and it
+ ;; looks confusing) -- factor out the logic
+ ;; if possible. - CSR, 2002-04-19
+ (name
+ &optional
+ (def (nth-value 1 (get-slot name)))
+ (supplied-test nil supplied-test-p))
+ arg
+ (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
+ (vars name)
+ (arg-type (get-slot name))
+ (when supplied-test-p
+ (vars supplied-test))))
+ (t
+ (do-default arg)))))
+
+ (when restp
+ (arglist '&rest rest)
+ (vars rest)
+ (ftype-args '&rest)
+ (arg-type t)
+ (decls `(type list ,rest)))
+
+ (when keyp
+ (arglist '&key)
+ (ftype-args '&key)
+ (dolist (key keys)
+ (if (consp key)
+ (destructuring-bind (wot
+ &optional
+ (def nil def-p)
+ (supplied-test nil supplied-test-p))
+ key
+ (multiple-value-bind (key name)
+ (if (consp wot)
+ (destructuring-bind (key var) wot
+ (values key var))
+ (values (keywordicate wot) wot))
+ (multiple-value-bind (type slot-def)
+ (get-slot name)
+ (arglist `(,wot ,(if def-p def slot-def)
+ ,@(if supplied-test-p `(,supplied-test) nil)))
+ (vars name)
+ (arg-type type key name)
+ (when supplied-test-p
+ (vars supplied-test)))))
+ (do-default key t))))
+
+ (when allowp
+ (arglist '&allow-other-keys)
+ (ftype-args '&allow-other-keys))
+
+ (when auxp
+ (arglist '&aux)
+ (dolist (arg aux)
+ (if (proper-list-of-length-p arg 2)
+ (let ((var (first arg)))
+ (arglist arg)
+ (vars var)
+ (decls `(type ,(get-slot var) ,var)))
+ (skipped-vars (if (consp arg) (first arg) arg)))))))
(funcall creator defstruct (first boa)
- (arglist) (vars) (types)
+ (arglist) (ftype-args) (decls)
(loop for slot in (dd-slots defstruct)
for name = (dsd-name slot)
collect (cond ((find name (skipped-vars) :test #'string=)
(unless (or defaults boas)
(push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
- (collect ((res) (names))
+ (collect ((res))
(when defaults
(let ((cname (first defaults)))
(setf (dd-default-constructor defstruct) cname)
- (res (create-keyword-constructor defstruct creator))
- (names cname)
+ (multiple-value-bind (cons ftype)
+ (create-keyword-constructor defstruct creator)
+ (res `(declaim (ftype ,ftype ,@defaults)))
+ (res cons))
(dolist (other-name (rest defaults))
- (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
- (names other-name))))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname))))))
(dolist (boa boas)
- (res (create-boa-constructor defstruct boa creator))
- (names (first boa)))
-
- (res `(declaim (ftype
- (sfunction *
- ,(if (eq (dd-type defstruct) 'structure)
- (dd-name defstruct)
- '*))
- ,@(names))))
+ (multiple-value-bind (cons ftype)
+ (create-boa-constructor defstruct boa creator)
+ (res `(declaim (ftype ,ftype ,(first boa))))
+ (res cons)))
(res))))
\f
(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