From: Andreas Fuchs Date: Fri, 17 Oct 2003 15:44:22 +0000 (+0000) Subject: 0.8.4.28: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0ba72140fb0956f4cafd7b4aca6b6ffb0aa83c05;p=sbcl.git 0.8.4.28: ASDF users, rejoice! * Add a condition SB-EXT:INVALID-FASL (subtype ERROR) * Make SB-FASL::CHECK-FASL-HEADER raise conditions that are subtype SB-EXT:INVALID-FASL on the appropriate errors (or the other way around, I forget) * Make SB-FASL::INTERNAL-LOAD also raise a condition if the FASL header is broken. --- diff --git a/NEWS b/NEWS index 69147bb..6aee499 100644 --- a/NEWS +++ b/NEWS @@ -2130,6 +2130,9 @@ changes in sbcl-0.8.5 relative to sbcl-0.8.4: of its result. * type declarations inside WITH-SLOTS are checked. (reported by salex on #lisp) + * loading incompatible FASLs, e.g. those produced by an incompatible + lisp implementation, cause a condition of type SB-EXT:INVALID-FASL + (a subtype of ERROR) to be raised. * fixed some bugs revealed by Paul Dietz' test suite: ** incorrect optimization of TRUNCATE for a positive first argument and negative second. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index a7d35a3..4c2bb04 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -591,6 +591,11 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." ;; to hide it from them.. "INTERACTIVE-EVAL" + ;; Subtype of SIMPLE-ERROR signalled when attempt to + ;; load an invalid fasl is made, so that user-code can + ;; try to recompile, etc. + "INVALID-FASL" + ;; weak pointers and finalization "CANCEL-FINALIZATION" "FINALIZE" diff --git a/src/code/load.lisp b/src/code/load.lisp index e8b9921..f97af52 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -205,6 +205,70 @@ (progn ,@forms) (setq *fop-stack-pointer* ,n-index))))))) +;;;; Conditions signalled on invalid fasls (wrong fasl version, etc), +;;;; so that user code (esp. ASDF) can reasonably handle attempts to +;;;; load such fasls by recompiling them, etc. For simplicity's sake +;;;; make only condition INVALID-FASL part of the public interface, +;;;; and keep the guts internal. + +(define-condition sb!ext::invalid-fasl (error) + ((stream :reader invalid-fasl-stream :initarg :stream) + (expected :reader invalid-fasl-expected :initarg :expected)) + (:report + (lambda (condition stream) + (format stream "~S is an invalid fasl file." + (invalid-fasl-stream condition))))) + +(define-condition invalid-fasl-header (sb!ext::invalid-fasl) + ((byte :reader invalid-fasl-byte :initarg :byte) + (byte-nr :reader invalid-fasl-byte-nr :initarg :byte-nr)) + (:report + (lambda (condition stream) + (format stream "~@<~S contains an illegal byte in the FASL header at ~ + position ~A: Expected ~A, got ~A.~:@>" + (invalid-fasl-stream condition) + (invalid-fasl-byte-nr condition) + (invalid-fasl-byte condition) + (invalid-fasl-expected condition))))) + +(define-condition invalid-fasl-version (sb!ext::invalid-fasl) + ((variant :reader invalid-fasl-variant :initarg :variant) + (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.~:@>" + (invalid-fasl-stream condition) + (invalid-fasl-variant condition) + (invalid-fasl-version condition) + (invalid-fasl-expected condition))))) + +(define-condition invalid-fasl-implementation (sb!ext::invalid-fasl) + ((implementation :reader invalid-fasl-implementation + :initarg :implementation)) + (:report + (lambda (condition stream) + (format stream "~S was compiled for implementation ~A, but this is a ~A." + (invalid-fasl-stream condition) + (invalid-fasl-implementation condition) + (invalid-fasl-expected condition))))) + +(define-condition invalid-fasl-features (sb!ext::invalid-fasl) + ((potential-features :reader invalid-fasl-potential-features + :initarg :potential-features) + (features :reader invalid-fasl-features :initarg :features)) + (:report + (lambda (condition stream) + (format stream "~@" + '*features* + (invalid-fasl-stream condition) + (invalid-fasl-potential-features condition) + (invalid-fasl-features condition) + (invalid-fasl-expected condition))))) + ;;;; LOAD-AS-FASL ;;;; ;;;; Note: LOAD-AS-FASL is used not only by LOAD, but also (with @@ -226,7 +290,11 @@ (let* ((fhsss *fasl-header-string-start-string*) (fhsss-length (length fhsss))) (unless (= byte (char-code (schar fhsss 0))) - (error "illegal first byte in fasl file header")) + (error 'invalid-fasl-header + :stream stream + :first-byte-p t + :byte byte + :expected (char-code (schar fhsss 0)))) (do ((byte (read-byte stream) (read-byte stream)) (count 1 (1+ count))) ((= byte +fasl-header-string-stop-char-code+) @@ -234,8 +302,11 @@ (declare (fixnum byte count)) (when (and (< count fhsss-length) (not (eql byte (char-code (schar fhsss count))))) - (error - "illegal subsequent (not first) byte in fasl file header")))) + (error 'invalid-fasl-header + :stream stream + :byte-nr count + :byte byte + :expected (char-code (schar fhsss count)))))) ;; Read and validate version-specific compatibility stuff. (flet ((string-from-stream () @@ -253,34 +324,27 @@ needed-version) (when (string= possible-implementation implementation) (or (= version needed-version) - (error "~@<~S is in ~A fasl file format version ~W, ~ - but this version of SBCL uses ~ - format version ~W.~:@>" - stream - variant - 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 "~S was compiled for implementation ~A, ~ - but this is a ~A." - stream - implementation - +backend-fasl-file-implementation+)))) + (error 'invalid-fasl-implementation + :stream stream + :implementation implementation + :expected +backend-fasl-file-implementation+)))) ;; 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*) - (error - "~@" - '*features* - stream - *features-potentially-affecting-fasl-format* - *features-affecting-fasl-format* - faff-in-this-file))) + (error 'invalid-fasl-features + :stream stream + :potential-features *features-potentially-affecting-fasl-format* + :expected *features-affecting-fasl-format* + :features faff-in-this-file))) ;; success t)))) diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 56a139e..79c2e89 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -42,6 +42,16 @@ ;;;; LOAD itself +(define-condition fasl-header-missing (sb!ext::invalid-fasl) + ((fhsss :reader invalid-fasl-fhsss :initarg :fhsss)) + (:report + (lambda (condition stream) + (format stream "~@" + (invalid-fasl-stream condition) + (invalid-fasl-expected condition) + (invalid-fasl-fhsss condition))))) + ;;; a helper function for LOAD: Load the stuff in a file when we have ;;; the name. (defun internal-load (pathname truename if-does-not-exist verbose print @@ -82,8 +92,10 @@ :binary)) (t (when (string= (pathname-type truename) *fasl-file-type*) - (error "File has a fasl file type, but no fasl file header:~% ~S" - (namestring truename))) + (error 'fasl-header-missing + :stream (namestring truename) + :fhsss first-line + :expected fhsss)) (internal-load pathname truename if-does-not-exist verbose print :source)))))))) diff --git a/version.lisp-expr b/version.lisp-expr index b3ef367..771e200 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.4.27" +"0.8.4.28"