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 target-platform-name ()
26 (let ((arch (intersection '(:alpha
:arm
:arm64
:hppa
:mips
:ppc
:sparc
:x86
:x86-64
)
28 (cond ((not arch
) (error "No architecture selected"))
29 ((> (length arch
) 1) (error "More than one architecture selected")))
30 (string-downcase (car arch
))))
32 ;;; Not necessarily the logical place to define BACKEND-ASM-PACKAGE-NAME,
33 ;;; but a convenient one, because *shebang-features* needs to have been
34 ;;; DEFVARed, and because 'chill' loads this and only this file.
35 (defun backend-asm-package-name ()
36 (concatenate 'string
"SB!" (string-upcase (target-platform-name)) "-ASM"))
38 (defun feature-in-list-p (feature list
)
39 (labels ((sane-expr-p (x)
41 (symbol (and (string/= x
"SB-XC") (string/= x
"SB-XC-HOST")))
42 ;; This allows you to write #!+(host-feature sbcl) <stuff>
43 ;; to muffle conditions, bypassing the "probable XC bug" check.
44 ;; Using the escape hatch is assumed never to be a mistake.
45 ((cons (eql :host-feature
)) t
)
46 (cons (every #'sane-expr-p
(cdr x
))))))
47 (unless (sane-expr-p feature
)
48 (error "Target feature expression ~S looks screwy" feature
)))
50 (symbol (member feature list
:test
#'eq
))
51 (cons (flet ((subfeature-in-list-p (subfeature)
52 (feature-in-list-p subfeature list
)))
53 (ecase (first feature
)
54 (:or
(some #'subfeature-in-list-p
(rest feature
)))
55 (:and
(every #'subfeature-in-list-p
(rest feature
)))
57 (destructuring-bind (subexpr) (cdr feature
)
58 (cond ((eq (first feature
) :host-feature
)
59 ;; (:HOST-FEATURE :sym) looks in *FEATURES* for :SYM
60 (check-type subexpr symbol
)
61 (member subexpr
*features
* :test
#'eq
))
63 (not (subfeature-in-list-p subexpr
)))))))))))
64 (compile 'feature-in-list-p
)
66 (defun shebang-reader (stream sub-character infix-parameter
)
67 (declare (ignore sub-character
))
69 (error "illegal read syntax: #~D!" infix-parameter
))
70 (let ((next-char (read-char stream
)))
71 (unless (find next-char
"+-")
72 (error "illegal read syntax: #!~C" next-char
))
73 (if (char= (if (let* ((*package
* (find-package "KEYWORD"))
75 (feature (read stream
)))
76 (feature-in-list-p feature
*shebang-features
*))
79 ;; Read (and discard) a form from input.
80 (let ((*read-suppress
* t
))
83 (compile 'shebang-reader
)
85 (set-dispatch-macro-character #\
# #\
! #'shebang-reader
)
86 ;;; while we are at it, let us write something which helps us sanity
87 ;;; check our own code; it is too easy to write #+ when meaning #!+,
88 ;;; and such mistakes can go undetected for a while.
90 ;;; ideally we wouldn't use *SHEBANG-FEATURES* but
91 ;;; *ALL-POSSIBLE-SHEBANG-FEATURES*, but maintaining that variable
93 (defun checked-feature-in-features-list-p (feature list
)
95 (symbol (unless (member feature
'(:ansi-cl
:common-lisp
:ieee-floating-point
))
96 (when (member feature
*shebang-features
* :test
#'eq
)
97 (error "probable XC bug in host read-time conditional")))
98 (member feature list
:test
#'eq
))
99 (cons (flet ((subfeature-in-list-p (subfeature)
100 (checked-feature-in-features-list-p subfeature list
)))
101 (ecase (first feature
)
102 (:or
(some #'subfeature-in-list-p
(rest feature
)))
103 (:and
(every #'subfeature-in-list-p
(rest feature
)))
104 (:not
(let ((rest (cdr feature
)))
105 (if (or (null (car rest
)) (cdr rest
))
106 (error "wrong number of terms in compound feature ~S"
108 (not (subfeature-in-list-p (second feature
)))))))))))
109 (compile 'checked-feature-in-features-list-p
)
111 (defun she-reader (stream sub-character infix-parameter
)
112 (when infix-parameter
113 (error "illegal read syntax: #~D~C" infix-parameter sub-character
))
114 (when (let* ((*package
* (find-package "KEYWORD"))
115 (*read-suppress
* nil
)
116 (notp (eql sub-character
#\-
))
117 (feature (read stream
)))
118 (if (checked-feature-in-features-list-p feature
*features
*)
121 (let ((*read-suppress
* t
))
122 (read stream t nil t
)))
124 (compile 'she-reader
)
126 ;;;; variables like *SHEBANG-FEATURES* but different
128 ;;; This variable is declared here (like *SHEBANG-FEATURES*) so that
129 ;;; things like chill.lisp work (because the variable has properties
130 ;;; similar to *SHEBANG-FEATURES*, and chill.lisp was set up to work
131 ;;; for that). For an explanation of what it really does, look
133 (export '*shebang-backend-subfeatures
*)
134 (declaim (type list
*shebang-backend-subfeatures
*))
135 (defvar *shebang-backend-subfeatures
*)
137 ;;;; string checker, for catching non-portability early
138 (defun make-quote-reader (standard-quote-reader)
139 (lambda (stream char
)
140 (let ((result (funcall standard-quote-reader stream char
)))
141 (unless (every (lambda (x) (typep x
'standard-char
)) result
)
142 (warn "Found non-STANDARD-CHAR in ~S" result
))
144 (compile 'make-quote-reader
)
146 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil
)))
148 ;;;; FIXME: Would it be worth implementing this?
150 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
151 ;;;; instead of leaving them to be skipped over at runtime
153 ;;; a counter of the number of bytes that we think we've avoided having to
154 ;;; compile into the system by virtue of doing compile-time processing
155 (defvar *shebang-double-quote--approx-bytes-saved
* 0)
157 ;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
158 ;;; and return the result. (This is a subset of the processing performed
159 ;;; by FORMAT, but we perform it at compile time instead of postponing
160 ;;; it until run-time.
161 (defun shebang-double-quote (stream)
162 (labels ((rc () (read-char stream
))
164 ;; Putting non-standard characters in the compiler source is
165 ;; generally a bad idea, since we'd like to be really portable.
166 ;; It's specifically a bad idea in strings intended to be
167 ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
168 ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
169 ;; (The most common problem would be to put a #\TAB -- which is
170 ;; not a STANDARD-CHAR -- into the string. If this is part of the
171 ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
172 ;; the string, it won't work, because it won't be recognized as
174 (unless (typep char
'standard-char
)
175 (warn "non-STANDARD-CHAR in #!\": ~C" result
))
176 (or (char= char
#\newline
)
177 (char= char
#\space
)))
179 (do ((char (rc) (rc))
180 (count 0 (1+ count
)))
181 ((not (white-p char
))
182 (unread-char char stream
)
184 (do ((adj-string (make-array 0 :element-type
'char
:adjustable t
))
186 ((char= char
#\") (coerce adj-string
'simple-string
))
187 (cond ((char= char
#\~
)
188 (let ((next-char (read-char stream
)))
189 (cond ((char= next-char
#\newline
)
190 (incf *shebang-double-quote--approx-bytes-saved
*
193 (vector-push-extend char adj-string
)
194 (vector-push-extend next-char adj-string
)))))
196 (vector-push-extend char adj-string
)
197 (vector-push-extend (rc) adj-string
))
198 (t (vector-push-extend char adj-string
))))))
200 (setf (gethash #\" *shebang-dispatch
*)
201 #'shebang-double-quote
)