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