[2d1cbf]: src / code / backq.lisp Maximize Restore History

Download this file

backq.lisp    272 lines (242 with data), 10.9 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
;;;; the backquote reader macro
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!IMPL")
(/show0 "entering backq.lisp")
;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
;;;
;;; |`,|: [a] => a
;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
;;; T: [a] => a ;the T flag is used when a is self-evaluating
;;; QUOTE: [a] => (QUOTE a)
;;; APPEND: [a] => (APPEND . a)
;;; NCONC: [a] => (NCONC . a)
;;; LIST: [a] => (LIST . a)
;;; LIST*: [a] => (LIST* . a)
;;;
;;; The flags are combined according to the following set of rules:
;;; ([a] means that a should be converted according to the previous table)
;;;
;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
;;;cdr \ || | T or NIL | |
;;;================================================================================
;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d])
;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
;;;
;;;<hair> involves starting over again pretending you had read ".,a)" instead
;;; of ",@a)"
(defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes")
(defvar *bq-comma-flag* '(|,|))
(defvar *bq-at-flag* '(|,@|))
(defvar *bq-dot-flag* '(|,.|))
(defvar *bq-vector-flag* '(|bqv|))
(defvar *bq-error* "Comma not inside a backquote.")
(/show0 "backq.lisp 50")
;;; the actual character macro
(defun backquote-macro (stream ignore)
(declare (ignore ignore))
(let ((*backquote-count* (1+ *backquote-count*)))
(multiple-value-bind (flag thing)
(backquotify stream (read stream t nil t))
(when (eq flag *bq-at-flag*)
(simple-reader-error stream ",@ after backquote in ~S" thing))
(when (eq flag *bq-dot-flag*)
(simple-reader-error stream ",. after backquote in ~S" thing))
(backquotify-1 flag thing))))
(/show0 "backq.lisp 64")
(defun comma-macro (stream ignore)
(declare (ignore ignore))
(unless (> *backquote-count* 0)
(when *read-suppress*
(return-from comma-macro nil))
(simple-reader-error stream *bq-error*))
(let ((c (read-char stream))
(*backquote-count* (1- *backquote-count*)))
(flet ((check (what)
(let ((x (peek-char t stream t nil t)))
(when (and (char= x #\)) (eq #'read-right-paren (get-macro-character #\))))
;; Easier to figure out than an "unmatched parenthesis".
(simple-reader-error stream "Trailing ~A in backquoted expression." what)))))
(cond ((char= c #\@)
(check "comma-at")
(cons *bq-at-flag* (read stream t nil t)))
((char= c #\.)
(check "comma-dot")
(cons *bq-dot-flag* (read stream t nil t)))
(t
(unread-char c stream)
(check "comma")
(cons *bq-comma-flag* (read stream t nil t)))))))
(/show0 "backq.lisp 83")
;;;
(defun expandable-backq-expression-p (object)
(and (consp object)
(let ((flag (car object)))
(or (eq flag *bq-at-flag*)
(eq flag *bq-dot-flag*)))))
(defun backquote-splice (method dflag a d what stream)
(cond (dflag
(values method
(cond ((eq dflag method)
(cons a d))
(t (list a (backquotify-1 dflag d))))))
((expandable-backq-expression-p a)
(values method (list a)))
((not (and (atom a) (backq-constant-p a)))
;; COMMA special cases a few constant atoms, which
;; are illegal in splices.
(comma a))
(t
(simple-reader-error stream "Invalid splice in backquote: ~A~A" what a))))
;;; This does the expansion from table 2.
(defun backquotify (stream code)
(cond ((atom code)
(cond ((null code) (values nil nil))
((or (consp code)
(symbolp code))
;; Keywords are self-evaluating. Install after packages.
(values 'quote code))
(t (values t code))))
((or (eq (car code) *bq-at-flag*)
(eq (car code) *bq-dot-flag*))
(values (car code) (cdr code)))
((eq (car code) *bq-comma-flag*)
(comma (cdr code)))
((eq (car code) *bq-vector-flag*)
(multiple-value-bind (dflag d) (backquotify stream (cdr code))
(values 'vector (backquotify-1 dflag d))))
(t (multiple-value-bind (aflag a) (backquotify stream (car code))
(multiple-value-bind (dflag d) (backquotify stream (cdr code))
(when (eq dflag *bq-at-flag*)
;; Get the errors later.
(simple-reader-error stream ",@ after dot in ~S" code))
(when (eq dflag *bq-dot-flag*)
(simple-reader-error stream ",. after dot in ~S" code))
(cond
((eq aflag *bq-at-flag*)
(backquote-splice 'append dflag a d ",@" stream))
((eq aflag *bq-dot-flag*)
(backquote-splice 'nconc dflag a d ",." stream))
((null dflag)
(if (member aflag '(quote t nil))
(values 'quote (list a))
(values 'list (list (backquotify-1 aflag a)))))
((member dflag '(quote t))
(if (member aflag '(quote t nil))
(values 'quote (cons a d ))
(values 'list* (list (backquotify-1 aflag a)
(backquotify-1 dflag d)))))
(t (setq a (backquotify-1 aflag a))
(if (member dflag '(list list*))
(values dflag (cons a d))
(values 'list*
(list a (backquotify-1 dflag d)))))))))))
(/show0 "backq.lisp 139")
(defun backq-constant-p (x)
(or (numberp x) (eq x t)))
;;; This handles the <hair> cases.
(defun comma (code)
(cond ((atom code)
(cond ((null code)
(values nil nil))
((backq-constant-p code)
(values t code))
(t
(values *bq-comma-flag* code))))
((and (eq (car code) 'quote)
(not (expandable-backq-expression-p (cadr code))))
(values (car code) (cadr code)))
((member (car code) '(append list list* nconc))
(values (car code) (cdr code)))
((eq (car code) 'cons)
(values 'list* (cdr code)))
(t (values *bq-comma-flag* code))))
(/show0 "backq.lisp 157")
;;; This handles table 1.
(defun backquotify-1 (flag thing)
(cond ((or (eq flag *bq-comma-flag*)
(member flag '(t nil)))
thing)
((eq flag 'quote)
(list 'quote thing))
((eq flag 'list*)
(cond ((and (null (cddr thing))
(not (expandable-backq-expression-p (car thing)))
(not (expandable-backq-expression-p (cadr thing))))
(cons 'backq-cons thing))
((expandable-backq-expression-p (car (last thing)))
(list 'backq-append
(cons 'backq-list (butlast thing))
;; Can it be optimized further? -- APD, 2001-12-21
(car (last thing))))
(t
(cons 'backq-list* thing))))
((eq flag 'vector)
(list 'backq-vector thing))
(t (cons (ecase flag
((list) 'backq-list)
((append) 'backq-append)
((nconc) 'backq-nconc))
thing))))
;;;; magic BACKQ- versions of builtin functions
(/show0 "backq.lisp 184")
;;; Define synonyms for the lisp functions we use, so that by using
;;; them, the backquoted material will be recognizable to the
;;; pretty-printer.
;;; These pass-through functions all have IR1 transforms whose signatures
;;; are more restrictive than &REST, so it's kind of weird to write
;;; (DEFUN BACKQ-CONS (&REST REST) (APPLY #'CONS REST))
;;; as was previously done.
;;; Better to say that pairs of symbols share functional bindings.
(macrolet ((def (b-name name)
`(setf (symbol-function ',b-name) #',name)))
(def backq-list list)
(def backq-list* list*)
(def backq-append append)
(def backq-nconc nconc)
(def backq-cons cons))
(/show0 "backq.lisp 204")
(defun backq-vector (list)
(declare (list list))
(coerce list 'simple-vector))
;;;; initialization
(/show0 "backq.lisp 212")
;;; Install BACKQ stuff in the current *READTABLE*.
;;;
;;; In the target Lisp, we have to wait to do this until the readtable
;;; has been created. In the cross-compilation host Lisp, we can do
;;; this right away. (You may ask: In the cross-compilation host,
;;; which already has its own implementation of the backquote
;;; readmacro, why do we do this at all? Because the cross-compilation
;;; host might -- as SBCL itself does -- express the backquote
;;; expansion in terms of internal, nonportable functions. By
;;; redefining backquote in terms of functions which are guaranteed to
;;; exist on the target Lisp, we ensure that backquote expansions in
;;; code-generating code work properly.)
(defun !backq-cold-init ()
(set-macro-character #\` #'backquote-macro)
(set-macro-character #\, #'comma-macro))
#+sb-xc-host (!backq-cold-init)
;;; The pretty-printer needs to know about our special tokens
(defvar *backq-tokens*
'(backq-comma backq-comma-at backq-comma-dot backq-list
backq-list* backq-append backq-nconc backq-cons backq-vector))
;;; Since our backquote is installed on the host lisp, and since
;;; developers make mistakes with backquotes and commas too, let's
;;; ensure that we can report errors rather than get an undefined
;;; function condition on SIMPLE-READER-ERROR.
#+sb-xc-host ; proper definition happens for the target
(defun simple-reader-error (stream format-string &rest format-args)
(bug "READER-ERROR on stream ~S: ~?" stream format-string format-args))
(/show0 "done with backq.lisp")