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