X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmain.lisp;h=17a2539e421192bcb623df0cabada4bc26255cd5;hb=b05f52060838600d14b5d8ad4604a61351dd7017;hp=d5ce1d971073b01af453c448389135d60dfc6a58;hpb=b33fd6859bbe71667bf9d8a6dbcaf62464bfbee5;p=sbcl.git diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d5ce1d9..17a2539 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1,4 +1,4 @@ -;;;; the top-level interfaces to the compiler, plus some other +;;;; the top level interfaces to the compiler, plus some other ;;;; compiler-related stuff (e.g. CL:CALL-ARGUMENTS-LIMIT) which ;;;; doesn't obviously belong anywhere else @@ -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* @@ -44,29 +30,6 @@ *last-source-form* *last-format-string* *last-format-args* *last-message-count* *lexenv*)) -(defvar *byte-compile-default* :maybe - #!+sb-doc - "the default value for the :BYTE-COMPILE argument to COMPILE-FILE") - -(defvar *byte-compile-top-level* - #-sb-xc-host t - #+sb-xc-host nil ; since the byte compiler isn't supported in cross-compiler - #!+sb-doc - "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level - forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE - (the default.) When true, we decide to byte-compile.") - -;;; the value of the :BYTE-COMPILE argument which was passed to the -;;; compiler -(defvar *byte-compile* :maybe) - -;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when -;;; native compiling. During IR1 conversion this can also be :MAYBE, -;;; in which case we must look at the policy, see (byte-compiling). -(defvar *byte-compiling* :maybe) -(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling* - *byte-compile-default*)) - (defvar *check-consistency* nil) (defvar *all-components*) @@ -87,10 +50,10 @@ (defvar *entry-points*) (declaim (list *entry-points*)) -;;; When block compiling, used by PROCESS-FORM to accumulate top-level +;;; When block compiling, used by PROCESS-FORM to accumulate top level ;;; lambdas resulting from compiling subforms. (In reverse order.) -(defvar *top-level-lambdas*) -(declaim (list *top-level-lambdas*)) +(defvar *toplevel-lambdas*) +(declaim (list *toplevel-lambdas*)) (defvar sb!xc:*compile-verbose* t #!+sb-doc @@ -205,21 +168,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 + "~W more use~:P of undefined ~(~A~) ~S" + more kind name)))))) (dolist (kind '(:variable :function :type)) (let ((summary (mapcar #'undefined-warning-name @@ -231,21 +192,20 @@ ~% ~{~<~% ~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~]~ - ~[~:;~:*~& 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~]" + ~[~:;~:*~& caught ~W fatal ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W ERROR condition~:P~]~ + ~[~:;~:*~& caught ~W WARNING condition~:P~]~ + ~[~:;~:*~& caught ~W STYLE-WARNING condition~:P~]~ + ~[~:;~:*~& printed ~W note~:P~]" abort-p *aborted-compilation-unit-count* *compiler-error-count* @@ -356,10 +316,10 @@ (declare (special *constraint-number* *delayed-ir1-transforms*)) (loop (ir1-optimize-until-done component) - (when (or (component-new-functions component) - (component-reanalyze-functions component)) + (when (or (component-new-funs component) + (component-reanalyze-funs component)) (maybe-mumble "locall ") - (local-call-analyze component)) + (locall-analyze-component component)) (dfo-as-needed component) (when *constraint-propagate* (maybe-mumble "constraint ") @@ -371,15 +331,15 @@ ;; confuse itself. (unless (and (or (component-reoptimize component) (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) + (component-new-funs component) + (component-reanalyze-funs component)) (< loop-count (- *reoptimize-after-type-check-max* 4))) (maybe-mumble "type ") (generate-type-checks component) (unless (or (component-reoptimize component) (component-reanalyze component) - (component-new-functions component) - (component-reanalyze-functions component)) + (component-new-funs component) + (component-reanalyze-funs component)) (return))) (when (>= loop-count *reoptimize-after-type-check-max*) (maybe-mumble "[reoptimize limit]") @@ -390,7 +350,7 @@ (ir1-finalize component) (values)) -(defun native-compile-component (component) +(defun %compile-component (component) (let ((*code-segment* nil) (*elsewhere* nil)) (maybe-mumble "GTN ") @@ -484,35 +444,16 @@ (values)) -(defun policy-byte-compile-p (thing) - (policy thing - (and (zerop speed) - (<= debug 1)))) - -;;; Return our best guess for whether we will byte compile code -;;; currently being IR1 converted. This is only a guess because the -;;; decision is made on a per-component basis. -;;; -;;; FIXME: This should be called something more mnemonic, e.g. -;;; PROBABLY-BYTE-COMPILING -(defun byte-compiling () - (if (eq *byte-compiling* :maybe) - (or (eq *byte-compile* t) - (policy-byte-compile-p *lexenv*)) - (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. -;;; -;;; FIXME: The original CMU CL comment said "This doesn't really cover -;;; all cases..." That's a little scary. (defun delete-if-no-entries (component) - (dolist (fun (component-lambdas component) - (delete-component component)) + (dolist (fun (component-lambdas component) (delete-component component)) + (when (functional-has-external-references-p fun) + (return)) (case (functional-kind fun) - (:top-level (return)) + (:toplevel (return)) (:external (unless (every (lambda (ref) (eq (block-component (node-block ref)) @@ -520,35 +461,23 @@ (leaf-refs fun)) (return)))))) -(defun byte-compile-this-component-p (component) - (ecase *byte-compile* - ((t) t) - ((nil) nil) - ((:maybe) - (every #'policy-byte-compile-p (component-lambdas component))))) - (defun compile-component (component) - (let* ((*component-being-compiled* component) - (*byte-compiling* (byte-compile-this-component-p component))) + (let* ((*component-being-compiled* component)) (when sb!xc:*compile-print* - (compiler-mumble "~&; ~:[~;byte ~]compiling ~A: " - *byte-compiling* - (component-name component))) + (compiler-mumble "~&; compiling ~A: " (component-name component))) (ir1-phases component) ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more? (maybe-mumble "env ") - (environment-analyze component) + (physenv-analyze component) (dfo-as-needed component) (delete-if-no-entries component) (unless (eq (block-next (component-head component)) (component-tail component)) - (if *byte-compiling* - (byte-compile-component component) - (native-compile-component component)))) + (%compile-component component))) (clear-constant-info) @@ -688,7 +617,7 @@ (defstruct (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 (required-argument) :type (or pathname (member :lisp :stream))) + (name (missing-arg) :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 @@ -715,48 +644,38 @@ (: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. +;;; 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)))) + + (make-source-info :file-info file-info))) + +;;; 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) - :files (list (make-file-info :name :lisp - :forms (vector form) - :positions '#(0))))) + (make-source-info :start-time (get-universal-time) + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)))) ;;; 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))) - -;;; Read a form 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). + (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) @@ -777,24 +696,24 @@ :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) @@ -804,99 +723,72 @@ (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)) (form (read-for-compile-file stream pos))) (if (eq form stream) ; i.e., if EOF (return) - (let* ((forms (file-info-forms file)) + (let* ((forms (file-info-forms file-info)) (current-idx (+ (fill-pointer forms) - (file-info-source-root file)))) + (file-info-source-root file-info)))) (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file)) - (clrhash *source-paths*) + (vector-push-extend pos (file-info-positions file-info)) (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. -;;; -;;; FIXME: This is unnecessarily general cruft now that we only read -;;; a single file in COMPILE-FILE. -(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)))) + (process-toplevel-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. -;;; -;;; FIXME: This is unnecessarily general cruft now that we only read -;;; a single file in COMPILE-FILE. (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 +;;;; processing of top level forms -;;; This is called by top-level form processing when we are ready to +;;; This is called by top level form processing when we are ready to ;;; actually compile something. If *BLOCK-COMPILE* is T, then we still ;;; convert the form, but delay compilation, pushing the result on -;;; *TOP-LEVEL-LAMBDAS* instead. +;;; *TOPLEVEL-LAMBDAS* instead. (defun convert-and-maybe-compile (form path) (declare (list path)) (let* ((*lexenv* (make-lexenv :policy *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))))) - -;;; 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))) + (tll (ir1-toplevel form path nil))) + (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*)) + (t (compile-toplevel (list tll) nil))))) -;;; 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) +(defun preprocessor-macroexpand-1 (form) (handler-case (sb!xc:macroexpand-1 form *lexenv*) (error (condition) - (compiler-error "(during macroexpansion)~%~A" condition)))) + (compiler-error "(during macroexpansion of ~A)~%~A" + (let ((*print-level* 1) + (*print-length* 2)) + (format nil "~S" form)) + condition)))) + +;;; 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-toplevel-progn (forms path compile-time-too) + (declare (list forms) (list path)) + (dolist (form forms) + (process-toplevel-form form path compile-time-too))) -;;; 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 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-toplevel-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 @@ -905,86 +797,297 @@ ;; 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-toplevel-progn forms path compile-time-too)))) + +;;; 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))) + + +;;; utilities for extracting COMPONENTs of FUNCTIONALs +(defun functional-components (f) + (declare (type functional f)) + (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)) + (maybe-frob (optional-dispatch-more-entry f)) + (maybe-frob (optional-dispatch-main-entry f))))))) + +(defun make-functional-from-toplevel-lambda (definition + &key + name + (path + ;; I'd thought NIL should + ;; work, but it doesn't. + ;; -- WHN 2001-09-20 + (missing-arg))) + (let* ((*current-path* path) + (component (make-empty-component)) + (*current-component* component)) + (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))) + (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) + :source-name (or name '.anonymous.) + :debug-name (unless name + "top level form")))) + (setf (functional-entry-fun fun) locall-fun + (functional-kind fun) :external + (functional-has-external-references-p fun) t) + fun))) + +;;; Compile LAMBDA-EXPRESSION into *COMPILE-OBJECT*, returning a +;;; description of the result. +;;; * If *COMPILE-OBJECT* is a CORE-OBJECT, then write the function +;;; into core and return the compiled FUNCTION value. +;;; * If *COMPILE-OBJECT* is a fasl file, then write the function +;;; into the fasl file and return a dump handle. +;;; +;;; If NAME is provided, then we try to use it as the name of the +;;; function for debugging/diagnostic information. +(defun %compile (lambda-expression + *compile-object* + &key + name + (path + ;; This magical idiom seems to be the appropriate + ;; path for compiling standalone LAMBDAs, judging + ;; from the CMU CL code and experiment, so it's a + ;; nice default for things where we don't have a + ;; real source path (as in e.g. inside CL:COMPILE). + '(original-source-start 0 0))) + (unless (or (null name) (legal-fun-name-p name)) + (error "not a legal function name: ~S" name)) + (let* ((*lexenv* (make-lexenv :policy *policy*)) + (fun (make-functional-from-toplevel-lambda lambda-expression + :name name + :path path))) + + ;; FIXME: The compile-it code from here on is sort of a + ;; twisted version of the code in COMPILE-TOPLEVEL. It'd be + ;; better to find a way to share the code there; or + ;; alternatively, to use this code to replace the code there. + ;; (The second alternative might be pretty easy if we used + ;; the :LOCALL-ONLY option to IR1-FOR-LAMBDA. Then maybe the + ;; 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)) + + (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))) + + (prog1 + (let ((entry-table (etypecase *compile-object* + (fasl-output (fasl-output-entry-table + *compile-object*)) + (core-object (core-object-entry-table + *compile-object*))))) + (multiple-value-bind (result found-p) + (gethash (leaf-info fun) entry-table) + (aver found-p) + result)) + (mapc #'clear-ir1-info components-from-dfo) + (clear-stuff))))) + +(defun process-toplevel-cold-fset (name lambda-expression path) + (unless (producing-fasl-file) + (error "can't COLD-FSET except in a fasl file")) + (unless (legal-fun-name-p name) + (error "not a legal function name: ~S" name)) + (fasl-dump-cold-fset name + (%compile lambda-expression + *compile-object* + :name name + :path path) + *compile-object*) + (values)) -;;; 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 - (fasl-output - (compile-top-level-lambdas () t) - (fasl-dump-cold-load-form form object)) - ((or null core-object) - (convert-and-maybe-compile form path))) - (when eval - (eval form)))) - -;;; Process a top-level FORM with the specified source PATH. -;;; * If this is a magic top-level form, then do stuff. +;;; 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-toplevel-form (form path compile-time-too) (declare (list path)) - (catch 'process-top-level-form-error-abort + (catch 'process-toplevel-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-toplevel-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) + ;; In the cross-compiler, top level COLD-FSET arranges + ;; for static linking at cold init time. + #+sb-xc-host + ((cold-fset) + (aver (not compile-time-too)) + (destructuring-bind (cold-fset fun-name lambda-expression) form + (declare (ignore cold-fset)) + (process-toplevel-cold-fset fun-name + lambda-expression + path))) + ((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-toplevel-progn + body path new-compile-time-too)) + (new-compile-time-too (eval + `(progn ,@body))))))) + ((macrolet) + (funcall-in-macrolet-lexenv + magic + (lambda () + (process-toplevel-locally body + path + compile-time-too)))) + ((symbol-macrolet) + (funcall-in-symbol-macrolet-lexenv + magic + (lambda () + (process-toplevel-locally body + path + compile-time-too))))))) + ((locally) + (process-toplevel-locally (rest form) path compile-time-too)) + ((progn) + (process-toplevel-progn (rest form) path compile-time-too)) + ;; When we're cross-compiling, 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. + ;; + ;; Then things get even dicier with something like + ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..) + ;; where we have to make sure that we don't uncross + ;; the SB!XC: prefix before we do EVAL, because otherwise + ;; we'd be trying to redefine the cross-compilation host's + ;; constants. + ;; + ;; (Isn't it fun to cross-compile Common Lisp?:-) + #+sb-xc-host + (t + (when compile-time-too + (eval form)) ; letting xc host EVAL do its own macroexpansion + (let* (;; (We uncross the operator name because things + ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE + ;; should be equivalent to their CL: counterparts + ;; when being compiled as target code. We leave + ;; the rest of the form uncrossed because macros + ;; might yet expand into EVAL-WHEN stuff, and + ;; things inside EVAL-WHEN can't be uncrossed + ;; until after we've EVALed them in the + ;; cross-compilation host.) + (slightly-uncrossed (cons (uncross (first form)) + (rest form))) + (expanded (preprocessor-macroexpand-1 + slightly-uncrossed))) + (if (eq expanded slightly-uncrossed) + ;; (Now that we're no longer processing toplevel + ;; forms, and hence no longer need to worry about + ;; EVAL-WHEN, we can uncross everything.) + (convert-and-maybe-compile expanded path) + ;; (We have to demote COMPILE-TIME-TOO to NIL + ;; here, no matter what it was before, since + ;; otherwise we'd tend to EVAL subforms more than + ;; once, because of WHEN COMPILE-TIME-TOO form + ;; above.) + (process-toplevel-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-1 form))) + (cond ((eq expanded form) + (when compile-time-too + (eval form)) + (convert-and-maybe-compile form path)) + (t + (process-toplevel-form expanded + path + compile-time-too)))))))))) (values)) @@ -992,11 +1095,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. @@ -1012,48 +1114,47 @@ (values (fasl-dump-load-time-value-lambda lambda *compile-object*) (let ((type (leaf-type lambda))) - (if (function-type-p type) - (single-value-type (function-type-returns type)) + (if (fun-type-p type) + (single-value-type (fun-type-returns type)) *wild-type*))))) ;;; Compile the FORMS and arrange for them to be called (for effect, ;;; not value) at load time. (defun compile-make-load-form-init-forms (forms name) (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil))) - (fasl-dump-top-level-lambda-call lambda *compile-object*))) + (fasl-dump-toplevel-lambda-call lambda *compile-object*))) ;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or ;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS. (defun compile-load-time-stuff (form name for-value) (with-ir1-namespace (let* ((*lexenv* (make-null-lexenv)) - (lambda (ir1-top-level form *current-path* for-value))) - (setf (leaf-name lambda) name) - (compile-top-level (list lambda) t) + (lambda (ir1-toplevel form *current-path* for-value))) + (compile-toplevel (list lambda) t) lambda))) -;;; Called by COMPILE-TOP-LEVEL when it was pased T for +;;; This is called by COMPILE-TOPLEVEL when it was passed T for ;;; LOAD-TIME-VALUE-P (which happens in COMPILE-LOAD-TIME-STUFF). We ;;; don't try to combine this component with anything else and frob -;;; the name. If not in a :TOP-LEVEL component, then don't bother +;;; the name. If not in a :TOPLEVEL component, then don't bother ;;; compiling, because it was merged with a run-time component. (defun compile-load-time-value-lambda (lambdas) (aver (null (cdr lambdas))) (let* ((lambda (car lambdas)) - (component (block-component (node-block (lambda-bind lambda))))) - (when (eq (component-kind component) :top-level) - (setf (component-name component) (leaf-name lambda)) + (component (lambda-component lambda))) + (when (eql (component-kind component) :toplevel) + (setf (component-name component) (leaf-debug-name lambda)) (compile-component component) (clear-ir1-info component)))) ;;;; COMPILE-FILE -;;; We build a list of top-level lambdas, and then periodically smash +;;; We build a list of top level lambdas, and then periodically smash ;;; them together into a single component and compile it. -(defvar *pending-top-level-lambdas*) +(defvar *pending-toplevel-lambdas*) -;;; The maximum number of top-level lambdas we put in a single -;;; top-level component. +;;; The maximum number of top level lambdas we put in a single +;;; top level component. ;;; ;;; CMU CL 18b used this nontrivially by default (setting it to 10) ;;; but consequently suffered from the inability to execute some @@ -1075,53 +1176,50 @@ ;;; GENESIS, which is desirable, since at least for SBCL version ;;; 0.6.7, this is the high water mark for memory usage during system ;;; construction. -(defparameter *top-level-lambda-max* 0) +(defparameter *toplevel-lambda-max* 0) -(defun object-call-top-level-lambda (tll) +(defun object-call-toplevel-lambda (tll) (declare (type functional tll)) (let ((object *compile-object*)) (etypecase object (fasl-output - (fasl-dump-top-level-lambda-call tll object)) + (fasl-dump-toplevel-lambda-call tll object)) (core-object - (core-call-top-level-lambda tll object)) + (core-call-toplevel-lambda tll object)) (null)))) ;;; Add LAMBDAS to the pending lambdas. If this leaves more than -;;; *TOP-LEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true, +;;; *TOPLEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true, ;;; then smash the lambdas into a single component, compile it, and ;;; call the resulting function. -(defun sub-compile-top-level-lambdas (lambdas force-p) +(defun sub-compile-toplevel-lambdas (lambdas force-p) (declare (list lambdas)) - (setq *pending-top-level-lambdas* - (append *pending-top-level-lambdas* lambdas)) - (let ((pending *pending-top-level-lambdas*)) + (setq *pending-toplevel-lambdas* + (append *pending-toplevel-lambdas* lambdas)) + (let ((pending *pending-toplevel-lambdas*)) (when (and pending - (or (> (length pending) *top-level-lambda-max*) + (or (> (length pending) *toplevel-lambda-max*) force-p)) - (multiple-value-bind (component tll) (merge-top-level-lambdas pending) - (setq *pending-top-level-lambdas* ()) - (let ((*byte-compile* (if (eq *byte-compile* :maybe) - *byte-compile-top-level* - *byte-compile*))) - (compile-component component)) + (multiple-value-bind (component tll) (merge-toplevel-lambdas pending) + (setq *pending-toplevel-lambdas* ()) + (compile-component component) (clear-ir1-info component) - (object-call-top-level-lambda tll)))) + (object-call-toplevel-lambda tll)))) (values)) -;;; Compile top-level code and call the top-level lambdas. We pick off -;;; top-level lambdas in non-top-level components here, calling -;;; SUB-c-t-l-l on each subsequence of normal top-level lambdas. -(defun compile-top-level-lambdas (lambdas force-p) +;;; Compile top level code and call the top level lambdas. We pick off +;;; top level lambdas in non-top-level components here, calling +;;; SUB-c-t-l-l on each subsequence of normal top level lambdas. +(defun compile-toplevel-lambdas (lambdas force-p) (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)))) + :toplevel))) lambdas :start start) len))) @@ -1129,65 +1227,51 @@ (loser (loser start) (loser start))) ((>= start len) (when force-p - (sub-compile-top-level-lambdas nil t))) - (sub-compile-top-level-lambdas (subseq lambdas start loser) - (or force-p (/= loser len))) + (sub-compile-toplevel-lambdas nil t))) + (sub-compile-toplevel-lambdas (subseq lambdas start loser) + (or force-p (/= loser len))) (unless (= loser len) - (object-call-top-level-lambda (elt lambdas loser)))))) + (object-call-toplevel-lambda (elt lambdas loser)))))) (values)) -;;; Compile LAMBDAS (a list of the lambdas for top-level forms) into -;;; the object file. We loop doing local call analysis until it -;;; converges, since a single pass might miss something due to -;;; components being joined by LET conversion. +;;; Compile LAMBDAS (a list of CLAMBDAs for top level forms) into the +;;; object file. ;;; ;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and ;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201 -(defun compile-top-level (lambdas load-time-value-p) +(defun compile-toplevel (lambdas load-time-value-p) (declare (list lambdas)) + (maybe-mumble "locall ") - (loop - (let ((did-something nil)) - (dolist (lambda lambdas) - (let* ((component (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (when (component-new-functions component) - (setq did-something t) - (local-call-analyze component)))) - (unless did-something (return)))) + (locall-analyze-clambdas-until-done lambdas) (maybe-mumble "IDFO ") (multiple-value-bind (components top-components hairy-top) (find-initial-dfo lambdas) (let ((*all-components* (append components top-components)) - (top-level-closure nil)) + (toplevel-closure nil)) (when *check-consistency* (maybe-mumble "[check]~%") (check-ir1-consistency *all-components*)) (dolist (component (append hairy-top top-components)) - (when (pre-environment-analyze-top-level component) - (setq top-level-closure t))) - - (let ((*byte-compile* - (if (and top-level-closure (eq *byte-compile* :maybe)) - nil - *byte-compile*))) - (dolist (component components) - (compile-component component) - (when (replace-top-level-xeps component) - (setq top-level-closure t))) + (when (pre-physenv-analyze-toplevel component) + (setq toplevel-closure t))) + + (dolist (component components) + (compile-component component) + (when (replace-toplevel-xeps component) + (setq toplevel-closure t))) - (when *check-consistency* - (maybe-mumble "[check]~%") - (check-ir1-consistency *all-components*)) + (when *check-consistency* + (maybe-mumble "[check]~%") + (check-ir1-consistency *all-components*)) - (if load-time-value-p - (compile-load-time-value-lambda lambdas) - (compile-top-level-lambdas lambdas top-level-closure))) + (if load-time-value-p + (compile-load-time-value-lambda lambdas) + (compile-toplevel-lambdas lambdas toplevel-closure)) - (dolist (component components) - (clear-ir1-info component)) + (mapc #'clear-ir1-info components) (clear-stuff))) (values)) @@ -1195,31 +1279,25 @@ ;;; compilation. (defun finish-block-compilation () (when *block-compile* - (when *top-level-lambdas* - (compile-top-level (nreverse *top-level-lambdas*) nil) - (setq *top-level-lambdas* ())) + (when *toplevel-lambdas* + (compile-toplevel (nreverse *toplevel-lambdas*) nil) + (setq *toplevel-lambdas* ())) (setq *block-compile* nil) (setq *entry-points* nil))) ;;; 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) - #+nil (*compiler-warning-count* 0) - #+nil (*compiler-style-warning-count* 0) - #+nil (*compiler-note-count* 0) - (*block-compile* *block-compile-argument*) + (let* ((*block-compile* *block-compile-argument*) (*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) - (*top-level-lambdas* ()) - (*pending-top-level-lambdas* ()) + (*toplevel-lambdas* ()) + (*pending-toplevel-lambdas* ()) (*compiler-error-bailout* (lambda () (compiler-mumble "~2&; fatal error, aborting compilation~%") @@ -1231,22 +1309,26 @@ (*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)) (handler-case (with-compilation-values (sb!xc:with-compilation-unit () (clear-stuff) - (process-sources info) + (sub-sub-compile-file info) (finish-block-compilation) - (compile-top-level-lambdas () t) + (compile-toplevel-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)) + (core-object (fix-core-source-info info object)) (null))) nil)) ;; Some errors are sufficiently bewildering that we just fail @@ -1258,12 +1340,10 @@ condition) (values nil t t))))) -;;; 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)))))) +;;; 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 @@ -1271,16 +1351,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) @@ -1290,11 +1365,12 @@ ;;; 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))) @@ -1326,8 +1402,7 @@ ;; extensions (trace-file nil) - ((:block-compile *block-compile-argument*) nil) - ((:byte-compile *byte-compile*) *byte-compile-default*)) + ((:block-compile *block-compile-argument*) nil)) #!+sb-doc "Compile INPUT-FILE, producing a corresponding fasl file and returning @@ -1337,14 +1412,6 @@ 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 derived from the input file name. - :BYTE-COMPILE {T | NIL | :MAYBE} - Determines whether to compile into interpreted byte code instead of - machine instructions. Byte code is several times smaller, but much - slower. If :MAYBE, then only byte-compile when SPEED is 0 and - DEBUG <= 1. The default is the value of SB-EXT:*BYTE-COMPILE-DEFAULT*, - which is initially :MAYBE. (This option will probably become - formally deprecated starting around sbcl-0.7.0, when various - cleanups related to the byte interpreter are planned.) Also, as a workaround for vaguely-non-ANSI behavior, the :BLOCK-COMPILE argument is quasi-supported, to determine whether multiple functions are compiled together as a unit, resolving function @@ -1366,15 +1433,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 @@ -1385,8 +1445,7 @@ :output-file output-file)) (setq fasl-output (open-fasl-output output-file-name - (namestring input-pathname) - (eq *byte-compile* t)))) + (namestring input-pathname)))) (when trace-file (let* ((default-trace-file-pathname (make-pathname :type "trace" :defaults input-pathname)) @@ -1440,8 +1499,7 @@ ;;; 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 (make-pathname :type *fasl-file-type* :defaults defaults))) retyped)) ;;; KLUDGE: Part of the ANSI spec for this seems contradictory: @@ -1543,7 +1601,7 @@ (:ignore-it nil) (t - (compile-top-level-lambdas () t) + (compile-toplevel-lambdas () t) (when (fasl-constant-already-dumped-p constant *compile-object*) (return-from emit-make-load-form nil)) (let* ((name (let ((*print-level* 1) (*print-length* 2))