(defmacro sb!xc:with-compilation-unit (options &body body)
#!+sb-doc
- "WITH-COMPILATION-UNIT ({Key Value}*) Form*
- This form affects compilations that take place within its dynamic extent. It
- is intended to be wrapped around the compilation of all files in the same
- system. These keywords are defined:
-
- :OVERRIDE Boolean-Form
- One of the effects of this form is to delay undefined warnings
- until the end of the form, instead of giving them at the end of each
- compilation. If OVERRIDE is NIL (the default), then the outermost
- WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
- OVERRIDE true causes that form to grab any enclosed warnings, even if
- it is enclosed by another WITH-COMPILATION-UNIT.
-
- :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. If Unaffected by :OVERRIDE."
+ "Affects compilations that take place within its dynamic extent. It is
+intended to be eg. wrapped around the compilation of all files in the same system.
+
+Following options are defined:
+
+ :OVERRIDE Boolean-Form
+ One of the effects of this form is to delay undefined warnings until the
+ end of the form, instead of giving them at the end of each compilation.
+ If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if it
+ is enclosed by another WITH-COMPILATION-UNIT.
+
+ :POLICY Optimize-Declaration-Form
+ Provides dynamic scoping for global compiler optimization qualities and
+ restrictions, limiting effects of subsequent OPTIMIZE proclamations and
+ calls to SB-EXT:RESTRICT-COMPILER-POLICY to the dynamic scope of BODY.
+
+ If OVERRIDE is false, specified POLICY is merged with current global
+ policy. If OVERRIDE is true, current global policy, including any
+ restrictions, is discarded in favor of the specified POLICY.
+
+ 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
+ subject to change.
+
+ :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.
+
+ If both an outer and an inner WITH-COMPILATION-UNIT provide a
+ SOURCE-NAMESTRING, the inner one takes precedence. Unaffected
+ by :OVERRIDE.
+
+ This is an SBCL-specific extension.
+
+ :SOURCE-PLIST Plist-Form
+ Attaches the value returned by the Plist-Form to internal debug-source
+ information of functions compiled in within the dynamic extent of BODY.
+
+ 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)
+(defvar *source-namestring* nil)
-(defun %with-compilation-unit (fn &key override source-plist)
+(defun %with-compilation-unit (fn &key override policy source-plist source-namestring)
(declare (type function fn))
- (let ((succeeded-p nil)
- (*source-plist* (append source-plist *source-plist*)))
- (if (and *in-compilation-unit* (not override))
- ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
- ;; ordinarily (unless OVERRIDE) basically a no-op.
- (unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*)))
- (let ((*aborted-compilation-unit-count* 0)
- (*compiler-error-count* 0)
- (*compiler-warning-count* 0)
- (*compiler-style-warning-count* 0)
- (*compiler-note-count* 0)
- (*undefined-warnings* nil)
- (*in-compilation-unit* t))
- (with-world-lock ()
- (handler-bind ((parse-unknown-type
- (lambda (c)
- (note-undefined-reference
- (parse-unknown-type-specifier c)
- :type))))
- (unwind-protect
- (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
- (unless succeeded-p
- (incf *aborted-compilation-unit-count*))
- (summarize-compilation-unit (not succeeded-p)))))))))
+ (flet ((with-it ()
+ (let ((succeeded-p nil)
+ (*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.
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*)))
+ (let ((*aborted-compilation-unit-count* 0)
+ (*compiler-error-count* 0)
+ (*compiler-warning-count* 0)
+ (*compiler-style-warning-count* 0)
+ (*compiler-note-count* 0)
+ (*undefined-warnings* nil)
+ (*in-compilation-unit* t))
+ (with-world-lock ()
+ (handler-bind ((parse-unknown-type
+ (lambda (c)
+ (note-undefined-reference
+ (parse-unknown-type-specifier c)
+ :type))))
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*))
+ (summarize-compilation-unit (not succeeded-p))))))))))
+ (if policy
+ (let ((*policy* (process-optimize-decl policy (unless override *policy*)))
+ (*policy-restrictions* (unless override *policy-restrictions*)))
+ (with-it))
+ (with-it))))
;;; Is NAME something that no conforming program can rely on
;;; defining?
(defun clear-constant-info ()
(maphash (lambda (k v)
(declare (ignore k))
- (setf (leaf-info v) nil))
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil))
*constants*)
(maphash (lambda (k v)
(declare (ignore k))
(when (constant-p v)
- (setf (leaf-info v) nil)))
+ (setf (leaf-info v) nil)
+ (setf (constant-boxed-tn v) nil)))
*free-vars*)
(values))
;;; 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)
(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
- (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.
(*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*)
;;; compilation. Normally just evaluate in the appropriate
;;; environment, but also compile if outputting a CFASL.
(defun eval-compile-toplevel (body path)
- (eval-in-lexenv `(progn ,@body) *lexenv*)
+ (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))))
;; the input file.
(fatal-compiler-error (condition)
(signal condition)
+ (fresh-line *error-output*)
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(format *error-output*
- "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
- condition))
+ "~@<~@:_compilation aborted because of fatal error: ~2I~_~A~@:_~:>"
+ (encapsulated-condition condition)))
(finish-output *error-output*)
(values t t t)))))
(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))
projects / sbcl.git / blobdiff