X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Ftarget-main.lisp;h=673c9987d4720dfecc81602b4ddf16ae24f5a97b;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=950ccf6954251ba6976975a4f65dfdc24509774b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp
index 950ccf6..673c998 100644
--- 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$")
 
-;;;; 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)))))