;;;; 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 *big-compiler-lock*
+;;;; the *world-lock*.
;;;; miscellaneous load utilities
position ~A: Expected ~A, got ~A.~:@>"
(invalid-fasl-stream condition)
(invalid-fasl-byte-nr condition)
- (invalid-fasl-byte condition)
- (invalid-fasl-expected condition)))))
+ (invalid-fasl-expected condition)
+ (invalid-fasl-byte condition)))))
(define-condition invalid-fasl-version (invalid-fasl)
- ((variant :reader invalid-fasl-variant :initarg :variant)
- (version :reader invalid-fasl-version :initarg :version))
+ ((version :reader invalid-fasl-version :initarg :version))
(:report
(lambda (condition stream)
- (format stream "~@<~S is in ~A fasl file format version ~W, ~
- but this version of SBCL uses format version ~W.~:@>"
+ (format stream "~@<~S is a fasl file compiled with SBCL ~W, and ~
+ can't be loaded into SBCL ~W.~:@>"
(invalid-fasl-stream condition)
- (invalid-fasl-variant condition)
(invalid-fasl-version condition)
(invalid-fasl-expected condition)))))
(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
;;; 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.
(let* ((fhsss *fasl-header-string-start-string*)
(fhsss-length (length fhsss)))
(unless (= byte (char-code (schar fhsss 0)))
(error 'invalid-fasl-header
:stream stream
- :first-byte-p t
+ :byte-nr 0
:byte byte
:expected (char-code (schar fhsss 0))))
(do ((byte (read-byte stream) (read-byte stream))
:byte-nr count
:byte byte
:expected (char-code (schar fhsss count))))))
-
;; Read and validate version-specific compatibility stuff.
(flet ((string-from-stream ()
(let* ((length (read-unsigned-byte-32-arg))
(read-string-as-bytes stream result)
result)))
;; Read and validate implementation and version.
- (let* ((implementation (keywordicate (string-from-stream)))
- ;; FIXME: The logic above to read a keyword from the fasl file
- ;; could probably be shared with the read-a-keyword fop.
- (version (read-word-arg)))
- (flet ((check-version (variant
- possible-implementation
- needed-version)
- (when (string= possible-implementation implementation)
- (or (= version needed-version)
- (error 'invalid-fasl-version
- ;; :error :wrong-version
- :stream stream
- :variant variant
- :version version
- :expected needed-version)))))
- (or (check-version "native code"
- +backend-fasl-file-implementation+
- +fasl-file-version+)
- (error 'invalid-fasl-implementation
+ (let ((implementation (keywordicate (string-from-stream)))
+ (expected-implementation +backend-fasl-file-implementation+))
+ (unless (string= expected-implementation implementation)
+ (error 'invalid-fasl-implementation
+ :stream stream
+ :implementation implementation
+ :expected expected-implementation)))
+ (let* ((fasl-version (read-word-arg))
+ (sbcl-version (if (<= fasl-version 76)
+ "1.0.11.18"
+ (string-from-stream)))
+ (expected-version (sb!xc:lisp-implementation-version)))
+ (unless (string= expected-version sbcl-version)
+ (restart-case
+ (error 'invalid-fasl-version
:stream stream
- :implementation implementation
- :expected +backend-fasl-file-implementation+))))
+ :version sbcl-version
+ :expected expected-version)
+ (continue () :report "Load the fasl file anyway"))))
;; Read and validate *FEATURES* which affect binary compatibility.
(let ((faff-in-this-file (string-from-stream)))
(unless (string= faff-in-this-file *features-affecting-fasl-format*)
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
(maybe-announce-load stream verbose)
- (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*)
+ (with-world-lock ()
(let* ((*fasl-input-stream* stream)
(*fasl-symbol-buffer* (make-string 100))
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
projects / sbcl.git / blobdiff