/[cmucl]/src/code/backq.lisp
ViewVC logotype

Contents of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Apr 20 17:57:43 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.16: +7 -7 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/backq.lisp,v 1.17 2010/04/20 17:57:43 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
13 ;;; (unparsing by Miles Bader)
14 ;;;
15 (in-package "LISP")
16
17 (intl:textdomain "cmucl")
18
19
20 ;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
21 ;;;
22 ;;; |`,|: [a] => a
23 ;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
24 ;;; T: [a] => a ;the T flag is used when a is self-evaluating
25 ;;; QUOTE: [a] => (QUOTE a)
26 ;;; APPEND: [a] => (APPEND . a)
27 ;;; NCONC: [a] => (NCONC . a)
28 ;;; LIST: [a] => (LIST . a)
29 ;;; LIST*: [a] => (LIST* . a)
30 ;;;
31 ;;; The flags are combined according to the following set of rules:
32 ;;; ([a] means that a should be converted according to the previous table)
33 ;;;
34 ;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
35 ;;;cdr \ || | T or NIL | |
36 ;;;================================================================================
37 ;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
38 ;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
39 ;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
40 ;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
41 ;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
42 ;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d])
43 ;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
44 ;;;
45 ;;;<hair> involves starting over again pretending you had read ".,a)" instead
46 ;;; of ",@a)"
47
48 (defvar *backquote-count* 0 "How deep we are into backquotes")
49 (defvar *bq-comma-flag* '(|,|))
50 (defvar *bq-at-flag* '(|,@|))
51 (defvar *bq-dot-flag* '(|,.|))
52 (defvar *bq-vector-flag* '(|bqv|))
53 (defvar *bq-tokens*
54 '(backq-comma backq-comma-at backq-comma-dot backq-list
55 backq-list* backq-append backq-nconc backq-cons backq-vector))
56
57 ;; This is the actual character macro.
58 (defun backquote-macro (stream ignore)
59 (declare (ignore ignore))
60 (let ((*backquote-count* (1+ *backquote-count*)))
61 (multiple-value-bind (flag thing)
62 (backquotify stream (read stream t nil t))
63 (if (eq flag *bq-at-flag*)
64 (%reader-error stream (intl:gettext ",@ after backquote in ~S") thing))
65 (if (eq flag *bq-dot-flag*)
66 (%reader-error stream (intl:gettext ",. after backquote in ~S") thing))
67 (values (backquotify-1 flag thing) 'list))))
68
69 (defun comma-macro (stream ignore)
70 (declare (ignore ignore))
71 (unless (> *backquote-count* 0)
72 (when *read-suppress*
73 (return-from comma-macro nil))
74 (%reader-error stream (intl:gettext "Comma not inside a backquote.")))
75 (let ((c (read-char stream))
76 (*backquote-count* (1- *backquote-count*)))
77 (values
78 (cond ((char= c #\@)
79 (cons *bq-at-flag* (read stream t nil t)))
80 ((char= c #\.)
81 (cons *bq-dot-flag* (read stream t nil t)))
82 (t (unread-char c stream)
83 (cons *bq-comma-flag* (read stream t nil t))))
84 'list)))
85
86 ;;;
87 (defun expandable-backq-expression-p (object)
88 (and (consp object)
89 (let ((flag (car object)))
90 (or (eq flag *bq-at-flag*)
91 (eq flag *bq-dot-flag*)))))
92
93
94 ;;; This does the expansion from table 2.
95 (defun backquotify (stream code)
96 (cond ((atom code)
97 (cond ((null code) (values nil nil))
98 ((or (consp code)
99 (symbolp code))
100 ;; Keywords are self evaluating. Install after packages.
101 (values 'quote code))
102 (t (values t code))))
103 ((or (eq (car code) *bq-at-flag*)
104 (eq (car code) *bq-dot-flag*))
105 (values (car code) (cdr code)))
106 ((eq (car code) *bq-comma-flag*)
107 (comma (cdr code)))
108 ((eq (car code) *bq-vector-flag*)
109 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
110 (values 'vector (backquotify-1 dflag d))))
111 (t (multiple-value-bind (aflag a) (backquotify stream (car code))
112 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
113 (if (eq dflag *bq-at-flag*)
114 ;; get the errors later.
115 (%reader-error stream (intl:gettext ",@ after dot in ~S") code))
116 (if (eq dflag *bq-dot-flag*)
117 (%reader-error stream (intl:gettext ",. after dot in ~S") code))
118 (cond
119 ((eq aflag *bq-at-flag*)
120 (if (null dflag)
121 (if (expandable-backq-expression-p a)
122 (values 'append (list a))
123 (comma a))
124 (values 'append
125 (cond ((eq dflag 'append)
126 (cons a d ))
127 (t (list a (backquotify-1 dflag d)))))))
128 ((eq aflag *bq-dot-flag*)
129 (if (null dflag)
130 (if (expandable-backq-expression-p a)
131 (values 'nconc (list a))
132 (comma a))
133 (values 'nconc
134 (cond ((eq dflag 'nconc)
135 (cons a d))
136 (t (list a (backquotify-1 dflag d)))))))
137 ((null dflag)
138 (if (memq aflag '(quote t nil))
139 (values 'quote (list a))
140 (values 'list (list (backquotify-1 aflag a)))))
141 ((memq dflag '(quote t))
142 (if (memq aflag '(quote t nil))
143 (values 'quote (cons a d ))
144 (values 'list* (list (backquotify-1 aflag a)
145 (backquotify-1 dflag d)))))
146 (t (setq a (backquotify-1 aflag a))
147 (if (memq dflag '(list list*))
148 (values dflag (cons a d))
149 (values 'list*
150 (list a (backquotify-1 dflag d)))))))))))
151
152 ;;; This handles the <hair> cases
153 (defun comma (code)
154 (cond ((atom code)
155 (cond ((null code)
156 (values nil nil))
157 ((or (numberp code) (eq code 't))
158 (values t code))
159 (t (values *bq-comma-flag* code))))
160 ((and (eq (car code) 'quote)
161 (not (expandable-backq-expression-p (cadr code))))
162 (values (car code) (cadr code)))
163 ((memq (car code) '(append list list* nconc))
164 (values (car code) (cdr code)))
165 ((eq (car code) 'cons)
166 (values 'list* (cdr code)))
167 (t (values *bq-comma-flag* code))))
168
169 ;;; This handles table 1.
170 (defun backquotify-1 (flag thing)
171 (cond ((or (eq flag *bq-comma-flag*)
172 (memq flag '(t nil)))
173 thing)
174 ((eq flag 'quote)
175 (list 'quote thing))
176 ((eq flag 'list*)
177 (cond ((and (null (cddr thing))
178 (not (expandable-backq-expression-p (cadr thing))))
179 (cons 'backq-cons thing))
180 ((expandable-backq-expression-p (car (last thing)))
181 (list 'backq-append
182 (cons 'backq-list (butlast thing))
183 ;; Can it be optimized further? -- APD, 2001-12-21
184 (car (last thing))))
185 (t
186 (cons 'backq-list* thing))))
187 ((eq flag 'vector)
188 (list 'backq-vector thing))
189 (t (cons (cdr
190 (assq flag
191 '((cons . backq-cons)
192 (list . backq-list)
193 (append . backq-append)
194 (nconc . backq-nconc))))
195 thing))))
196
197
198 ;;;; Magic backq- versions of builtin functions.
199
200 ;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
201 ;;; material when pretty-printing
202
203 (defun backq-list (&rest args)
204 args)
205 (defun backq-list* (&rest args)
206 (apply #'list* args))
207 (defun backq-append (&rest args)
208 (apply #'append args))
209 (defun backq-nconc (&rest args)
210 (apply #'nconc args))
211 (defun backq-cons (x y)
212 (cons x y))
213
214 (macrolet ((frob (b-name name)
215 `(define-compiler-macro ,b-name (&rest args)
216 `(,',name ,@args))))
217 (frob backq-list list)
218 (frob backq-list* list*)
219 (frob backq-append append)
220 (frob backq-nconc nconc)
221 (frob backq-cons cons))
222
223 (defun backq-vector (list)
224 (declare (list list))
225 (coerce list 'simple-vector))
226
227
228 ;;;; Unparsing
229
230 (defun backq-unparse-expr (form splicing)
231 (ecase splicing
232 ((nil)
233 `(backq-comma ,form))
234 ((t)
235 `((backq-comma-at ,form)))
236 (:nconc
237 `((backq-comma-dot ,form)))
238 ))
239
240 (defun backq-unparse (form &optional splicing)
241 "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
242 BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
243 corresponding backquote input form. In this form, `,' `,@' and `,.' are
244 represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
245 BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
246 SPLICING indicates whether a comma-escape return should be modified for
247 splicing with other forms: a value of T or :NCONC meaning that an extra
248 level of parentheses should be added."
249 (cond
250 ((atom form)
251 (backq-unparse-expr form splicing))
252 ((not (null (cdr (last form))))
253 (intl:gettext "### illegal dotted backquote form ###"))
254 (t
255 (case (car form)
256 (backq-list
257 (mapcar #'backq-unparse (cdr form)))
258 (backq-list*
259 (do ((tail (cdr form) (cdr tail))
260 (accum nil))
261 ((null (cdr tail))
262 (nconc (nreverse accum)
263 (backq-unparse (car tail) t)))
264 (push (backq-unparse (car tail)) accum)))
265 (backq-append
266 (mapcar #'(lambda (el) (backq-unparse el t))
267 (cdr form)))
268 (backq-nconc
269 (mapcar #'(lambda (el) (backq-unparse el :nconc))
270 (cdr form)))
271 (backq-cons
272 (cons (backq-unparse (cadr form) nil)
273 (backq-unparse (caddr form) t)))
274 (backq-vector
275 (coerce (backq-unparse (cadr form)) 'vector))
276 (quote
277 (cadr form))
278 (t
279 (backq-unparse-expr form splicing))))))
280
281 (defun pprint-backquote (stream form &rest noise)
282 (declare (ignore noise))
283 (write-char #\` stream)
284 (write (backq-unparse form) :stream stream))
285
286 (defun pprint-backq-comma (stream form &rest noise)
287 (declare (ignore noise))
288 (ecase (car form)
289 (backq-comma
290 (write-char #\, stream)
291 ;; We want to write ", @foo" and not ",@foo"! The latter is
292 ;; wrong if the variable is @foo. Same for ", .foo"; ",.foo"
293 ;; would be wrong if the symbol is .foo. Do we need to check for
294 ;; the symbol-package? If we don't we'll just put a space that
295 ;; isn't needed, so it seems harmless.
296 (when (symbolp (cadr form))
297 (let ((first-char (char (symbol-name (cadr form)) 0)))
298 (when (or (char= #\@ first-char)
299 (char= #\. first-char))
300 (write-char #\space stream)))))
301 (backq-comma-at
302 (princ ",@" stream))
303 (backq-comma-dot
304 (princ ",." stream)))
305 (write (cadr form) :stream stream))
306
307
308 ;;;; BACKQ-INIT and BACKQ-PP-INIT
309
310 (set-macro-character #\` #'backquote-macro)
311 (set-macro-character #\, #'comma-macro)
312
313 ;;; BACKQ-PP-INIT -- interface.
314 ;;;
315 ;;; This is called by PPRINT-INIT. This must be seperate from BACKQ-INIT
316 ;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
317 ;;;
318 (defun backq-pp-init ()
319 (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
320 (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
321 (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
322 (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
323 (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
324 (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
325
326 (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
327 (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
328 (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))

  ViewVC Help
Powered by ViewVC 1.1.5