(declaim (special *constants* *free-vars* *component-being-compiled*
*code-vector* *next-location* *result-fixups*
*free-funs* *source-paths*
- *seen-blocks* *seen-funs* *list-conflicts-table*
*continuation-number* *continuation-numbers*
*number-continuations* *tn-id* *tn-ids* *id-tns*
*label-ids* *label-id* *id-labels*
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.
`(%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)
- (*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.
(*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))))))))))
+ (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*)))
(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))
;;; actually in use, so that this function could go away.
(defun clear-stuff (&optional (debug-too t))
- ;; Clear global tables.
- (when (boundp '*free-funs*)
- (clrhash *free-funs*)
- (clrhash *free-vars*)
- (clrhash *constants*))
-
- ;; Clear debug counters and tables.
- (clrhash *seen-blocks*)
- (clrhash *seen-funs*)
- (clrhash *list-conflicts-table*)
-
(when debug-too
(clrhash *continuation-numbers*)
(clrhash *number-continuations*)
(handler-case
(read-preserving-whitespace stream nil stream)
(reader-error (condition)
- (error 'input-error-in-compile-file
- :condition condition
- ;; We don't need to supply :POSITION here because
- ;; READER-ERRORs already know their position in the file.
- ))
+ (compiler-error 'input-error-in-compile-file
+ ;; We don't need to supply :POSITION here because
+ ;; READER-ERRORs already know their position in the file.
+ :condition condition
+ :stream stream))
;; ANSI, in its wisdom, says that READ should return END-OF-FILE
;; (and that this is not a READER-ERROR) when it encounters end of
;; file in the middle of something it's trying to read.
(end-of-file (condition)
- (error 'input-error-in-compile-file
- :condition condition
- ;; We need to supply :POSITION here because the END-OF-FILE
- ;; condition doesn't carry the position that the user
- ;; probably cares about, where the failed READ began.
- :position position))))
+ (compiler-error 'input-error-in-compile-file
+ :condition condition
+ ;; We need to supply :POSITION here because the END-OF-FILE
+ ;; condition doesn't carry the position that the user
+ ;; probably cares about, where the failed READ began.
+ :position position
+ :stream stream))
+ (error (condition)
+ (compiler-error 'input-error-in-compile-file
+ :condition condition
+ :position position
+ :stream stream))))
;;; If STREAM is present, return it, otherwise open a stream to the
;;; current file. There must be a current file.
;;; 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)
;;; 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))))
(*fun-names-in-this-file* ())
(*allow-instrumenting* nil)
(*compiler-error-bailout*
- (lambda ()
- (compiler-mumble "~2&; fatal error, aborting compilation~%")
+ (lambda (&optional error)
+ (declare (ignore error))
(return-from sub-compile-file (values t t t))))
(*current-path* nil)
(*last-source-context* nil)
(handler-case
(handler-bind (((satisfies handle-condition-p) #'handle-condition-handler))
(with-compilation-values
- (sb!xc:with-compilation-unit ()
+ (sb!xc:with-compilation-unit ()
+ (with-world-lock ()
(clear-stuff)
-
(sub-sub-compile-file info)
-
(unless (zerop (hash-table-count *code-coverage-records*))
;; Dump the code coverage records into the fasl.
(fopcompile `(record-code-coverage
',(namestring *compile-file-pathname*)
',(let (list)
- (maphash (lambda (k v)
- (declare (ignore k))
- (push v list))
- *code-coverage-records*)
- list))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (push v list))
+ *code-coverage-records*)
+ list))
nil
nil))
-
(finish-block-compilation)
(let ((object *compile-object*))
(etypecase object
(fasl-output (fasl-dump-source-info info object))
(core-object (fix-core-source-info info object))
(null)))
- nil)))
+ nil))))
;; Some errors are sufficiently bewildering that we just fail
;; immediately, without trying to recover and compile more of
;; the input file.
(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