X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fshebang.lisp;h=753a877b8060e78ca2661ce6a1bad9799c7c7116;hb=ba70061023f0e124aa1149f3203ec67c0fac155d;hp=9a0c53206973a06b1939bbd5ef62b38f35758293;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/cold/shebang.lisp b/src/cold/shebang.lisp index 9a0c532..753a877 100644 --- a/src/cold/shebang.lisp +++ b/src/cold/shebang.lisp @@ -11,35 +11,36 @@ (in-package "SB-COLD") -;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-, -;;;; but redirectable to any list of features. (This is handy when -;;;; cross-compiling for making a distinction between features of the -;;;; host Common Lisp and features of the target SBCL.) +;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-, but +;;;; for *SHEBANG-FEATURES* instead of CL:*FEATURES*. (This is handy +;;;; when cross-compiling, so that we can make a distinction between +;;;; features of the host Common Lisp and features of the target +;;;; SBCL.) ;;; the feature list for the target system (export '*shebang-features*) -(declaim (type symbol *shebang-features*)) +(declaim (type list *shebang-features*)) (defvar *shebang-features*) (defun feature-in-list-p (feature list) (etypecase feature (symbol (member feature list :test #'eq)) (cons (flet ((subfeature-in-list-p (subfeature) - (feature-in-list-p subfeature list))) - (ecase (first feature) - (:or (some #'subfeature-in-list-p (rest feature))) - (:and (every #'subfeature-in-list-p (rest feature))) - (:not (let ((rest (cdr feature))) - (if (or (null (car rest)) (cdr rest)) - (error "wrong number of terms in compound feature ~S" - feature) - (not (subfeature-in-list-p (second feature))))))))))) + (feature-in-list-p subfeature list))) + (ecase (first feature) + (:or (some #'subfeature-in-list-p (rest feature))) + (:and (every #'subfeature-in-list-p (rest feature))) + (:not (let ((rest (cdr feature))) + (if (or (null (car rest)) (cdr rest)) + (error "wrong number of terms in compound feature ~S" + feature) + (not (subfeature-in-list-p (second feature))))))))))) (compile 'feature-in-list-p) (defun shebang-reader (stream sub-character infix-parameter) (declare (ignore sub-character)) (when infix-parameter - (error "illegal read syntax: #~DT" infix-parameter)) + (error "illegal read syntax: #~D!" infix-parameter)) (let ((next-char (read-char stream))) (unless (find next-char "+-") (error "illegal read syntax: #!~C" next-char)) @@ -47,20 +48,42 @@ ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then ;; would become "unless test is satisfied".. (when (let* ((*package* (find-package "KEYWORD")) - (*read-suppress* nil) - (not-p (char= next-char #\-)) - (feature (read stream))) - (if (feature-in-list-p feature *shebang-features*) - not-p - (not not-p))) + (*read-suppress* nil) + (not-p (char= next-char #\-)) + (feature (read stream))) + (if (feature-in-list-p feature *shebang-features*) + not-p + (not not-p))) ;; Read (and discard) a form from input. (let ((*read-suppress* t)) - (read stream t nil t)))) + (read stream t nil t)))) (values)) (compile 'shebang-reader) (set-dispatch-macro-character #\# #\! #'shebang-reader) +;;;; variables like *SHEBANG-FEATURES* but different + +;;; This variable is declared here (like *SHEBANG-FEATURES*) so that +;;; things like chill.lisp work (because the variable has properties +;;; similar to *SHEBANG-FEATURES*, and chill.lisp was set up to work +;;; for that). For an explanation of what it really does, look +;;; elsewhere. +(export '*shebang-backend-subfeatures*) +(declaim (type list *shebang-features*)) +(defvar *shebang-backend-subfeatures*) + +;;;; string checker, for catching non-portability early +(defun make-quote-reader (standard-quote-reader) + (lambda (stream char) + (let ((result (funcall standard-quote-reader stream char))) + (unless (every (lambda (x) (typep x 'standard-char)) result) + (warn "Found non-STANDARD-CHAR in ~S" result)) + result))) +(compile 'make-quote-reader) + +(set-macro-character #\" (make-quote-reader (get-macro-character #\" nil))) + ;;;; FIXME: Would it be worth implementing this? #| ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time @@ -76,42 +99,42 @@ ;;; it until run-time. (defun shebang-double-quote (stream) (labels ((rc () (read-char stream)) - (white-p (char) - ;; Putting non-standard characters in the compiler source is - ;; generally a bad idea, since we'd like to be really portable. - ;; It's specifically a bad idea in strings intended to be - ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no - ;; portable way to test a non-STANDARD-CHAR for whitespaceness. - ;; (The most common problem would be to put a #\TAB -- which is - ;; not a STANDARD-CHAR -- into the string. If this is part of the - ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in - ;; the string, it won't work, because it won't be recognized as - ;; whitespace.) - (unless (typep char 'standard-char) - (warn "non-STANDARD-CHAR in #!\": ~C" result)) - (or (char= char #\newline) - (char= char #\space))) - (skip-white () - (do ((char (rc) (rc)) - (count 0 (1+ count))) - ((not (white-p char)) - (unread-char char stream) - count)))) + (white-p (char) + ;; Putting non-standard characters in the compiler source is + ;; generally a bad idea, since we'd like to be really portable. + ;; It's specifically a bad idea in strings intended to be + ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no + ;; portable way to test a non-STANDARD-CHAR for whitespaceness. + ;; (The most common problem would be to put a #\TAB -- which is + ;; not a STANDARD-CHAR -- into the string. If this is part of the + ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in + ;; the string, it won't work, because it won't be recognized as + ;; whitespace.) + (unless (typep char 'standard-char) + (warn "non-STANDARD-CHAR in #!\": ~C" result)) + (or (char= char #\newline) + (char= char #\space))) + (skip-white () + (do ((char (rc) (rc)) + (count 0 (1+ count))) + ((not (white-p char)) + (unread-char char stream) + count)))) (do ((adj-string (make-array 0 :element-type 'char :adjustable t)) - (char (rc) (rc))) - ((char= char #\") (coerce adj-string 'simple-string)) + (char (rc) (rc))) + ((char= char #\") (coerce adj-string 'simple-string)) (cond ((char= char #\~) - (let ((next-char (read-char stream))) - (cond ((char= next-char #\newline) - (incf *shebang-double-quote--approx-bytes-saved* - (+ 2 (skip-white)))) - (t - (vector-push-extend char adj-string) - (vector-push-extend next-char adj-string))))) - ((char= char #\\) - (vector-push-extend char adj-string) - (vector-push-extend (rc) adj-string)) - (t (vector-push-extend char adj-string)))))) + (let ((next-char (read-char stream))) + (cond ((char= next-char #\newline) + (incf *shebang-double-quote--approx-bytes-saved* + (+ 2 (skip-white)))) + (t + (vector-push-extend char adj-string) + (vector-push-extend next-char adj-string))))) + ((char= char #\\) + (vector-push-extend char adj-string) + (vector-push-extend (rc) adj-string)) + (t (vector-push-extend char adj-string)))))) (setf (gethash #\" *shebang-dispatch*) #'shebang-double-quote)