X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=6508d2c8e8526141eba4dd9133662dd1a9578351;hb=5da5805594423a2d2a841b88617fd2c87fc05750;hp=6d70ebeed6980add1042cd96452344d6634ecec8;hpb=beccf6c476f5cf2ef0bd839866527a46ec88d626;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6d70ebe..6508d2c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -337,15 +337,18 @@ (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)) @@ -358,6 +361,8 @@ (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 @@ -609,7 +614,7 @@ (symbol (when (keywordp spec) (style-warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT: ~S." + error in DEFSTRUCT: ~S." spec)) spec) (cons @@ -693,7 +698,7 @@ ;;; ;;; 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 @@ -817,8 +822,8 @@ modified (copy-structure included-slot)))) (when (and (neq (dsd-type new-slot) (dsd-type included-slot)) - (not (subtypep (dsd-type included-slot) - (dsd-type new-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? @@ -838,15 +843,26 @@ (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 @@ -909,8 +925,9 @@ ;; 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))))))) @@ -926,11 +943,13 @@ `(,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) @@ -1087,10 +1106,10 @@ (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)))) @@ -1160,12 +1179,16 @@ (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) @@ -1307,7 +1330,7 @@ ,@(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