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

Contents of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Mon Oct 14 21:37:57 2002 UTC (11 years, 6 months ago) by toy
Branch: MAIN
CVS Tags: snapshot-2003-10, release-18e-base, remove_negative_zero_not_zero, dynamic-extent-base, sparc_gencgc_merge, release-18e-pre2, cold-pcl-base, snapshot-2003-11, sparc_gencgc, snapshot-2003-12, release-18e, lisp-executable-base, release-18e-pre1
Branch point for: sparc_gencgc_branch, dynamic-extent, lisp-executable, release-18e-branch, cold-pcl
Changes since 1.10: +29 -10 lines
Port over SBCL's fix for the Entomotomy bug
backquote-over-eager-optimization.
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.11 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/backq.lisp,v 1.11 2002/10/14 21:37:57 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    
52     ;; This is the actual character macro.
53     (defun backquote-macro (stream ignore)
54     (declare (ignore ignore))
55     (let ((*backquote-count* (1+ *backquote-count*)))
56     (multiple-value-bind (flag thing)
57 ram 1.4 (backquotify stream (read stream t nil t))
58 ram 1.1 (if (eq flag *bq-at-flag*)
59 ram 1.4 (%reader-error stream ",@ after backquote in ~S" thing))
60 ram 1.1 (if (eq flag *bq-dot-flag*)
61 ram 1.4 (%reader-error stream ",. after backquote in ~S" thing))
62 ram 1.1 (values (backquotify-1 flag thing) 'list))))
63    
64     (defun comma-macro (stream ignore)
65     (declare (ignore ignore))
66     (unless (> *backquote-count* 0)
67     (when *read-suppress*
68     (return-from comma-macro nil))
69 ram 1.4 (%reader-error stream "Comma not inside a backquote."))
70 ram 1.1 (let ((c (read-char stream))
71     (*backquote-count* (1- *backquote-count*)))
72     (values
73     (cond ((char= c #\@)
74     (cons *bq-at-flag* (read stream t nil t)))
75     ((char= c #\.)
76     (cons *bq-dot-flag* (read stream t nil t)))
77     (t (unread-char c stream)
78     (cons *bq-comma-flag* (read stream t nil t))))
79     'list)))
80 wlott 1.3
81 toy 1.11 ;;;
82     (defun expandable-backq-expression-p (object)
83     (and (consp object)
84     (let ((flag (car object)))
85     (or (eq flag *bq-at-flag*)
86     (eq flag *bq-dot-flag*)))))
87    
88    
89 ram 1.1 ;;; This does the expansion from table 2.
90 ram 1.4 (defun backquotify (stream code)
91 ram 1.1 (cond ((atom code)
92     (cond ((null code) (values nil nil))
93 toy 1.11 ((or (consp code)
94     (symbolp code))
95 ram 1.1 ;; Keywords are self evaluating. Install after packages.
96 toy 1.11 (values 'quote code))
97     (t (values t code))))
98 ram 1.1 ((or (eq (car code) *bq-at-flag*)
99     (eq (car code) *bq-dot-flag*))
100     (values (car code) (cdr code)))
101     ((eq (car code) *bq-comma-flag*)
102     (comma (cdr code)))
103     ((eq (car code) *bq-vector-flag*)
104 ram 1.4 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
105 ram 1.1 (values 'vector (backquotify-1 dflag d))))
106 ram 1.4 (t (multiple-value-bind (aflag a) (backquotify stream (car code))
107     (multiple-value-bind (dflag d) (backquotify stream (cdr code))
108 ram 1.1 (if (eq dflag *bq-at-flag*)
109     ;; get the errors later.
110 ram 1.4 (%reader-error stream ",@ after dot in ~S" code))
111 ram 1.1 (if (eq dflag *bq-dot-flag*)
112 ram 1.4 (%reader-error stream ",. after dot in ~S" code))
113 ram 1.1 (cond
114     ((eq aflag *bq-at-flag*)
115     (if (null dflag)
116 toy 1.11 (if (expandable-backq-expression-p a)
117     (values 'append (list a))
118     (comma a))
119 ram 1.1 (values 'append
120     (cond ((eq dflag 'append)
121     (cons a d ))
122     (t (list a (backquotify-1 dflag d)))))))
123     ((eq aflag *bq-dot-flag*)
124     (if (null dflag)
125 toy 1.11 (if (expandable-backq-expression-p a)
126     (values 'nconc (list a))
127     (comma a))
128 ram 1.1 (values 'nconc
129     (cond ((eq dflag 'nconc)
130     (cons a d))
131     (t (list a (backquotify-1 dflag d)))))))
132     ((null dflag)
133     (if (memq aflag '(quote t nil))
134     (values 'quote (list a))
135     (values 'list (list (backquotify-1 aflag a)))))
136     ((memq dflag '(quote t))
137     (if (memq aflag '(quote t nil))
138     (values 'quote (cons a d ))
139     (values 'list* (list (backquotify-1 aflag a)
140     (backquotify-1 dflag d)))))
141     (t (setq a (backquotify-1 aflag a))
142     (if (memq dflag '(list list*))
143     (values dflag (cons a d))
144     (values 'list*
145     (list a (backquotify-1 dflag d)))))))))))
146    
147     ;;; This handles the <hair> cases
148     (defun comma (code)
149     (cond ((atom code)
150     (cond ((null code)
151     (values nil nil))
152     ((or (numberp code) (eq code 't))
153     (values t code))
154     (t (values *bq-comma-flag* code))))
155 toy 1.11 ((and (eq (car code) 'quote)
156     (not (expandable-backq-expression-p (cadr code))))
157 ram 1.1 (values (car code) (cadr code)))
158     ((memq (car code) '(append list list* nconc))
159     (values (car code) (cdr code)))
160     ((eq (car code) 'cons)
161     (values 'list* (cdr code)))
162     (t (values *bq-comma-flag* code))))
163    
164     ;;; This handles table 1.
165     (defun backquotify-1 (flag thing)
166     (cond ((or (eq flag *bq-comma-flag*)
167     (memq flag '(t nil)))
168     thing)
169     ((eq flag 'quote)
170     (list 'quote thing))
171     ((eq flag 'list*)
172 toy 1.11 (cond ((and (null (cddr thing))
173     (not (expandable-backq-expression-p (cadr thing))))
174 wlott 1.3 (cons 'backq-cons thing))
175 toy 1.11 ((expandable-backq-expression-p (car (last thing)))
176     (list 'backq-append
177     (cons 'backq-list (butlast thing))
178     ;; Can it be optimized further? -- APD, 2001-12-21
179     (car (last thing))))
180     (t
181 wlott 1.3 (cons 'backq-list* thing))))
182 ram 1.1 ((eq flag 'vector)
183 wlott 1.3 (list 'backq-vector thing))
184 ram 1.1 (t (cons (cdr
185     (assq flag
186 wlott 1.3 '((cons . backq-cons)
187     (list . backq-list)
188     (append . backq-append)
189     (nconc . backq-nconc))))
190 ram 1.1 thing))))
191    
192 wlott 1.3
193     ;;;; Magic backq- versions of builtin functions.
194 ram 1.1
195 wlott 1.3 ;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
196     ;;; material when pretty-printing
197 ram 1.5
198 wlott 1.3 (defun backq-list (&rest args)
199     args)
200     (defun backq-list* (&rest args)
201     (apply #'list* args))
202     (defun backq-append (&rest args)
203     (apply #'append args))
204     (defun backq-nconc (&rest args)
205     (apply #'nconc args))
206     (defun backq-cons (x y)
207     (cons x y))
208 ram 1.6
209     (macrolet ((frob (b-name name)
210     `(define-compiler-macro ,b-name (&rest args)
211     `(,',name ,@args))))
212     (frob backq-list list)
213     (frob backq-list* list*)
214     (frob backq-append append)
215     (frob backq-nconc nconc)
216     (frob backq-cons cons))
217    
218 wlott 1.3 (defun backq-vector (list)
219 ram 1.6 (declare (list list))
220     (coerce list 'simple-vector))
221 ram 1.1
222 wlott 1.3
223     ;;;; Unparsing
224    
225     (defun backq-unparse-expr (form splicing)
226     (ecase splicing
227     ((nil)
228     `(backq-comma ,form))
229     ((t)
230     `((backq-comma-at ,form)))
231     (:nconc
232     `((backq-comma-dot ,form)))
233     ))
234    
235     (defun backq-unparse (form &optional splicing)
236     "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
237     BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
238     corresponding backquote input form. In this form, `,' `,@' and `,.' are
239     represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
240     BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
241     SPLICING indicates whether a comma-escape return should be modified for
242     splicing with other forms: a value of T or :NCONC meaning that an extra
243     level of parentheses should be added."
244 ram 1.7 (cond
245     ((atom form)
246     (backq-unparse-expr form splicing))
247     ((not (null (cdr (last form))))
248     "### illegal dotted backquote form ###")
249     (t
250     (case (car form)
251     (backq-list
252     (mapcar #'backq-unparse (cdr form)))
253     (backq-list*
254     (do ((tail (cdr form) (cdr tail))
255     (accum nil))
256     ((null (cdr tail))
257     (nconc (nreverse accum)
258     (backq-unparse (car tail) t)))
259     (push (backq-unparse (car tail)) accum)))
260     (backq-append
261     (mapcan #'(lambda (el) (backq-unparse el t))
262     (cdr form)))
263     (backq-nconc
264     (mapcan #'(lambda (el) (backq-unparse el :nconc))
265     (cdr form)))
266     (backq-cons
267     (cons (backq-unparse (cadr form) nil)
268     (backq-unparse (caddr form) t)))
269     (backq-vector
270     (coerce (backq-unparse (cadr form)) 'vector))
271     (quote
272     (cadr form))
273     (t
274     (backq-unparse-expr form splicing))))))
275 wlott 1.3
276     (defun pprint-backquote (stream form &rest noise)
277     (declare (ignore noise))
278     (write-char #\` stream)
279     (write (backq-unparse form) :stream stream))
280    
281     (defun pprint-backq-comma (stream form &rest noise)
282     (declare (ignore noise))
283     (ecase (car form)
284     (backq-comma
285     (write-char #\, stream))
286     (backq-comma-at
287     (princ ",@" stream))
288     (backq-comma-dot
289     (princ ",." stream)))
290     (write (cadr form) :stream stream))
291    
292    
293     ;;;; BACKQ-INIT and BACKQ-PP-INIT
294    
295 ram 1.8 (set-macro-character #\` #'backquote-macro)
296     (set-macro-character #\, #'comma-macro)
297 wlott 1.3
298     ;;; BACKQ-PP-INIT -- interface.
299     ;;;
300     ;;; This is called by PPRINT-INIT. This must be seperate from BACKQ-INIT
301     ;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
302     ;;;
303     (defun backq-pp-init ()
304     (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
305     (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
306     (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
307     (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
308     (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
309     (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
310    
311     (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
312     (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
313     (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))

  ViewVC Help
Powered by ViewVC 1.1.5