(:conc-name dd-)
(:make-load-form-fun just-dump-it-normally)
#-sb-xc-host (:pure t)
- (:constructor make-defstruct-description (name)))
+ (:constructor make-defstruct-description
+ (name &aux
+ (conc-name (symbolicate name "-"))
+ (copier-name (symbolicate "COPY-" name))
+ (predicate-name (symbolicate name "-P")))))
;; name of the structure
- (name (missing-arg) :type symbol)
+ (name (missing-arg) :type symbol :read-only t)
;; documentation on the structure
(doc nil :type (or string null))
;; prefix for slot names. If NIL, none.
- (conc-name (symbolicate name "-") :type (or symbol null))
+ (conc-name nil :type (or symbol null))
;; the name of the primary standard keyword constructor, or NIL if none
(default-constructor nil :type (or symbol null))
;; all the explicit :CONSTRUCTOR specs, with name defaulted
(constructors () :type list)
;; name of copying function
- (copier-name (symbolicate "COPY-" name) :type (or symbol null))
+ (copier-name nil :type (or symbol null))
;; name of type predicate
- (predicate-name (symbolicate name "-P") :type (or symbol null))
+ (predicate-name nil :type (or symbol null))
;; the arguments to the :INCLUDE option, or NIL if no included
;; structure
(include nil :type list)
fun-name)))
(cond ((not (eql pf 0))
`((def!method print-object ((,x ,name) ,s)
- (funcall #',(farg pf) ,x ,s *current-level*))))
+ (funcall #',(farg pf)
+ ,x
+ ,s
+ *current-level-in-print*))))
((not (eql po 0))
`((def!method print-object ((,x ,name) ,s)
(funcall #',(farg po) ,x ,s))))
(when offset (incf (dd-length dd) offset)))))
(when (dd-include dd)
- (do-dd-inclusion-stuff dd))
+ (frob-dd-inclusion-stuff dd))
dd)))
;;; RAW? is true if TYPE should be stored in a raw slot.
;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
+;;;
+;;; 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
;;; Process any included slots pretty much like they were specified.
;;; Also inherit various other attributes.
-(defun do-dd-inclusion-stuff (dd)
+(defun frob-dd-inclusion-stuff (dd)
(destructuring-bind (included-name &rest modified-slots) (dd-include dd)
(let* ((type (dd-type dd))
(included-structure
(dolist (included-slot (dd-slots included-structure))
(let* ((included-name (dsd-name included-slot))
(modified (or (find included-name modified-slots
- :key #'(lambda (x) (if (atom x) x (car x)))
+ :key (lambda (x) (if (atom x) x (car x)))
:test #'string=)
`(,included-name))))
(parse-1-dsd dd
;; Various other operations only make sense on the target SBCL.
#-sb-xc-host
- (progn
- (remhash (dd-name dd) *typecheckfuns*)
- (%target-defstruct dd layout)
- (when (dd-doc dd)
- (setf (fdocumentation (dd-name dd) 'type)
- (dd-doc dd)))))
+ (%target-defstruct dd layout))
(values))
\f
,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)
+ (funcall (nth-value 1
+ (slot-accessor-inline-expansion-designators dd dsd))))
+
;;; core compile-time setup of any class with a LAYOUT, used even by
;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
(defun %compiler-set-up-layout (dd
(%compiler-set-up-layout dd inherits)
- (let* ((dd-name (dd-name dd))
- (dtype (dd-declarable-type dd))
- (class (sb!xc:find-class dd-name)))
+ (let* ((dtype (dd-declarable-type dd)))
(let ((copier-name (dd-copier-name dd)))
(when copier-name
(res)))
\f
-;;;; slot accessors for raw slots
-
-;;; Return info about how to read/write a slot in the value stored in
-;;; OBJECT. This is also used by constructors (since we can't safely
-;;; use the accessor function, since some slots are read-only). If
-;;; supplied, DATA is a variable holding the raw-data vector.
-;;;
-;;; returned values:
-;;; 1. accessor function name (SETFable)
-;;; 2. index to pass to accessor.
-;;; 3. object form to pass to accessor
-(defun slot-accessor-form (defstruct slot object &optional data)
- (let ((rtype (dsd-raw-type slot)))
- (values
- (ecase rtype
- (single-float '%raw-ref-single)
- (double-float '%raw-ref-double)
- #!+long-float
- (long-float '%raw-ref-long)
- (complex-single-float '%raw-ref-complex-single)
- (complex-double-float '%raw-ref-complex-double)
- #!+long-float
- (complex-long-float '%raw-ref-complex-long)
- (unsigned-byte 'aref)
- ((t) '%instance-ref))
- (case rtype
- #!+long-float
- (complex-long-float
- (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
- #!+long-float
- (long-float
- (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
- (double-float
- (ash (dsd-index slot) -1))
- (complex-double-float
- (ash (dsd-index slot) -2))
- (complex-single-float
- (ash (dsd-index slot) -1))
- (t
- (dsd-index slot)))
- (cond
- ((eq rtype t) object)
- (data)
- (t
- `(truly-the (simple-array (unsigned-byte 32) (*))
- (%instance-ref ,object ,(dd-raw-index defstruct))))))))
-\f
;;; These functions are called to actually make a constructor after we
;;; have processed the arglist. The correct variant (according to the
;;; DD-TYPE) should be called. The function is defined with the
;;; various weird places, whereas STRUCTURE structures have
;;; a LAYOUT slot.
;;; * We really want to use LIST to make list structures, instead of
-;;; MAKE-LIST/(SETF ELT).
+;;; MAKE-LIST/(SETF ELT). (We can't in general use VECTOR in an
+;;; analogous way, since VECTOR makes a SIMPLE-VECTOR and vector-typed
+;;; 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. We use SLOT-ACCESSOR-FORM
-;;; to compute how to set the slots, which deals with raw slots.
+;;; allocated and indirectly referenced.
(defun create-vector-constructor (dd cons-name arglist vars types values)
(let ((temp (gensym))
(etype (dd-element-type dd)))
`(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
+ (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var))
vars types))
(let ((,temp (make-array ,(dd-length dd)
:element-type ',(dd-element-type dd))))
- ,@(mapcar #'(lambda (x)
- `(setf (aref ,temp ,(cdr x)) ',(car x)))
+ ,@(mapcar (lambda (x)
+ `(setf (aref ,temp ,(cdr x)) ',(car x)))
(find-name-indices dd))
- ,@(mapcar #'(lambda (dsd value)
- `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+ ,@(mapcar (lambda (dsd value)
+ `(setf (aref ,temp ,(dsd-index dsd)) ,value))
(dd-slots dd) values)
,temp))))
(defun create-list-constructor (dd cons-name arglist vars types values)
(setf (elt vals (dsd-index dsd)) val))
`(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
- vars types))
+ (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
(list ,@vals))))
(defun create-structure-constructor (dd cons-name arglist vars types values)
- (let* ((temp (gensym))
- (raw-index (dd-raw-index dd))
- (n-raw-data (when raw-index (gensym))))
+ (let* ((instance (gensym "INSTANCE"))
+ (raw-index (dd-raw-index dd)))
`(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+ (declare ,@(mapcar (lambda (var type) `(type ,type ,var))
vars types))
- (let ((,temp (truly-the ,(dd-name dd)
- (%make-instance ,(dd-length dd))))
- ,@(when n-raw-data
- `((,n-raw-data
- (make-array ,(dd-raw-length dd)
- :element-type '(unsigned-byte 32))))))
- (setf (%instance-layout ,temp)
- (%delayed-get-compiler-layout ,(dd-name dd)))
- ,@(when n-raw-data
- `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
+ (let ((,instance (truly-the ,(dd-name dd)
+ (%make-instance-with-layout
+ (%delayed-get-compiler-layout ,(dd-name dd))))))
+ (declare (optimize (safety 0))) ; Suppress redundant slot type checks.
+ ,@(when raw-index
+ `((setf (%instance-ref ,instance ,raw-index)
+ (make-array ,(dd-raw-length dd)
+ :element-type '(unsigned-byte 32)))))
,@(mapcar (lambda (dsd value)
- (multiple-value-bind (accessor index data)
- (slot-accessor-form dd dsd temp n-raw-data)
- `(setf (,accessor ,data ,index) ,value)))
+ ;; (Note that we can't in general use the
+ ;; ordinary named slot setter function here
+ ;; 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))
(dd-slots dd)
values)
- ,temp))))
+ ,instance))))
;;; Create a default (non-BOA) keyword constructor.
(defun create-keyword-constructor (defstruct creator)
(dolist (arg opt)
(cond ((consp arg)
(destructuring-bind
- (name &optional (def (nth-value 1 (get-slot name))))
+ ;; FIXME: this shares some logic (though not
+ ;; code) with the &key case below (and it
+ ;; looks confusing) -- factor out the logic
+ ;; if possible. - CSR, 2002-04-19
+ (name
+ &optional
+ (def (nth-value 1 (get-slot name)))
+ (supplied-test nil supplied-test-p))
arg
- (arglist `(,name ,def))
+ (arglist `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
(types (get-slot name))))
(t
(arglist '&key)
(dolist (key keys)
(if (consp key)
- (destructuring-bind (wot &optional (def nil def-p)) key
+ (destructuring-bind (wot
+ &optional
+ (def nil def-p)
+ (supplied-test nil supplied-test-p))
+ key
(let ((name (if (consp wot)
(destructuring-bind (key var) wot
(declare (ignore key))
var)
wot)))
- (multiple-value-bind (type slot-def) (get-slot name)
- (arglist `(,wot ,(if def-p def slot-def)))
+ (multiple-value-bind (type slot-def)
+ (get-slot name)
+ (arglist `(,wot ,(if def-p def slot-def)
+ ,@(if supplied-test-p `(,supplied-test) nil)))
(vars name)
(types type))))
(do-default key))))
(funcall creator defstruct (first boa)
(arglist) (vars) (types)
- (mapcar #'(lambda (slot)
- (or (find (dsd-name slot) (vars) :test #'string=)
- (dsd-default slot)))
+ (mapcar (lambda (slot)
+ (or (find (dsd-name slot) (vars) :test #'string=)
+ (dsd-default slot)))
(dd-slots defstruct))))))
;;; Grovel the constructor options, and decide what constructors (if
:metaclass-name metaclass-name
:metaclass-constructor metaclass-constructor
:dd-type dd-type))
- (conc-name (concatenate 'string (symbol-name class-name) "-"))
(dd-slots (dd-slots dd))
(dd-length (1+ (length slot-names)))
(object-gensym (gensym "OBJECT"))
projects / sbcl.git / blobdiff