src/cold/shebang.lisp

   1 ;;;; cold-boot-only readmacro syntax
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB-COLD")
  13 \f
  14 ;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-, but
  15 ;;;; for *SHEBANG-FEATURES* instead of CL:*FEATURES*. (This is handy
  16 ;;;; when cross-compiling, so that we can make a distinction between
  17 ;;;; features of the host Common Lisp and features of the target
  18 ;;;; SBCL.)
  19
  20 ;;; the feature list for the target system
  21 (export '*shebang-features*)
  22 (declaim (type list *shebang-features*))
  23 (defvar *shebang-features*)
  24
  25 (defun feature-in-list-p (feature list)
  26   (labels ((sane-expr-p (x)
  27              (typecase x
  28                (symbol (and (string/= x "SB-XC") (string/= x "SB-XC-HOST")))
  29                ;; This allows you to write #!+(host-feature sbcl) <stuff>
  30                ;; to muffle conditions, bypassing the "probable XC bug" check.
  31                ;; Using the escape hatch is assumed never to be a mistake.
  32                ((cons (eql :host-feature)) t)
  33                (cons (every #'sane-expr-p (cdr x))))))
  34     (unless (sane-expr-p feature)
  35       (error "Target feature expression ~S looks screwy" feature)))
  36   (etypecase feature
  37     (symbol (member feature list :test #'eq))
  38     (cons (flet ((subfeature-in-list-p (subfeature)
  39                    (feature-in-list-p subfeature list)))
  40             (ecase (first feature)
  41               (:or  (some  #'subfeature-in-list-p (rest feature)))
  42               (:and (every #'subfeature-in-list-p (rest feature)))
  43               ((:host-feature :not)
  44                (destructuring-bind (subexpr) (cdr feature)
  45                  (cond ((eq (first feature) :host-feature)
  46                         ;; (:HOST-FEATURE :sym) looks in *FEATURES* for :SYM
  47                         (check-type subexpr symbol)
  48                         (member subexpr *features* :test #'eq))
  49                        (t
  50                         (not (subfeature-in-list-p subexpr)))))))))))
  51 (compile 'feature-in-list-p)
  52
  53 (defun shebang-reader (stream sub-character infix-parameter)
  54   (declare (ignore sub-character))
  55   (when infix-parameter
  56     (error "illegal read syntax: #~D!" infix-parameter))
  57   (let ((next-char (read-char stream)))
  58     (unless (find next-char "+-")
  59       (error "illegal read syntax: #!~C" next-char))
  60     (if (char= (if (let* ((*package* (find-package "KEYWORD"))
  61                           (*read-suppress* nil)
  62                           (feature (read stream)))
  63                      (feature-in-list-p feature *shebang-features*))
  64                    #\+ #\-) next-char)
  65         (read stream t nil t)
  66         ;; Read (and discard) a form from input.
  67         (let ((*read-suppress* t))
  68           (read stream t nil t)
  69           (values)))))
  70 (compile 'shebang-reader)
  71
  72 (set-dispatch-macro-character #\# #\! #'shebang-reader)
  73 ;;; while we are at it, let us write something which helps us sanity
  74 ;;; check our own code; it is too easy to write #+ when meaning #!+,
  75 ;;; and such mistakes can go undetected for a while.
  76 ;;;
  77 ;;; ideally we wouldn't use *SHEBANG-FEATURES* but
  78 ;;; *ALL-POSSIBLE-SHEBANG-FEATURES*, but maintaining that variable
  79 ;;; will not be easy.
  80 (defun checked-feature-in-features-list-p (feature list)
  81   (etypecase feature
  82     (symbol (unless (member feature '(:ansi-cl :common-lisp :ieee-floating-point))
  83               (when (member feature *shebang-features* :test #'eq)
  84                 (error "probable XC bug in host read-time conditional")))
  85             (member feature list :test #'eq))
  86     (cons (flet ((subfeature-in-list-p (subfeature)
  87                    (checked-feature-in-features-list-p subfeature list)))
  88             (ecase (first feature)
  89               (:or  (some  #'subfeature-in-list-p (rest feature)))
  90               (:and (every #'subfeature-in-list-p (rest feature)))
  91               (:not (let ((rest (cdr feature)))
  92                       (if (or (null (car rest)) (cdr rest))
  93                         (error "wrong number of terms in compound feature ~S"
  94                                feature)
  95                         (not (subfeature-in-list-p (second feature)))))))))))
  96 (compile 'checked-feature-in-features-list-p)
  97
  98 (defun she-reader (stream sub-character infix-parameter)
  99   (when infix-parameter
 100     (error "illegal read syntax: #~D~C" infix-parameter sub-character))
 101   (when (let* ((*package* (find-package "KEYWORD"))
 102                (*read-suppress* nil)
 103                (notp (eql sub-character #\-))
 104                (feature (read stream)))
 105           (if (checked-feature-in-features-list-p feature *features*)
 106               notp
 107               (not notp)))
 108     (let ((*read-suppress* t))
 109       (read stream t nil t)))
 110   (values))
 111 (compile 'she-reader)
 112 \f
 113 ;;;; variables like *SHEBANG-FEATURES* but different
 114
 115 ;;; This variable is declared here (like *SHEBANG-FEATURES*) so that
 116 ;;; things like chill.lisp work (because the variable has properties
 117 ;;; similar to *SHEBANG-FEATURES*, and chill.lisp was set up to work
 118 ;;; for that). For an explanation of what it really does, look
 119 ;;; elsewhere.
 120 (export '*shebang-backend-subfeatures*)
 121 (declaim (type list *shebang-backend-subfeatures*))
 122 (defvar *shebang-backend-subfeatures*)
 123 \f
 124 ;;;; string checker, for catching non-portability early
 125 (defun make-quote-reader (standard-quote-reader)
 126   (lambda (stream char)
 127     (let ((result (funcall standard-quote-reader stream char)))
 128       (unless (every (lambda (x) (typep x 'standard-char)) result)
 129         (warn "Found non-STANDARD-CHAR in ~S" result))
 130       result)))
 131 (compile 'make-quote-reader)
 132
 133 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil)))
 134 \f
 135 ;;;; FIXME: Would it be worth implementing this?
 136 #|
 137 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
 138 ;;;; instead of leaving them to be skipped over at runtime
 139
 140 ;;; a counter of the number of bytes that we think we've avoided having to
 141 ;;; compile into the system by virtue of doing compile-time processing
 142 (defvar *shebang-double-quote--approx-bytes-saved* 0)
 143
 144 ;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
 145 ;;; and return the result. (This is a subset of the processing performed
 146 ;;; by FORMAT, but we perform it at compile time instead of postponing
 147 ;;; it until run-time.
 148 (defun shebang-double-quote (stream)
 149   (labels ((rc () (read-char stream))
 150            (white-p (char)
 151              ;; Putting non-standard characters in the compiler source is
 152              ;; generally a bad idea, since we'd like to be really portable.
 153              ;; It's specifically a bad idea in strings intended to be
 154              ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
 155              ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
 156              ;; (The most common problem would be to put a #\TAB -- which is
 157              ;; not a STANDARD-CHAR -- into the string. If this is part of the
 158              ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
 159              ;; the string, it won't work, because it won't be recognized as
 160              ;; whitespace.)
 161              (unless (typep char 'standard-char)
 162                (warn "non-STANDARD-CHAR in #!\": ~C" result))
 163              (or (char= char #\newline)
 164                  (char= char #\space)))
 165            (skip-white ()
 166              (do ((char (rc) (rc))
 167                   (count 0 (1+ count)))
 168                  ((not (white-p char))
 169                   (unread-char char stream)
 170                   count))))
 171     (do ((adj-string (make-array 0 :element-type 'char :adjustable t))
 172          (char (rc) (rc)))
 173         ((char= char #\") (coerce adj-string 'simple-string))
 174       (cond ((char= char #\~)
 175              (let ((next-char (read-char stream)))
 176                (cond ((char= next-char #\newline)
 177                       (incf *shebang-double-quote--approx-bytes-saved*
 178                             (+ 2 (skip-white))))
 179                      (t
 180                       (vector-push-extend      char adj-string)
 181                       (vector-push-extend next-char adj-string)))))
 182             ((char= char #\\)
 183              (vector-push-extend char adj-string)
 184              (vector-push-extend (rc) adj-string))
 185             (t (vector-push-extend char adj-string))))))
 186
 187 (setf (gethash #\" *shebang-dispatch*)
 188       #'shebang-double-quote)
 189 |#