;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
;;; defconstructor is used to define special purpose functions which just
;;; call make-instance with a symbol as the first argument. The semantics
;; So instead:
(declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
,name))
- ,(make-top-level-form `(defconstructor ,name)
- '(load eval)
- `(load-constructor
- ',class-name
- ',(class-name (class-of class))
- ',name
- ',supplied-initarg-names
- ;; make-constructor-code-generators is called to return a list
- ;; of constructor code generators. The actual interpretation
- ;; of this list is left to compute-constructor-code, but the
- ;; general idea is that it should be an plist where the keys
- ;; name a kind of constructor code and the values are generator
- ;; functions which return the actual constructor code. The
- ;; constructor code is usually a closures over the arguments
- ;; to the generator.
- ,(make-constructor-code-generators class
- name
- lambda-list
- supplied-initarg-names
- supplied-initargs))))))
+ (load-constructor
+ ',class-name
+ ',(class-name (class-of class))
+ ',name
+ ',supplied-initarg-names
+ ;; make-constructor-code-generators is called to return a list
+ ;; of constructor code generators. The actual interpretation
+ ;; of this list is left to compute-constructor-code, but the
+ ;; general idea is that it should be an plist where the keys
+ ;; name a kind of constructor code and the values are generator
+ ;; functions which return the actual constructor code. The
+ ;; constructor code is usually a closures over the arguments
+ ;; to the generator.
+ ,(make-constructor-code-generators class
+ name
+ lambda-list
+ supplied-initarg-names
+ supplied-initargs)))))
(defun load-constructor (class-name metaclass-name constructor-name
supplied-initarg-names code-generators)
(funcall fn constructor))
(dolist (subclass (class-direct-subclasses class))
(recurse subclass))))
- (recurse (find-class 't))
+ (recurse (find-class t))
(values nclasses nconstructors))))
(defun reset-constructors ()
(initfn (slot-definition-initfunction slotd)))
(cond ((null (memq name layout)))
((null initfn)
- (push (cons name *slot-unbound*) constants))
+ (push (cons name +slot-unbound+) constants))
((constantp initform)
(push (cons name (eval initform)) constants)
(when (eq flag ':unsupplied) (setq flag ':constants)))
(t
- (push (cons name *slot-unbound*) constants)
- (setq flag 't)))))
+ (push (cons name +slot-unbound+) constants)
+ (setq flag t)))))
(let* ((constants-alist (sort constants #'(lambda (x y)
(memq (car y)
(memq (car x) layout)))))
(.initargs. .constant-initargs.))
.positions.
- (dolist (entry .initfns-initargs-and-positions.)
- (let ((val (funcall (car entry)))
- (initarg (cadr entry)))
- (when initarg
- (push val .initargs.)
- (push initarg .initargs.))
- (dolist (pos (cddr entry))
- (setf (%instance-ref .slots. pos) val))))
+ (dolist (entry .initfns-initargs-and-positions.)
+ (let ((val (funcall (car entry)))
+ (initarg (cadr entry)))
+ (when initarg
+ (push val .initargs.)
+ (push initarg .initargs.))
+ (dolist (pos (cddr entry))
+ (setf (clos-slots-ref .slots. pos) val))))
,@(gathering1 (collecting)
- (doplist (initarg value) supplied-initargs
+ (doplist (initarg value) supplied-initargs
(unless (constantp value)
(gather1 `(let ((.value. ,value))
(push .value. .initargs.)
(push ',initarg .initargs.)
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.)
+ (setf (clos-slots-ref .slots. .p.)
.value.)))))))
(dolist (fn .shared-initfns.)
(dolist (entry .initfns-and-positions.)
(let ((val (funcall (car entry))))
(dolist (pos (cdr entry))
- (setf (%instance-ref .slots. pos) val))))
+ (setf (clos-slots-ref .slots. pos) val))))
,@(gathering1 (collecting)
(doplist (initarg value) supplied-initargs
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.) .value.)))))))
+ (setf (clos-slots-ref .slots. .p.)
+ .value.)))))))
.instance.))))))))
(gather1
`(let ((.value. ,value))
(dolist (.p. (pop .positions.))
- (setf (%instance-ref .slots. .p.)
+ (setf (clos-slots-ref .slots. .p.)
.value.)))))))
.instance.))))))))))
(bail-out)))))
(values constants (nreverse supplied-initarg-positions)))))
-