(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
(symbol
(when (keywordp spec)
(style-warn "Keyword slot name indicates probable syntax ~
- error in DEFSTRUCT: ~S."
+ error in DEFSTRUCT: ~S."
spec))
spec)
(cons
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 ((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
(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
;; 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 (unsigned-byte 32) (*))
- ,raw-vector-bare-form))
+ `(truly-the
+ (simple-array sb!vm:word (*))
+ ,raw-vector-bare-form))
raw-vector-bare-form)))
`(,raw-slot-accessor ,raw-vector-form ,scaled-dsd-index)))))))
`(,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
projects / sbcl.git / blobdiff