0.8.13.47:

[sbcl.git] / src / compiler / ir1tran-lambda.lisp

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 3fcf355..c107a93 100644 (file)
--- 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
@@ -261,6 +261,7 @@
 ;;; whereas NEXT is a variable naming a CTRAN in the body.  -- CSR,
 ;;; 2004-03-30.
 (defmacro with-dynamic-extent ((start body-start next kind) &body body)
+  (declare (ignore kind))
   (with-unique-names (cleanup next-ctran)
     `(progn
       (ctran-starts-block ,body-start)
@@ -426,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))
@@ -594,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)
@@ -613,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)
@@ -621,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)))))
@@ -707,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)
@@ -777,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
@@ -846,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
@@ -966,6 +966,7 @@
                                      (source-name '.anonymous.)
                                      debug-name
                                      allow-debug-catch-tag)
+  (declare (ignore allow-debug-catch-tag))
   (destructuring-bind (decls macros symbol-macros &rest body)
                      (if (eq (car fun) 'lambda-with-lexenv)
                          (cdr fun)
@@ -1080,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)