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