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