X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fload.lisp;h=3b2a82fbac5d6a20c7825619e58bca146f707069;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=9ca88ae8742b7265284a25b1932c696b54ee0ae9;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git

diff --git a/src/code/load.lisp b/src/code/load.lisp
index 9ca88ae..3b2a82f 100644
--- a/src/code/load.lisp
+++ b/src/code/load.lisp
@@ -20,7 +20,7 @@
 ;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
 ;;;; around deciding how to thread-safetify it.  So we use a Big Lock.
 ;;;; Because this code is mutually recursive with the compiler, we use
-;;;; the *world-lock*.
+;;;; the **WORLD-LOCK**.
 
 ;;;; miscellaneous load utilities
 
@@ -269,6 +269,48 @@
              (invalid-fasl-features condition)
              (invalid-fasl-expected condition)))))
 
+;;; Skips past the shebang line on stream, if any.
+(defun maybe-skip-shebang-line (stream)
+  (let ((p (file-position stream)))
+    (flet ((next () (read-byte stream nil)))
+      (unwind-protect
+           (when (and (eq (next) (char-code #\#))
+                      (eq (next) (char-code #\!)))
+             (setf p nil)
+             (loop for x = (next)
+                   until (or (not x) (eq x (char-code #\newline)))))
+        (when p
+          (file-position stream p))))
+    t))
+
+;;; Returns T if the stream is a binary input stream with a FASL header.
+(defun fasl-header-p (stream &key errorp)
+  (let ((p (file-position stream)))
+    (unwind-protect
+         (let* ((header *fasl-header-string-start-string*)
+                (buffer (make-array (length header) :element-type '(unsigned-byte 8)))
+                (n 0))
+           (flet ((scan ()
+                    (maybe-skip-shebang-line stream)
+                    (setf n (read-sequence buffer stream))))
+             (if errorp
+                 (scan)
+                 (or (ignore-errors (scan))
+                     ;; no a binary input stream
+                     (return-from fasl-header-p nil))))
+           (if (mismatch buffer header
+                         :test #'(lambda (code char) (= code (char-code char))))
+               ;; Immediate EOF is valid -- we want to match what
+               ;; CHECK-FASL-HEADER does...
+               (or (zerop n)
+                   (when errorp
+                     (error 'fasl-header-missing
+                            :stream stream
+                            :fhsss buffer
+                            :expected header)))
+               t))
+      (file-position stream p))))
+
 ;;;; LOAD-AS-FASL
 ;;;;
 ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with
@@ -278,10 +320,11 @@
 
 ;;; a helper function for LOAD-FASL-GROUP
 ;;;
-;;; Return true if we successfully read a FASL header from the stream,
-;;; or NIL if EOF was hit before anything was read. Signal an error if
-;;; we encounter garbage.
+;;; Return true if we successfully read a FASL header from the stream, or NIL
+;;; if EOF was hit before anything except the optional shebang line was read.
+;;; Signal an error if we encounter garbage.
 (defun check-fasl-header (stream)
+  (maybe-skip-shebang-line stream)
   (let ((byte (read-byte stream nil)))
     (when byte
       ;; Read and validate constant string prefix in fasl header.
@@ -413,6 +456,8 @@
         ;; that this would go away?
         (fill *current-fop-table* nil))))
   t)
+
+(declaim (notinline read-byte)) ; Why is it even *declaimed* inline above?
 
 ;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)