X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=6508d2c8e8526141eba4dd9133662dd1a9578351;hb=f78c1fecf191e147ca081026cc11f2683ee80905;hp=feec05a3c3b231958cb109e8616483a90a4bc362;hpb=ff57884e206ac28660af6af34315bc9b81697f57;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index feec05a..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 @@ -424,15 +429,16 @@ (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) @@ -455,7 +461,7 @@ (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 @@ -608,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 @@ -656,11 +662,18 @@ 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 @@ -672,8 +685,8 @@ (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 "~@" (dsd-name slot))))) slot)) @@ -685,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 @@ -805,9 +818,16 @@ (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? + ))))))) ;;;; various helper functions for setting up DEFSTRUCTs @@ -823,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 @@ -894,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))))))) @@ -911,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) @@ -986,7 +1020,7 @@ (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) @@ -1072,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)))) @@ -1145,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) @@ -1292,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