(: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
(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
(%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
(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* ((instance (gensym "INSTANCE"))
(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