1.0.12.37: RUN-PROGRAM now uses execvp(3) to search for executables
[sbcl.git] / 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 \f
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
18 ;;;; SBCL.)
19
20 ;;; the feature list for the target system
21 (export '*shebang-features*)
22 (declaim (type list *shebang-features*))
23 (defvar *shebang-features*)
24
25 (defun feature-in-list-p (feature list)
26   (etypecase feature
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"
36                                feature)
37                         (not (subfeature-in-list-p (second feature)))))))))))
38 (compile 'feature-in-list-p)
39
40 (defun shebang-reader (stream sub-character infix-parameter)
41   (declare (ignore sub-character))
42   (when infix-parameter
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"))
51                  (*read-suppress* nil)
52                  (not-p (char= next-char #\-))
53                  (feature (read stream)))
54             (if (feature-in-list-p feature *shebang-features*)
55                 not-p
56                 (not not-p)))
57       ;; Read (and discard) a form from input.
58       (let ((*read-suppress* t))
59         (read stream t nil t))))
60   (values))
61 (compile 'shebang-reader)
62
63 (set-dispatch-macro-character #\# #\! #'shebang-reader)
64 \f
65 ;;;; variables like *SHEBANG-FEATURES* but different
66
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
71 ;;; elsewhere.
72 (export '*shebang-backend-subfeatures*)
73 (declaim (type list *shebang-backend-subfeatures*))
74 (defvar *shebang-backend-subfeatures*)
75 \f
76 ;;;; string checker, for catching non-portability early
77 (defun make-quote-reader (standard-quote-reader)
78   (lambda (stream char)
79     (let ((result (funcall standard-quote-reader stream char)))
80       (unless (every (lambda (x) (typep x 'standard-char)) result)
81         (warn "Found non-STANDARD-CHAR in ~S" result))
82       result)))
83 (compile 'make-quote-reader)
84
85 (set-macro-character #\" (make-quote-reader (get-macro-character #\" nil)))
86 \f
87 ;;;; FIXME: Would it be worth implementing this?
88 #|
89 ;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
90 ;;;; instead of leaving them to be skipped over at runtime
91
92 ;;; a counter of the number of bytes that we think we've avoided having to
93 ;;; compile into the system by virtue of doing compile-time processing
94 (defvar *shebang-double-quote--approx-bytes-saved* 0)
95
96 ;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
97 ;;; and return the result. (This is a subset of the processing performed
98 ;;; by FORMAT, but we perform it at compile time instead of postponing
99 ;;; it until run-time.
100 (defun shebang-double-quote (stream)
101   (labels ((rc () (read-char stream))
102            (white-p (char)
103              ;; Putting non-standard characters in the compiler source is
104              ;; generally a bad idea, since we'd like to be really portable.
105              ;; It's specifically a bad idea in strings intended to be
106              ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
107              ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
108              ;; (The most common problem would be to put a #\TAB -- which is
109              ;; not a STANDARD-CHAR -- into the string. If this is part of the
110              ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
111              ;; the string, it won't work, because it won't be recognized as
112              ;; whitespace.)
113              (unless (typep char 'standard-char)
114                (warn "non-STANDARD-CHAR in #!\": ~C" result))
115              (or (char= char #\newline)
116                  (char= char #\space)))
117            (skip-white ()
118              (do ((char (rc) (rc))
119                   (count 0 (1+ count)))
120                  ((not (white-p char))
121                   (unread-char char stream)
122                   count))))
123     (do ((adj-string (make-array 0 :element-type 'char :adjustable t))
124          (char (rc) (rc)))
125         ((char= char #\") (coerce adj-string 'simple-string))
126       (cond ((char= char #\~)
127              (let ((next-char (read-char stream)))
128                (cond ((char= next-char #\newline)
129                       (incf *shebang-double-quote--approx-bytes-saved*
130                             (+ 2 (skip-white))))
131                      (t
132                       (vector-push-extend      char adj-string)
133                       (vector-push-extend next-char adj-string)))))
134             ((char= char #\\)
135              (vector-push-extend char adj-string)
136              (vector-push-extend (rc) adj-string))
137             (t (vector-push-extend char adj-string))))))
138
139 (setf (gethash #\" *shebang-dispatch*)
140       #'shebang-double-quote)
141 |#