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
)
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"
37 (not (subfeature-in-list-p (second feature
)))))))))))
38 (compile 'feature-in-list-p
)
40 (defun shebang-reader (stream sub-character infix-parameter
)
41 (declare (ignore sub-character
))
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"))
52 (not-p (char= next-char
#\-
))
53 (feature (read stream
)))
54 (if (feature-in-list-p feature
*shebang-features
*)
57 ;; Read (and discard) a form from input.
58 (let ((*read-suppress
* t
))
59 (read stream t nil t
))))
61 (compile 'shebang-reader
)
63 (set-dispatch-macro-character #\
# #\
! #'shebang-reader
)
65 ;;;; variables like *SHEBANG-FEATURES* but different
67 ;;; This variable is declared here (like *SHEBANG-FEATURES*) so that
68 ;;; things like chill.lisp work (because the variable has properties
69 ;;; similar to *SHEBANG-FEATURES*, and chill.lisp was set up to work
70 ;;; for that). For an explanation of what it really does, look
72 (export '*shebang-backend-subfeatures
*)
73 (declaim (type list
*shebang-features
*))
74 (defvar *shebang-backend-subfeatures
*)
76 ;;;; FIXME: Would it be worth implementing this?
78 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
79 ;;;; instead of leaving them to be skipped over at runtime
81 ;;; a counter of the number of bytes that we think we've avoided having to
82 ;;; compile into the system by virtue of doing compile-time processing
83 (defvar *shebang-double-quote--approx-bytes-saved
* 0)
85 ;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
86 ;;; and return the result. (This is a subset of the processing performed
87 ;;; by FORMAT, but we perform it at compile time instead of postponing
88 ;;; it until run-time.
89 (defun shebang-double-quote (stream)
90 (labels ((rc () (read-char stream
))
92 ;; Putting non-standard characters in the compiler source is
93 ;; generally a bad idea, since we'd like to be really portable.
94 ;; It's specifically a bad idea in strings intended to be
95 ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
96 ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
97 ;; (The most common problem would be to put a #\TAB -- which is
98 ;; not a STANDARD-CHAR -- into the string. If this is part of the
99 ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
100 ;; the string, it won't work, because it won't be recognized as
102 (unless (typep char
'standard-char
)
103 (warn "non-STANDARD-CHAR in #!\": ~C" result
))
104 (or (char= char
#\newline
)
105 (char= char
#\space
)))
107 (do ((char (rc) (rc))
108 (count 0 (1+ count
)))
109 ((not (white-p char
))
110 (unread-char char stream
)
112 (do ((adj-string (make-array 0 :element-type
'char
:adjustable t
))
114 ((char= char
#\") (coerce adj-string
'simple-string
))
115 (cond ((char= char
#\~
)
116 (let ((next-char (read-char stream
)))
117 (cond ((char= next-char
#\newline
)
118 (incf *shebang-double-quote--approx-bytes-saved
*
121 (vector-push-extend char adj-string
)
122 (vector-push-extend next-char adj-string
)))))
124 (vector-push-extend char adj-string
)
125 (vector-push-extend (rc) adj-string
))
126 (t (vector-push-extend char adj-string
))))))
128 (setf (gethash #\" *shebang-dispatch
*)
129 #'shebang-double-quote
)