From 40bd773c3fc66abeba93c724ff54b99f89dc9456 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Tue, 1 Jul 2003 16:32:41 +0000
Subject: [PATCH] 	* src/pcl/ctor.lisp (toplevel): New function name
 syntax 	for (make-instance ...). 
 (install-optimized-constructor): Call compile-lambda with 	:name set to
 such a function name.

---
 pcl/ctor.lisp | 29 ++++++++++++++++++-----------
 1 file changed, 18 insertions(+), 11 deletions(-)

diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp
index 3aae7fd3a..3e10e9c52 100644
--- a/pcl/ctor.lisp
+++ b/pcl/ctor.lisp
@@ -46,7 +46,7 @@
 ;;; is called.
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.14 2003/07/01 14:49:39 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.15 2003/07/01 16:32:41 gerd Exp $")
 
 (in-package "PCL")
 
@@ -110,6 +110,10 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (define-function-name-syntax ctor (name)
+    (when (symbolp (cadr name))
+      (values t (cadr name))))
+  
+  (define-function-name-syntax make-instance (name)
     (when (symbolp (cadr name))
       (values t (cadr name)))))
 
@@ -240,16 +244,19 @@
 (defvar *the-system-si-method* nil)
 
 (defun install-optimized-constructor (ctor)
-   (flet ((install (optimized-p)
-	    (without-package-locks
-	     (multiple-value-bind (lambda fn)
-		 (if optimized-p
-		     (constructor-function-form ctor)
-		     (fallback-generator ctor))
-	       (setf (kernel:funcallable-instance-function ctor)
-		     (or fn
-			 (letf (((compiler-macro-function 'make-instance) nil))
-			   (compile-lambda lambda))))))))
+   (labels ((lambda-name (ctor)
+	      (cons 'make-instance
+		    (cdr (ctor-function-name ctor))))
+	    (install (optimized-p)
+	      (without-package-locks
+	       (multiple-value-bind (lambda fn)
+		   (if optimized-p
+		       (constructor-function-form ctor)
+		       (fallback-generator ctor))
+		 (setf (kernel:funcallable-instance-function ctor)
+		       (or fn
+			   (letf (((compiler-macro-function 'make-instance) nil))
+			     (compile-lambda lambda :name (lambda-name ctor)))))))))
      (let ((class (find-class (ctor-class-name ctor) nil)))
        (setf (ctor-class ctor) class)
        (cond ((null class)
-- 
GitLab