;;;; 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)
:reader constructor-code-generators)) ;could use.
(:metaclass funcallable-standard-class))
-;;; Because the value in the code-type slot should always correspond to the
-;;; funcallable-instance-function of the constructor, this function should
-;;; always be used to set the both at the same time.
+;;; Because the value in the code-type slot should always correspond
+;;; to the FUNCALLABLE-INSTANCE-FUN of the constructor, this function
+;;; should always be used to set them both at the same time.
(defun set-constructor-code (constructor code type)
- (set-funcallable-instance-function constructor code)
- (set-function-name constructor (constructor-name constructor))
+ (set-funcallable-instance-fun constructor code)
+ (set-fun-name constructor (constructor-name constructor))
(setf (constructor-code-type constructor) type))
(defmethod describe-object ((constructor constructor) stream)
(doplist (key val) (constructor-code-generators constructor)
(gather1 key)))))
-;;; I am not in a hairy enough mood to make this implementation be metacircular
-;;; enough that it can support a defconstructor for constructor objects.
+;;; I am not in a hairy enough mood to make this implementation be
+;;; metacircular enough that it can support a defconstructor for
+;;; constructor objects.
(defun make-constructor (class name supplied-initarg-names code-generators)
(make-instance 'constructor
:class class
name class)
())))
-;;; This is called to actually load a defconstructor constructor. It must
-;;; install the lazy installer in the function cell of the constructor name,
-;;; and also add this constructor to the list of constructors the class has.
+;;; This is called to actually load a defconstructor constructor. It
+;;; must install the lazy installer in the function cell of the
+;;; constructor name, and also add this constructor to the list of
+;;; constructors the class has.
(defmethod load-constructor-internal
((class slot-class) name initargs generators)
(let ((constructor (make-constructor class name initargs generators))
(apply constructor args)))
'lazy)))
-;;; The interface to keeping the constructors updated.
+;;; the interface to keeping the constructors updated
;;;
-;;; add-method and remove-method (for standard-generic-function and -method),
-;;; promise to call maybe-update-constructors on the generic function and
-;;; the method.
+;;; add-method and remove-method (for standard-generic-function and
+;;; -method), promise to call maybe-update-constructors on the generic
+;;; function and the method.
;;;
-;;; The class update code promises to call update-constructors whenever the
-;;; class is changed. That is, whenever the supers, slots or options change.
-;;; If user defined classes of constructor needs to be updated in more than
-;;; these circumstances, they should use the dependent updating mechanism to
-;;; make sure update-constructors is called.
+;;; The class update code promises to call update-constructors
+;;; whenever the class is changed. That is, whenever the supers, slots
+;;; or options change. If user defined classes of constructor needs to
+;;; be updated in more than these circumstances, they should use the
+;;; dependent updating mechanism to make sure update-constructors is
+;;; called.
;;;
-;;; Bootstrapping concerns force the definitions of maybe-update-constructors
-;;; and update-constructors to be in the file std-class. For clarity, they
-;;; also appear below. Be sure to keep the definition here and there in sync.
+;;; Bootstrapping concerns force the definitions of
+;;; maybe-update-constructors and update-constructors to be in the
+;;; file std-class. For clarity, they also appear below. Be sure to
+;;; keep the definition here and there in sync.
;(defvar *initialization-generic-functions*
; (list #'make-instance
; #'default-initargs
(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)))))
-
projects / sbcl.git / blobdiff