(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))
(:copier nil)
#-sb-xc-host (:pure t))
;; string name of slot
- %name
+ %name
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
(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
;; 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
;; 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))
(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
(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.
(setf (dsd-%name slot) (string name))
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
- (let ((accessor-name (symbolicate (or (dd-conc-name defstruct) "") name))
+ (let ((accessor-name (if (dd-conc-name defstruct)
+ (symbolicate (dd-conc-name defstruct) name)
+ name))
(predicate-name (dd-predicate-name defstruct)))
(setf (dsd-accessor-name slot) accessor-name)
(when (eql accessor-name predicate-name)
(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
(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)))))
(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)))
(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
;;; 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))))))
+ (accessor-place-form (%accessor-place-form dd dsd 'instance))
+ (dsd-type (dsd-type dsd))
+ (value-the (if (dsd-safe-p dsd) 'truly-the 'the)))
+ (values (lambda () `(lambda (instance)
+ ,instance-type-decl
+ (,value-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))))))
;;; Return a LAMBDA form which can be used to set a slot.
(defun slot-setter-lambda-form (dd dsd)
(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
"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))
;;; 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)
;;; 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 "~@<attempt to redefine the ~S class ~S incompatibly with the current definition~:@>"
'structure-object
(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)
(;; 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)
;;; 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*)
;;; structures can have arbitrary subtypes of VECTOR, not necessarily
;;; SIMPLE-VECTOR.)
;;; * STRUCTURE structures can have raw slots that must also be
-;;; allocated and indirectly referenced.
+;;; allocated and indirectly referenced.
(defun create-vector-constructor (dd cons-name arglist vars types values)
(let ((temp (gensym))
(etype (dd-element-type dd)))
`(setf (aref ,temp ,(cdr x)) ',(car x)))
(find-name-indices dd))
,@(mapcar (lambda (dsd value)
- `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+ (unless (eq value '.do-not-initialize-slot.)
+ `(setf (aref ,temp ,(dsd-index dsd)) ,value)))
(dd-slots dd) values)
,temp))))
(defun create-list-constructor (dd cons-name arglist vars types values)
(dolist (x (find-name-indices dd))
(setf (elt vals (cdr x)) `',(car x)))
(loop for dsd in (dd-slots dd) and val in values do
- (setf (elt vals (dsd-index dsd)) val))
+ (setf (elt vals (dsd-index dsd))
+ (if (eq val '.do-not-initialize-slot.) 0 val)))
`(defun ,cons-name ,arglist
(declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
;; because the slot might be :READ-ONLY, so we
;; whip up new LAMBDA representations of slot
;; setters for the occasion.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+ (unless (eq value '.do-not-initialize-slot.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))
(dd-slots dd)
values)
,instance))))
(parse-lambda-list (second boa))
(collect ((arglist)
(vars)
- (types))
+ (types)
+ (skipped-vars))
(labels ((get-slot (name)
(let ((res (find name (dd-slots defstruct)
:test #'string=
(arglist arg)
(vars arg)
(types (get-slot arg)))
-
+
(when opt
(arglist '&optional)
(dolist (arg opt)
(when auxp
(arglist '&aux)
(dolist (arg aux)
- (let* ((arg (if (consp arg) arg (list arg)))
- (var (first arg)))
- (arglist arg)
- (vars var)
- (types (get-slot var))))))
+ (arglist arg)
+ (if (proper-list-of-length-p arg 2)
+ (let ((var (first arg)))
+ (vars var)
+ (types (get-slot var)))
+ (skipped-vars (if (consp arg) (first arg) arg))))))
(funcall creator defstruct (first boa)
(arglist) (vars) (types)
- (mapcar (lambda (slot)
- (or (find (dsd-name slot) (vars) :test #'string=)
- (dsd-default slot)))
- (dd-slots defstruct))))))
+ (loop for slot in (dd-slots defstruct)
+ for name = (dsd-name 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.
;;;; 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
,slot-name)))
slot-names)
,object-gensym))
-
+
;; predicate
,@(when predicate
;; Just delegate to the compiler's type optimization
projects / sbcl.git / blobdiff