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

Contents of /src/code/backq.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Fri Aug 14 01:34:40 1992 UTC (21 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.5: +13 -5 lines
Changed backq-list, etc., from being inline functions to compiler-macros, since
although the optimizer does eventually get the right code, it has to work awful
hard.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/backq.lisp,v 1.6 1992/08/14 01:34:40 ram Exp $")
11 ram 1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; BACKQUOTE: Code Spice Lispified by Lee Schumacher.
15 wlott 1.3 ;;; (unparsing by Miles Bader)
16 ram 1.1 ;;;
17     (in-package 'lisp)
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    
54     ;; This is the actual character macro.
55     (defun backquote-macro (stream ignore)
56     (declare (ignore ignore))
57     (let ((*backquote-count* (1+ *backquote-count*)))
58     (multiple-value-bind (flag thing)
59 ram 1.4 (backquotify stream (read stream t nil t))
60 ram 1.1 (if (eq flag *bq-at-flag*)
61 ram 1.4 (%reader-error stream ",@ after backquote in ~S" thing))
62 ram 1.1 (if (eq flag *bq-dot-flag*)
63 ram 1.4 (%reader-error stream ",. after backquote in ~S" thing))
64 ram 1.1 (values (backquotify-1 flag thing) 'list))))
65    
66     (defun comma-macro (stream ignore)
67     (declare (ignore ignore))
68     (unless (> *backquote-count* 0)
69     (when *read-suppress*
70     (return-from comma-macro nil))
71 ram 1.4 (%reader-error stream "Comma not inside a backquote."))
72 ram 1.1 (let ((c (read-char stream))
73     (*backquote-count* (1- *backquote-count*)))
74     (values
75     (cond ((char= c #\@)
76     (cons *bq-at-flag* (read stream t nil t)))
77     ((char= c #\.)
78     (cons *bq-dot-flag* (read stream t nil t)))
79     (t (unread-char c stream)
80     (cons *bq-comma-flag* (read stream t nil t))))
81     'list)))
82 wlott 1.3
83 ram 1.1 ;;; This does the expansion from table 2.
84 ram 1.4 (defun backquotify (stream code)
85 ram 1.1 (cond ((atom code)
86     (cond ((null code) (values nil nil))
87     ((or (numberp code)
88     (eq code t))
89     ;; Keywords are self evaluating. Install after packages.
90     (values t code))
91     (t (values 'quote code))))
92     ((or (eq (car code) *bq-at-flag*)
93     (eq (car code) *bq-dot-flag*))
94     (values (car code) (cdr code)))
95     ((eq (car code) *bq-comma-flag*)
96     (comma (cdr code)))
97     ((eq (car code) *bq-vector-flag*)
98 ram 1.4 (multiple-value-bind (dflag d) (backquotify stream (cdr code))
99 ram 1.1 (values 'vector (backquotify-1 dflag d))))
100 ram 1.4 (t (multiple-value-bind (aflag a) (backquotify stream (car code))
101     (multiple-value-bind (dflag d) (backquotify stream (cdr code))
102 ram 1.1 (if (eq dflag *bq-at-flag*)
103     ;; get the errors later.
104 ram 1.4 (%reader-error stream ",@ after dot in ~S" code))
105 ram 1.1 (if (eq dflag *bq-dot-flag*)
106 ram 1.4 (%reader-error stream ",. after dot in ~S" code))
107 ram 1.1 (cond
108     ((eq aflag *bq-at-flag*)
109     (if (null dflag)
110     (comma a)
111     (values 'append
112     (cond ((eq dflag 'append)
113     (cons a d ))
114     (t (list a (backquotify-1 dflag d)))))))
115     ((eq aflag *bq-dot-flag*)
116     (if (null dflag)
117     (comma a)
118     (values 'nconc
119     (cond ((eq dflag 'nconc)
120     (cons a d))
121     (t (list a (backquotify-1 dflag d)))))))
122     ((null dflag)
123     (if (memq aflag '(quote t nil))
124     (values 'quote (list a))
125     (values 'list (list (backquotify-1 aflag a)))))
126     ((memq dflag '(quote t))
127     (if (memq aflag '(quote t nil))
128     (values 'quote (cons a d ))
129     (values 'list* (list (backquotify-1 aflag a)
130     (backquotify-1 dflag d)))))
131     (t (setq a (backquotify-1 aflag a))
132     (if (memq dflag '(list list*))
133     (values dflag (cons a d))
134     (values 'list*
135     (list a (backquotify-1 dflag d)))))))))))
136    
137     ;;; This handles the <hair> cases
138     (defun comma (code)
139     (cond ((atom code)
140     (cond ((null code)
141     (values nil nil))
142     ((or (numberp code) (eq code 't))
143     (values t code))
144     (t (values *bq-comma-flag* code))))
145     ((eq (car code) 'quote)
146     (values (car code) (cadr code)))
147     ((memq (car code) '(append list list* nconc))
148     (values (car code) (cdr code)))
149     ((eq (car code) 'cons)
150     (values 'list* (cdr code)))
151     (t (values *bq-comma-flag* code))))
152    
153     ;;; This handles table 1.
154     (defun backquotify-1 (flag thing)
155     (cond ((or (eq flag *bq-comma-flag*)
156     (memq flag '(t nil)))
157     thing)
158     ((eq flag 'quote)
159     (list 'quote thing))
160     ((eq flag 'list*)
161     (cond ((null (cddr thing))
162 wlott 1.3 (cons 'backq-cons thing))
163     (t
164     (cons 'backq-list* thing))))
165 ram 1.1 ((eq flag 'vector)
166 wlott 1.3 (list 'backq-vector thing))
167 ram 1.1 (t (cons (cdr
168     (assq flag
169 wlott 1.3 '((cons . backq-cons)
170     (list . backq-list)
171     (append . backq-append)
172     (nconc . backq-nconc))))
173 ram 1.1 thing))))
174    
175 wlott 1.3
176     ;;;; Magic backq- versions of builtin functions.
177 ram 1.1
178 wlott 1.3 ;;; Use synonyms for the lisp functions we use, so we can recognize backquoted
179     ;;; material when pretty-printing
180 ram 1.5
181 wlott 1.3 (defun backq-list (&rest args)
182     args)
183     (defun backq-list* (&rest args)
184     (apply #'list* args))
185     (defun backq-append (&rest args)
186     (apply #'append args))
187     (defun backq-nconc (&rest args)
188     (apply #'nconc args))
189     (defun backq-cons (x y)
190     (cons x y))
191 ram 1.6
192     (macrolet ((frob (b-name name)
193     `(define-compiler-macro ,b-name (&rest args)
194     `(,',name ,@args))))
195     (frob backq-list list)
196     (frob backq-list* list*)
197     (frob backq-append append)
198     (frob backq-nconc nconc)
199     (frob backq-cons cons))
200    
201 wlott 1.3 (defun backq-vector (list)
202 ram 1.6 (declare (list list))
203     (coerce list 'simple-vector))
204 ram 1.1
205 wlott 1.3
206     ;;;; Unparsing
207    
208     (defun backq-unparse-expr (form splicing)
209     (ecase splicing
210     ((nil)
211     `(backq-comma ,form))
212     ((t)
213     `((backq-comma-at ,form)))
214     (:nconc
215     `((backq-comma-dot ,form)))
216     ))
217    
218     (defun backq-unparse (form &optional splicing)
219     "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
220     BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
221     corresponding backquote input form. In this form, `,' `,@' and `,.' are
222     represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
223     BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
224     SPLICING indicates whether a comma-escape return should be modified for
225     splicing with other forms: a value of T or :NCONC meaning that an extra
226     level of parentheses should be added."
227     (if (atom form)
228     (backq-unparse-expr form splicing)
229     (case (car form)
230     (backq-list
231     (mapcar #'backq-unparse (cdr form)))
232     (backq-list*
233     (do ((tail (cdr form) (cdr tail))
234     (accum nil))
235     ((null (cdr tail))
236     (nconc (nreverse accum)
237     (backq-unparse (car tail) t)))
238     (push (backq-unparse (car tail)) accum)))
239     (backq-append
240     (mapcan #'(lambda (el) (backq-unparse el t))
241     (cdr form)))
242     (backq-nconc
243     (mapcan #'(lambda (el) (backq-unparse el :nconc))
244     (cdr form)))
245     (backq-cons
246     (cons (backq-unparse (cadr form) nil)
247     (backq-unparse (caddr form) t)))
248     (backq-vector
249     (coerce (backq-unparse (cadr form)) 'vector))
250     (quote
251     (cadr form))
252     (t
253     (backq-unparse-expr form splicing)))))
254    
255     (defun pprint-backquote (stream form &rest noise)
256     (declare (ignore noise))
257     (write-char #\` stream)
258     (write (backq-unparse form) :stream stream))
259    
260     (defun pprint-backq-comma (stream form &rest noise)
261     (declare (ignore noise))
262     (ecase (car form)
263     (backq-comma
264     (write-char #\, stream))
265     (backq-comma-at
266     (princ ",@" stream))
267     (backq-comma-dot
268     (princ ",." stream)))
269     (write (cadr form) :stream stream))
270    
271    
272     ;;;; BACKQ-INIT and BACKQ-PP-INIT
273    
274     ;;; BACKQ-INIT -- interface.
275     ;;;
276     ;;; This is called by %INITIAL-FUNCTION.
277     ;;;
278 ram 1.1 (defun backq-init ()
279     (let ((*readtable* std-lisp-readtable))
280     (set-macro-character #\` #'backquote-macro)
281     (set-macro-character #\, #'comma-macro)))
282 wlott 1.3
283     ;;; BACKQ-PP-INIT -- interface.
284     ;;;
285     ;;; This is called by PPRINT-INIT. This must be seperate from BACKQ-INIT
286     ;;; because SET-PPRINT-DISPATCH doesn't work until the compiler is loaded.
287     ;;;
288     (defun backq-pp-init ()
289     (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
290     (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
291     (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
292     (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
293     (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
294     (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
295    
296     (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
297     (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
298     (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))

  ViewVC Help
Powered by ViewVC 1.1.5