0.pre7.20:

[sbcl.git] / src / compiler / target-main.lisp

diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp
index 950ccf6..673c998 100644 (file)
--- a/src/compiler/target-main.lisp
+++ b/src/compiler/target-main.lisp
@@ -12,11 +12,8 @@
 ;;;; files for more information.
 
 (in-package "SB!C")
-
-(file-comment
-  "$Header$")
 \f
-;;;; COMPILE and UNCOMPILE
+;;;; CL:COMPILE
 
 (defun get-lambda-to-compile (definition)
   (if (consp definition)
@@ -46,27 +43,26 @@
        (when old (substitute-leaf fun old)))
       name)))
 
-(defun compile (name &optional (definition (fdefinition name)))
-  #!+sb-doc
-  "Compiles the function whose name is Name. If Definition is supplied,
-  it should be a lambda expression that is compiled and then placed in the
-  function cell of Name. If Name is Nil, the compiled code object is
-  returned."
+;;; Handle the nontrivial case of CL:COMPILE.
+(defun actually-compile (name definition)
   (with-compilation-values
     (sb!xc:with-compilation-unit ()
-      (let* ((*info-environment* (or *backend-info-environment*
-                                    *info-environment*))
+      (let* (;; FIXME: Do we need this rebinding here? It's a literal
+            ;; translation of the old CMU CL rebinding to
+            ;; (OR *BACKEND-INFO-ENVIRONMENT* *INFO-ENVIRONMENT*),
+            ;; and it's not obvious whether the rebinding to itself is
+            ;; needed that SBCL doesn't need *BACKEND-INFO-ENVIRONMENT*.
+            (*info-environment* *info-environment*)
             (*lexenv* (make-null-lexenv))
             (form `#',(get-lambda-to-compile definition))
             (*source-info* (make-lisp-source-info form))
             (*top-level-lambdas* ())
-            (*converting-for-interpreter* nil)
             (*block-compile* nil)
             (*compiler-error-bailout*
              #'(lambda ()
                  (compiler-mumble
                   "~2&fatal error, aborting compilation~%")
-                 (return-from compile (values nil t nil))))
+                 (return-from actually-compile (values nil t nil))))
             (*current-path* nil)
             (*last-source-context* nil)
             (*last-original-source* nil)
@@ -100,9 +96,27 @@
              (dolist (component *all-components*)
                (compile-component component))))
 
-         (let* ((res1 (core-call-top-level-lambda lambda *compile-object*))
-                (result (or name res1)))
-           (fix-core-source-info *source-info* *compile-object* res1)
-           (when name
-             (setf (fdefinition name) res1))
-           result))))))
+         (let ((compiled-fun (core-call-top-level-lambda lambda
+                                                         *compile-object*)))
+           (fix-core-source-info *source-info* *compile-object* compiled-fun)
+           compiled-fun))))))
+
+(defun compile (name &optional (definition (fdefinition name)))
+  #!+sb-doc
+  "Coerce DEFINITION (by default, the function whose name is NAME)
+  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
+  where if NAME is NIL, THING is the result of compilation, and
+  otherwise THING is NAME. When NAME is not NIL, the compiled function
+  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
+  (FDEFINITION NAME) otherwise."
+  (multiple-value-bind (compiled-definition warnings-p failure-p)
+      (if (compiled-function-p definition)
+         (values definition nil nil)
+         (actually-compile name definition))
+    (cond (name
+          (if (macro-function name)
+              (setf (macro-function name) compiled-definition)
+              (setf (fdefinition name) compiled-definition))
+          (values name warnings-p failure-p))
+         (t
+          (values compiled-definition warnings-p failure-p)))))