(: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)))
;;; 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
(%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
: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"))