X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=ef5559c7de0a3d3246f50e9db282bfd9563eb817;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=01ed4b24d3c2add12743c9275c147aae3d7d461f;hpb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 01ed4b2..ef5559c 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -49,10 +49,10 @@ ;; 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.") - (let ((layout (gensym "LAYOUT"))) + (with-unique-names (layout) `(let ((,layout (info :type :compiler-layout ',name))) (unless (typep (layout-info ,layout) 'defstruct-description) (error "Class is not a structure class: ~S" ',name)) @@ -174,8 +174,8 @@ (:conc-name dsd-) (:copier nil) #-sb-xc-host (:pure t)) - ;; string name of slot - %name + ;; name of slot + name ;; its position in the implementation sequence (index (missing-arg) :type fixnum) ;; the name of the accessor function @@ -187,6 +187,8 @@ (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 @@ -202,14 +204,6 @@ (def!method print-object ((x defstruct-slot-description) stream) (print-unreadable-object (x stream :type t) (prin1 (dsd-name x) stream))) - -;;; Return the name of a defstruct slot as a symbol. We store it as a -;;; string to avoid creating lots of worthless symbols at load time. -(defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) - (if (dsd-accessor-name dsd) - (symbol-package (dsd-accessor-name dsd)) - (sane-package)))) ;;;; typed (non-class) structures @@ -221,7 +215,7 @@ ;;;; shared machinery for inline and out-of-line slot accessor functions -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed (defstruct raw-slot-data @@ -235,11 +229,11 @@ ;; 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 @@ -287,7 +281,7 @@ ;; class names which creates fast but non-cold-loadable, ;; non-compact code. In this context, we'd rather have ;; compact, cold-loadable code. -- WHN 19990928 - (declare (notinline sb!xc:find-class)) + (declare (notinline find-classoid)) ,@(let ((pf (dd-print-function defstruct)) (po (dd-print-object defstruct)) (x (gensym)) @@ -316,16 +310,16 @@ (t nil)))) ,@(let ((pure (dd-pure defstruct))) (cond ((eq pure t) - `((setf (layout-pure (class-layout - (sb!xc:find-class ',name))) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) t))) ((eq pure :substructure) - `((setf (layout-pure (class-layout - (sb!xc:find-class ',name))) + `((setf (layout-pure (classoid-layout + (find-classoid ',name))) 0))))) ,@(let ((def-con (dd-default-constructor defstruct))) (when (and def-con (not (dd-alternate-metaclass defstruct))) - `((setf (structure-class-constructor (sb!xc:find-class ',name)) + `((setf (structure-classoid-constructor (find-classoid ',name)) #',def-con)))))))) ;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT @@ -343,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)) @@ -364,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,12 +423,22 @@ (predicate-name (dd-predicate-name defstruct)) (argname (gensym))) (when (and predicate-name (dd-named defstruct)) - (let ((ltype (dd-lisp-type defstruct))) + (let ((ltype (dd-lisp-type defstruct)) + (name-index (cdr (car (last (find-name-indices defstruct)))))) `((defun ,predicate-name (,argname) (and (typep ,argname ',ltype) - (eq (elt (the ,ltype ,argname) - ,(cdr (car (last (find-name-indices defstruct))))) - ',name)))))))) + ,(cond + ((subtypep ltype 'list) + `(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) + `(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)))))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. (defun typed-copier-definitions (defstruct) @@ -452,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 @@ -468,7 +477,7 @@ ((not (= (cdr inherited) index)) (style-warn "~@" name (dsd-%name slot)))))))) + instead).~:@>" name (dsd-name slot)))))))) (stuff))) ;;;; parsing @@ -597,33 +606,39 @@ ;;; that we modify to get the new slot. This is supplied when handling ;;; included slots. (defun parse-1-dsd (defstruct spec &optional - (slot (make-defstruct-slot-description :%name "" + (slot (make-defstruct-slot-description :name "" :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)) - - (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name) + (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= + :key (lambda (x) (symbol-name (dsd-name x)))) (error 'simple-program-error :format-control "duplicate slot name ~S" :format-arguments (list name))) - (setf (dsd-%name slot) (string name)) + (setf (dsd-name slot) name) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot))) (let ((accessor-name (if (dd-conc-name defstruct) @@ -647,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 @@ -663,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)) @@ -676,12 +698,7 @@ ;;; ;;; 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 @@ -753,12 +770,12 @@ (specifier-type (dd-element-type dd)))) (error ":TYPE option mismatch between structures ~S and ~S" (dd-name dd) included-name)) - (let ((included-class (sb!xc:find-class included-name nil))) - (when included-class + (let ((included-classoid (find-classoid included-name nil))) + (when included-classoid ;; It's not particularly well-defined to :INCLUDE any of the ;; CMU CL INSTANCE weirdosities like CONDITION or ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant. - (let* ((included-layout (class-layout included-class)) + (let* ((included-layout (classoid-layout included-classoid)) (included-dd (layout-info included-layout))) (when (and (dd-alternate-metaclass included-dd) ;; As of sbcl-0.pre7.73, anyway, STRUCTURE-OBJECT @@ -801,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 (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 @@ -816,18 +840,29 @@ (super (if include (compiler-layout-or-lose (first include)) - (class-layout (sb!xc:find-class - (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 - (class-layout (sb!xc:find-class 'stream)))) - (concatenate 'simple-vector - (layout-inherits super) - (vector super))))) + (classoid-layout (find-classoid + (or (first superclass-opt) + 'structure-object)))))) + (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 @@ -838,10 +873,10 @@ (declare (type defstruct-description dd)) ;; We set up LAYOUTs even in the cross-compilation host. - (multiple-value-bind (class layout old-layout) + (multiple-value-bind (classoid layout old-layout) (ensure-structure-class dd inherits "current" "new") (cond ((not old-layout) - (unless (eq (class-layout class) layout) + (unless (eq (classoid-layout classoid) layout) (register-layout layout))) (t (let ((old-dd (layout-info old-layout))) @@ -850,9 +885,9 @@ (fmakunbound (dsd-accessor-name slot)) (unless (dsd-read-only slot) (fmakunbound `(setf ,(dsd-accessor-name slot))))))) - (%redefine-defstruct class old-layout layout) - (setq layout (class-layout class)))) - (setf (sb!xc:find-class (dd-name dd)) class) + (%redefine-defstruct classoid old-layout layout) + (setq layout (classoid-layout classoid)))) + (setf (find-classoid (dd-name dd)) classoid) ;; Various other operations only make sense on the target SBCL. #-sb-xc-host @@ -880,30 +915,47 @@ (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)))))) - -;;; Return inline expansion designators (i.e. values suitable for -;;; (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR ..)) for the reader -;;; 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)))))) + (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 +;;; source transforms work faster. +(defun slot-accessor-transforms (dd dsd) + (let ((accessor-place-form (%accessor-place-form dd dsd + `(the ,(dd-name dd) instance))) + (dsd-type (dsd-type dsd)) + (value-the (if (dsd-safe-p dsd) 'truly-the 'the))) + (values (sb!c:source-transform-lambda (instance) + `(,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 + (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) - (funcall (nth-value 1 - (slot-accessor-inline-expansion-designators dd dsd)))) + `(lambda (new-value instance) + ,(funcall (nth-value 1 (slot-accessor-transforms dd dsd)) + '(dummy new-value instance)))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities @@ -918,7 +970,7 @@ (inherits (vector (find-layout t) (find-layout 'instance)))) - (multiple-value-bind (class layout old-layout) + (multiple-value-bind (classoid layout old-layout) (multiple-value-bind (clayout clayout-p) (info :type :compiler-layout (dd-name dd)) (ensure-structure-class dd @@ -927,27 +979,27 @@ "compiled" :compiler-layout clayout)) (cond (old-layout - (undefine-structure (layout-class old-layout)) - (when (and (class-subclasses class) + (undefine-structure (layout-classoid old-layout)) + (when (and (classoid-subclasses classoid) (not (eq layout old-layout))) (collect ((subs)) - (dohash (class layout (class-subclasses class)) + (dohash (classoid layout (classoid-subclasses classoid)) (declare (ignore layout)) - (undefine-structure class) - (subs (class-proper-name class))) + (undefine-structure classoid) + (subs (classoid-proper-name classoid))) (when (subs) (warn "removing old subclasses of ~S:~% ~S" - (sb!xc:class-name class) + (classoid-name classoid) (subs)))))) (t - (unless (eq (class-layout class) layout) + (unless (eq (classoid-layout classoid) layout) (register-layout layout :invalidate nil)) - (setf (sb!xc:find-class (dd-name dd)) class))) + (setf (find-classoid (dd-name dd)) classoid))) ;; At this point the class should be set up in the INFO database. ;; But the logic that enforces this is a little tangled and ;; scattered, so it's not obvious, so let's check. - (aver (sb!xc:find-class (dd-name dd) nil)) + (aver (find-classoid (dd-name dd) nil)) (setf (info :type :compiler-layout (dd-name dd)) layout)) @@ -964,15 +1016,15 @@ (let ((copier-name (dd-copier-name dd))) (when copier-name - (sb!xc:proclaim `(ftype (function (,dtype) ,dtype) ,copier-name)))) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dtype) ,copier-name)))) (let ((predicate-name (dd-predicate-name dd))) (when predicate-name - (sb!xc:proclaim `(ftype (function (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) - ;; Let the predicate be inlined. + ;; Let the predicate be inlined. (setf (info :function :inline-expansion-designator predicate-name) (lambda () `(lambda (x) @@ -998,31 +1050,24 @@ (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) + (slot-accessor-transforms dd dsd) + (sb!xc:proclaim `(ftype (sfunction (,dtype) ,dsd-type) ,accessor-name)) - (setf (info :function :inline-expansion-designator - accessor-name) - reader-designator - (info :function :inlinep accessor-name) - :inline) + (setf (info :function :source-transform accessor-name) + reader-designator) (unless (dsd-read-only dsd) (let ((setf-accessor-name `(setf ,accessor-name))) (sb!xc:proclaim - `(ftype (function (,dsd-type ,dtype) ,dsd-type) + `(ftype (sfunction (,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))))) + (setf (info :function :source-transform setf-accessor-name) + writer-designator))))) ((not (= (cdr inherited) (dsd-index dsd))) (style-warn "~@" accessor-name - (dsd-%name dsd))))))))) + (dsd-name dsd))))))))) (values)) ;;;; redefinition stuff @@ -1039,32 +1084,32 @@ (collect ((moved) (retyped)) (dolist (name (intersection onames nnames)) - (let ((os (find name oslots :key #'dsd-name)) - (ns (find name nslots :key #'dsd-name))) - (unless (subtypep (dsd-type ns) (dsd-type os)) + (let ((os (find name oslots :key #'dsd-name :test #'string=)) + (ns (find name nslots :key #'dsd-name :test #'string=))) + (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os)) (retyped name)) (unless (and (= (dsd-index os) (dsd-index ns)) (eq (dsd-raw-type os) (dsd-raw-type ns))) (moved name)))) (values (moved) (retyped) - (set-difference onames nnames))))) + (set-difference onames nnames :test #'string=))))) ;;; If we are redefining a structure with different slots than in the ;;; currently loaded version, give a warning and return true. -(defun redefine-structure-warning (class old new) +(defun redefine-structure-warning (classoid old new) (declare (type defstruct-description old new) - (type sb!xc:class class) - (ignore class)) + (type classoid classoid) + (ignore classoid)) (let ((name (dd-name new))) (multiple-value-bind (moved retyped deleted) (compare-slots old new) (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)))) @@ -1072,9 +1117,10 @@ ;;; structure CLASS to have the specified NEW-LAYOUT. We signal an ;;; error with some proceed options and return the layout that should ;;; be used. -(defun %redefine-defstruct (class old-layout new-layout) - (declare (type sb!xc:class class) (type layout old-layout new-layout)) - (let ((name (class-proper-name class))) +(defun %redefine-defstruct (classoid old-layout new-layout) + (declare (type classoid classoid) + (type layout old-layout new-layout)) + (let ((name (classoid-proper-name classoid))) (restart-case (error "~@" 'structure-object @@ -1121,24 +1167,29 @@ (destructuring-bind (&optional name - (class 'sb!xc:structure-class) - (constructor 'make-structure-class)) + (class 'structure-classoid) + (constructor 'make-structure-classoid)) (dd-alternate-metaclass info) (declare (ignore name)) - (insured-find-class (dd-name info) - (if (eq class 'sb!xc:structure-class) - (lambda (x) - (typep x 'sb!xc:structure-class)) - (lambda (x) - (sb!xc:typep x (sb!xc:find-class class)))) - (fdefinition constructor))) - (setf (class-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-class (svref inherits (1- (length inherits)))) - (layout-class (svref inherits (- (length inherits) 2)))) - (list (layout-class (svref inherits (1- (length inherits))))))) - (let ((new-layout (make-layout :class class + (insured-find-classoid (dd-name info) + (if (eq class 'structure-classoid) + (lambda (x) + (sb!xc:typep x 'structure-classoid)) + (lambda (x) + (sb!xc:typep x (find-classoid class)))) + (fdefinition constructor))) + (setf (classoid-direct-superclasses class) + (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) :length (dd-length info) @@ -1150,7 +1201,7 @@ (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING ;; of classic CMU CL. I moved it out to here because it was only ;; exercised in this code path anyway. -- WHN 19990510 - (not (eq (layout-class new-layout) (layout-class old-layout))) + (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) (error "shouldn't happen: weird state of OLD-LAYOUT?")) ((not *type-system-initialized*) (setf (layout-info old-layout) info) @@ -1183,7 +1234,7 @@ ;;; over this type, clearing the compiler structure type info, and ;;; undefining all the associated functions. (defun undefine-structure (class) - (let ((info (layout-info (class-layout class)))) + (let ((info (layout-info (classoid-layout class)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (remhash type *typecheckfuns*) @@ -1279,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 @@ -1398,10 +1449,11 @@ (arglist) (vars) (types) (loop for slot in (dd-slots defstruct) for name = (dsd-name slot) - collect (if (find name (skipped-vars) :test #'string=) - '.do-not-initialize-slot. - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default 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. @@ -1428,17 +1480,26 @@ (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)))) @@ -1461,7 +1522,7 @@ ;;;; 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 @@ -1485,7 +1546,7 @@ (index 1)) (dolist (slot-name slot-names) (push (make-defstruct-slot-description - :%name (symbol-name slot-name) + :name slot-name :index index :accessor-name (symbolicate conc-name slot-name)) reversed-result) @@ -1575,7 +1636,8 @@ (let ((,object-gensym ,raw-maker-form)) ,@(mapcar (lambda (slot-name) (let ((dsd (find (symbol-name slot-name) dd-slots - :key #'dsd-%name + :key (lambda (x) + (symbol-name (dsd-name x))) :test #'string=))) ;; KLUDGE: bug 117 bogowarning. Neither ;; DECLAREing the type nor TRULY-THE cut @@ -1585,7 +1647,7 @@ ,slot-name))) slot-names) ,object-gensym)) - + ;; predicate ,@(when predicate ;; Just delegate to the compiler's type optimization