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

Contents of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Fri Jan 16 03:13:09 2004 UTC (10 years, 3 months ago) by toy
Branch: MAIN
CVS Tags: snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, mod-arith-base, amd64-merge-start, release-19a-base, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, snapshot-2004-04
Branch point for: mod-arith-branch, release-19a-branch
Changes since 1.11: +5 -2 lines
Fix for (pprint '`(lambda ,x)) bug wherein the backquote
implementation details leaks out.

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

  ViewVC Help
Powered by ViewVC 1.1.5