X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fconstruct.lisp;h=5f3b40c96cfe507d56b0c05fb4c13e22342d2a22;hb=419ce099442b9bffe41eff8516c6a2be085259de;hp=ab66487b4e08a9052bd43eaed47dfc3d8de43f0a;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/construct.lisp b/src/pcl/construct.lisp index ab66487..5f3b40c 100644 --- a/src/pcl/construct.lisp +++ b/src/pcl/construct.lisp @@ -25,9 +25,6 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") ;;; defconstructor is used to define special purpose functions which just ;;; call make-instance with a symbol as the first argument. The semantics @@ -129,26 +126,24 @@ ;; 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) @@ -207,12 +202,12 @@ :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) @@ -226,8 +221,9 @@ (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 @@ -258,9 +254,10 @@ 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)) @@ -280,21 +277,23 @@ (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 @@ -448,7 +447,7 @@ (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 () @@ -526,13 +525,13 @@ (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))))) @@ -635,23 +634,23 @@ (.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.) @@ -789,7 +788,7 @@ (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 @@ -797,7 +796,8 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) .value.))))))) + (setf (clos-slots-ref .slots. .p.) + .value.))))))) .instance.)))))))) @@ -919,7 +919,7 @@ (gather1 `(let ((.value. ,value)) (dolist (.p. (pop .positions.)) - (setf (%instance-ref .slots. .p.) + (setf (clos-slots-ref .slots. .p.) .value.))))))) .instance.)))))))))) @@ -1002,4 +1002,3 @@ (bail-out))))) (values constants (nreverse supplied-initarg-positions))))) -