X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fmain.lisp;h=5fb8f4d309f14897e766398be8c77f824ba20e40;hb=82e0a78df47685519b12683f495d7ae19e07d3cf;hp=a28f61ffc4e8666dc560a258b2c92da612689bdb;hpb=e02c32bd4d07a7d30c9a9d78be54f1f9f84f9877;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index a28f61f..5fb8f4d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -103,8 +103,8 @@ ;;; the values of *PACKAGE* and policy when compilation started (defvar *initial-package*) -(defvar *initial-cookie*) -(defvar *initial-interface-cookie*) +(defvar *initial-policy*) +(defvar *initial-interface-policy*) ;;; The source-info structure for the current compilation. This is null ;;; globally to indicate that we aren't currently in any identifiable @@ -122,7 +122,9 @@ ;;; Mumble conditional on *COMPILE-PROGRESS*. (defun maybe-mumble (&rest foo) (when *compile-progress* - (apply #'compiler-mumble foo))) + (compiler-mumble "~&") + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (apply #'compiler-mumble foo)))) (deftype object () '(or fasl-file core-object null)) @@ -225,19 +227,21 @@ (zerop *compiler-warning-count*) (zerop *compiler-style-warning-count*) (zerop *compiler-note-count*))) - (compiler-mumble - "~2&compilation unit ~:[finished~;aborted~]~ - ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D ERROR condition~:P~]~ - ~[~:;~:*~& caught ~D WARNING condition~:P~]~ - ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ - ~[~:;~:*~& printed ~D note~:P~]~2%" - abort-p - *aborted-compilation-unit-count* - *compiler-error-count* - *compiler-warning-count* - *compiler-style-warning-count* - *compiler-note-count*))) + (format *error-output* "~&") + (pprint-logical-block (*error-output* nil :per-line-prefix "; ") + (compiler-mumble "compilation unit ~:[finished~;aborted~]~ + ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~ + ~[~:;~:*~& caught ~D ERROR condition~:P~]~ + ~[~:;~:*~& caught ~D WARNING condition~:P~]~ + ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~ + ~[~:;~:*~& printed ~D note~:P~]" + abort-p + *aborted-compilation-unit-count* + *compiler-error-count* + *compiler-warning-count* + *compiler-style-warning-count* + *compiler-note-count*))) + (format *error-output* "~&")) ;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P ;;; FAILURE-P), where BODY-VALUE is the first value of the body, and @@ -380,7 +384,7 @@ (entry-analyze component) (ir2-convert component) - (when (policy nil (>= speed cspeed)) + (when (policy nil (>= speed compilation-speed)) (maybe-mumble "copy ") (copy-propagate component)) @@ -459,13 +463,14 @@ (defun byte-compiling () (if (eq *byte-compiling* :maybe) (or (eq *byte-compile* t) - (policy nil (zerop speed) (<= debug 1))) + (policy nil (and (zerop speed) (<= debug 1)))) (and *byte-compile* *byte-compiling*))) ;;; Delete components with no external entry points before we try to -;;; generate code. Unreachable closures can cause IR2 conversion to puke on -;;; itself, since it is the reference to the closure which normally causes the -;;; components to be combined. This doesn't really cover all cases... +;;; generate code. Unreachable closures can cause IR2 conversion to +;;; puke on itself, since it is the reference to the closure which +;;; normally causes the components to be combined. This doesn't really +;;; cover all cases... (defun delete-if-no-entries (component) (dolist (fun (component-lambdas component) (delete-component component)) @@ -487,11 +492,11 @@ (:maybe (dolist (fun (component-lambdas component) t) (unless (policy (lambda-bind fun) - (zerop speed) (<= debug 1)) + (and (zerop speed) (<= debug 1))) (return nil))))))) (when sb!xc:*compile-print* - (compiler-mumble "~&~:[~;byte ~]compiling ~A: " + (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " *byte-compiling* (component-name component))) @@ -643,26 +648,26 @@ ;;;; Source-Info structure. The bookkeeping is done as a side-effect ;;;; of getting the next source form. -;;; The File-Info structure holds all the source information for a +;;; A FILE-INFO structure holds all the source information for a ;;; given file. (defstruct file-info - ;; If a file, the truename of the corresponding source file. If from a Lisp - ;; form, :LISP, if from a stream, :STREAM. + ;; If a file, the truename of the corresponding source file. If from + ;; a Lisp form, :LISP. If from a stream, :STREAM. (name (required-argument) :type (or pathname (member :lisp :stream))) - ;; 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 debug-info. + ;; 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 + ;; debug-info. (untruename nil :type (or pathname null)) - ;; The file's write date (if relevant.) + ;; the file's write date (if relevant) (write-date nil :type (or unsigned-byte null)) - ;; This file's FILE-COMMENT, or NIL if none. - (comment nil :type (or simple-string null)) - ;; The source path root number of the first form in this file (i.e. the - ;; total number of forms converted previously in this compilation.) + ;; the source path root number of the first form in this file (i.e. + ;; the total number of forms converted previously in this + ;; compilation) (source-root 0 :type unsigned-byte) - ;; Parallel vectors containing the forms read out of the file and the file - ;; positions that reading of each form started at (i.e. the end of the - ;; previous form.) + ;; parallel vectors containing the forms read out of the file and + ;; the file positions that reading of each form started at (i.e. the + ;; end of the previous form) (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)) (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))) @@ -795,7 +800,7 @@ '(cerror "Skip this form." "compile-time read error")))) -;;; If Stream is present, return it, otherwise open a stream to the +;;; 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. @@ -807,10 +812,9 @@ (declare (type source-info info)) (cond ((source-info-stream info)) (t - (setq *package* *initial-package*) - (setq *default-cookie* (copy-cookie *initial-cookie*)) - (setq *default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) + (setf *package* *initial-package* + *default-policy* *initial-policy* + *default-interface-policy* *initial-interface-policy*) (let* ((finfo (first (source-info-current-file info))) (name (file-info-name finfo))) (setq sb!xc:*compile-file-truename* name) @@ -888,8 +892,8 @@ ;;; *TOP-LEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) - (let* ((*lexenv* (make-lexenv :cookie *default-cookie* - :interface-cookie *default-interface-cookie*)) + (let* ((*lexenv* (make-lexenv :policy *default-policy* + :interface-policy *default-interface-policy*)) (tll (ir1-top-level form path nil))) (cond ((eq *block-compile* t) (push tll *top-level-lambdas*)) (t (compile-top-level (list tll) nil))))) @@ -912,38 +916,28 @@ ;;; Process a top-level use of LOCALLY. We parse declarations and then ;;; recursively process the body. ;;; -;;; Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it +;;; Binding *DEFAULT-xxx-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 value of -;;; *DEFAULT-COOKIE* as the policy. The need for this hack is due to -;;; the quirk that there is no way to represent in a cookie that an +;;; *DEFAULT-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. (defun process-top-level-locally (form path) (declare (list path)) (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil) (let* ((*lexenv* (process-decls decls nil nil (make-continuation))) - (*default-cookie* (lexenv-cookie *lexenv*)) - (*default-interface-cookie* (lexenv-interface-cookie *lexenv*))) + (*default-policy* (lexenv-policy *lexenv*)) + (*default-interface-policy* (lexenv-interface-policy *lexenv*))) (process-top-level-progn forms path)))) -;;; Stash file comment in the FILE-INFO structure. -(defun process-file-comment (form) - (unless (and (proper-list-of-length-p form 2) - (stringp (second form))) - (compiler-error "bad FILE-COMMENT form: ~S" form)) - (let ((file (first (source-info-current-file *source-info*)))) - (cond ((file-info-comment file) - (compiler-warning "ignoring extra file comment:~% ~S" form)) - (t - (let ((comment (coerce (second form) 'simple-string))) - (setf (file-info-comment file) comment) - (when sb!xc:*compile-verbose* - (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment))))))) - -;;; Force any pending top-level forms to be compiled and dumped so that they -;;; will be evaluated in the correct package environment. Dump the form to be -;;; evaled at (cold) load time, and if EVAL is true, eval the form immediately. +;;; Force any pending top-level forms to be compiled and dumped so +;;; that they will be evaluated in the correct package environment. +;;; Dump the form to be evaled at (cold) load time, and if EVAL is +;;; true, eval the form immediately. (defun process-cold-load-form (form path eval) (let ((object *compile-object*)) (etypecase object @@ -1010,7 +1004,6 @@ (process-top-level-progn (cddr form) path)))) (locally (process-top-level-locally form path)) (progn (process-top-level-progn (cdr form) path)) - (file-comment (process-file-comment form)) (t (let* ((uform (uncross form)) (exp (preprocessor-macroexpand uform))) @@ -1362,13 +1355,12 @@ #+nil (*compiler-style-warning-count* 0) #+nil (*compiler-note-count* 0) (*block-compile* *block-compile-argument*) - (*package* *package*) - (*initial-package* *package*) - (*initial-cookie* *default-cookie*) - (*initial-interface-cookie* *default-interface-cookie*) - (*default-cookie* (copy-cookie *initial-cookie*)) - (*default-interface-cookie* - (copy-cookie *initial-interface-cookie*)) + (*package* (sane-package)) + (*initial-package* (sane-package)) + (*initial-policy* *default-policy*) + (*initial-interface-policy* *default-interface-policy*) + (*default-policy* *initial-policy*) + (*default-interface-policy* *initial-interface-policy*) (*lexenv* (make-null-lexenv)) (*converting-for-interpreter* nil) (*source-info* info) @@ -1377,10 +1369,9 @@ (*top-level-lambdas* ()) (*pending-top-level-lambdas* ()) (*compiler-error-bailout* - #'(lambda () - (compiler-mumble - "~2&fatal error, aborting compilation~%") - (return-from sub-compile-file (values nil t t)))) + (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) @@ -1439,18 +1430,18 @@ (defun start-error-output (source-info) (declare (type source-info source-info)) (dolist (x (source-info-files source-info)) - (compiler-mumble "compiling file ~S (written ~A):~%" + (compiler-mumble "~&; compiling file ~S (written ~A):~%" (namestring (file-info-name x)) (sb!int:format-universal-time nil (file-info-write-date x) :style :government :print-weekday nil :print-timezone nil))) - (compiler-mumble "~%") (values)) + (defun finish-error-output (source-info won) (declare (type source-info source-info)) - (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&" + (compiler-mumble "~&; compilation ~:[aborted after~;finished in~] ~A~&" won (elapsed-time-to-string (- (get-universal-time) @@ -1461,9 +1452,9 @@ ;;; out of the compile, then abort the writing of the output file, so ;;; we don't overwrite it with known garbage. (defun sb!xc:compile-file - (source + (input-file &key - (output-file t) ; FIXME: ANSI says this should be a pathname designator. + (output-file (cfp-output-file-default input-file)) ;; FIXME: ANSI doesn't seem to say anything about ;; *COMPILE-VERBOSE* and *COMPILE-PRINT* being rebound by this ;; function.. @@ -1474,9 +1465,9 @@ ((:entry-points *entry-points*) nil) ((:byte-compile *byte-compile*) *byte-compile-default*)) #!+sb-doc - "Compile SOURCE, producing a corresponding FASL file. + "Compile INPUT-FILE, producing a corresponding fasl file. :Output-File - The name of the fasl to output, NIL for none, T for the default. + The name of the fasl to output. :Block-Compile Determines whether multiple functions are compiled together as a unit, resolving function references at compile time. NIL means that global @@ -1499,7 +1490,6 @@ (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 next calls ;; is to interface to old CMU CL code which accepted and ;; returned lists of multiple source files. It would be @@ -1507,18 +1497,17 @@ ;; VERIFY-SOURCE-FILE, accepting a single source file, and ;; do a similar transformation on MAKE-FILE-SOURCE-INFO too. ;; -- WHN 20000201 - (source (first (verify-source-files (list source)))) - (source-info (make-file-source-info (list source)))) + (input-pathname (first (verify-source-files (list input-file)))) + (source-info (make-file-source-info (list input-pathname)))) (unwind-protect (progn (when output-file (setq output-file-name - (sb!xc:compile-file-pathname source - :output-file output-file - :byte-compile *byte-compile*)) + (sb!xc:compile-file-pathname input-file + :output-file output-file)) (setq fasl-file (open-fasl-file output-file-name - (namestring source) + (namestring input-pathname) (eq *byte-compile* t)))) (when sb!xc:*compile-verbose* @@ -1535,7 +1524,7 @@ (close-fasl-file fasl-file (not compile-won)) (setq output-file-name (pathname (fasl-file-stream fasl-file))) (when (and compile-won sb!xc:*compile-verbose*) - (compiler-mumble "~2&~A written~%" (namestring output-file-name)))) + (compiler-mumble "~2&; ~A written~%" (namestring output-file-name)))) (when sb!xc:*compile-verbose* (finish-error-output source-info compile-won))) @@ -1547,22 +1536,36 @@ warnings-p failure-p))) -(defun sb!xc:compile-file-pathname (file-path - &key (output-file t) byte-compile +;;; a helper function for COMPILE-FILE-PATHNAME: the default for +;;; the OUTPUT-FILE argument +;;; +;;; ANSI: The defaults for the OUTPUT-FILE are taken from the pathname +;;; that results from merging the INPUT-FILE with the value of +;;; *DEFAULT-PATHNAME-DEFAULTS*, except that the type component should +;;; default to the appropriate implementation-defined default type for +;;; compiled files. +(defun cfp-output-file-default (input-file) + (let* ((defaults (merge-pathnames input-file + *default-pathname-defaults*)) + (retyped (make-pathname :type *backend-fasl-file-type* + :defaults defaults))) + retyped)) + +;;; KLUDGE: Part of the ANSI spec for this seems contradictory: +;;; If INPUT-FILE is a logical pathname and OUTPUT-FILE is unsupplied, +;;; the result is a logical pathname. If INPUT-FILE is a logical +;;; pathname, it is translated into a physical pathname as if by +;;; calling TRANSLATE-LOGICAL-PATHNAME. +;;; So I haven't really tried to make this precisely ANSI-compatible +;;; at the level of e.g. whether it returns logical pathname or a +;;; physical pathname. Patches to make it more correct are welcome. +;;; -- WHN 2000-12-09 +(defun sb!xc:compile-file-pathname (input-file + &key + (output-file (cfp-output-file-default + input-file)) &allow-other-keys) #!+sb-doc "Return a pathname describing what file COMPILE-FILE would write to given these arguments." - (declare (values (or null pathname))) - (let ((pathname (pathname file-path))) - (cond ((not (eq output-file t)) - (when output-file - (translate-logical-pathname (pathname output-file)))) - ((and (typep pathname 'logical-pathname) (not (eq byte-compile t))) - (make-pathname :type "FASL" :defaults pathname - :case :common)) - (t - (make-pathname :defaults (translate-logical-pathname pathname) - :type (if (eq byte-compile t) - (backend-byte-fasl-file-type) - *backend-fasl-file-type*)))))) + (pathname output-file))