X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=c107a938282ab3f8e0c37e1405c5f5705e3792cf;hb=0d1030c5fea1986c6383b6be531f95da7ae20644;hp=88d3429de05ae34d6700c8eebd5678519371b977;hpb=15e14ef1ccd3ab6f4711632435a40493dc4cdd9d;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 88d3429..c107a93 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -214,7 +214,7 @@
  					  :aux-vars (rest aux-vars)
  					  :aux-vals (rest aux-vals)
  					  :debug-name (debug-namify
- 						       "&AUX bindings ~S"
+ 						       "&AUX bindings " 
  						       aux-vars))))
 	(reference-leaf start ctran fun-lvar fun)
 	(ir1-convert-combination-args fun-lvar ctran next result
@@ -427,8 +427,8 @@
                                                        ,@(default-vals))))
                                          arg-vars
                                          :debug-name
-                                         (debug-namify "&OPTIONAL processor ~D"
-                                                       (random 100))
+                                         (debug-namify "&OPTIONAL processor "
+						       (gensym))
                                          :note-lexical-bindings nil))))
     (mapc (lambda (var arg-var)
 	    (when (cdr (leaf-refs arg-var))
@@ -595,7 +595,7 @@
                 (tests `((eq ,n-key :allow-other-keys)
                          (setq ,n-allowp ,n-value-temp))))
 	      (tests `(t
-		       (setq ,n-losep ,n-key))))
+		       (setq ,n-losep (list ,n-key)))))
 
 	    (body
 	     `(when (oddp ,n-count)
@@ -614,7 +614,7 @@
 
 	    (unless allowp
 	      (body `(when (and ,n-losep (not ,n-allowp))
-		       (%unknown-key-arg-error ,n-losep)))))))
+		       (%unknown-key-arg-error (car ,n-losep))))))))
 
       (let ((ep (ir1-convert-lambda-body
 		 `((let ,(temps)
@@ -622,7 +622,7 @@
 		     (%funcall ,(optional-dispatch-main-entry res)
 			       ,@(arg-vals))))
 		 (arg-vars)
-		 :debug-name (debug-namify "~S processing" '&more)
+		 :debug-name "&MORE processing"
                  :note-lexical-bindings nil)))
 	(setf (optional-dispatch-more-entry res)
               (register-entry-point ep res)))))
@@ -708,9 +708,8 @@
 			body (main-vars)
 			:aux-vars (append (bind-vars) aux-vars)
 			:aux-vals (append (bind-vals) aux-vals)
-			:debug-name (debug-namify "varargs entry for ~A"
-						  (as-debug-name source-name
-								 debug-name))))
+			:debug-name (debug-namify
+				     "varargs entry for " source-name debug-name)))
 	   (last-entry (convert-optional-entry main-entry default-vars
 					       (main-vals) ())))
       (setf (optional-dispatch-main-entry res)
@@ -778,9 +777,9 @@
 			 :aux-vars aux-vars
 			 :aux-vals aux-vals
 			 :debug-name (debug-namify
-				      "hairy arg processor for ~A"
-				      (as-debug-name source-name
-						     debug-name)))))
+				      "hairy arg processor for "
+				      source-name
+				      debug-name))))
                (setf (optional-dispatch-main-entry res) fun)
                (register-entry-point fun res)
                (push (if supplied-p-p
@@ -847,7 +846,7 @@
 				      &key
 				      (source-name '.anonymous.)
 				      (debug-name (debug-namify
-						   "OPTIONAL-DISPATCH ~S"
+						   "OPTIONAL-DISPATCH "
 						   vars)))
   (declare (list body vars aux-vars aux-vals))
   (let ((res (make-optional-dispatch :arglist vars
@@ -1082,18 +1081,25 @@
 ;;;
 ;;; The INLINE-EXPANSION is a LAMBDA-WITH-LEXENV, or NIL if there is
 ;;; no inline expansion.
-(defun %compiler-defun (name lambda-with-lexenv)
+(defun %compiler-defun (name lambda-with-lexenv compile-toplevel)
 
   (let ((defined-fun nil)) ; will be set below if we're in the compiler
 
-    (when (boundp '*lexenv*) ; when in the compiler
+    (when compile-toplevel
+      ;; better be in the compiler
+      (aver (boundp '*lexenv*)) 
       (when sb!xc:*compile-print*
 	(compiler-mumble "~&; recognizing DEFUN ~S~%" name))
       (remhash name *free-funs*)
-      (setf defined-fun (get-defined-fun name)))
+      (setf defined-fun (get-defined-fun name))
 
-    (become-defined-fun-name name)
+      (aver (fasl-output-p *compile-object*))
+      (if (member name *fun-names-in-this-file* :test #'equal)
+	  (warn 'duplicate-definition :name name)
+	  (push name *fun-names-in-this-file*)))
 
+    (become-defined-fun-name name)
+    
     (cond (lambda-with-lexenv
 	   (setf (info :function :inline-expansion-designator name)
 		 lambda-with-lexenv)