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
  14 ;;;; $Header$
  15 \f
  16 ;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-,
  17 ;;;; but redirectable to any list of features. (This is handy when
  18 ;;;; cross-compiling for making a distinction between features of the
  19 ;;;; host Common Lisp and features of the target SBCL.)
  20
  21 ;;; the feature list for the target system
  22 (export '*shebang-features*)
  23 (declaim (type symbol *shebang-features*))
  24 (defvar *shebang-features*)
  25
  26 (defun feature-in-list-p (feature list)
  27   (etypecase feature
  28     (symbol (member feature list :test #'eq))
  29     (cons (flet ((subfeature-in-list-p (subfeature)
  30                    (feature-in-list-p subfeature list)))
  31             (ecase (first feature)
  32               (:or  (some  #'subfeature-in-list-p (rest feature)))
  33               (:and (every #'subfeature-in-list-p (rest feature)))
  34               (:not (let ((rest (cdr feature)))
  35                       (if (or (null (car rest)) (cdr rest))
  36                         (error "wrong number of terms in compound feature ~S"
  37                                feature)
  38                         (not (subfeature-in-list-p (second feature)))))))))))
  39 (compile 'feature-in-list-p)
  40
  41 (defun shebang-reader (stream sub-character infix-parameter)
  42   (declare (ignore sub-character))
  43   (when infix-parameter
  44     (error "illegal read syntax: #~DT" infix-parameter))
  45   (let ((next-char (read-char stream)))
  46     (unless (find next-char "+-")
  47       (error "illegal read syntax: #!~C" next-char))
  48     ;; When test is not satisfied
  49     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
  50     ;; would become "unless test is satisfied"..
  51     (when (let* ((*package* (find-package "KEYWORD"))
  52                  (*read-suppress* nil)
  53                  (not-p (char= next-char #\-))
  54                  (feature (read stream)))
  55             (if (feature-in-list-p feature *shebang-features*)
  56                 not-p
  57                 (not not-p)))
  58       ;; Read (and discard) a form from input.
  59       (let ((*read-suppress* t))
  60         (read stream t nil t))))
  61   (values))
  62 (compile 'shebang-reader)
  63
  64 (set-dispatch-macro-character #\# #\! #'shebang-reader)
  65 \f
  66 ;;;; FIXME: Would it be worth implementing this?
  67 #|
  68 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
  69 ;;;; instead of leaving them to be skipped over at runtime
  70
  71 ;;; a counter of the number of bytes that we think we've avoided having to
  72 ;;; compile into the system by virtue of doing compile-time processing
  73 (defvar *shebang-double-quote--approx-bytes-saved* 0)
  74
  75 ;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
  76 ;;; and return the result. (This is a subset of the processing performed
  77 ;;; by FORMAT, but we perform it at compile time instead of postponing
  78 ;;; it until run-time.
  79 (defun shebang-double-quote (stream)
  80   (labels ((rc () (read-char stream))
  81            (white-p (char)
  82              ;; Putting non-standard characters in the compiler source is
  83              ;; generally a bad idea, since we'd like to be really portable.
  84              ;; It's specifically a bad idea in strings intended to be
  85              ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
  86              ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
  87              ;; (The most common problem would be to put a #\TAB -- which is
  88              ;; not a STANDARD-CHAR -- into the string. If this is part of the
  89              ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
  90              ;; the string, it won't work, because it won't be recognized as
  91              ;; whitespace.)
  92              (unless (typep char 'standard-char)
  93                (warn "non-STANDARD-CHAR in #!\": ~C" result))
  94              (or (char= char #\newline)
  95                  (char= char #\space)))
  96            (skip-white ()
  97              (do ((char (rc) (rc))
  98                   (count 0 (1+ count)))
  99                  ((not (white-p char))
 100                   (unread-char char stream)
 101                   count))))
 102     (do ((adj-string (make-array 0 :element-type 'char :adjustable t))
 103          (char (rc) (rc)))
 104         ((char= char #\") (coerce adj-string 'simple-string))
 105       (cond ((char= char #\~)
 106              (let ((next-char (read-char stream)))
 107                (cond ((char= next-char #\newline)
 108                       (incf *shebang-double-quote--approx-bytes-saved*
 109                             (+ 2 (skip-white))))
 110                      (t
 111                       (vector-push-extend      char adj-string)
 112                       (vector-push-extend next-char adj-string)))))
 113             ((char= char #\\)
 114              (vector-push-extend char adj-string)
 115              (vector-push-extend (rc) adj-string))
 116             (t (vector-push-extend char adj-string))))))
 117
 118 (setf (gethash #\" *shebang-dispatch*)
 119       #'shebang-double-quote)
 120 |#