X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=39e1d69037d85aab3c66a7cd8e3ecbd5c5641cd7;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=01bca3ad44fd738bad09fe250e92ba05a42d9265;hpb=6498af7fdc48d9bf5df33e75d7e4d385893feb06;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 01bca3a..39e1d69 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -28,11 +28,19 @@ #!+sb-show *compiler-trace-output* *last-source-context* *last-original-source* *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *lexenv*)) + *last-message-count* *lexenv* *fun-names-in-this-file* + *allow-instrumenting*)) + +;;; Whether call of a function which cannot be defined causes a full +;;; warning. +(defvar *flame-on-necessarily-undefined-function* nil) (defvar *check-consistency* nil) (defvar *all-components*) +;;; Set to NIL to disable loop analysis for register allocation. +(defvar *loop-analyze* t) + ;;; Bind this to a stream to capture various internal debugging output. (defvar *compiler-trace-output* nil) @@ -112,26 +120,24 @@ 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." + 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." `(%with-compilation-unit (lambda () ,@body) ,@options)) (defun %with-compilation-unit (fn &key override) + (declare (type function fn)) (let ((succeeded-p nil)) (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)) + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) (unless succeeded-p (incf *aborted-compilation-unit-count*))) - ;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than - ;; one place. If we can get rid of the IR1 interpreter, this - ;; should be easier to clean up. (let ((*aborted-compilation-unit-count* 0) (*compiler-error-count* 0) (*compiler-warning-count* 0) @@ -139,16 +145,23 @@ (*compiler-note-count* 0) (*undefined-warnings* nil) (*in-compilation-unit* t)) - (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)))))))) + (sb!thread:with-recursive-lock (*big-compiler-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))))))))) + +;;; Is FUN-NAME something that no conforming program can rely on +;;; defining as a function? +(defun fun-name-reserved-by-ansi-p (fun-name) + (eq (symbol-package (fun-name-block-name fun-name)) + *cl-package*)) ;;; This is to be called at the end of a compilation unit. It signals ;;; any residual warnings about unknown stuff, then prints the total @@ -172,23 +185,53 @@ (warnings (undefined-warning-warnings undef)) (undefined-warning-count (undefined-warning-count undef))) (dolist (*compiler-error-context* warnings) - (compiler-style-warn "undefined ~(~A~): ~S" kind name)) + (if #-sb-xc-host (and (eq kind :function) + (fun-name-reserved-by-ansi-p name) + *flame-on-necessarily-undefined-function*) + #+sb-xc-host nil + (case name + ((declare) + (compiler-warn + "~@" + name name)) + (t + (compiler-warn + "~@" + kind name))) + (if (eq kind :variable) + (compiler-warn "undefined ~(~A~): ~S" kind name) + (compiler-style-warn "undefined ~(~A~): ~S" kind name)))) (let ((warn-count (length warnings))) (when (and warnings (> undefined-warning-count warn-count)) (let ((more (- undefined-warning-count warn-count))) - (compiler-style-warn - "~W more use~:P of undefined ~(~A~) ~S" - more kind name)))))) - + (if (eq kind :variable) + (compiler-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name) + (compiler-style-warn + "~W more use~:P of undefined ~(~A~) ~S" + more kind name))))))) + (dolist (kind '(:variable :function :type)) (let ((summary (mapcar #'undefined-warning-name - (remove kind undefs :test-not #'eq + (remove kind undefs :test #'neq :key #'undefined-warning-kind)))) (when summary - (compiler-style-warn - "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ - ~% ~{~<~% ~1:;~S~>~^ ~}" - (cdr summary) kind summary))))))) + (if (eq kind :variable) + (compiler-warn + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + (cdr summary) kind summary) + (compiler-style-warn + "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~ + ~% ~{~<~% ~1:;~S~>~^ ~}" + (cdr summary) kind summary)))))))) (unless (and (not abort-p) (zerop *aborted-compilation-unit-count*) @@ -244,17 +287,20 @@ (maybe-mumble "opt") (event ir1-optimize-until-done) (let ((count 0) - (cleared-reanalyze nil)) + (cleared-reanalyze nil) + (fastp nil)) (loop (when (component-reanalyze component) (setq count 0) (setq cleared-reanalyze t) (setf (component-reanalyze component) nil)) (setf (component-reoptimize component) nil) - (ir1-optimize component) + (ir1-optimize component fastp) (cond ((component-reoptimize component) (incf count) - (when (= count *max-optimize-iterations*) + (when (and (>= count *max-optimize-iterations*) + (not (component-reanalyze component)) + (eq (component-reoptimize component) :maybe)) (maybe-mumble "*") (cond ((retry-delayed-ir1-transforms :optimize) (maybe-mumble "+") @@ -271,7 +317,8 @@ (t (maybe-mumble " ") (return))) - (maybe-mumble ".")) + (setq fastp (>= count *max-optimize-iterations*)) + (maybe-mumble (if fastp "-" "."))) (when cleared-reanalyze (setf (component-reanalyze component) t))) (values)) @@ -359,7 +406,8 @@ (maybe-mumble "control ") (control-analyze component #'make-ir2-block) - (when (ir2-component-values-receivers (component-info component)) + (when (or (ir2-component-values-receivers (component-info component)) + (component-dx-lvars component)) (maybe-mumble "stack ") (stack-analyze component) ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by @@ -409,9 +457,10 @@ (describe-ir2-component component *compiler-trace-output*)) (maybe-mumble "code ") - (multiple-value-bind (code-length trace-table fixups) + (multiple-value-bind (code-length trace-table fixup-notes) (generate-code component) + #-sb-xc-host (when *compiler-trace-output* (format *compiler-trace-output* "~|~%disassembly of code for ~S~2%" component) @@ -425,7 +474,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (core-object (maybe-mumble "core") @@ -433,7 +482,7 @@ *code-segment* code-length trace-table - fixups + fixup-notes *compile-object*)) (null)))))) @@ -481,6 +530,25 @@ (ir1-phases component) + (when *loop-analyze* + (dfo-as-needed component) + (find-dominators component) + (loop-analyze component)) + + #| + (when (and *loop-analyze* *compiler-trace-output*) + (labels ((print-blocks (block) + (format *compiler-trace-output* " ~A~%" block) + (when (block-loop-next block) + (print-blocks (block-loop-next block)))) + (print-loop (loop) + (format *compiler-trace-output* "loop=~A~%" loop) + (print-blocks (loop-blocks loop)) + (dolist (l (loop-inferiors loop)) + (print-loop l)))) + (print-loop (component-outer-loop component)))) + |# + ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") (physenv-analyze component) @@ -572,13 +640,7 @@ (setq *tn-id* 0) (clrhash *label-ids*) (clrhash *id-labels*) - (setq *label-id* 0) - - ;; Clear some PACK data structures (for GC purposes only). - (aver (not *in-pack*)) - (dolist (sb *backend-sb-list*) - (when (finite-sb-p sb) - (fill (finite-sb-live-tns sb) nil)))) + (setq *label-id* 0)) ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here. ;; Superficially, this seemed harmful -- the user could reasonably be @@ -597,7 +659,7 @@ (defun describe-component (component *standard-output*) (declare (type component component)) (format t "~|~%;;;; component: ~S~2%" (component-name component)) - (print-blocks component) + (print-all-blocks component) (values)) (defun describe-ir2-component (component *standard-output*) @@ -607,7 +669,7 @@ (format t "~4TL~D: ~S~:[~; [closure]~]~%" (label-id (entry-info-offset entry)) (entry-info-name entry) - (entry-info-closure-p entry))) + (entry-info-closure-tn entry))) (terpri) (pre-pack-tn-stats component *standard-output*) (terpri) @@ -627,10 +689,12 @@ ;;; A FILE-INFO structure holds all the source information for a ;;; given file. -(defstruct (file-info (:copier nil)) +(def!struct (file-info (:copier nil)) ;; If a file, the truename of the corresponding source file. If from ;; a Lisp form, :LISP. If from a stream, :STREAM. (name (missing-arg) :type (or pathname (member :lisp :stream))) + ;; the external format that we'll call OPEN with, if NAME is a file. + (external-format nil) ;; the defaulted, but not necessarily absolute file name (i.e. prior ;; to TRUENAME call.) Null if not a file. This is used to set ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the @@ -650,11 +714,11 @@ ;;; The SOURCE-INFO structure provides a handle on all the source ;;; information for an entire compilation. -(defstruct (source-info - #-no-ansi-print-object - (:print-object (lambda (s stream) - (print-unreadable-object (s stream :type t)))) - (:copier nil)) +(def!struct (source-info + #-no-ansi-print-object + (:print-object (lambda (s stream) + (print-unreadable-object (s stream :type t)))) + (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) ;; the FILE-INFO structure for this compilation @@ -664,9 +728,10 @@ (stream nil :type (or stream null))) ;;; Given a pathname, return a SOURCE-INFO structure. -(defun make-file-source-info (file) +(defun make-file-source-info (file external-format) (let ((file-info (make-file-info :name (truename file) :untruename file + :external-format external-format :write-date (file-write-date file)))) (make-source-info :file-info file-info))) @@ -693,7 +758,7 @@ (handler-case (read stream nil stream) (reader-error (condition) (error 'input-error-in-compile-file - :error condition + :condition condition ;; We don't need to supply :POSITION here because ;; READER-ERRORs already know their position in the file. )) @@ -702,7 +767,7 @@ ;; file in the middle of something it's trying to read. (end-of-file (condition) (error 'input-error-in-compile-file - :error condition + :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. @@ -723,10 +788,13 @@ (declare (type source-info info)) (or (source-info-stream info) (let* ((file-info (source-info-file-info info)) - (name (file-info-name file-info))) + (name (file-info-name file-info)) + (external-format (file-info-external-format file-info))) (setf sb!xc:*compile-file-truename* name sb!xc:*compile-file-pathname* (file-info-untruename file-info) - (source-info-stream info) (open name :direction :input))))) + (source-info-stream info) + (open name :direction :input + :external-format external-format))))) ;;; Close the stream in INFO if it is open. (defun close-source-info (info) @@ -771,7 +839,9 @@ ;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ((*lexenv* (make-lexenv :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (tll (ir1-toplevel form path nil))) (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*)) (t (compile-toplevel (list tll) nil))))) @@ -801,9 +871,11 @@ ;;; We parse declarations and then recursively process the body. (defun process-toplevel-locally (body path compile-time-too &key vars funs) (declare (list path)) - (multiple-value-bind (forms decls) (parse-body body nil) - (let* ((*lexenv* - (process-decls decls vars funs (make-continuation))) + (multiple-value-bind (forms decls) + (parse-body body :doc-string-allowed nil :toplevel t) + (let* ((*lexenv* (process-decls decls vars funs)) + ;; FIXME: VALUES declaration + ;; ;; Binding *POLICY* is pretty much of a hack, since it ;; causes LOCALLY to "capture" enclosed proclamations. It ;; is necessary because CONVERT-AND-MAYBE-COMPILE uses the @@ -814,7 +886,11 @@ ;; FIXME: Ideally, something should be done so that DECLAIM ;; inside LOCALLY works OK. Failing that, at least we could ;; issue a warning instead of silently screwing up. - (*policy* (lexenv-policy *lexenv*))) + (*policy* (lexenv-policy *lexenv*)) + ;; This is probably also a hack + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))) (process-toplevel-progn forms path compile-time-too)))) ;;; Parse an EVAL-WHEN situations list, returning three flags, @@ -846,15 +922,16 @@ (etypecase f (clambda (list (lambda-component f))) (optional-dispatch (let ((result nil)) - (labels ((frob (clambda) - (pushnew (lambda-component clambda) - result)) - (maybe-frob (maybe-clambda) - (when maybe-clambda - (frob maybe-clambda)))) - (mapc #'frob (optional-dispatch-entry-points f)) + (flet ((maybe-frob (maybe-clambda) + (when (and maybe-clambda + (promise-ready-p maybe-clambda)) + (pushnew (lambda-component + (force maybe-clambda)) + result)))) + (map nil #'maybe-frob (optional-dispatch-entry-points f)) (maybe-frob (optional-dispatch-more-entry f)) - (maybe-frob (optional-dispatch-main-entry f))))))) + (maybe-frob (optional-dispatch-main-entry f))) + result)))) (defun make-functional-from-toplevel-lambda (definition &key @@ -870,10 +947,11 @@ (setf (component-name component) (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) - (let* ((locall-fun (ir1-convert-lambda - definition - :debug-name (debug-namify "top level local call ~S" - name))) + (let* ((locall-fun (let ((*allow-instrumenting* t)) + (ir1-convert-lambdalike + definition + :debug-name (debug-namify "top level local call " + name)))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name @@ -907,7 +985,10 @@ '(original-source-start 0 0))) (when name (legal-fun-name-or-type-error name)) - (let* ((*lexenv* (make-lexenv :policy *policy*)) + (let* ( + (*lexenv* (make-lexenv :policy *policy* + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -921,18 +1002,12 @@ ;; whole FUNCTIONAL-KIND=:TOPLEVEL case could go away..) (locall-analyze-clambdas-until-done (list fun)) - + (multiple-value-bind (components-from-dfo top-components hairy-top) (find-initial-dfo (list fun)) + (declare (ignore hairy-top)) (let ((*all-components* (append components-from-dfo top-components))) - ;; FIXME: This is more monkey see monkey do based on CMU CL - ;; code. If anyone figures out why to only prescan HAIRY-TOP - ;; and TOP-COMPONENTS here, instead of *ALL-COMPONENTS* or - ;; some other combination of results from FIND-INITIAL-VALUES, - ;; it'd be good to explain it. - (mapc #'preallocate-physenvs-for-toplevelish-lambdas hairy-top) - (mapc #'preallocate-physenvs-for-toplevelish-lambdas top-components) (dolist (component-from-dfo components-from-dfo) (compile-component component-from-dfo) (replace-toplevel-xeps component-from-dfo))) @@ -1012,11 +1087,9 @@ (catch 'process-toplevel-form-error-abort (let* ((path (or (gethash form *source-paths*) (cons form path))) (*compiler-error-bailout* - (lambda () + (lambda (&optional condition) (convert-and-maybe-compile - `(error 'simple-program-error - :format-control "execution of a form compiled with errors:~% ~S" - :format-arguments (list ',form)) + (make-compiler-error-form condition form) path) (throw 'process-toplevel-form-error-abort nil)))) @@ -1130,19 +1203,23 @@ ((macrolet) (funcall-in-macrolet-lexenv magic - (lambda (&key funs) + (lambda (&key funs prepend) (declare (ignore funs)) + (aver (null prepend)) (process-toplevel-locally body path - compile-time-too)))) + compile-time-too)) + :compile)) ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic - (lambda (&key vars) + (lambda (&key vars prepend) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too - :vars vars))))))) + :vars vars)) + :compile))))) ((locally) (process-toplevel-locally (rest form) path compile-time-too)) ((progn) @@ -1295,56 +1372,103 @@ (setq *block-compile* nil) (setq *entry-points* nil))) +(defun handle-condition-p (condition) + (let ((lexenv + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) + (let ((muffles (lexenv-handled-conditions lexenv))) + (if (null muffles) ; common case + nil + (dolist (muffle muffles nil) + (destructuring-bind (typespec . restart-name) muffle + (when (and (typep condition typespec) + (find-restart restart-name condition)) + (return t)))))))) + +(defun handle-condition-handler (condition) + (let ((lexenv + (etypecase *compiler-error-context* + (node + (node-lexenv *compiler-error-context*)) + (compiler-error-context + (let ((lexenv (compiler-error-context-lexenv + *compiler-error-context*))) + (aver lexenv) + lexenv)) + (null *lexenv*)))) + (let ((muffles (lexenv-handled-conditions lexenv))) + (aver muffles) + (dolist (muffle muffles (bug "fell through")) + (destructuring-bind (typespec . restart-name) muffle + (when (typep condition typespec) + (awhen (find-restart restart-name condition) + (invoke-restart it)))))))) + ;;; Read all forms from INFO and compile them, with output to OBJECT. ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). (defun sub-compile-file (info) (declare (type source-info info)) - (let* ((*block-compile* *block-compile-arg*) - (*package* (sane-package)) - (*policy* *policy*) - (*lexenv* (make-null-lexenv)) - (*source-info* info) - (sb!xc:*compile-file-pathname* nil) - (sb!xc:*compile-file-truename* nil) - (*toplevel-lambdas* ()) - (*compiler-error-bailout* - (lambda () - (compiler-mumble "~2&; fatal error, aborting compilation~%") - (return-from sub-compile-file (values nil t t)))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - ;; 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*) - (*gensym-counter* 0)) + (let ((*package* (sane-package)) + (*readtable* *readtable*) + (sb!xc:*compile-file-pathname* nil) ; really bound in + (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE + + (*policy* *policy*) + (*handled-conditions* *handled-conditions*) + (*disabled-package-locks* *disabled-package-locks*) + (*lexenv* (make-null-lexenv)) + (*block-compile* *block-compile-arg*) + (*source-info* info) + (*toplevel-lambdas* ()) + (*fun-names-in-this-file* ()) + (*allow-instrumenting* nil) + (*compiler-error-bailout* + (lambda () + (compiler-mumble "~2&; fatal error, aborting compilation~%") + (return-from sub-compile-file (values nil t t)))) + (*current-path* nil) + (*last-source-context* nil) + (*last-original-source* nil) + (*last-source-form* nil) + (*last-format-string* nil) + (*last-format-args* nil) + (*last-message-count* 0) + ;; 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*) + (*gensym-counter* 0)) (handler-case - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (sub-sub-compile-file info) - - (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)) + (handler-bind (((satisfies handle-condition-p) #'handle-condition-handler)) + (with-compilation-values + (sb!xc:with-compilation-unit () + (clear-stuff) + + (sub-sub-compile-file info) + + (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))) ;; Some errors are sufficiently bewildering that we just fail ;; immediately, without trying to recover and compile more of ;; the input file. - (input-error-in-compile-file (condition) + (fatal-compiler-error (condition) + (signal condition) (format *error-output* - "~@" + "~@" condition) (values nil t t))))) @@ -1415,7 +1539,7 @@ #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning its filename. Besides the ANSI &KEY arguments :OUTPUT-FILE, :VERBOSE, - :PRINT, and :EXTERNAL-FORMAT,the following extensions are supported: + :PRINT, and :EXTERNAL-FORMAT, the following extensions are supported: :TRACE-FILE If given, internal data structures are dumped to the specified file, or if a value of T is given, to a file of *.trace type @@ -1434,17 +1558,15 @@ optimization values, and the :BLOCK-COMPILE argument will probably become deprecated." - (unless (eq external-format :default) - (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported.")) (let* ((fasl-output nil) (output-file-name nil) (compile-won nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later (input-pathname (verify-source-file input-file)) - (source-info (make-file-source-info input-pathname)) + (source-info (make-file-source-info input-pathname external-format)) (*compiler-trace-output* nil)) ; might be modified below - + (unwind-protect (progn (when output-file @@ -1597,11 +1719,9 @@ (throw 'pending-init circular-ref))) (multiple-value-bind (creation-form init-form) (handler-case - (sb!xc:make-load-form constant (make-null-lexenv)) + (sb!xc:make-load-form constant (make-null-lexenv)) (error (condition) - (compiler-error "(while making load form for ~S)~%~A" - constant - condition))) + (compiler-error condition))) (case creation-form (:sb-just-dump-it-normally (fasl-validate-structure constant *compile-object*)