1.0.48.28: make TRULY-THE macroexpandable

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

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 102a843..84bfea7 100644 (file)
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -161,47 +161,67 @@ Following options are defined:
       Supplying POLICY NIL is equivalent to the option not being supplied at
       all, ie. dynamic scoping of policy does not take place.
 
       Supplying POLICY NIL is equivalent to the option not being supplied at
       all, ie. dynamic scoping of policy does not take place.
 

-      This option is an SBCL specific EXPERIMENTAL extension: Interface
+      This option is an SBCL-specific experimental extension: Interface

       subject to change.
 
       subject to change.
 

-      Examples:
+  :SOURCE-NAMESTRING Namestring-Form
+      Attaches the value returned by the Namestring-Form to the internal
+      debug-source information as the namestring of the source file. Normally
+      the namestring of the input-file for COMPILE-FILE is used: this option
+      can be used to provide source-file information for functions compiled
+      using COMPILE, or to override the input-file of COMPILE-FILE.

 
 

-        ;; Prevent OPTIMIZE proclamations from file leaking, and
-        ;; restrict SAFETY to 3 for the LOAD -- otherwise uses the
-        ;; current global policy.
-        (with-compilation-unit (:policy '(optimize))
-          (restrict-compiler-policy 'safety 3)
-          (load \"foo.lisp\"))
+      If both an outer and an inner WITH-COMPILATION-UNIT provide a
+      SOURCE-NAMESTRING, the inner one takes precedence. Unaffected
+      by :OVERRIDE.

 
 

-        ;; Load using default policy instead of the current global one, except
-        ;; for DEBUG 3.
-        (with-compilation-unit (:policy '(optimize debug) :override t)
-          (load \"foo.lisp\"))
-
-        ;; Same as if :POLICY had not been specified at all: SAFETY 3
-        ;; leaks outside WITH-COMPILATION-UNIT.
-        (with-compilation-unit (:policy nil)
-          (declaim (optimize safety)))
+      This is an SBCL-specific extension.

 
   :SOURCE-PLIST Plist-Form
       Attaches the value returned by the Plist-Form to internal debug-source
 
   :SOURCE-PLIST Plist-Form
       Attaches the value returned by the Plist-Form to internal debug-source

-      information of functions compiled in within the dynamic contour.
-      Primarily for use by development environments, in order to eg. associate
-      function definitions with editor-buffers. Can be accessed as
-      SB-INTROSPECT:DEFINITION-SOURCE-PLIST. If multiple, nested
-      WITH-COMPILATION-UNITs provide :SOURCE-PLISTs, they are appended
-      togather, innermost left. Unaffected by :OVERRIDE.
+      information of functions compiled in within the dynamic extent of BODY.

 
 

-      This SBCL is and specific extension."
+      Primarily for use by development environments, in order to eg. associate
+      function definitions with editor-buffers. Can be accessed using
+      SB-INTROSPECT:DEFINITION-SOURCE-PLIST.
+
+      If an outer WITH-COMPILATION-UNIT form also provide a SOURCE-PLIST, it
+      is appended to the end of the provided SOURCE-PLIST. Unaffected
+      by :OVERRIDE.
+
+      This is an SBCL-specific extension.
+
+Examples:
+
+  ;; Prevent proclamations from the file leaking, and restrict
+  ;; SAFETY to 3 -- otherwise uses the current global policy.
+  (with-compilation-unit (:policy '(optimize))
+    (restrict-compiler-policy 'safety 3)
+    (load \"foo.lisp\"))
+
+  ;; Using default policy instead of the current global one,
+  ;; except for DEBUG 3.
+  (with-compilation-unit (:policy '(optimize debug)
+                          :override t)
+    (load \"foo.lisp\"))
+
+  ;; Same as if :POLICY had not been specified at all: SAFETY 3
+  ;; proclamation leaks out from WITH-COMPILATION-UNIT.
+  (with-compilation-unit (:policy nil)
+    (declaim (optimize safety))
+    (load \"foo.lisp\"))
+"

   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defvar *source-plist* nil)
   `(%with-compilation-unit (lambda () ,@body) ,@options))
 
 (defvar *source-plist* nil)

+(defvar *source-namestring* nil)

 
 

-(defun %with-compilation-unit (fn &key override policy source-plist)
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)

   (declare (type function fn))
   (flet ((with-it ()
            (let ((succeeded-p nil)
   (declare (type function fn))
   (flet ((with-it ()
            (let ((succeeded-p nil)

-                 (*source-plist* (append source-plist *source-plist*)))
+                 (*source-plist* (append source-plist *source-plist*))
+                 (*source-namestring* (or source-namestring *source-namestring*)))

              (if (and *in-compilation-unit* (not override))
                  ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
                  ;; ordinarily (unless OVERRIDE) basically a no-op.
              (if (and *in-compilation-unit* (not override))
                  ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
                  ;; ordinarily (unless OVERRIDE) basically a no-op.

@@ -994,7 +1014,7 @@ Following options are defined:
 ;;; We only expand one level, so that we retain all the intervening
 ;;; forms in the source path.
 (defun preprocessor-macroexpand-1 (form)
 ;;; We only expand one level, so that we retain all the intervening
 ;;; forms in the source path.
 (defun preprocessor-macroexpand-1 (form)

-  (handler-case (sb!xc:macroexpand-1 form *lexenv*)
+  (handler-case (%macroexpand-1 form *lexenv*)

     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
                       (let ((*print-level* 2)
     (error (condition)
       (compiler-error "(during macroexpansion of ~A)~%~A"
                       (let ((*print-level* 2)

@@ -1092,28 +1112,39 @@ Following options are defined:
          (source-name (or name '.anonymous.)))
     (setf (component-name component) (debug-name 'initial-component debug-name-tail)
           (component-kind component) :initial)
          (source-name (or name '.anonymous.)))
     (setf (component-name component) (debug-name 'initial-component debug-name-tail)
           (component-kind component) :initial)

-    (let* ((locall-fun (let ((*allow-instrumenting* t))
-                         (funcall #'ir1-convert-lambdalike
-                                  lambda-expression
-                                  :source-name source-name)))
-           ;; Convert the XEP using the policy of the real
-           ;; function. Otherwise the wrong policy will be used for
-           ;; deciding whether to type-check the parameters of the
-           ;; real function (via CONVERT-CALL / PROPAGATE-TO-ARGS).
-           ;; -- JES, 2007-02-27
-           (*lexenv* (make-lexenv :policy (lexenv-policy
-                                           (functional-lexenv locall-fun))))
-           (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
+    (let* ((fun (let ((*allow-instrumenting* t))
+                  (funcall #'ir1-convert-lambdalike
+                           lambda-expression
+                           :source-name source-name)))
+           ;; Convert the XEP using the policy of the real function. Otherwise
+           ;; the wrong policy will be used for deciding whether to type-check
+           ;; the parameters of the real function (via CONVERT-CALL /
+           ;; PROPAGATE-TO-ARGS). -- JES, 2007-02-27
+           (*lexenv* (make-lexenv :policy (lexenv-policy (functional-lexenv fun))))
+           (xep (ir1-convert-lambda (make-xep-lambda-expression fun)

                                     :source-name source-name
                                     :debug-name (debug-name 'tl-xep debug-name-tail)
                                     :system-lambda t)))
       (when name
                                     :source-name source-name
                                     :debug-name (debug-name 'tl-xep debug-name-tail)
                                     :system-lambda t)))
       (when name

-        (assert-global-function-definition-type name locall-fun))
-      (setf (functional-entry-fun fun) locall-fun
-            (functional-kind fun) :external
-            (functional-has-external-references-p locall-fun) t
-            (functional-has-external-references-p fun) t)
-      fun)))
+        (assert-global-function-definition-type name fun))
+      (setf (functional-kind xep) :external
+            (functional-entry-fun xep) fun
+            (functional-entry-fun fun) xep
+            (component-reanalyze component) t
+            (functional-has-external-references-p xep) t)
+      (reoptimize-component component :maybe)
+      (locall-analyze-xep-entry-point fun)
+      ;; Any leftover REFs to FUN outside local calls get replaced with the
+      ;; XEP.
+      (substitute-leaf-if (lambda (ref)
+                            (let* ((lvar (ref-lvar ref))
+                                   (dest (when lvar (lvar-dest lvar)))
+                                   (kind (when (basic-combination-p dest)
+                                           (basic-combination-kind dest))))
+                              (neq :local kind)))
+                          xep
+                          fun)
+      xep)))

 
 ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
 ;;; description of the result.
 
 ;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a
 ;;; description of the result.

@@ -1229,8 +1260,10 @@ Following options are defined:
                  (*print-level* 2)
                  (*print-pretty* nil))
              (with-compiler-io-syntax
                  (*print-level* 2)
                  (*print-pretty* nil))
              (with-compiler-io-syntax

-                 (compiler-mumble "~&; ~:[compiling~;converting~] ~S"
-                                  *block-compile* form)))
+                 (compiler-mumble
+                  #-sb-xc-host "~&; ~:[compiling~;converting~] ~S"
+                  #+sb-xc-host "~&; ~:[x-compiling~;x-converting~] ~S"
+                  *block-compile* form)))

              form)
           ((and finalp
                 (eq :top-level-forms *compile-print*)
              form)
           ((and finalp
                 (eq :top-level-forms *compile-print*)

@@ -1248,10 +1281,7 @@ Following options are defined:
 ;;; compilation. Normally just evaluate in the appropriate
 ;;; environment, but also compile if outputting a CFASL.
 (defun eval-compile-toplevel (body path)
 ;;; compilation. Normally just evaluate in the appropriate
 ;;; environment, but also compile if outputting a CFASL.
 (defun eval-compile-toplevel (body path)

-  (handler-case (eval-in-lexenv `(progn ,@body) *lexenv*)
-    (error (condition)
-      (compiler-error "(during compile-time-too processing)~%~A"
-                      condition)))
+  (eval-tlf `(progn ,@body) (source-path-tlf-number path) *lexenv*)

   (when *compile-toplevel-object*
     (let ((*compile-object* *compile-toplevel-object*))
       (convert-and-maybe-compile `(progn ,@body) path))))
   (when *compile-toplevel-object*
     (let ((*compile-object* *compile-toplevel-object*))
       (convert-and-maybe-compile `(progn ,@body) path))))

@@ -2020,6 +2050,6 @@ SPEED and COMPILATION-SPEED optimization values, and the
   (compile name lambda))
 
 #+sb-xc-host
   (compile name lambda))
 
 #+sb-xc-host

-(defun eval-in-lexenv (form lexenv)
-  (declare (ignore lexenv))
+(defun eval-tlf (form index &optional lexenv)
+  (declare (ignore index lexenv))

   (eval form))
   (eval form))