X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=89957c7abe19529074bcc3d89ebdbd1471bb989f;hb=77d1a39f28fe8d240cf441a9a54a80d4bc98ea52;hp=fddc971660324562204c3ba4b90879fa740033ea;hpb=b305d276b905654e4877cc49d03a2d3c9187cdff;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index fddc971..89957c7 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -62,6 +62,14 @@ ;;; Utilities ******* ;;; ****************** +(defun quote-plist-keys (plist) + (loop for (key . more) on plist by #'cddr + if (null more) do + (error "Not a property list: ~S" plist) + else + collect `(quote ,key) + and collect (car more))) + (defun plist-keys (plist &key test) (loop for (key . more) on plist by #'cddr if (null more) do @@ -82,6 +90,12 @@ (and (symbolp constant) (not (null (symbol-package constant))))))) +;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just +;;; collecting the defaulted initargs for the call. +(defun ctor-default-initkeys (supplied-initargs class-default-initargs) + (loop for (key nil) in class-default-initargs + when (eq (getf supplied-initargs key '.not-there.) '.not-there.) + collect key)) ;;; ***************** ;;; CTORS ********* @@ -108,10 +122,8 @@ (defun make-ctor-parameter-list (ctor) (plist-values (ctor-initargs ctor) :test (complement #'constantp))) -;;; ;;; Reset CTOR to use a default function that will compute an ;;; optimized constructor function when called. -;;; (defun install-initial-constructor (ctor &key force-p) (when (or force-p (ctor-class ctor)) (setf (ctor-class ctor) nil) @@ -122,9 +134,7 @@ (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -;;; ;;; Keep this a separate function for testing. -;;; (defun make-ctor-function-name (class-name initargs) (let ((*package* *pcl-package*) (*print-case* :upcase) @@ -136,16 +146,12 @@ (plist-keys initargs) (plist-values initargs :test #'constantp)))) -;;; ;;; Keep this a separate function for testing. -;;; (defun ensure-ctor (function-name class-name initargs) (unless (fboundp function-name) (make-ctor function-name class-name initargs))) -;;; ;;; Keep this a separate function for testing. -;;; (defun make-ctor (function-name class-name initargs) (without-package-locks ; for (setf symbol-function) (let ((ctor (%make-ctor function-name class-name nil initargs))) @@ -265,10 +271,37 @@ (compute-applicable-methods #'make-instance (list class))) (allocate-instance-methods (compute-applicable-methods #'allocate-instance (list class))) + ;; I stared at this in confusion for a while, thinking + ;; carefully about the possibility of the class prototype not + ;; being of sufficient discrimiating power, given the + ;; possibility of EQL-specialized methods on + ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given + ;; that this is a constructor optimization, the user doesn't + ;; yet have the instance to create a method with such an EQL + ;; specializer. + ;; + ;; There remains the (theoretical) possibility of someone + ;; coming along with code of the form + ;; + ;; (defmethod initialize-instance :before ((o foo) ...) + ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) + ;; + ;; but probably we can afford not to worry about this too + ;; much for now. -- CSR, 2004-07-12 (ii-methods (compute-applicable-methods #'initialize-instance (list proto))) (si-methods - (compute-applicable-methods #'shared-initialize (list proto t)))) + (compute-applicable-methods #'shared-initialize (list proto t))) + (setf-svuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'(setf slot-value-using-class) + (list nil class proto slot)))) + (sbuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'slot-boundp-using-class + (list class proto slot))))) ;; Cannot initialize these variables earlier because the generic ;; functions don't exist when PCL is built. (when (null *the-system-si-method*) @@ -286,12 +319,28 @@ (not (condition-class-p class)) (null (cdr make-instance-methods)) (null (cdr allocate-instance-methods)) - (null (check-initargs-1 class (plist-keys (ctor-initargs ctor)) - (append ii-methods si-methods) nil nil)) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class)) + (null (check-initargs-1 + class + (append + (ctor-default-initkeys + (ctor-initargs ctor) (class-default-initargs class)) + (plist-keys (ctor-initargs ctor))) + (append ii-methods si-methods) nil nil)) (not (around-or-nonstandard-primary-method-p ii-methods *the-system-ii-method*)) (not (around-or-nonstandard-primary-method-p si-methods *the-system-si-method*)) + ;; the instance structure protocol goes through + ;; slot-value(-using-class) and friends (actually just + ;; (SETF SLOT-VALUE-USING-CLASS) and + ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard + ;; applicable methods we can't shortcircuit them. + (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) (optimizing-generator ctor ii-methods si-methods)) (fallback-generator ctor ii-methods si-methods)))) @@ -353,21 +402,17 @@ ,body .instance.)))) -;;; ;;; Return a form for invoking METHOD with arguments from ARGS. As ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could ;;; call fast method functions directly here, but benchmarks show that ;;; there's no speed to gain, so lets avoid the hair here. -;;; (defmacro invoke-method (method args) `(funcall ,(method-function method) ,args ())) -;;; ;;; Return a form that is sort of an effective method comprising all ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would ;;; normally have taken place when calling MAKE-INSTANCE. -;;; (defun fake-initialization-emf (ctor ii-methods si-methods) (multiple-value-bind (ii-around ii-before ii-primary ii-after) (standard-sort-methods ii-methods) @@ -376,30 +421,33 @@ (standard-sort-methods si-methods) (declare (ignore si-primary)) (aver (and (null ii-around) (null si-around))) - (let ((initargs (ctor-initargs ctor)) - (slot-inits (slot-init-forms ctor (or ii-before si-before)))) + (let ((initargs (ctor-initargs ctor))) + (multiple-value-bind (bindings vars defaulting-initargs body) + (slot-init-forms ctor (or ii-before si-before)) (values - `(let (,@(when (or ii-before ii-after) - `((.ii-args. (list .instance. ,@initargs)))) - ,@(when (or si-before si-after) - `((.si-args. (list .instance. t ,@initargs))))) + `(let ,bindings + (declare (ignorable ,@vars)) + (let (,@(when (or ii-before ii-after) + `((.ii-args. + (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs)))) + ,@(when (or si-before si-after) + `((.si-args. + (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs))))) ,@(loop for method in ii-before collect `(invoke-method ,method .ii-args.)) ,@(loop for method in si-before collect `(invoke-method ,method .si-args.)) - ,slot-inits + ,@body ,@(loop for method in si-after collect `(invoke-method ,method .si-args.)) ,@(loop for method in ii-after - collect `(invoke-method ,method .ii-args.))) - (or ii-before si-before)))))) + collect `(invoke-method ,method .ii-args.)))) + (or ii-before si-before))))))) -;;; ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after ;;; methods. Before and after methods are sorted in the order they ;;; must be called. -;;; (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods as qualifiers = (method-qualifiers method) @@ -414,15 +462,14 @@ finally (return (values around before (first primary) (reverse after))))) -;;; -;;; Return a form initializing instance and class slots of an object -;;; costructed by CTOR. The variable .SLOTS. is assumed to bound to -;;; the instance's slot vector. BEFORE-METHOD-P T means -;;; before-methods will be called, which means that 1) other code will -;;; initialize instance slots to +SLOT-UNBOUND+ before the -;;; before-methods are run, and that we have to check if these -;;; before-methods have set slots. -;;; +;;; Return as multiple values bindings for default initialization +;;; arguments, variable names, defaulting initargs and a body for +;;; initializing instance and class slots of an object costructed by +;;; CTOR. The variable .SLOTS. is assumed to bound to the instance's +;;; slot vector. BEFORE-METHOD-P T means before-methods will be +;;; called, which means that 1) other code will initialize instance +;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and +;;; that we have to check if these before-methods have set slots. (defun slot-init-forms (ctor before-method-p) (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) @@ -432,6 +479,7 @@ :initial-element nil)) (class-inits ()) (default-inits ()) + (defaulting-initargs ()) (default-initargs (class-default-initargs class)) (initarg-locations (compute-initarg-locations @@ -481,6 +529,13 @@ unless (member key initkeys :test #'eq) do (let* ((type (if (constantp initform) 'constant 'var)) (init (if (eq type 'var) initfn initform))) + (ecase type + (constant + (push key defaulting-initargs) + (push initform defaulting-initargs)) + (var + (push key defaulting-initargs) + (push (default-init-var-name i) defaulting-initargs))) (when (eq type 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) @@ -544,10 +599,9 @@ collect var into vars collect `(,var (funcall ,initfn)) into bindings finally (return (values vars bindings))) - `(let ,bindings - (declare (ignorable ,@vars)) - ,@(delete nil instance-init-forms) - ,@class-init-forms)))))) + (values bindings vars (nreverse defaulting-initargs) + `(,@(delete nil instance-init-forms) + ,@class-init-forms))))))) ;;; Return an alist of lists (KEY LOCATION ...) telling, for each ;;; key in INITKEYS, which locations the initarg initializes. @@ -598,7 +652,15 @@ initialize-instance shared-initialize) (reset (class-of-1st-method-param method) t t)) ((reinitialize-instance) - (reset (class-of-1st-method-param method) t nil)))))))) + (reset (class-of-1st-method-param method) t nil)) + (t (when (or (eq (generic-function-name generic-function) + 'slot-boundp-using-class) + (equal (generic-function-name generic-function) + '(setf slot-value-using-class))) + ;; this looks awfully expensive, but given that one + ;; can specialize on the SLOTD argument, nothing is + ;; safe. -- CSR, 2004-07-12 + (reset (find-class 'standard-object)))))))))) (defun precompile-ctors () (dolist (ctor *all-ctors*)