(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*
(pprint-logical-block (*error-output* nil :per-line-prefix "; ")
(apply #'compiler-mumble foo))))
-(deftype object () '(or fasl-file core-object null))
+(deftype object () '(or fasl-output core-object null))
(defvar *compile-object* nil)
(declaim (type object *compile-object*))
(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
~% ~{~<~% ~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~]~
*compiler-trace-output*))
(etypecase *compile-object*
- (fasl-file
+ (fasl-output
(maybe-mumble "fasl")
(fasl-dump-component component
*code-segment*
(: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)
(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))))
\f
;;;; top-level form processing
(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)
(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
;; 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.
(defun process-cold-load-form (form path eval)
(let ((object *compile-object*))
(etypecase object
- (fasl-file
+ (fasl-output
(compile-top-level-lambdas () t)
(fasl-dump-cold-load-form form object))
((or null core-object)
(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))
\f
;;;;
;;;; (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-file-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.
(setf (component-name component) (leaf-name lambda))
(compile-component component)
(clear-ir1-info component))))
-
-;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion
-;;; finds a constant structure, it invokes this to arrange for proper
-;;; dumping. If it turns out that the constant has already been
-;;; dumped, then we don't need to do anything.
-;;;
-;;; If the constant hasn't been dumped, then we check to see whether
-;;; we are in the process of creating it. We detect this by
-;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all
-;;; the constants we are in the process of creating. Actually, each
-;;; entry is a list of the constant and any init forms that need to be
-;;; processed on behalf of that constant.
-;;;
-;;; It's not necessarily an error for this to happen. If we are
-;;; processing the init form for some object that showed up *after*
-;;; the original reference to this constant, then we just need to
-;;; defer the processing of that init form. To detect this, we
-;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the
-;;; constants created since the last time we started processing an
-;;; init form. If the constant passed to emit-make-load-form shows up
-;;; in this list, then there is a circular chain through creation
-;;; forms, which is an error.
-;;;
-;;; If there is some intervening init form, then we blow out of
-;;; processing it by throwing to the tag PENDING-INIT. The value we
-;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the
-;;; offending init form can be tacked onto the init forms for the
-;;; circular object.
-;;;
-;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then
-;;; we have to create it. We call MAKE-LOAD-FORM and check to see
-;;; whether the creation form is the magic value
-;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The
-;;; dumper will eventually get its hands on the object and use the
-;;; normal structure dumping noise on it.
-;;;
-;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and
-;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form
-;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the
-;;; dumper to use that result instead whenever it sees this constant.
-;;;
-;;; Now we try to compile the init form. We bind
-;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* to NIL and compile the init
-;;; form (and any init forms that were added because of circularity
-;;; detection). If this works, great. If not, we add the init forms to
-;;; the init forms for the object that caused the problems and let it
-;;; deal with it.
-(defvar *constants-being-created* nil)
-(defvar *constants-created-since-last-init* nil)
-;;; FIXME: Shouldn't these^ variables be bound in LET forms?
-(defun emit-make-load-form (constant)
- (aver (fasl-file-p *compile-object*))
- (unless (or (fasl-constant-already-dumped constant *compile-object*)
- ;; KLUDGE: This special hack is because I was too lazy
- ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM
- ;; function of LAYOUT returns nontrivial forms when
- ;; building the cross-compiler but :IGNORE-IT when
- ;; cross-compiling or running under the target Lisp. --
- ;; WHN 19990914
- #+sb-xc-host (typep constant 'layout))
- (let ((circular-ref (assoc constant *constants-being-created* :test #'eq)))
- (when circular-ref
- (when (find constant *constants-created-since-last-init* :test #'eq)
- (throw constant t))
- (throw 'pending-init circular-ref)))
- (multiple-value-bind (creation-form init-form)
- (handler-case
- (sb!xc:make-load-form constant (make-null-lexenv))
- (error (condition)
- (compiler-error "(while making load form for ~S)~%~A"
- constant
- condition)))
- (case creation-form
- (:just-dump-it-normally
- (fasl-validate-structure constant *compile-object*)
- t)
- (:ignore-it
- nil)
- (t
- (compile-top-level-lambdas () t)
- (when (fasl-constant-already-dumped constant *compile-object*)
- (return-from emit-make-load-form nil))
- (let* ((name (let ((*print-level* 1) (*print-length* 2))
- (with-output-to-string (stream)
- (write constant :stream stream))))
- (info (if init-form
- (list constant name init-form)
- (list constant))))
- (let ((*constants-being-created*
- (cons info *constants-being-created*))
- (*constants-created-since-last-init*
- (cons constant *constants-created-since-last-init*)))
- (when
- (catch constant
- (fasl-note-handle-for-constant
- constant
- (compile-load-time-value
- creation-form
- (format nil "creation form for ~A" name))
- *compile-object*)
- nil)
- (compiler-error "circular references in creation form for ~S"
- constant)))
- (when (cdr info)
- (let* ((*constants-created-since-last-init* nil)
- (circular-ref
- (catch 'pending-init
- (loop for (name form) on (cdr info) by #'cddr
- collect name into names
- collect form into forms
- finally
- (compile-make-load-form-init-forms
- forms
- (format nil "init form~:[~;s~] for ~{~A~^, ~}"
- (cdr forms) names)))
- nil)))
- (when circular-ref
- (setf (cdr circular-ref)
- (append (cdr circular-ref) (cdr info))))))))))))
\f
;;;; COMPILE-FILE
(declare (type functional tll))
(let ((object *compile-object*))
(etypecase object
- (fasl-file
+ (fasl-output
(fasl-dump-top-level-lambda-call tll object))
(core-object
(core-call-top-level-lambda tll object))
(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)))
;;; 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)
(*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)
(*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-file (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*
+ "~@<compilation aborted because of input error: ~2I~_~A~:>"
+ 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
(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)
;;; 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~&"
(unless (eq external-format :default)
(error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
- (let* ((fasl-file nil)
+ (let* ((fasl-output nil)
(output-file-name nil)
(compile-won nil)
(warnings-p nil)
(failure-p t) ; T in case error keeps this from being set later
- ;; 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
(setq output-file-name
(sb!xc:compile-file-pathname input-file
:output-file output-file))
- (setq fasl-file
- (open-fasl-file output-file-name
- (namestring input-pathname)
- (eq *byte-compile* t))))
+ (setq fasl-output
+ (open-fasl-output output-file-name
+ (namestring input-pathname)
+ (eq *byte-compile* t))))
(when trace-file
(let* ((default-trace-file-pathname
(make-pathname :type "trace" :defaults input-pathname))
(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
(when sb!xc:*compile-verbose*
(start-error-output source-info))
- (let ((*compile-object* fasl-file)
+ (let ((*compile-object* fasl-output)
dummy)
(multiple-value-setq (dummy warnings-p failure-p)
(sub-compile-file source-info)))
(close-source-info source-info)
- (when fasl-file
- (close-fasl-file fasl-file (not compile-won))
- (setq output-file-name (pathname (fasl-file-stream fasl-file)))
+ (when fasl-output
+ (close-fasl-output fasl-output (not compile-won))
+ (setq output-file-name
+ (pathname (fasl-output-stream fasl-output)))
(when (and compile-won sb!xc:*compile-verbose*)
(compiler-mumble "~2&; ~A written~%" (namestring output-file-name))))
;;; default to the appropriate implementation-defined default type for
;;; compiled files.
(defun cfp-output-file-default (input-file)
- (let* (;; FIXME: I think the PHYSICALIZE-PATHNAME wrapper here
- ;; shouldn't really be necessary. Unfortunately
- ;; sbcl-0.6.12.18's MERGE-PATHNAMES doesn't like logical
- ;; pathnames very much, and doesn't get good results in
- ;; tests/side-effectful-pathnames.sh for (COMPILE-FILE
- ;; "TEST:$StudlyCapsStem"), unless I do this. It would be
- ;; good to straighten out how MERGE-PATHNAMES is really
- ;; supposed to work for logical pathnames, and add a bunch of
- ;; test cases to check it, then get rid of this cruft.
- (defaults (merge-pathnames (physicalize-pathname (pathname
- input-file))
- *default-pathname-defaults*))
- (retyped (make-pathname :type *backend-fasl-file-type*
- :defaults defaults)))
+ (let* ((defaults (merge-pathnames input-file *default-pathname-defaults*))
+ (retyped (make-pathname :type *fasl-file-type* :defaults defaults)))
retyped))
;;; KLUDGE: Part of the ANSI spec for this seems contradictory:
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
(pathname output-file))
+\f
+;;;; MAKE-LOAD-FORM stuff
+
+;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion
+;;; finds a constant structure, it invokes this to arrange for proper
+;;; dumping. If it turns out that the constant has already been
+;;; dumped, then we don't need to do anything.
+;;;
+;;; If the constant hasn't been dumped, then we check to see whether
+;;; we are in the process of creating it. We detect this by
+;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all
+;;; the constants we are in the process of creating. Actually, each
+;;; entry is a list of the constant and any init forms that need to be
+;;; processed on behalf of that constant.
+;;;
+;;; It's not necessarily an error for this to happen. If we are
+;;; processing the init form for some object that showed up *after*
+;;; the original reference to this constant, then we just need to
+;;; defer the processing of that init form. To detect this, we
+;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the
+;;; constants created since the last time we started processing an
+;;; init form. If the constant passed to emit-make-load-form shows up
+;;; in this list, then there is a circular chain through creation
+;;; forms, which is an error.
+;;;
+;;; If there is some intervening init form, then we blow out of
+;;; processing it by throwing to the tag PENDING-INIT. The value we
+;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the
+;;; offending init form can be tacked onto the init forms for the
+;;; circular object.
+;;;
+;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then
+;;; we have to create it. We call MAKE-LOAD-FORM and check to see
+;;; whether the creation form is the magic value
+;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The
+;;; dumper will eventually get its hands on the object and use the
+;;; normal structure dumping noise on it.
+;;;
+;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and
+;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form
+;;; much the way LOAD-TIME-VALUE does. When this finishes, we tell the
+;;; dumper to use that result instead whenever it sees this constant.
+;;;
+;;; Now we try to compile the init form. We bind
+;;; *CONSTANTS-CREATED-SINCE-LAST-INIT* to NIL and compile the init
+;;; form (and any init forms that were added because of circularity
+;;; detection). If this works, great. If not, we add the init forms to
+;;; the init forms for the object that caused the problems and let it
+;;; deal with it.
+(defvar *constants-being-created* nil)
+(defvar *constants-created-since-last-init* nil)
+;;; FIXME: Shouldn't these^ variables be bound in LET forms?
+(defun emit-make-load-form (constant)
+ (aver (fasl-output-p *compile-object*))
+ (unless (or (fasl-constant-already-dumped-p constant *compile-object*)
+ ;; KLUDGE: This special hack is because I was too lazy
+ ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM
+ ;; function of LAYOUT returns nontrivial forms when
+ ;; building the cross-compiler but :IGNORE-IT when
+ ;; cross-compiling or running under the target Lisp. --
+ ;; WHN 19990914
+ #+sb-xc-host (typep constant 'layout))
+ (let ((circular-ref (assoc constant *constants-being-created* :test #'eq)))
+ (when circular-ref
+ (when (find constant *constants-created-since-last-init* :test #'eq)
+ (throw constant t))
+ (throw 'pending-init circular-ref)))
+ (multiple-value-bind (creation-form init-form)
+ (handler-case
+ (sb!xc:make-load-form constant (make-null-lexenv))
+ (error (condition)
+ (compiler-error "(while making load form for ~S)~%~A"
+ constant
+ condition)))
+ (case creation-form
+ (:just-dump-it-normally
+ (fasl-validate-structure constant *compile-object*)
+ t)
+ (:ignore-it
+ nil)
+ (t
+ (compile-top-level-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))
+ (with-output-to-string (stream)
+ (write constant :stream stream))))
+ (info (if init-form
+ (list constant name init-form)
+ (list constant))))
+ (let ((*constants-being-created*
+ (cons info *constants-being-created*))
+ (*constants-created-since-last-init*
+ (cons constant *constants-created-since-last-init*)))
+ (when
+ (catch constant
+ (fasl-note-handle-for-constant
+ constant
+ (compile-load-time-value
+ creation-form
+ (format nil "creation form for ~A" name))
+ *compile-object*)
+ nil)
+ (compiler-error "circular references in creation form for ~S"
+ constant)))
+ (when (cdr info)
+ (let* ((*constants-created-since-last-init* nil)
+ (circular-ref
+ (catch 'pending-init
+ (loop for (name form) on (cdr info) by #'cddr
+ collect name into names
+ collect form into forms
+ finally
+ (compile-make-load-form-init-forms
+ forms
+ (format nil "init form~:[~;s~] for ~{~A~^, ~}"
+ (cdr forms) names)))
+ nil)))
+ (when circular-ref
+ (setf (cdr circular-ref)
+ (append (cdr circular-ref) (cdr info))))))))))))