X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffast-init.lisp;h=2d723e159c14c0c676c4eac813b39510541b5102;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=9740481bc912d62cc772984c6ad3ffaa62402abc;hpb=099d6dd1f6a5ac2ffec5c14d07a4b905322ef968;p=sbcl.git

diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp
index 9740481..2d723e1 100644
--- a/src/pcl/fast-init.lisp
+++ b/src/pcl/fast-init.lisp
@@ -60,19 +60,21 @@
 	     (sym (make-instance-function-symbol key)))
 	(push key *make-instance-function-keys*)
 	(when sym
-          ;; MNA: cmucl-commit Sat, 27 Jan 2001 07:07:45 -0800 (PST)
-          ;; Silence compiler warnings about undefined function
-          ;; <hairy-make-instance-name>
-          ;; when compiling a method containing a make-instance call.
-          (progn ;; Lifted from c::%%defun.
-            (sb-c::proclaim-as-function-name sym)
-	    (when (eq (sb-int:info :function :where-from sym) :assumed)
-	      (setf (sb-int:info :function :where-from sym) :defined)
-	      (when (sb-int:info :function :assumed-type sym)
-		(setf (sb-int:info :function :assumed-type sym) nil))))
+	  ;; (famous last words:
+	  ;;   1. Don't worry, I know what I'm doing.
+	  ;;   2. You and what army?
+	  ;;   3. If you were as smart as you think you are, you
+	  ;;      wouldn't be a copy.
+	  ;; This is case #1.:-) Even if SYM hasn't been defined yet,
+	  ;; it must be an implementation function, or we we wouldn't
+	  ;; have expanded into it. So declare SYM as defined, so that
+	  ;; even if it hasn't been defined yet, the user doesn't get
+	  ;; obscure warnings about undefined internal implementation
+	  ;; functions like HAIRY-MAKE-instance-name.
+	  (sb-kernel:become-defined-fun-name sym)
 	  `(,sym ',class (list ,@initargs)))))))
 
-(defmacro expanding-make-instance-top-level (&rest forms &environment env)
+(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
   (let* ((*make-instance-function-keys* nil)
 	 (form (macroexpand `(expanding-make-instance ,@forms) env)))
     `(progn
@@ -93,12 +95,6 @@
 				      subform))))
 	       forms)))
 
-(defmacro defconstructor
-	  (name class lambda-list &rest initialization-arguments)
-  `(expanding-make-instance-top-level
-    (defun ,name ,lambda-list
-      (make-instance ',class ,@initialization-arguments))))
-
 (defun get-make-instance-functions (key-list)
   (dolist (key key-list)
     (let* ((cell (find-class-cell (car key)))
@@ -176,7 +172,7 @@
 				     'initialize-info name)))
 		 *initialize-info-cached-slots*)))
     `(progn
-       (defstruct initialize-info
+       (defstruct (initialize-info (:copier nil))
 	 key wrapper
 	 ,@(mapcar #'(lambda (name)
 		       `(,name :unknown))
@@ -693,7 +689,7 @@
 (defvar *note-iis-entry-p* nil)
 
 (defvar *compiled-initialize-instance-simple-functions*
-  (make-hash-table :test #'equal))
+  (make-hash-table :test 'equal))
 
 (defun initialize-instance-simple-function (use info class form-list)
   (let* ((pv-cell (get-pv-cell-for-class class))
@@ -744,17 +740,18 @@
 
 (defmacro precompile-iis-functions (&optional system)
   `(progn
-    ,@(gathering1 (collecting)
-                  (dolist (iis-entry *initialize-instance-simple-alist*)
-                    (when (or (null (caddr iis-entry))
-                              (eq (caddr iis-entry) system))
-                      (when system (setf (caddr iis-entry) system))
-                      (gather1
-                       `(load-precompiled-iis-entry
-                         ',(car iis-entry)
-                         #',(car iis-entry)
-                         ',system
-                         ',(cdddr iis-entry))))))))
+    ,@(let (collect)
+        (dolist (iis-entry *initialize-instance-simple-alist*)
+          (when (or (null (caddr iis-entry))
+                    (eq (caddr iis-entry) system))
+            (when system (setf (caddr iis-entry) system))
+            (push `(load-precompiled-iis-entry
+                    ',(car iis-entry)
+                    #',(car iis-entry)
+                    ',system
+                    ',(cdddr iis-entry))
+                  collect)))
+        (nreverse collect))))
 
 (defun compile-iis-functions (after-p)
   (let ((*compile-make-instance-functions-p* t)