X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=89a4edc56b902830a1d22558808bd897f2ca9bb7;hb=d76c81b0ca4dcfc99f0cd805f5c20493fa80b2b6;hp=2a7cebe9e1d7238702977d4c2d1669874b41ae08;hpb=25e76ec2b1083ac6a4bba42af7ad7b5a8239f2b8;p=sbcl.git diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2a7cebe..89a4edc 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -52,7 +52,7 @@ (sb!c::compiler-note "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)) @@ -207,11 +207,14 @@ ;;; 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. +;;; +;;; FIXME: This has horrible package issues. In many ways, it would +;;; be very nice to treat the names of structure slots as strings, but +;;; unfortunately PCL requires slot names to be interned symbols. +;;; Maybe we want to resurrect something like the old +;;; SB-SLOT-ACCESSOR-NAME package? (defun dsd-name (dsd) - (intern (string (dsd-%name dsd)) - (if (dsd-accessor-name dsd) - (symbol-package (dsd-accessor-name dsd)) - (sane-package)))) + (intern (dsd-%name dsd))) ;;;; typed (non-class) structures @@ -223,7 +226,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 @@ -289,7 +292,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)) @@ -318,16 +321,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 @@ -426,11 +429,20 @@ (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) + ,(cond + ((subtypep ltype 'list) + `(consp (nthcdr ,name-index (the ,ltype ,argname)))) + ((subtypep ltype 'vector) + `(= (length (the ,ltype ,argname)) + ,(dd-length defstruct))) + (t (bug "Uncatered-for lisp type in typed DEFSTRUCT: ~S." + ltype))) (eq (elt (the ,ltype ,argname) - ,(cdr (car (last (find-name-indices defstruct))))) + ,name-index) ',name)))))))) ;;; Return a list of forms to create a copier function of a typed DEFSTRUCT. @@ -755,12 +767,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 @@ -818,15 +830,15 @@ (super (if include (compiler-layout-or-lose (first include)) - (class-layout (sb!xc:find-class - (or (first superclass-opt) - 'structure-object)))))) + (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 - (class-layout (sb!xc:find-class 'stream)))) + (classoid-layout (find-classoid 'stream)))) (concatenate 'simple-vector (layout-inherits super) (vector super))))) @@ -840,10 +852,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))) @@ -852,9 +864,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 @@ -919,7 +931,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 @@ -928,27 +940,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)) @@ -1040,23 +1052,23 @@ (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) @@ -1073,9 +1085,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 @@ -1122,24 +1135,25 @@ (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) + (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) (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 + (list (layout-classoid (svref inherits (1- (length inherits)))) + (layout-classoid (svref inherits (- (length inherits) 2)))) + (list (layout-classoid + (svref inherits (1- (length inherits))))))) + (let ((new-layout (make-layout :classoid class :inherits inherits :depthoid (length inherits) :length (dd-length info) @@ -1151,7 +1165,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) @@ -1184,7 +1198,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*)