X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=658414241bbe6f7ffbf8bec442b5839992630e79;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=403732accab9933750bbab7e649313eebd0fd080;hpb=f8c8f81c3e10865a40ea6ceb79be0a045a6e6e4e;p=sbcl.git

diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 403732a..6584142 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -97,12 +97,22 @@
          (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.
+;;; Somewhat akin to DEFAULT-INITARGS, but just collecting the defaulted
+;;; initargs for the call.
 (defun ctor-default-initkeys (supplied-initargs class-default-initargs)
   (loop for (key) in class-default-initargs
         when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
         collect key))
+
+;;; Like DEFAULT-INITARGS, but return a list that can be spliced into source,
+;;; instead of a list with values already evaluated.
+(defun ctor-default-initargs (supplied-initargs class-default-initargs)
+  (loop for (key form fun) in class-default-initargs
+        when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+        append (list key (if (constantp form) form `(funcall ,fun)))
+          into default-initargs
+        finally
+          (return (append supplied-initargs default-initargs))))
 
 ;;; *****************
 ;;; CTORS   *********
@@ -145,17 +155,19 @@
 
 ;;; Keep this a separate function for testing.
 (defun ensure-ctor (function-name class-name initargs safe-code-p)
-  (unless (fboundp function-name)
-    (make-ctor function-name class-name initargs safe-code-p)))
+  (with-world-lock ()
+    (if (fboundp function-name)
+        (the ctor (fdefinition function-name))
+        (make-ctor function-name class-name initargs safe-code-p))))
 
 ;;; Keep this a separate function for testing.
 (defun make-ctor (function-name class-name initargs safe-p)
   (without-package-locks ; for (setf symbol-function)
-   (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
-     (push ctor *all-ctors*)
-     (setf (fdefinition function-name) ctor)
-     (install-initial-constructor ctor :force-p t)
-     ctor)))
+    (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
+      (install-initial-constructor ctor :force-p t)
+      (push ctor *all-ctors*)
+      (setf (fdefinition function-name) ctor)
+      ctor)))
 
 ;;; *****************
 ;;; Inline CTOR cache
@@ -298,25 +310,35 @@
       (setf table (nth-value 1 (put-ctor ctor table))))
     table))
 
-(defun ctor-for-caching (class-name initargs safe-code-p)
-  (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
-    (or (ensure-ctor name class-name initargs safe-code-p)
-        (fdefinition name))))
-
 (defun ensure-cached-ctor (class-name store initargs safe-code-p)
-  (if (listp store)
-      (multiple-value-bind (ctor list) (find-ctor class-name store)
-        (if ctor
-            (values ctor list)
-            (let ((ctor (ctor-for-caching class-name initargs safe-code-p)))
-              (if (< (length list) +ctor-list-max-size+)
-                  (values ctor (cons ctor list))
-                  (values ctor (ctor-list-to-table list))))))
-      (let ((ctor (get-ctor class-name store)))
-        (if ctor
-            (values ctor store)
-            (put-ctor (ctor-for-caching class-name initargs safe-code-p)
-                      store)))))
+  (flet ((maybe-ctor-for-caching ()
+           (if (typep class-name '(or symbol class))
+               (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
+                 (ensure-ctor name class-name initargs safe-code-p))
+               ;; Invalid first argument: let MAKE-INSTANCE worry about it.
+               (return-from ensure-cached-ctor
+                 (values (lambda (&rest ctor-parameters)
+                           (let (mi-initargs)
+                             (doplist (key value) initargs
+                               (push key mi-initargs)
+                               (push (if (constantp value)
+                                         value
+                                         (pop ctor-parameters))
+                                     mi-initargs))
+                             (apply #'make-instance class-name (nreverse mi-initargs))))
+                         store)))))
+    (if (listp store)
+        (multiple-value-bind (ctor list) (find-ctor class-name store)
+          (if ctor
+              (values ctor list)
+              (let ((ctor (maybe-ctor-for-caching)))
+                (if (< (length list) +ctor-list-max-size+)
+                    (values ctor (cons ctor list))
+                    (values ctor (ctor-list-to-table list))))))
+       (let ((ctor (get-ctor class-name store)))
+         (if ctor
+             (values ctor store)
+             (put-ctor (maybe-ctor-for-caching) store))))))
 
 ;;; ***********************************************
 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
@@ -397,7 +419,7 @@
                                (function (&rest t) t))
                            ,function-name))
                    (funcall (function ,function-name) ,@value-forms))))
-            (when class-arg
+            (when (and class-arg (not (constantp class-arg)))
               ;; Build an inline cache: a CONS, with the actual cache in the CDR.
               `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
                                                         make-instance))
@@ -565,7 +587,7 @@
            (make-instance ,class ,@initargs))
         (let ((defaults (class-default-initargs class)))
           (when defaults
-            (setf initargs (default-initargs initargs defaults)))
+            (setf initargs (ctor-default-initargs initargs defaults)))
           `(lambda ,lambda-list
              (declare #.*optimize-speed*)
              (fast-make-instance ,class ,@initargs))))))