X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-main.lisp;h=683804191d368f86bb9700312153dd71b05456fd;hb=4bc9a2b01540f3a7cbf4499b4689b292fe406139;hp=70178958b31aaf7f9e8044feb929e9e054339c2b;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git

diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp
index 7017895..6838041 100644
--- a/src/compiler/target-main.lisp
+++ b/src/compiler/target-main.lisp
@@ -27,25 +27,8 @@
 	  (error "can't find a definition for ~S" definition-designator))
 	definition)))
 
-;;; Find the function that is being compiled by COMPILE and bash its
-;;; name to NAME. We also substitute for any references to name so
-;;; that recursive calls will be compiled direct. LAMBDA is the
-;;; top-level lambda for the compilation. A REF for the real function
-;;; is the only thing in the top-level lambda other than the bind and
-;;; return, so it isn't too hard to find.
-(defun compile-fix-fun-name (lambda name)
-  (declare (type clambda lambda) (type (or symbol cons) name))
-  (when name
-    (let ((fun (ref-leaf
-		(continuation-next
-		 (node-cont (lambda-bind lambda))))))
-      (setf (leaf-name fun) name)
-      (let ((old (gethash name *free-functions*)))
-	(when old (substitute-leaf fun old)))
-      name)))
-
 ;;; Handle the nontrivial case of CL:COMPILE.
-(defun actually-compile (name definition)
+(defun actually-compile (name definition *lexenv*)
   (with-compilation-values
     (sb!xc:with-compilation-unit ()
       ;; FIXME: These bindings were copied from SUB-COMPILE-FILE with
@@ -61,16 +44,15 @@
 	     ;; rebinding to itself is needed now 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* ())
+	     (*toplevel-lambdas* ())
 	     (*block-compile* nil)
 	     (*compiler-error-bailout*
-	      #'(lambda ()
-		  (compiler-mumble
-		   "~2&fatal error, aborting compilation~%")
-		  (return-from actually-compile (values nil t nil))))
+	      (lambda ()
+		(compiler-mumble
+		 "~2&fatal error, aborting compilation~%")
+		(return-from actually-compile (values nil t nil))))
 	     (*current-path* nil)
 	     (*last-source-context* nil)
 	     (*last-original-source* nil)
@@ -79,6 +61,15 @@
 	     (*last-format-args* nil)
 	     (*last-message-count* 0)
 	     (*gensym-counter* 0)
+	     ;; KLUDGE: This rebinding of policy is necessary so that
+	     ;; forms such as LOCALLY at the REPL actually extend the
+	     ;; compilation policy correctly.  However, there is an
+	     ;; invariant that is potentially violated: future
+	     ;; refactoring must not allow this to be done in the file
+	     ;; compiler.  At the moment we're clearly alright, as we
+	     ;; call %COMPILE with a core-object, not a fasl-stream,
+	     ;; but caveat future maintainers. -- CSR, 2002-10-27
+	     (*policy* (lexenv-policy *lexenv*))
 	     ;; FIXME: ANSI doesn't say anything about CL:COMPILE
 	     ;; interacting with these variables, so we shouldn't. As
 	     ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
@@ -93,22 +84,27 @@
 		  :name name
 		  :path '(original-source-start 0 0))))))
 
-(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."
+(defun compile-in-lexenv (name definition lexenv)
   (multiple-value-bind (compiled-definition warnings-p failure-p)
       (if (compiled-function-p definition)
 	  (values definition nil nil)
-	  (actually-compile name definition))
+	  (actually-compile name definition lexenv))
     (cond (name
-	   (if (macro-function name)
+	   (if (and (symbolp name)
+                    (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)))))
+
+(defun compile (name &optional (definition (or (macro-function name)
+					       (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."
+  (compile-in-lexenv name definition (make-null-lexenv)))