(t res))))
;;; 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.
+;;; compiled, since it doesn't exist until after the EVAL-WHEN
+;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
+;;; DEFSTRUCT is executing in a non-toplevel context, the
+;;; compiler-layout still doesn't exist at compilation time, and we
+;;; delay still further.)
(sb!xc:defmacro %delayed-get-compiler-layout (name)
- `',(compiler-layout-or-lose name))
+ (let ((layout (info :type :compiler-layout name)))
+ (cond (layout
+ ;; ordinary case: When the DEFSTRUCT is at top level,
+ ;; then EVAL-WHEN (COMPILE) stuff will have set up the
+ ;; layout for us to use.
+ (unless (typep (layout-info layout) 'defstruct-description)
+ (error "Class is not a structure class: ~S" name))
+ `,layout)
+ (t
+ ;; KLUDGE: In the case that DEFSTRUCT is not at top-level
+ ;; the layout doesn't exist at compile time. In that case
+ ;; we laboriously look it up at run time. This code will
+ ;; run on every constructor call and will likely be quite
+ ;; slow, so if anyone cares about performance of
+ ;; non-toplevel DEFSTRUCTs, it should be rewritten to be
+ ;; cleverer. -- WHN 2002-10-23
+ (sb!c::compiler-note
+ "implementation limitation: ~
+ Non-toplevel DEFSTRUCT constructors are slow.")
+ (let ((layout (gensym "LAYOUT")))
+ `(let ((,layout (info :type :compiler-layout ',name)))
+ (unless (typep (layout-info ,layout) 'defstruct-description)
+ (error "Class is not a structure class: ~S" ',name))
+ ,layout))))))
;;; Get layout right away.
(sb!xc:defmacro compile-time-find-layout (name)
(:conc-name dd-)
(:make-load-form-fun just-dump-it-normally)
#-sb-xc-host (:pure t)
- (:constructor make-defstruct-description (name)))
+ (:constructor make-defstruct-description
+ (name &aux
+ (conc-name (symbolicate name "-"))
+ (copier-name (symbolicate "COPY-" name))
+ (predicate-name (symbolicate name "-P")))))
;; name of the structure
- (name (missing-arg) :type symbol)
+ (name (missing-arg) :type symbol :read-only t)
;; documentation on the structure
(doc nil :type (or string null))
;; prefix for slot names. If NIL, none.
- (conc-name (symbolicate name "-") :type (or symbol null))
+ (conc-name nil :type (or symbol null))
;; the name of the primary standard keyword constructor, or NIL if none
(default-constructor nil :type (or symbol null))
;; all the explicit :CONSTRUCTOR specs, with name defaulted
(constructors () :type list)
;; name of copying function
- (copier-name (symbolicate "COPY-" name) :type (or symbol null))
+ (copier-name nil :type (or symbol null))
;; name of type predicate
- (predicate-name (symbolicate name "-P") :type (or symbol null))
+ (predicate-name nil :type (or symbol null))
;; the arguments to the :INCLUDE option, or NIL if no included
;; structure
(include nil :type list)
;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
;; (including included ones)
(slots () :type list)
+ ;; a list of (NAME . INDEX) pairs for accessors of included structures
+ (inherited-accessor-alist () :type list)
;; number of elements we've allocated (See also RAW-LENGTH.)
(length 0 :type index)
;; General kind of implementation.
(:copier nil)
#-sb-xc-host (:pure t))
;; string name of slot
- %name
+ %name
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
(accessor-name nil)
default ; default value expression
(type t) ; declared type specifier
+ (safe-p t :type boolean) ; whether the slot is known to be
+ ; always of the specified type
;; If this object does not describe a raw slot, this value is T.
;;
;; If this object describes a raw slot, this value is the type of the
;; What operator is used (on the raw data vector) to access a slot
;; of this type?
(accessor-name (missing-arg) :type symbol :read-only t)
- ;; How many words are each value of this type? (This is used to
+ ;; How many words are each value of this type? (This is used to
;; rescale the offset into the raw data vector.)
(n-words (missing-arg) :type (and index (integer 1)) :read-only t))
- (defvar *raw-slot-data-list*
+ (defvar *raw-slot-data-list*
(list
;; The compiler thinks that the raw data vector is a vector of
;; word-sized unsigned bytes, so if the slot we want to access
fun-name)))
(cond ((not (eql pf 0))
`((def!method print-object ((,x ,name) ,s)
- (funcall #',(farg pf) ,x ,s *current-level*))))
+ (funcall #',(farg pf)
+ ,x
+ ,s
+ *current-level-in-print*))))
((not (eql po 0))
`((def!method print-object ((,x ,name) ,s)
(funcall #',(farg po) ,x ,s))))
(if (dd-class-p dd)
(let ((inherits (inherits-for-structure dd)))
`(progn
+ ;; Note we intentionally call %DEFSTRUCT first, and
+ ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT
+ ;; has the tests (and resulting CERROR) for collisions
+ ;; with LAYOUTs which already exist in the runtime. If
+ ;; there are any collisions, we want the user's
+ ;; response to CERROR to control what happens.
+ ;; Especially, if the user responds to the collision
+ ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to
+ ;; modify the definition of the class.
+ (%defstruct ',dd ',inherits)
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-defstruct ',dd ',inherits))
- (%defstruct ',dd ',inherits)
,@(unless expanding-into-code-for-xc-host-p
(append ;; FIXME: We've inherited from CMU CL nonparallel
;; code for creating copiers for typed and untyped
;; structures. This should be fixed.
- ;(copier-definition dd)
+ ;(copier-definition dd)
(constructor-definitions dd)
(class-method-definitions dd)))
',name))
\f
;;;; functions to generate code for various parts of DEFSTRUCT definitions
+;;; First, a helper to determine whether a name names an inherited
+;;; accessor.
+(defun accessor-inherited-data (name defstruct)
+ (assoc name (dd-inherited-accessor-alist defstruct) :test #'eq))
+
;;; Return a list of forms which create a predicate function for a
;;; typed DEFSTRUCT.
(defun typed-predicate-definitions (defstruct)
(index (dsd-index slot))
(slot-type `(and ,(dsd-type slot)
,(dd-element-type defstruct))))
- (stuff `(proclaim '(inline ,name (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))))
- (unless (dsd-read-only slot)
- (stuff
- `(defun (setf ,name) (new-value structure)
- (declare (type ,ltype structure) (type ,slot-type new-value))
- (setf (elt structure ,index) new-value)))))))
+ (let ((inherited (accessor-inherited-data name defstruct)))
+ (cond
+ ((not inherited)
+ (stuff `(proclaim '(inline ,name (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))))
+ (unless (dsd-read-only slot)
+ (stuff
+ `(defun (setf ,name) (new-value structure)
+ (declare (type ,ltype structure) (type ,slot-type new-value))
+ (setf (elt structure ,index) new-value)))))
+ ((not (= (cdr inherited) index))
+ (style-warn "~@<Non-overwritten accessor ~S does not access ~
+ slot with name ~S (accessing an inherited slot ~
+ instead).~:@>" name (dsd-%name slot))))))))
(stuff)))
\f
;;;; parsing
(name (dd-name dd)))
(case (first option)
(:conc-name
- (destructuring-bind (conc-name) args
+ (destructuring-bind (&optional conc-name) args
(setf (dd-conc-name dd)
(if (symbolp conc-name)
conc-name
(setf (dsd-%name slot) (string name))
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
- (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+ (let ((accessor-name (if (dd-conc-name defstruct)
+ (symbolicate (dd-conc-name defstruct) name)
+ name))
(predicate-name (dd-predicate-name defstruct)))
(setf (dsd-accessor-name slot) accessor-name)
(when (eql accessor-name predicate-name)
accessor, but you can't rely on this behavior, so it'd be wise to ~
remove the ambiguity in your code.~@:>"
accessor-name)
- (setf (dd-predicate-name defstruct) nil)))
+ (setf (dd-predicate-name defstruct) nil))
+ #-sb-xc-host
+ (when (and (fboundp accessor-name)
+ (not (accessor-inherited-data accessor-name defstruct)))
+ (style-warn "redefining ~S in DEFSTRUCT" accessor-name)))
(when default-p
(setf (dsd-default slot) default))
(setf (dd-raw-index dd) (dd-raw-index included-structure))
(setf (dd-raw-length dd) (dd-raw-length included-structure)))
+ (setf (dd-inherited-accessor-alist dd)
+ (dd-inherited-accessor-alist included-structure))
(dolist (included-slot (dd-slots included-structure))
(let* ((included-name (dsd-name included-slot))
(modified (or (find included-name modified-slots
:key (lambda (x) (if (atom x) x (car x)))
:test #'string=)
`(,included-name))))
+ ;; We stash away an alist of accessors to parents' slots
+ ;; that have already been created to avoid conflicts later
+ ;; so that structures with :INCLUDE and :CONC-NAME (and
+ ;; other edge cases) can work as specified.
+ (when (dsd-accessor-name included-slot)
+ ;; the "oldest" (i.e. highest up the tree of inheritance)
+ ;; will prevail, so don't push new ones on if they
+ ;; conflict.
+ (pushnew (cons (dsd-accessor-name included-slot)
+ (dsd-index included-slot))
+ (dd-inherited-accessor-alist dd)
+ :test #'eq :key #'car))
(parse-1-dsd dd
modified
(copy-structure included-slot)))))))
;;; and writer functions of the slot described by DSD.
(defun slot-accessor-inline-expansion-designators (dd dsd)
(let ((instance-type-decl `(declare (type ,(dd-name dd) instance)))
- (accessor-place-form (%accessor-place-form dd dsd 'instance))
- (dsd-type (dsd-type dsd)))
- (values (lambda ()
- `(lambda (instance)
- ,instance-type-decl
- (truly-the ,dsd-type ,accessor-place-form)))
- (lambda ()
- `(lambda (new-value instance)
- (declare (type ,dsd-type new-value))
- ,instance-type-decl
- (setf ,accessor-place-form new-value))))))
+ (accessor-place-form (%accessor-place-form dd dsd 'instance))
+ (dsd-type (dsd-type dsd))
+ (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
+ (values (lambda () `(lambda (instance)
+ ,instance-type-decl
+ (,value-the ,dsd-type ,accessor-place-form)))
+ (lambda () `(lambda (new-value instance)
+ (declare (type ,dsd-type new-value))
+ ,instance-type-decl
+ (setf ,accessor-place-form new-value))))))
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
(%compiler-set-up-layout dd inherits)
- (let* ((dd-name (dd-name dd))
- (dtype (dd-declarable-type dd))
- (class (sb!xc:find-class dd-name)))
+ (let* ((dtype (dd-declarable-type dd)))
(let ((copier-name (dd-copier-name dd)))
(when copier-name
(let* ((accessor-name (dsd-accessor-name dsd))
(dsd-type (dsd-type dsd)))
(when accessor-name
- (multiple-value-bind (reader-designator writer-designator)
- (slot-accessor-inline-expansion-designators dd dsd)
- (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
- ,accessor-name))
- (setf (info :function :inline-expansion-designator accessor-name)
- reader-designator
- (info :function :inlinep accessor-name)
- :inline)
- (unless (dsd-read-only dsd)
- (let ((setf-accessor-name `(setf ,accessor-name)))
- (sb!xc:proclaim
- `(ftype (function (,dsd-type ,dtype) ,dsd-type)
- ,setf-accessor-name))
- (setf (info :function
- :inline-expansion-designator
- setf-accessor-name)
- writer-designator
- (info :function :inlinep setf-accessor-name)
- :inline))))))))
-
+ (let ((inherited (accessor-inherited-data accessor-name dd)))
+ (cond
+ ((not inherited)
+ (multiple-value-bind (reader-designator writer-designator)
+ (slot-accessor-inline-expansion-designators dd dsd)
+ (sb!xc:proclaim `(ftype (function (,dtype) ,dsd-type)
+ ,accessor-name))
+ (setf (info :function :inline-expansion-designator
+ accessor-name)
+ reader-designator
+ (info :function :inlinep accessor-name)
+ :inline)
+ (unless (dsd-read-only dsd)
+ (let ((setf-accessor-name `(setf ,accessor-name)))
+ (sb!xc:proclaim
+ `(ftype (function (,dsd-type ,dtype) ,dsd-type)
+ ,setf-accessor-name))
+ (setf (info :function
+ :inline-expansion-designator
+ setf-accessor-name)
+ writer-designator
+ (info :function :inlinep setf-accessor-name)
+ :inline)))))
+ ((not (= (cdr inherited) (dsd-index dsd)))
+ (style-warn "~@<Non-overwritten accessor ~S does not access ~
+ slot with name ~S (accessing an inherited slot ~
+ instead).~:@>"
+ accessor-name
+ (dsd-%name dsd)))))))))
(values))
\f
;;;; redefinition stuff
(declare (type sb!xc:class class) (type layout old-layout new-layout))
(let ((name (class-proper-name class)))
(restart-case
- (error "redefining class ~S incompatibly with the current definition"
+ (error "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
+ 'structure-object
name)
(continue ()
- :report "Invalidate current definition."
- (warn "Previously loaded ~S accessors will no longer work." name)
- (register-layout new-layout))
+ :report (lambda (s)
+ (format s
+ "~@<Use the new definition of ~S, invalidating ~
+ already-loaded code and instances.~@:>"
+ name))
+ (register-layout new-layout))
+ (recklessly-continue ()
+ :report (lambda (s)
+ (format s
+ "~@<Use the new definition of ~S as if it were ~
+ compatible, allowing old accessors to use new ~
+ instances and allowing new accessors to use old ~
+ instances.~@:>"
+ name))
+ ;; classic CMU CL warning: "Any old ~S instances will be in a bad way.
+ ;; I hope you know what you're doing..."
+ (register-layout new-layout
+ :invalidate nil
+ :destruct-layout old-layout))
(clobber-it ()
- :report "Smash current layout, preserving old code."
- (warn "Any old ~S instances will be in a bad way.~@
- I hope you know what you're doing..."
- name)
- (register-layout new-layout :invalidate nil
- :destruct-layout old-layout))))
+ ;; FIXME: deprecated 2002-10-16, and since it's only interactive
+ ;; hackery instead of a supported feature, can probably be deleted
+ ;; in early 2003
+ :report "(deprecated synonym for RECKLESSLY-CONTINUE)"
+ (register-layout new-layout
+ :invalidate nil
+ :destruct-layout old-layout))))
(values))
;;; This is called when we are about to define a structure class. It
(undefine-fun-name (dd-predicate-name info))
(dolist (slot (dd-slots info))
(let ((fun (dsd-accessor-name slot)))
- (undefine-fun-name fun)
- (unless (dsd-read-only slot)
- (undefine-fun-name `(setf ,fun))))))
+ (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)))
;;; structures can have arbitrary subtypes of VECTOR, not necessarily
;;; SIMPLE-VECTOR.)
;;; * STRUCTURE structures can have raw slots that must also be
-;;; allocated and indirectly referenced.
+;;; allocated and indirectly referenced.
(defun create-vector-constructor (dd cons-name arglist vars types values)
(let ((temp (gensym))
(etype (dd-element-type dd)))
`(setf (aref ,temp ,(cdr x)) ',(car x)))
(find-name-indices dd))
,@(mapcar (lambda (dsd value)
- `(setf (aref ,temp ,(dsd-index 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)
(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)) val))
+ (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))
(let ((,instance (truly-the ,(dd-name dd)
(%make-instance-with-layout
(%delayed-get-compiler-layout ,(dd-name dd))))))
- (declare (optimize (safety 0))) ; Suppress redundant slot type checks.
,@(when raw-index
`((setf (%instance-ref ,instance ,raw-index)
(make-array ,(dd-raw-length dd)
;; 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))
+ (unless (eq value '.do-not-initialize-slot.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))
(dd-slots dd)
values)
,instance))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
+ (declare (type function creator))
(collect ((arglist (list '&key))
(types)
(vals))
;;; Given a structure and a BOA constructor spec, call CREATOR with
;;; the appropriate args to make a constructor.
(defun create-boa-constructor (defstruct boa creator)
- (multiple-value-bind (req opt restp rest keyp keys allowp aux)
- (sb!kernel:parse-lambda-list (second boa))
+ (declare (type function creator))
+ (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
+ (parse-lambda-list (second boa))
(collect ((arglist)
(vars)
- (types))
+ (types)
+ (skipped-vars))
(labels ((get-slot (name)
(let ((res (find name (dd-slots defstruct)
:test #'string=
(arglist arg)
(vars arg)
(types (get-slot arg)))
-
+
(when opt
(arglist '&optional)
(dolist (arg opt)
(cond ((consp arg)
(destructuring-bind
- (name &optional (def (nth-value 1 (get-slot name))))
+ ;; 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))
+ (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
(types (get-slot name))))
(t
(arglist '&key)
(dolist (key keys)
(if (consp key)
- (destructuring-bind (wot &optional (def nil def-p)) 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)))
+ (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 aux
+ (when auxp
(arglist '&aux)
(dolist (arg aux)
- (let* ((arg (if (consp arg) arg (list arg)))
- (var (first arg)))
- (arglist arg)
- (vars var)
- (types (get-slot var))))))
+ (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))))))
(funcall creator defstruct (first boa)
(arglist) (vars) (types)
- (mapcar (lambda (slot)
- (or (find (dsd-name slot) (vars) :test #'string=)
- (dsd-default slot)))
- (dd-slots defstruct))))))
+ (loop for slot in (dd-slots defstruct)
+ for name = (dsd-name slot)
+ collect (cond ((find name (skipped-vars) :test #'string=)
+ (setf (dsd-safe-p slot) nil)
+ '.do-not-initialize-slot.)
+ ((or (find (dsd-name slot) (vars) :test #'string=)
+ (dsd-default slot)))))))))
;;; Grovel the constructor options, and decide what constructors (if
;;; any) to create.
;;;; main DEFSTRUCT macro. Hopefully it will go away presently
;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below.
;;;; -- WHN 2001-10-28
-;;;;
+;;;;
;;;; FIXME: There seems to be no good reason to shoehorn CONDITION,
;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures
;;;; instead of just implementing them as primitive objects. (This
:metaclass-name metaclass-name
:metaclass-constructor metaclass-constructor
:dd-type dd-type))
- (conc-name (concatenate 'string (symbol-name class-name) "-"))
(dd-slots (dd-slots dd))
(dd-length (1+ (length slot-names)))
(object-gensym (gensym "OBJECT"))
(let ((dsd (find (symbol-name slot-name) dd-slots
:key #'dsd-%name
:test #'string=)))
+ ;; KLUDGE: bug 117 bogowarning. Neither
+ ;; DECLAREing the type nor TRULY-THE cut
+ ;; the mustard -- it still gives warnings.
+ (enforce-type dsd defstruct-slot-description)
`(setf (,(dsd-accessor-name dsd) ,object-gensym)
- ,slot-name)))
+ ,slot-name)))
slot-names)
,object-gensym))
-
+
;; predicate
,@(when predicate
;; Just delegate to the compiler's type optimization
projects / sbcl.git / blobdiff