X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcold%2Fshebang.lisp;h=521f4126f6ef1a20627f90e8ba1932458381600b;hb=e2c40f8cdd32e299f90cbd7aab985e15928a37cb;hp=6d6a2cb22100bb217e8ddc03299fcc332422c7d3;hpb=771b864c8f32af7734bc0550aeaf1539fc4df194;p=sbcl.git diff --git a/src/cold/shebang.lisp b/src/cold/shebang.lisp index 6d6a2cb..521f412 100644 --- a/src/cold/shebang.lisp +++ b/src/cold/shebang.lisp @@ -26,15 +26,15 @@ (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) @@ -48,19 +48,58 @@ ;; 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) +;;; while we are at it, let us write something which helps us sanity +;;; check our own code; it is too easy to write #+ when meaning #!+, +;;; and such mistakes can go undetected for a while. +;;; +;;; ideally we wouldn't use *SHEBANG-FEATURES* but +;;; *ALL-POSSIBLE-SHEBANG-FEATURES*, but maintaining that variable +;;; will not be easy. +(defun checked-feature-in-features-list-p (feature list) + (etypecase feature + (symbol (unless (member feature '(:ansi-cl :common-lisp :ieee-floating-point)) + (when (member feature *shebang-features* :test #'eq) + (error "probable XC bug in host read-time conditional"))) + (member feature list :test #'eq)) + (cons (flet ((subfeature-in-list-p (subfeature) + (checked-feature-in-features-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 'checked-feature-in-features-list-p) + +(defun she-reader (stream sub-character infix-parameter) + (when infix-parameter + (error "illegal read syntax: #~D~C" infix-parameter sub-character)) + (when (let* ((*package* (find-package "KEYWORD")) + (*read-suppress* nil) + (notp (eql sub-character #\-)) + (feature (read stream))) + (if (checked-feature-in-features-list-p feature *features*) + notp + (not notp))) + (let ((*read-suppress* t)) + (read stream t nil t))) + (values)) +(compile 'she-reader) ;;;; variables like *SHEBANG-FEATURES* but different @@ -70,7 +109,7 @@ ;;; for that). For an explanation of what it really does, look ;;; elsewhere. (export '*shebang-backend-subfeatures*) -(declaim (type list *shebang-features*)) +(declaim (type list *shebang-backend-subfeatures*)) (defvar *shebang-backend-subfeatures*) ;;;; string checker, for catching non-portability early @@ -99,42 +138,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)