From 01488e5ddb6c8c10bc01bc9c502be1fe9de8e370 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 21 Jun 2009 16:30:32 +0000 Subject: [PATCH] 1.0.29.27: add shebang line to fasls * Don't advertise yet, and don't make fasls executable out of the box -- since the SBCL version used to run the fasl has to be the same as compiled it this is clearly not good for distributing stuff in general, just for local convenience. --- package-data-list.lisp-expr | 2 +- src/code/common-os.lisp | 7 +++--- src/code/early-extensions.lisp | 8 +++++++ src/code/load.lisp | 49 +++++++++++++++++++++++++++++++++++++--- src/code/target-load.lisp | 34 ++++++++++------------------ src/code/toplevel.lisp | 16 +------------ src/compiler/dump.lisp | 7 ++++++ version.lisp-expr | 2 +- 8 files changed, 79 insertions(+), 46 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 320a078..1e99f35 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -579,7 +579,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS" "SB!GRAY") :export ( ;; Information about how the program was invoked is ;; nonstandard but very useful. - "*POSIX-ARGV*" "*CORE-PATHNAME*" + "*POSIX-ARGV*" "*CORE-PATHNAME*" "*RUNTIME-PATHNAME*" "POSIX-GETENV" "POSIX-ENVIRON" ;; Atomic operations diff --git a/src/code/common-os.lisp b/src/code/common-os.lisp index 7de4d46..51ebbc1 100644 --- a/src/code/common-os.lisp +++ b/src/code/common-os.lisp @@ -13,12 +13,9 @@ (defvar *software-version* nil) -(defvar *core-pathname* nil - #!+sb-doc - "The absolute pathname of the running SBCL core.") - (sb!alien:define-alien-variable ("posix_argv" *native-posix-argv*) (* (* char))) (sb!alien:define-alien-variable ("core_string" *native-core-string*) (* char)) +(sb!alien:define-alien-routine os-get-runtime-executable-path sb!alien:c-string) ;;; if something ever needs to be done differently for one OS, then ;;; split out the different part into per-os functions. @@ -45,4 +42,6 @@ (/show0 "setting *CORE-PATHNAME*") (setf *core-pathname* (merge-pathnames (native-pathname *core-string*))) + (/show0 "setting *RUNTIME-PATHNAME*") + (setf *runtime-pathname* (native-pathname (os-get-runtime-executable-path))) (/show0 "leaving OS-COLD-INIT-OR-REINIT")) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 272e0eb..46bc505 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -13,6 +13,14 @@ (in-package "SB!IMPL") +(defvar *core-pathname* nil + #!+sb-doc + "The absolute pathname of the running SBCL core.") + +(defvar *runtime-pathname* nil + #!+sb-doc + "The absolute pathname of the running SBCL runtime.") + ;;; something not EQ to anything we might legitimately READ (defparameter *eof-object* (make-symbol "EOF-OBJECT")) diff --git a/src/code/load.lisp b/src/code/load.lisp index 9ca88ae..00bfde7 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -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. diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 31d6102..d022e55 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -81,7 +81,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)) @@ -109,12 +109,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)))))) + ;; 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) @@ -135,26 +137,14 @@ :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= (pathname-type real) *fasl-file-type*)))) + (when (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 diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 87a4752..ba8c00c 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -383,25 +383,11 @@ command-line.") (dolist (option options) (process-1 option))))) -;;; 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)) - (defun process-script (script) (let ((pathname (native-pathname script))) (handling-end-of-the-world (with-open-file (f pathname :element-type :default) - (maybe-skip-shebang-line f) + (sb!fasl::maybe-skip-shebang-line f) (load f :verbose nil :print nil) (quit))))) diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 491716a..fa44379 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -298,6 +298,13 @@ :if-exists :supersede :element-type 'sb!assem:assembly-unit)) (res (make-fasl-output :stream stream))) + ;; Before the actual FASL header, write a shebang line using the current + ;; runtime path, so our fasls can be executed directly from the shell. + (when *runtime-pathname* + (fasl-write-string + (format nil "#!~A --script~%" + (native-namestring *runtime-pathname* :as-file t)) + stream)) ;; Begin the header with the constant machine-readable (and ;; semi-human-readable) string which is used to identify fasl files. (fasl-write-string *fasl-header-string-start-string* stream) diff --git a/version.lisp-expr b/version.lisp-expr index 66e56d6..37d4dde 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".) -"1.0.29.26" +"1.0.29.27" -- 1.7.10.4