;; 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
+ (sb!c:compiler-notify
"implementation limitation: ~
Non-toplevel DEFSTRUCT constructors are slow.")
(with-unique-names (layout)
(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.
+ ;; Note we intentionally enforce package locks and
+ ;; 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.
+ (with-single-package-locked-error
+ (:symbol ',name "defining ~A as a structure"))
(%defstruct ',dd ',inherits)
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-defstruct ',dd ',inherits))
(class-method-definitions dd)))
',name))
`(progn
+ (with-single-package-locked-error
+ (:symbol ',name "defining ~A as a structure"))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (info :typed-structure :info ',name) ',dd))
,@(unless expanding-into-code-for-xc-host-p
(and (typep ,argname ',ltype)
,(cond
((subtypep ltype 'list)
- `(consp (nthcdr ,name-index (the ,ltype ,argname))))
+ `(do ((head (the ,ltype ,argname) (cdr head))
+ (i 0 (1+ i)))
+ ((or (not (consp head)) (= i ,name-index))
+ (and (consp head) (eq ',name (car head))))))
((subtypep ltype 'vector)
- `(= (length (the ,ltype ,argname))
- ,(dd-length defstruct)))
+ `(and (= (length (the ,ltype ,argname))
+ ,(dd-length defstruct))
+ (eq ',name (aref (the ,ltype ,argname) ,name-index))))
(t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S."
- ltype)))
- (eq (elt (the ,ltype ,argname)
- ,name-index)
- ',name))))))))
+ ltype))))))))))
;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
(defun typed-copier-definitions (defstruct)
(let ((inherited (accessor-inherited-data name defstruct)))
(cond
((not inherited)
- (stuff `(proclaim '(inline ,name (setf ,name))))
+ (stuff `(declaim (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
:index 0
:type t)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
- (cond
- ((listp spec)
- (destructuring-bind
- (name
- &optional (default nil default-p)
- &key (type nil type-p) (read-only nil ro-p))
- spec
- (values name
- default default-p
- (uncross type) type-p
- read-only ro-p)))
- (t
- (when (keywordp spec)
- (style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
- spec))
- spec))
+ (typecase spec
+ (symbol
+ (when (keywordp spec)
+ (style-warn "Keyword slot name indicates probable syntax ~
+ error in DEFSTRUCT: ~S."
+ spec))
+ spec)
+ (cons
+ (destructuring-bind
+ (name
+ &optional (default nil default-p)
+ &key (type nil type-p) (read-only nil ro-p))
+ spec
+ (values name
+ default default-p
+ (uncross type) type-p
+ read-only ro-p)))
+ (t (error 'simple-program-error
+ :format-control "in DEFSTRUCT, ~S is not a legal slot ~
+ description."
+ :format-arguments (list spec))))
(when (find name (dd-slots defstruct)
:test #'string=
remove the ambiguity in your code.~@:>"
accessor-name)
(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)))
-
+ ;; FIXME: It would be good to check for name collisions here, but
+ ;; the easy check,
+ ;;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)))
+ ;; 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
+ ;; is actually compiled or loaded.
+ )
+
(when default-p
(setf (dsd-default slot) default))
(when type-p
(if read-only
(setf (dsd-read-only slot) t)
(when (dsd-read-only slot)
- (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
- name
+ (error "~@<The slot ~S is :READ-ONLY in superclass, and so must ~
+ be :READ-ONLY in subclass.~:@>"
(dsd-name slot)))))
slot))
;;;
;;; FIXME: This should use the data in *RAW-SLOT-DATA-LIST*.
(defun structure-raw-slot-type-and-size (type)
- (cond #+nil
- (;; FIXME: For now we suppress raw slots, since there are various
- ;; issues about the way that the cross-compiler handles them.
- (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
- (values nil nil nil))
- ((and (sb!xc:subtypep type '(unsigned-byte 32))
+ (cond ((and (sb!xc:subtypep type 'sb!vm:word)
(multiple-value-bind (fixnum? fixnum-certain?)
(sb!xc:subtypep type 'fixnum)
;; (The extra test for FIXNUM-CERTAIN? here is
(dsd-index included-slot))
(dd-inherited-accessor-alist dd)
:test #'eq :key #'car))
- (parse-1-dsd dd
- modified
- (copy-structure included-slot)))))))
+ (let ((new-slot (parse-1-dsd dd
+ modified
+ (copy-structure included-slot))))
+ (when (and (neq (dsd-type new-slot) (dsd-type included-slot))
+ (not (sb!xc:subtypep (dsd-type included-slot)
+ (dsd-type new-slot)))
+ (dsd-safe-p included-slot))
+ (setf (dsd-safe-p new-slot) nil)
+ ;; XXX: notify?
+ )))))))
\f
;;;; various helper functions for setting up DEFSTRUCTs
(classoid-layout (find-classoid
(or (first superclass-opt)
'structure-object))))))
- (if (eq (dd-name info) 'ansi-stream)
- ;; a hack to add the CL:STREAM class as a mixin for ANSI-STREAMs
- (concatenate 'simple-vector
- (layout-inherits super)
- (vector super
- (classoid-layout (find-classoid 'stream))))
- (concatenate 'simple-vector
- (layout-inherits super)
- (vector super)))))
+ (case (dd-name info)
+ ((ansi-stream)
+ (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super (classoid-layout (find-classoid 'stream)))))
+ ((fd-stream)
+ (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super
+ (classoid-layout (find-classoid 'file-stream)))))
+ ((sb!impl::string-input-stream
+ sb!impl::string-output-stream
+ sb!impl::fill-pointer-output-stream)
+ (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super
+ (classoid-layout (find-classoid 'string-stream)))))
+ (t (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super))))))
;;; Do miscellaneous (LOAD EVAL) time actions for the structure
;;; described by DD. Create the class and LAYOUT, checking for
(multiple-value-bind (scaled-dsd-index misalignment)
(floor (dsd-index dsd) raw-n-words)
(aver (zerop misalignment))
- `(,raw-slot-accessor (,ref ,instance-name ,(dd-raw-index dd))
- ,scaled-dsd-index))))))
+ (let* ((raw-vector-bare-form
+ `(,ref ,instance-name ,(dd-raw-index dd)))
+ (raw-vector-form
+ (if (eq raw-type 'unsigned-byte)
+ (progn
+ (aver (= raw-n-words 1))
+ (aver (eq raw-slot-accessor 'aref))
+ ;; FIXME: when the 64-bit world rolls
+ ;; around, this will need to be reviewed,
+ ;; along with the whole RAW-SLOT thing.
+ `(truly-the
+ (simple-array sb!vm:word (*))
+ ,raw-vector-bare-form))
+ raw-vector-bare-form)))
+ `(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
;;; Return source transforms for the reader and writer functions of
;;; the slot described by DSD. They should be inline expanded, but
`(,value-the ,dsd-type ,(subst instance 'instance
accessor-place-form)))
(sb!c:source-transform-lambda (new-value instance)
- (destructuring-bind (accessor-name &rest accessor-args)
- accessor-place-form
- `(,(info :setf :inverse accessor-name)
- ,@(subst instance 'instance accessor-args)
- (the ,dsd-type ,new-value)))))))
+ (destructuring-bind (accessor-name &rest accessor-args)
+ accessor-place-form
+ (once-only ((new-value new-value)
+ (instance instance))
+ `(,(info :setf :inverse accessor-name)
+ ,@(subst instance 'instance accessor-args)
+ (the ,dsd-type ,new-value))))))))
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
(let ((predicate-name (dd-predicate-name dd)))
(when predicate-name
- (sb!xc:proclaim `(ftype (sfunction (t) t) ,predicate-name))
+ (sb!xc:proclaim `(ftype (sfunction (t) boolean) ,predicate-name))
;; Provide inline expansion (or not).
(ecase (dd-type dd)
((structure funcallable-structure)
(when (or moved retyped deleted)
(warn
"incompatibly redefining slots of structure class ~S~@
- Make sure any uses of affected accessors are recompiled:~@
- ~@[ These slots were moved to new positions:~% ~S~%~]~
- ~@[ These slots have new incompatible types:~% ~S~%~]~
- ~@[ These slots were deleted:~% ~S~%~]"
+ Make sure any uses of affected accessors are recompiled:~@
+ ~@[ These slots were moved to new positions:~% ~S~%~]~
+ ~@[ These slots have new incompatible types:~% ~S~%~]~
+ ~@[ These slots were deleted:~% ~S~%~]"
name moved retyped deleted)
t))))
(sb!xc:typep x (find-classoid class))))
(fdefinition constructor)))
(setf (classoid-direct-superclasses class)
- (if (eq (dd-name info) 'ansi-stream)
- ;; a hack to add CL:STREAM as a superclass mixin to ANSI-STREAMs
- (list (layout-classoid (svref inherits (1- (length inherits))))
- (layout-classoid (svref inherits (- (length inherits) 2))))
- (list (layout-classoid
- (svref inherits (1- (length inherits)))))))
+ (case (dd-name info)
+ ((ansi-stream
+ fd-stream
+ sb!impl::string-input-stream sb!impl::string-output-stream
+ sb!impl::fill-pointer-output-stream)
+ (list (layout-classoid (svref inherits (1- (length inherits))))
+ (layout-classoid (svref inherits (- (length inherits) 2)))))
+ (t
+ (list (layout-classoid
+ (svref inherits (1- (length inherits))))))))
(let ((new-layout (make-layout :classoid class
:inherits inherits
:depthoid (length inherits)
,@(when raw-index
`((setf (%instance-ref ,instance ,raw-index)
(make-array ,(dd-raw-length dd)
- :element-type '(unsigned-byte 32)))))
+ :element-type 'sb!vm:word))))
,@(mapcar (lambda (dsd value)
;; (Note that we can't in general use the
;; ordinary named slot setter function here
(unless (or defaults boas)
(push (symbolicate "MAKE-" (dd-name defstruct)) defaults))
- (collect ((res))
+ (collect ((res) (names))
(when defaults
- (let ((cname (first defaults)))
- (setf (dd-default-constructor defstruct) cname)
- (res (create-keyword-constructor defstruct creator))
- (dolist (other-name (rest defaults))
- (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
- (res `(declaim (ftype function ',other-name))))))
+ (let ((cname (first defaults)))
+ (setf (dd-default-constructor defstruct) cname)
+ (res (create-keyword-constructor defstruct creator))
+ (names cname)
+ (dolist (other-name (rest defaults))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+ (names other-name))))
(dolist (boa boas)
- (res (create-boa-constructor defstruct boa creator)))
+ (res (create-boa-constructor defstruct boa creator))
+ (names (first boa)))
+
+ (res `(declaim (ftype
+ (sfunction *
+ ,(if (eq (dd-type defstruct) 'structure)
+ (dd-name defstruct)
+ '*))
+ ,@(names))))
(res))))
\f