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 #+/#-, 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
20 ;;; the feature list for the target system
21 (export '*shebang-features
*)
22 (declaim (type list
*shebang-features
*))
23 (defvar *shebang-features
*)
25 (defun feature-in-list-p (feature list
)
26 (labels ((sane-expr-p (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
)))
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
)))
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
))
50 (not (subfeature-in-list-p subexpr
)))))))))))
51 (compile 'feature-in-list-p
)
53 (defun shebang-reader (stream sub-character infix-parameter
)
54 (declare (ignore sub-character
))
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"))
62 (feature (read stream
)))
63 (feature-in-list-p feature
*shebang-features
*))
66 ;; Read (and discard) a form from input.
67 (let ((*read-suppress
* t
))
70 (compile 'shebang-reader
)
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.
77 ;;; ideally we wouldn't use *SHEBANG-FEATURES* but
78 ;;; *ALL-POSSIBLE-SHEBANG-FEATURES*, but maintaining that variable
80 (defun checked-feature-in-features-list-p (feature list
)
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"
95 (not (subfeature-in-list-p (second feature
)))))))))))
96 (compile 'checked-feature-in-features-list-p
)
98 (defun she-reader (stream sub-character 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
*)
108 (let ((*read-suppress
* t
))
109 (read stream t nil t
)))
111 (compile 'she-reader
)
113 ;;;; variables like *SHEBANG-FEATURES* but different
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
120 (export '*shebang-backend-subfeatures
*)
121 (declaim (type list
*shebang-backend-subfeatures
*))
122 (defvar *shebang-backend-subfeatures
*)
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
))
131 (compile 'make-quote-reader
)
133 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil
)))
135 ;;;; FIXME: Would it be worth implementing this?
137 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
138 ;;;; instead of leaving them to be skipped over at runtime
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)
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
))
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
161 (unless (typep char
'standard-char
)
162 (warn "non-STANDARD-CHAR in #!\": ~C" result
))
163 (or (char= char
#\newline
)
164 (char= char
#\space
)))
166 (do ((char (rc) (rc))
167 (count 0 (1+ count
)))
168 ((not (white-p char
))
169 (unread-char char stream
)
171 (do ((adj-string (make-array 0 :element-type
'char
:adjustable t
))
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
*
180 (vector-push-extend char adj-string
)
181 (vector-push-extend next-char adj-string
)))))
183 (vector-push-extend char adj-string
)
184 (vector-push-extend (rc) adj-string
))
185 (t (vector-push-extend char adj-string
))))))
187 (setf (gethash #\" *shebang-dispatch
*)
188 #'shebang-double-quote
)