X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=3a086896854d562c57d21cb9ca32d23ea52db632;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=0ef967b22a167f890c4dd3572837d8e52b2a3057;hpb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 0ef967b..3a08689 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,37 +134,22 @@
     (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)
-	(*print-pretty* nil)
-	(*print-gensym* t))
-    (intern (format nil "CTOR ~S::~S ~S ~S"
-		    (package-name (symbol-package class-name))
-		    (symbol-name class-name)
-		    (plist-keys initargs)
-		    (plist-values initargs :test #'constantp))
-	    *pcl-package*)))
+  (list* 'ctor class-name initargs))
 
-;;;
 ;;; 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)
-  (let ((ctor (%make-ctor function-name class-name nil initargs)))
-    (push ctor *all-ctors*)
-    (setf (symbol-function function-name) ctor)
-    (install-initial-constructor ctor :force-p t)
-    ctor))
+  (without-package-locks ; for (setf symbol-function)
+   (let ((ctor (%make-ctor function-name class-name nil initargs)))
+     (push ctor *all-ctors*)
+     (setf (fdefinition function-name) ctor)
+     (install-initial-constructor ctor :force-p t)
+     ctor)))
 
 
 ;;; ***********************************************
@@ -174,14 +171,12 @@
 	     (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.)))
 	       (if (array-in-bounds-p ps i)
 		   (aref ps i)
-		   (intern (format nil ".P~D." i) *pcl-package*))))
-	   ;;
+		   (format-symbol *pcl-package* ".P~D." i))))
 	   ;; Check if CLASS-NAME is a constant symbol.  Give up if
 	   ;; not.
 	   (check-class ()
 	     (unless (and class-name (constant-symbol-p class-name))
 	       (return-from make-instance->constructor-call nil)))
-	   ;;
 	   ;; Check if ARGS are suitable for an optimized constructor.
 	   ;; Return NIL from the outer function if not.
 	   (check-args ()
@@ -192,7 +187,6 @@
 		       (return-from make-instance->constructor-call nil)))))
       (check-class)
       (check-args)
-      ;;
       ;; Collect a plist of initargs and constant values/parameter names
       ;; in INITARGS.  Collect non-constant initialization forms in
       ;; VALUE-FORMS.
@@ -208,7 +202,6 @@
 		  (return (values initargs value-forms)))
 	(let* ((class-name (eval class-name))
 	       (function-name (make-ctor-function-name class-name initargs)))
-	  ;;
 	  ;; Prevent compiler warnings for calling the ctor.
 	  (proclaim-as-fun-name function-name)
 	  (note-name-defined function-name :function)
@@ -216,33 +209,32 @@
 	    (setf (info :function :where-from function-name) :defined)
 	    (when (info :function :assumed-type function-name)
 	      (setf (info :function :assumed-type function-name) nil)))
-	  ;;
 	  ;; Return code constructing a ctor at load time, which, when
 	  ;; called, will set its funcallable instance function to an
 	  ;; optimized constructor function.
-	  `(let ((.x. (load-time-value
-		       (ensure-ctor ',function-name ',class-name ',initargs))))
-	     (declare (ignore .x.))
-	     ;;; ??? check if this is worth it.
-	     (declare
-	      (ftype (or (function ,(make-list (length value-forms)
-					       :initial-element t)
-				   t)
-			 (function (&rest t) t))
-		     ,function-name))
-	     (,function-name ,@value-forms)))))))
+	  `(locally 
+	       (declare (disable-package-locks ,function-name))
+	    (let ((.x. (load-time-value
+			(ensure-ctor ',function-name ',class-name ',initargs))))
+	      (declare (ignore .x.))
+	      ;; ??? check if this is worth it.
+	      (declare
+	       (ftype (or (function ,(make-list (length value-forms)
+						:initial-element t)
+				    t)
+			  (function (&rest t) t))
+		      ,function-name))
+	      (funcall (function ,function-name) ,@value-forms))))))))
 
 
 ;;; **************************************************
 ;;; Load-Time Constructor Function Generation  *******
 ;;; **************************************************
 
-;;;
 ;;; The system-supplied primary INITIALIZE-INSTANCE and
-;;; SHARED-INITIALIZE methods.  One cannot initialized these variables
+;;; SHARED-INITIALIZE methods.  One cannot initialize these variables
 ;;; to the right values here because said functions don't exist yet
 ;;; when this file is first loaded.
-;;;
 (defvar *the-system-ii-method* nil)
 (defvar *the-system-si-method* nil)
 
@@ -258,6 +250,9 @@
 	  ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
 	  ;; expressions.  The below should be equivalent, since we
 	  ;; have a compiler-only implementation.
+	  ;;
+	  ;; (except maybe for optimization qualities? -- CSR,
+	  ;; 2004-07-12)
 	  (eval `(function ,(constructor-function-form ctor))))))
 	      
 (defun constructor-function-form (ctor)
@@ -267,10 +262,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*)
@@ -288,12 +310,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))))
 
@@ -314,6 +352,11 @@
 (defun fallback-generator (ctor ii-methods si-methods)
   (declare (ignore ii-methods si-methods))
   `(instance-lambda ,(make-ctor-parameter-list ctor)
+     ;; The CTOR MAKE-INSTANCE optimization only kicks in when the
+     ;; first argument to MAKE-INSTANCE is a constant symbol: by
+     ;; calling it with a class, as here, we inhibit the optimization,
+     ;; so removing the possibility of endless recursion.  -- CSR,
+     ;; 2004-07-12
      (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
 
 (defun optimizing-generator (ctor ii-methods si-methods)
@@ -323,14 +366,12 @@
        (declare #.*optimize-speed*)
        ,(wrap-in-allocate-forms ctor body before-method-p))))
 
-;;;
 ;;; Return a form wrapped around BODY that allocates an instance
 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
 ;;; before-methods, in which case we initialize instance slots to
 ;;; +SLOT-UNBOUND+.  The resulting form binds the local variables
 ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot
 ;;; vector around BODY.
-;;;
 (defun wrap-in-allocate-forms (ctor body before-method-p)
   (let* ((class (ctor-class ctor))
 	 (wrapper (class-wrapper class))
@@ -352,21 +393,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)
@@ -375,30 +412,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)
@@ -413,15 +453,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))
@@ -431,6 +470,7 @@
 		      :initial-element nil))
 	 (class-inits ())
 	 (default-inits ())
+         (defaulting-initargs ())
 	 (default-initargs (class-default-initargs class))
 	 (initarg-locations
 	  (compute-initarg-locations
@@ -456,7 +496,7 @@
 	       (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
 		 (if (array-in-bounds-p ps i)
 		     (aref ps i)
-		     (intern (format nil ".D~D." i) *the-pcl-package*)))))
+		     (format-symbol *pcl-package* ".D~D." i)))))
       ;; Loop over supplied initargs and values and record which
       ;; instance and class slots they initialize.
       (loop for (key value) on initargs by #'cddr
@@ -466,7 +506,7 @@
 		    (if (consp location)
 			(class-init location 'constant value)
 			(instance-init location 'constant value)))
-		    (dolist (location locations)
+		  (dolist (location locations)
 		      (if (consp location)
 			  (class-init location 'param value)
 			  (instance-init location 'param value)))))
@@ -478,16 +518,23 @@
       ;; if not actually used for initializing a slot.
       (loop for (key initfn initform) in default-initargs and i from 0
 	    unless (member key initkeys :test #'eq) do
-	      (let* ((type (if (constantp initform) 'constant 'var))
-		     (init (if (eq type 'var) initfn initform)))
-		(when (eq type 'var)
-		  (let ((init-var (default-init-var-name i)))
-		    (setq init init-var)
-		    (push (cons init-var initfn) default-inits)))
-		(dolist (location (initarg-locations key))
-		  (if (consp location)
-		      (class-init location type init)
-		      (instance-init location type init)))))
+	    (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)
+		  (push (cons init-var initfn) default-inits)))
+	      (dolist (location (initarg-locations key))
+		(if (consp location)
+		    (class-init location type init)
+		    (instance-init location type init)))))
       ;; Loop over all slots of the class, filling in the rest from
       ;; slot initforms.
       (loop for slotd in (class-slots class)
@@ -543,16 +590,13 @@
 		  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.
 ;;; CLASS is the class of the instance being initialized.
-;;;
 (defun compute-initarg-locations (class initkeys)
   (loop with slots = (class-slots class)
 	for key in initkeys collect
@@ -580,11 +624,9 @@
 	     (dolist (subclass (class-direct-subclasses class))
 	       (reset subclass ri-cache-p ctorsp))))
     (ecase reason
-      ;;
       ;; CLASS must have been specified.
       (finalize-inheritance
        (reset class t))
-      ;;
       ;; NAME must have been specified.
       (setf-find-class
        (loop for ctor in *all-ctors*
@@ -592,7 +634,6 @@
 	     (when (ctor-class ctor)
 	       (reset (ctor-class ctor)))
 	     (loop-finish)))
-      ;;
       ;; GENERIC-FUNCTION and METHOD must have been specified.
       ((add-method remove-method)
        (flet ((class-of-1st-method-param (method)
@@ -602,7 +643,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*)