\f
;;;; LOAD-AS-SOURCE
-;;; Load a text file. (Note that load-as-fasl is in another file.)
-(defun load-as-source (stream verbose print)
+;;; Load a text stream. (Note that load-as-fasl is in another file.)
+(defun load-as-source (stream &key verbose print (context "loading"))
(maybe-announce-load stream verbose)
- (do ((sexpr (read stream nil *eof-object*)
- (read stream nil *eof-object*)))
- ((eq sexpr *eof-object*)
- t)
- (if print
- (let ((results (multiple-value-list (eval sexpr))))
- (load-fresh-line)
- (format t "~{~S~^, ~}~%" results))
- (eval sexpr))))
+ (let* ((pathname (ignore-errors (translate-logical-pathname stream)))
+ (native (when pathname (native-namestring pathname))))
+ (with-simple-restart (abort "Abort ~A file ~S." context native)
+ (flet ((eval-form (form index)
+ (with-simple-restart (continue "Ignore error and continue ~A file ~S."
+ context native)
+ (loop
+ (with-simple-restart (retry "Retry EVAL of current toplevel form.")
+ (if print
+ (let ((results (multiple-value-list (eval-tlf form index))))
+ (load-fresh-line)
+ (format t "~{~S~^, ~}~%" results))
+ (eval-tlf form index)))
+ (return)))))
+ (if pathname
+ (let* ((info (sb!c::make-file-source-info
+ pathname (stream-external-format stream)))
+ (sb!c::*source-info* info))
+ (setf (sb!c::source-info-stream info) stream)
+ (sb!c::do-forms-from-info ((form current-index) info)
+ (sb!c::with-source-paths
+ (sb!c::find-source-paths form current-index)
+ (eval-form form current-index))))
+ (let ((sb!c::*source-info* nil))
+ (do ((form (read stream nil *eof-object*)
+ (read stream nil *eof-object*)))
+ ((eq form *eof-object*))
+ (sb!c::with-source-paths
+ (eval-form form nil))))))))
+ t)
\f
;;;; LOAD itself
#!+sb-doc
"Load the file given by FILESPEC into the Lisp environment, returning
T on success."
- (flet ((load-stream (stream)
+ (flet ((load-stream (stream faslp)
(let* (;; Bindings required by ANSI.
(*readtable* *readtable*)
(*package* (sane-package))
;; behavior. Hmm. -- WHN 2001-04-06
(sb!c::*policy* sb!c::*policy*))
(return-from load
- (if (equal (stream-element-type stream) '(unsigned-byte 8))
+ (if faslp
(load-as-fasl stream verbose print)
- (load-as-source stream verbose print))))))
+ (load-as-source stream :verbose verbose :print print))))))
+ ;; Case 1: stream.
(when (streamp pathspec)
- (return-from load (load-stream pathspec)))
+ (return-from load (load-stream pathspec (fasl-header-p pathspec))))
(let ((pathname (pathname pathspec)))
+ ;; Case 2: Open as binary, try to process as a fasl.
(with-open-stream
(stream (or (open pathspec :element-type '(unsigned-byte 8)
:if-does-not-exist nil)
:format-arguments (list pathspec)))))
(unless stream
(return-from load nil))
-
- (let* ((header-line (make-array
- (length *fasl-header-string-start-string*)
- :element-type '(unsigned-byte 8))))
- (read-sequence header-line stream)
- (if (mismatch header-line *fasl-header-string-start-string*
- :test #'(lambda (code char) (= code (char-code char))))
- (let ((truename (probe-file stream)))
- (when (and truename
- (string= (pathname-type truename) *fasl-file-type*))
- (error 'fasl-header-missing
- :stream (namestring truename)
- :fhsss header-line
- :expected *fasl-header-string-start-string*)))
- (progn
- (file-position stream :start)
- (return-from load
- (load-stream stream))))))
+ (let* ((real (probe-file stream))
+ (should-be-fasl-p
+ (and real (string-equal (pathname-type real) *fasl-file-type*))))
+ ;; Don't allow empty .fasls, and assume other empty files
+ ;; are source files.
+ (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))
+ (fasl-header-p stream :errorp should-be-fasl-p))
+ (return-from load (load-stream stream t)))))
+ ;; Case 3: Open using the gived external format, process as source.
(with-open-file (stream pathname :external-format external-format)
- (load-stream stream)))))
+ (load-stream stream nil)))))
;; This implements the defaulting SBCL seems to have inherited from
;; CMU. This routine does not try to perform any loading; all it does
(defun load-code (box-num code-length)
(declare (fixnum box-num code-length))
(with-fop-stack t
- (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
+ (let ((code (sb!c:allocate-code-object box-num code-length))
(index (+ sb!vm:code-trace-table-offset-slot box-num)))
(declare (type index index))
(setf (%code-debug-info code) (pop-stack))
tto)
(format t " loading to the dynamic space~%"))
- (let ((code (%primitive sb!c:allocate-code-object
- box-num
- code-length))
+ (let ((code (sb!c:allocate-code-object box-num code-length))
(index (+ sb!vm:code-trace-table-offset-slot box-num)))
(declare (type index index))
(when *load-code-verbose*
projects / sbcl.git / blobdiff