X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=908270ffd8b8002ce3a4dacabd54b9bfef17c56d;hb=b5703d98da9ebfd688c87e14862ab4e26dc94d14;hp=90e02dbb57817f30f9b831b5bb307f7f293ed325;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 90e02db..908270f 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -13,20 +13,6 @@ (in-package "SB!C") -(defconstant sb!xc:call-arguments-limit most-positive-fixnum - #!+sb-doc - "The exclusive upper bound on the number of arguments which may be passed - to a function, including &REST args.") -(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum - #!+sb-doc - "The exclusive upper bound on the number of parameters which may be specifed - in a given lambda list. This is actually the limit on required and &OPTIONAL - parameters. With &KEY and &AUX you can get more.") -(defconstant sb!xc:multiple-values-limit most-positive-fixnum - #!+sb-doc - "The exclusive upper bound on the number of multiple VALUES that you can - return.") - ;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? (declaim (special *constants* *free-variables* *component-being-compiled* *code-vector* *next-location* *result-fixups* @@ -205,21 +191,19 @@ (if (symbolp x) (symbol-name x) (prin1-to-string x))))))) - (unless *converting-for-interpreter* - (dolist (undef undefs) - (let ((name (undefined-warning-name undef)) - (kind (undefined-warning-kind undef)) - (warnings (undefined-warning-warnings undef)) - (undefined-warning-count (undefined-warning-count undef))) - (dolist (*compiler-error-context* warnings) - (compiler-style-warning "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-warning - "~D more use~:P of undefined ~(~A~) ~S" - more kind name))))))) + (dolist (undef undefs) + (let ((name (undefined-warning-name undef)) + (kind (undefined-warning-kind undef)) + (warnings (undefined-warning-warnings undef)) + (undefined-warning-count (undefined-warning-count undef))) + (dolist (*compiler-error-context* warnings) + (compiler-style-warning "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-warning + "~D more use~:P of undefined ~(~A~) ~S" + more kind name)))))) (dolist (kind '(:variable :function :type)) (let ((summary (mapcar #'undefined-warning-name @@ -231,13 +215,12 @@ ~% ~{~<~% ~1:;~S~>~^ ~}" (cdr summary) kind summary))))))) - (unless (or *converting-for-interpreter* - (and (not abort-p) - (zerop *aborted-compilation-unit-count*) - (zerop *compiler-error-count*) - (zerop *compiler-warning-count*) - (zerop *compiler-style-warning-count*) - (zerop *compiler-note-count*))) + (unless (and (not abort-p) + (zerop *aborted-compilation-unit-count*) + (zerop *compiler-error-count*) + (zerop *compiler-warning-count*) + (zerop *compiler-style-warning-count*) + (zerop *compiler-note-count*)) (format *error-output* "~&") (pprint-logical-block (*error-output* nil :per-line-prefix "; ") (compiler-mumble "compilation unit ~:[finished~;aborted~]~ @@ -715,146 +698,76 @@ (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) - ;; a list of the FILE-INFO structures for this compilation - (files nil :type list) - ;; the tail of the FILES for the file we are currently reading - (current-file nil :type list) - ;; the stream that we are using to read the CURRENT-FILE, or NIL if + ;; the FILE-INFO structure for this compilation + (file-info nil :type (or file-info null)) + ;; the stream that we are using to read the FILE-INFO, or NIL if ;; no stream has been opened yet (stream nil :type (or stream null))) -;;; Given a list of pathnames, return a SOURCE-INFO structure. -(defun make-file-source-info (files) - (declare (list files)) - (let ((file-info - (mapcar (lambda (x) - (make-file-info :name (truename x) - :untruename x - :write-date (file-write-date x))) - files))) - - (make-source-info :files file-info - :current-file file-info))) - -;;; Return a SOURCE-INFO to describe the incremental compilation of -;;; FORM. Also used by SB!EVAL:INTERNAL-EVAL. -(defun make-lisp-source-info (form) - (make-source-info - :start-time (get-universal-time) - :files (list (make-file-info :name :lisp - :forms (vector form) - :positions '#(0))))) +;;; Given a pathname, return a SOURCE-INFO structure. +(defun make-file-source-info (file) + (let ((file-info (make-file-info :name (truename file) + :untruename file + :write-date (file-write-date file)))) -;;; Return a SOURCE-INFO which will read from Stream. -(defun make-stream-source-info (stream) - (let ((files (list (make-file-info :name :stream)))) - (make-source-info - :files files - :current-file files - :stream stream))) - -;;; Print an error message for a non-EOF error on STREAM. OLD-POS is a -;;; preceding file position that hopefully comes before the beginning -;;; of the line. Of course, this only works on streams that support -;;; the file-position operation. -(defun normal-read-error (stream old-pos condition) - (declare (type stream stream) (type unsigned-byte old-pos)) - (let ((pos (file-position stream))) - (file-position stream old-pos) - (let ((start old-pos)) - (loop - (let ((line (read-line stream nil)) - (end (file-position stream))) - (when (>= end pos) - ;; FIXME: READER-ERROR also prints the file position. Do we really - ;; need to try to give position information here? - (compiler-abort "read error at ~D:~% \"~A/\\~A\"~%~A" - pos - (string-left-trim " " - (subseq line 0 (- pos start))) - (subseq line (- pos start)) - condition) - (return)) - (setq start end))))) - (values)) + (make-source-info :file-info file-info))) -;;; Back STREAM up to the position Pos, then read a form with -;;; *READ-SUPPRESS* on, discarding the result. If an error happens -;;; during this read, then bail out using COMPILER-ERROR (fatal in -;;; this context). -(defun ignore-error-form (stream pos) - (declare (type stream stream) (type unsigned-byte pos)) - (file-position stream pos) - (handler-case (let ((*read-suppress* t)) - (read stream)) - (error (condition) - (declare (ignore condition)) - (compiler-error "unable to recover from read error")))) - -;;; Print an error message giving some context for an EOF error. We -;;; print the first line after POS that contains #\" or #\(, or -;;; lacking that, the first non-empty line. -(defun unexpected-eof-error (stream pos condition) - (declare (type stream stream) (type unsigned-byte pos)) - (let ((res nil)) - (file-position stream pos) - (loop - (let ((line (read-line stream nil nil))) - (unless line (return)) - (when (or (find #\" line) (find #\( line)) - (setq res line) - (return)) - (unless (or res (zerop (length line))) - (setq res line)))) - (compiler-abort "read error in form starting at ~D:~%~@[ \"~A\"~%~]~A" - pos - res - condition)) - (file-position stream (file-length stream)) - (values)) +;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. +(defun make-lisp-source-info (form) + (make-source-info :start-time (get-universal-time) + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)))) -;;; Read a form from STREAM, returning EOF at EOF. If a read error -;;; happens, then attempt to recover if possible, returning a proxy -;;; error form. -;;; -;;; FIXME: This seems like quite a lot of complexity, and it seems -;;; impossible to get it quite right. (E.g. the `(CERROR ..) form -;;; returned here won't do the right thing if it's not in a position -;;; for an executable form.) I think it might be better to just stop -;;; trying to recover from read errors, punting all this noise -;;; (including UNEXPECTED-EOF-ERROR and IGNORE-ERROR-FORM) and doing a -;;; COMPILER-ABORT instead. -(defun careful-read (stream eof pos) - (handler-case (read stream nil eof) - (error (condition) - (let ((new-pos (file-position stream))) - (cond ((= new-pos (file-length stream)) - (unexpected-eof-error stream pos condition)) - (t - (normal-read-error stream pos condition) - (ignore-error-form stream pos)))) - '(cerror "Skip this form." - "compile-time read error")))) +;;; Return a SOURCE-INFO which will read from STREAM. +(defun make-stream-source-info (stream) + (let ((file-info (make-file-info :name :stream))) + (make-source-info :file-info file-info + :stream stream))) + +;;; Return a form read from STREAM; or for EOF use the trick, +;;; popularized by Kent Pitman, of returning STREAM itself. If an +;;; error happens, then convert it to standard abort-the-compilation +;;; error condition (possibly recording some extra location +;;; information). +(defun read-for-compile-file (stream position) + (handler-case (read stream nil stream) + (reader-error (condition) + (error 'input-error-in-compile-file + :error condition + ;; We don't need to supply :POSITION here because + ;; READER-ERRORs already know their position in the file. + )) + ;; 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 + :error 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)))) ;;; If STREAM is present, return it, otherwise open a stream to the -;;; current file. There must be a current file. When we open a new -;;; file, we also reset *PACKAGE* and policy. This gives the effect of -;;; rebinding around each file. +;;; current file. There must be a current file. ;;; -;;; FIXME: Since we now do the standard ANSI thing of only one file -;;; per compile (unlike the CMU CL extended COMPILE-FILE) this code is -;;; becoming stale, and the remaining bits of it (and the related code -;;; in ADVANCE-SOURCE-FILE) can go away. +;;; FIXME: This is probably an unnecessarily roundabout way to do +;;; things now that we process a single file in COMPILE-FILE (unlike +;;; the old CMU CL code, which accepted multiple files). Also, the old +;;; comment said +;;; When we open a new file, we also reset *PACKAGE* and policy. +;;; This gives the effect of rebinding around each file. +;;; which doesn't seem to be true now. Check to make sure that if +;;; such rebinding is necessary, it's still done somewhere. (defun get-source-stream (info) (declare (type source-info info)) - (cond ((source-info-stream info)) - (t - (let* ((finfo (first (source-info-current-file info))) - (name (file-info-name finfo))) - (setq sb!xc:*compile-file-truename* name) - (setq sb!xc:*compile-file-pathname* (file-info-untruename finfo)) - (setf (source-info-stream info) - (open name :direction :input)))))) + (or (source-info-stream info) + (let* ((file-info (source-info-file-info info)) + (name (file-info-name 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))))) ;;; Close the stream in INFO if it is open. (defun close-source-info (info) @@ -864,59 +777,33 @@ (setf (source-info-stream info) nil) (values)) -;;; Advance INFO to the next source file. If there is no next source -;;; file, return NIL, otherwise T. -(defun advance-source-file (info) - (declare (type source-info info)) - (close-source-info info) - (let ((prev (pop (source-info-current-file info)))) - (if (source-info-current-file info) - (let ((current (first (source-info-current-file info)))) - (setf (file-info-source-root current) - (+ (file-info-source-root prev) - (length (file-info-forms prev)))) - t) - nil))) - -;;; Read the sources from the source files and process them. -(defun process-sources (info) - (let* ((file (first (source-info-current-file info))) +;;; Read and compile the source file. +(defun sub-sub-compile-file (info) + (let* ((file-info (source-info-file-info info)) (stream (get-source-stream info))) (loop (let* ((pos (file-position stream)) - (eof '(*eof*)) - (form (careful-read stream eof pos))) - (if (eq form eof) - (return) - (let* ((forms (file-info-forms file)) - (current-idx (+ (fill-pointer forms) - (file-info-source-root file)))) - (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file)) - (clrhash *source-paths*) - (find-source-paths form current-idx) - (process-top-level-form form - `(original-source-start 0 ,current-idx)))))) - (when (advance-source-file info) - (process-sources info)))) - -;;; Return the FILE-INFO describing the INDEX'th form. -(defun find-file-info (index info) - (declare (type index index) (type source-info info)) - (dolist (file (source-info-files info)) - (when (> (+ (length (file-info-forms file)) - (file-info-source-root file)) - index) - (return file)))) + (form (read-for-compile-file stream pos))) + (if (eq form stream) ; i.e., if EOF + (return) + (let* ((forms (file-info-forms file-info)) + (current-idx (+ (fill-pointer forms) + (file-info-source-root file-info)))) + (vector-push-extend form forms) + (vector-push-extend pos (file-info-positions file-info)) + (clrhash *source-paths*) + (find-source-paths form current-idx) + (process-top-level-form form + `(original-source-start 0 ,current-idx) + nil))))))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. (defun find-source-root (index info) - (declare (type source-info info) (type index index)) - (let* ((file (find-file-info index info)) - (idx (- index (file-info-source-root file)))) - (values (aref (file-info-forms file) idx) - (aref (file-info-positions file) idx)))) + (declare (type index index) (type source-info info)) + (let ((file-info (source-info-file-info info))) + (values (aref (file-info-forms file-info) index) + (aref (file-info-positions file-info) index)))) ;;;; top-level form processing @@ -931,14 +818,7 @@ (cond ((eq *block-compile* t) (push tll *top-level-lambdas*)) (t (compile-top-level (list tll) nil))))) -;;; Process a PROGN-like portion of a top-level form. Forms is a list of -;;; the forms, and Path is source path of the form they came out of. -(defun process-top-level-progn (forms path) - (declare (list forms) (list path)) - (dolist (form forms) - (process-top-level-form form path))) - -;;; Macroexpand form in the current environment with an error handler. +;;; Macroexpand FORM in the current environment with an error handler. ;;; We only expand one level, so that we retain all the intervening ;;; forms in the source path. (defun preprocessor-macroexpand (form) @@ -946,11 +826,20 @@ (error (condition) (compiler-error "(during macroexpansion)~%~A" condition)))) -;;; Process a top-level use of LOCALLY. We parse declarations and then -;;; recursively process the body. -(defun process-top-level-locally (form path) +;;; Process a PROGN-like portion of a top-level form. FORMS is a list of +;;; the forms, and PATH is the source path of the FORM they came out of. +;;; COMPILE-TIME-TOO is as in ANSI "3.2.3.1 Processing of Top Level Forms". +(defun process-top-level-progn (forms path compile-time-too) + (declare (list forms) (list path)) + (dolist (form forms) + (process-top-level-form form path compile-time-too))) + +;;; Process a top-level use of LOCALLY, or anything else (e.g. +;;; MACROLET) at top-level which has declarations and ordinary forms. +;;; We parse declarations and then recursively process the body. +(defun process-top-level-locally (body path compile-time-too) (declare (list path)) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil) + (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (let* ((*lexenv* (process-decls decls nil nil (make-continuation))) ;; Binding *POLICY* is pretty much of a hack, since it @@ -959,11 +848,12 @@ ;; value of *POLICY* as the policy. The need for this hack ;; is due to the quirk that there is no way to represent in ;; a POLICY that an optimize quality came from the default. + ;; ;; 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*))) - (process-top-level-progn forms path)))) + (process-top-level-progn forms path compile-time-too)))) ;;; Force any pending top-level forms to be compiled and dumped so ;;; that they will be evaluated in the correct package environment. @@ -980,67 +870,147 @@ (when eval (eval form)))) -(declaim (special *compiler-error-bailout*)) +;;; Parse an EVAL-WHEN situations list, returning three flags, +;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating +;;; the types of situations present in the list. +(defun parse-eval-when-situations (situations) + (when (or (not (listp situations)) + (set-difference situations + '(:compile-toplevel + compile + :load-toplevel + load + :execute + eval))) + (compiler-error "bad EVAL-WHEN situation list: ~S" situations)) + (let ((deprecated-names (intersection situations '(compile load eval)))) + (when deprecated-names + (style-warn "using deprecated EVAL-WHEN situation names~{ ~S~}" + deprecated-names))) + (values (intersection '(:compile-toplevel compile) + situations) + (intersection '(:load-toplevel load) situations) + (intersection '(:execute eval) situations))) ;;; Process a top-level FORM with the specified source PATH. ;;; * If this is a magic top-level form, then do stuff. ;;; * If this is a macro, then expand it. ;;; * Otherwise, just compile it. -(defun process-top-level-form (form path) +;;; +;;; COMPILE-TIME-TOO is as defined in ANSI +;;; "3.2.3.1 Processing of Top Level Forms". +(defun process-top-level-form (form path compile-time-too) (declare (list path)) (catch 'process-top-level-form-error-abort (let* ((path (or (gethash form *source-paths*) (cons form path))) (*compiler-error-bailout* - #'(lambda () - (convert-and-maybe-compile - `(error "execution of a form compiled with errors:~% ~S" - ',form) - path) - (throw 'process-top-level-form-error-abort nil)))) + (lambda () + (convert-and-maybe-compile + `(error "execution of a form compiled with errors:~% ~S" + ',form) + path) + (throw 'process-top-level-form-error-abort nil)))) + (if (atom form) + ;; (There are no EVAL-WHEN issues in the ATOM case until + ;; SBCL gets smart enough to handle global + ;; DEFINE-SYMBOL-MACRO.) (convert-and-maybe-compile form path) - (case (car form) - ;; FIXME: It's not clear to me why we would want this - ;; special case; it might have been needed for some - ;; variation of the old GENESIS system, but it certainly - ;; doesn't seem to be needed for ours. Sometime after the - ;; system is running I'd like to remove it tentatively and - ;; see whether anything breaks, and if nothing does break, - ;; remove it permanently. (And if we *do* want special - ;; treatment of all these, we probably want to treat WARN - ;; the same way..) - ((error cerror break signal) - (process-cold-load-form form path nil)) - ;; FIXME: ANSI seems to encourage things like DEFSTRUCT to - ;; be done with EVAL-WHEN, without this kind of one-off - ;; compiler magic. - (sb!kernel:%compiler-defstruct - (convert-and-maybe-compile form path) - (compile-top-level-lambdas () t)) - ((eval-when) - (unless (>= (length form) 2) - (compiler-error "EVAL-WHEN form is too short: ~S" form)) - (do-eval-when-stuff - (cadr form) (cddr form) - #'(lambda (forms) - (process-top-level-progn forms path)))) - ((macrolet) - (unless (>= (length form) 2) - (compiler-error "MACROLET form is too short: ~S" form)) - (do-macrolet-stuff - (cadr form) - #'(lambda () - (process-top-level-progn (cddr form) path)))) - (locally (process-top-level-locally form path)) - (progn (process-top-level-progn (cdr form) path)) - (t - (let* ((uform (uncross form)) - (exp (preprocessor-macroexpand uform))) - (if (eq exp uform) - (convert-and-maybe-compile uform path) - (process-top-level-form exp path)))))))) + (flet ((need-at-least-one-arg (form) + (unless (cdr form) + (compiler-error "~S form is too short: ~S" + (car form) + form)))) + (case (car form) + ;; FIXME: It's not clear to me why we would want this + ;; special case; it might have been needed for some + ;; variation of the old GENESIS system, but it certainly + ;; doesn't seem to be needed for ours. Sometime after the + ;; system is running I'd like to remove it tentatively and + ;; see whether anything breaks, and if nothing does break, + ;; remove it permanently. (And if we *do* want special + ;; treatment of all these, we probably want to treat WARN + ;; the same way..) + ((error cerror break signal) + (process-cold-load-form form path nil)) + ((eval-when macrolet symbol-macrolet);things w/ 1 arg before body + (need-at-least-one-arg form) + (destructuring-bind (special-operator magic &rest body) form + (ecase special-operator + ((eval-when) + ;; CT, LT, and E here are as in Figure 3-7 of ANSI + ;; "3.2.3.1 Processing of Top Level Forms". + (multiple-value-bind (ct lt e) + (parse-eval-when-situations magic) + (let ((new-compile-time-too (or ct + (and compile-time-too + e)))) + (cond (lt (process-top-level-progn + body path new-compile-time-too)) + (new-compile-time-too (eval + `(progn ,@body))))))) + ((macrolet) + (funcall-in-macrolet-lexenv + magic + (lambda () + (process-top-level-locally body + path + compile-time-too)))) + ((symbol-macrolet) + (funcall-in-symbol-macrolet-lexenv + magic + (lambda () + (process-top-level-locally body + path + compile-time-too))))))) + ((locally) + (process-top-level-locally (rest form) path compile-time-too)) + ((progn) + (process-top-level-progn (rest form) path compile-time-too)) + #+sb-xc-host + ;; Consider: What should we do when we hit e.g. + ;; (EVAL-WHEN (:COMPILE-TOPLEVEL) + ;; (DEFUN FOO (X) (+ 7 X)))? + ;; DEFUN has a macro definition in the cross-compiler, + ;; and a different macro definition in the target + ;; compiler. The only sensible thing is to use the + ;; target compiler's macro definition, since the + ;; cross-compiler's macro is in general into target + ;; functions which can't meaningfully be executed at + ;; cross-compilation time. So make sure we do the EVAL + ;; here, before we macroexpand. + ;; + ;; (Isn't it fun to cross-compile Common Lisp?:-) + (t + (when compile-time-too + (eval form)) ; letting xc host EVAL do its own macroexpansion + (let* ((uncrossed (uncross form)) + ;; letting our cross-compiler do its macroexpansion too + (expanded (preprocessor-macroexpand uncrossed))) + (if (eq expanded uncrossed) + (convert-and-maybe-compile expanded path) + ;; Note that we also have to demote + ;; COMPILE-TIME-TOO to NIL, no matter what it was + ;; before, since otherwise we'd tend to EVAL + ;; subforms more than once. + (process-top-level-form expanded path nil)))) + ;; When we're not cross-compiling, we only need to + ;; macroexpand once, so we can follow the 1-thru-6 + ;; sequence of steps in ANSI's "3.2.3.1 Processing of + ;; Top Level Forms". + #-sb-xc-host + (t + (let ((expanded (preprocessor-macroexpand form))) + (cond ((eq expanded form) + (when compile-time-too + (eval form)) + (convert-and-maybe-compile form path)) + (t + (process-top-level-form expanded + path + compile-time-too)))))))))) (values)) @@ -1048,11 +1018,10 @@ ;;;; ;;;; (See EMIT-MAKE-LOAD-FORM.) -;;; Returns T iff we are currently producing a fasl file and hence +;;; Return T if we are currently producing a fasl file and hence ;;; constants need to be dumped carefully. (defun producing-fasl-file () - (unless *converting-for-interpreter* - (fasl-output-p *compile-object*))) + (fasl-output-p *compile-object*)) ;;; Compile FORM and arrange for it to be called at load-time. Return ;;; the dumper handle and our best guess at the type of the object. @@ -1172,12 +1141,12 @@ (declare (list lambdas)) (let ((len (length lambdas))) (flet ((loser (start) - (or (position-if #'(lambda (x) - (not (eq (component-kind - (block-component - (node-block - (lambda-bind x)))) - :top-level))) + (or (position-if (lambda (x) + (not (eq (component-kind + (block-component + (node-block + (lambda-bind x)))) + :top-level))) lambdas :start start) len))) @@ -1259,7 +1228,7 @@ ;;; Read all forms from INFO and compile them, with output to OBJECT. ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). -(defun sub-compile-file (info &optional d-s-info) +(defun sub-compile-file (info) (declare (type source-info info)) (let* (;; These are bound in WITH-COMPILATION-UNIT now. -- WHN 20000308 #+nil (*compiler-error-count* 0) @@ -1270,7 +1239,6 @@ (*package* (sane-package)) (*policy* *policy*) (*lexenv* (make-null-lexenv)) - (*converting-for-interpreter* nil) (*source-info* info) (sb!xc:*compile-file-pathname* nil) (sb!xc:*compile-file-truename* nil) @@ -1287,30 +1255,41 @@ (*last-format-string* nil) (*last-format-args* nil) (*last-message-count* 0) - (*info-environment* (or *backend-info-environment* - *info-environment*)) + ;; 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)) - (with-compilation-values - (sb!xc:with-compilation-unit () - (clear-stuff) - - (process-sources info) - - (finish-block-compilation) - (compile-top-level-lambdas () t) - (let ((object *compile-object*)) - (etypecase object - (fasl-output (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object d-s-info)) - (null))) - nil)))) - -;;; Return a list of pathnames for the named files. All the files must -;;; exist. -(defun verify-source-files (stuff) - (let* ((stuff (if (listp stuff) stuff (list stuff))) - (default-host (make-pathname - :host (pathname-host (pathname (first stuff)))))) + (handler-case + (with-compilation-values + (sb!xc:with-compilation-unit () + (clear-stuff) + + (sub-sub-compile-file info) + + (finish-block-compilation) + (compile-top-level-lambdas () t) + (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) + (format *error-output* + "~@" + condition) + (values nil t t))))) + +;;; Return a pathname for the named file. The file must exist. +(defun verify-source-file (pathname-designator) + (let* ((pathname (pathname pathname-designator)) + (default-host (make-pathname :host (pathname-host pathname)))) (flet ((try-with-type (path type error-p) (let ((new (merge-pathnames path (make-pathname :type type @@ -1318,16 +1297,11 @@ (if (probe-file new) new (and error-p (truename new)))))) - (unless stuff - (error "can't compile with no source files")) - (mapcar #'(lambda (x) - (let ((x (pathname x))) - (cond ((typep x 'logical-pathname) - (try-with-type x "LISP" t)) - ((probe-file x) x) - ((try-with-type x "lisp" nil)) - ((try-with-type x "lisp" t))))) - stuff)))) + (cond ((typep pathname 'logical-pathname) + (try-with-type pathname "LISP" t)) + ((probe-file pathname) pathname) + ((try-with-type pathname "lisp" nil)) + ((try-with-type pathname "lisp" t)))))) (defun elapsed-time-to-string (tsec) (multiple-value-bind (tmin sec) (truncate tsec 60) @@ -1337,16 +1311,16 @@ ;;; Print some junk at the beginning and end of compilation. (defun start-error-output (source-info) (declare (type source-info source-info)) - (dolist (x (source-info-files source-info)) + (let ((file-info (source-info-file-info source-info))) (compiler-mumble "~&; compiling file ~S (written ~A):~%" - (namestring (file-info-name x)) + (namestring (file-info-name file-info)) (sb!int:format-universal-time nil - (file-info-write-date x) + (file-info-write-date + file-info) :style :government :print-weekday nil :print-timezone nil))) (values)) - (defun finish-error-output (source-info won) (declare (type source-info source-info)) (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" @@ -1414,15 +1388,8 @@ (compile-won nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later - ;; KLUDGE: The listifying and unlistifying in the stuff - ;; related to VERIFY-SOURCE-FILES below is to interface to - ;; old CMU CL code which accepted and returned lists of - ;; multiple source files. It would be cleaner to redo - ;; VERIFY-SOURCE-FILES as VERIFY-SOURCE-FILE, accepting a - ;; single source file, and do a similar transformation on - ;; MAKE-FILE-SOURCE-INFO too. -- WHN 20000201 - (input-pathname (first (verify-source-files (list input-file)))) - (source-info (make-file-source-info (list input-pathname))) + (input-pathname (verify-source-file input-file)) + (source-info (make-file-source-info input-pathname)) (*compiler-trace-output* nil)) ; might be modified below (unwind-protect @@ -1441,8 +1408,8 @@ (trace-file-pathname (if (eql trace-file t) default-trace-file-pathname - (make-pathname trace-file - default-trace-file-pathname)))) + (merge-pathnames trace-file + default-trace-file-pathname)))) (setf *compiler-trace-output* (open trace-file-pathname :if-exists :supersede