X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-load.lisp;h=48b3fc394a18f5dd8e1cc4646f3fd159c67d2cf2;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=b20c4e40335a963313691235fad4ef6b6dcdcc7f;hpb=00ca0f6bd2e4e4e4c6214466c83b2f5e7c063c65;p=sbcl.git

diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp
index b20c4e4..48b3fc3 100644
--- a/src/code/target-load.lisp
+++ b/src/code/target-load.lisp
@@ -27,18 +27,38 @@
 
 ;;;; 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)
+                   (sb!c::*source-paths* (make-hash-table :test 'eq)))
+              (setf (sb!c::source-info-stream info) stream)
+              (sb!c::do-forms-from-info ((form current-index) info)
+                (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*))
+                (eval-form form nil)))))))
+  t)
 
 ;;;; LOAD itself
 
@@ -67,7 +87,7 @@
   #!+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))
@@ -95,12 +115,14 @@
                   ;; 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)
@@ -121,26 +143,17 @@
                                  :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
@@ -186,7 +199,7 @@
 (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))
@@ -232,9 +245,7 @@
                       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*