source: branches/qres/ccl/lib/backquote.lisp @ 14172

Last change on this file since 14172 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.0 KB
Line 
1; -*- Mode:Lisp; Package:CCL; -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15
16; Backquote.lisp
17
18(in-package "CCL")
19
20#+nil
21(progn
22;;; Common Lisp backquote implementation, written in Common Lisp.
23;;; Author: Guy L. Steele Jr.     Date: 27 December 1985
24;;; Texted under Symbolics Common Lisp and Lucid Common Lisp.
25;;; This software is in the public domain.
26
27;;; The following are unique tokens used during processing
28;;; They need not be symbols; they need not even be atoms.
29
30(defvar *comma* (make-symbol "`,"))
31(defvar *comma-atsign* (make-symbol "`,@"))
32(defvar *comma-dot* (make-symbol "`,."))
33(defvar *bq-list* (make-symbol "BQ-LIST"))
34(defvar *bq-append* (make-symbol "BQ-APPEND"))
35(defvar *bq-list** (make-symbol "BQ-LIST*"))
36(defvar *bq-nconc* (make-symbol "BQ-NCONC"))
37(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
38(defvar *bq-quote* (make-symbol "BQ-QUOTE"))
39(defvar *bq-quote-nil* (list *bq-quote* nil))
40
41;;; Reader macro characters:
42;;;    `foo is read in as (BACKQUOTE foo)
43;;;    ,foo is read in as (#:COMMA foo)
44;;;    ,@foo is read in as (#:COMMA-ATSIGN foo)
45;;;    ,.foo is read in as (#:COMMA-DOT foo)
46;;; where #:COMMA is the value of the variable *COMMA* etc.
47
48;;; BACKQUOTE is an ordinary macro (not a read-macro) that
49;;; processes the expression foo, looking for occurrences of
50;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code
51;;; in strict accordance with the rules on pages 349-350 of
52;;; of the first edition (pages 528-529 of this second edition).
53;;; It then optionally applies a code simplifier.
54
55(set-macro-character #\`
56                     #'(lambda (stream char)
57                         (declare (ignore char))
58                         (list 'backquote (read stream t nil t))))
59
60(set-macro-character #\,
61                     #'(lambda (stream char)
62                         (declare (ignore char))
63                         (case (peek-char nil stream t nil t)
64                           (#\@ (read-char stream t nil t)
65                            (list *comma-atsign* (read stream t nil t)))
66                           (#\. (read-char stream t nil t)
67                            (list *comma-dot* (read stream t nil t)))
68                           (otherwise (list *comma* (read stream t nil t))))))
69
70;;; if the value of *BQ-SIMPLIFY* is non-nil, then BACKQUOTE
71;;; processing applies the code simplifier.  If the value is NIL,
72;;; then the code resulting from BACKQUOTE is exactly that
73;;; specified by the official rules.
74
75(defvar *bq-simplify* t)
76
77(defmacro backquote (x)
78  (bq-completely-process x))
79
80;;; Backquote processing proceeds in three stages:
81;;;
82;;; (1) BQ-PROCESS applies the rules to remove occurrences of
83;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
84;;; this level of BACKQUOTE.  (It also causes embedded calls to
85;;; BACKQUOTE to be expanded so that nesting is properly handled.)
86;;; Code is produced that is expressed in terms of functions
87;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
88;;; so that the simplifier will simplify only list construction
89;;; functions actually generated by backquote and will not involve
90;;; any user code in the simplification.   #:BQ-LIST means LIST,
91;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
92;;; but indicates places where ",." was used and where NCONC may
93;;; therefore be introduced by the simplifier for efficiency.
94;;;
95;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
96;;; BQ-PROCESS to produce equivalent but faster code.  The
97;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
98;;; introduced into the code.
99;;;
100;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
101;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
102;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
103;;; replaced by its argument).  #:BQ-LIST* is replaced by either
104;;; LIST* or CONS (the latter is used in the two-argument case,
105;;; purely to make the resulting code a tad more readable).
106
107(defun bq-completely-process (x)
108  (let ((raw-result (bq-process x)))
109    (bq-remove-tokens (if *bq-simplify*
110                        (bq-simplify raw-result)
111                        raw-result))))
112
113; Portable code could just say (coerce list 'vector)
114(defun list-to-vector (list)
115  (unless (listp list)
116    (setq list (require-type list 'list)))
117  (%list-to-uvector nil list))
118
119(define-compiler-macro list-to-vector (&whole whole form)
120  (if (quoted-form-p form)
121    (list-to-vector (cadr form))
122    whole))
123
124(defun bq-process (x)
125  (cond ((atom x)
126         (if (simple-vector-p x)
127           (list 'list-to-vector (bq-process (coerce x 'list)))
128           (list *bq-quote* x)))
129        ((eq (car x) 'backquote)
130         (bq-process (bq-completely-process (cadr x))))
131        ((eq (car x) *comma*) (cadr x))
132        ((eq (car x) *comma-atsign*)
133         (error ",@~S after `" (cadr x)))
134        ((eq (car x) *comma-dot*)
135         (error ",.~S after `" (cadr x)))
136        (t (do ((p x (cdr p))
137                (q '() (cons (bracket (car p)) q)))
138               ((atom p)
139                (cons *bq-append*
140                      (nreconc q (list (list *bq-quote* p)))))
141             (when (eq (car p) *comma*)
142               (unless (null (cddr p)) (error "Malformed ,~S" p))
143               (return (cons *bq-append*
144                             (nreconc q (list (cadr p))))))
145             (when (eq (car p) *comma-atsign*)
146               (error "Dotted ,@~S" p))
147             (when (eq (car p) *comma-dot*)
148               (error "Dotted ,.~S" p))))))
149
150;;; This implements the bracket operator of the formal rules
151
152(defun bracket (x)
153  (cond ((atom x)
154         (list *bq-list* (bq-process x)))
155        ((eq (car x) *comma*)
156         (list *bq-list* (cadr x)))
157        ((eq (car x) *comma-atsign*)
158         (cadr x))
159        ((eq (car x) *comma-dot*)
160         (list *bq-clobberable* (cadr x)))
161        (t (list *bq-list* (bq-process x)))))
162
163;;; This auxiliary function is like MAPCAR but has two extra
164;;; purpoess: (1) it handles dotted lists; (2) it tries to make
165;;; the result share with the argument x as much as possible.
166
167(defun maptree (fn x)
168  (if (atom x)
169    (funcall fn x)
170    (let ((a (funcall fn (car x)))
171          (d (maptree fn (cdr x))))
172      (if (and (eql a (car x)) (eql d (cdr x)))
173        x
174        (cons a d)))))
175
176;;; This predicate is true of a form that when read looked
177;;; like ,@foo or ,.foo
178
179(defun bq-splicing-frob (x)
180  (and (consp x)
181       (or (eq (car x) *comma-atsign*)
182           (eq (car x) *comma-dot*))))
183
184;;; This predicate is true of a form that when read
185;;; looked like ,@foo or just plain ,foo.
186
187(defun bq-frob (x)
188  (and (consp x)
189       (or (eq (car x) *comma*)
190           (eq (car x) *comma-atsign*)
191           (eq (car x) *comma-dot*))))
192
193;;; The simplifier essentially looks for calls to #:BQ-APPEND and
194;;; tries to simplify them.  The arguments to #:BQ-APPEND are
195;;; processed from right to left, building up a replacement for.
196;;; At each step a number of special cases are handled that,
197;;; loosely speaking, look like this:
198;;;
199;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo)
200;;;   provided a, b, c are not splicing frobs
201;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
202;;;   provided a, b, c are not splicing frobs
203;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
204;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
205
206(defun bq-simplify (x)
207  (if (atom x)
208    x
209    (let ((x (if (eq (car x) *bq-quote*)
210               x
211               (maptree #'bq-simplify x))))
212      (if (not (eq (car x) *bq-append*))
213        x
214        (bq-simplify-args x)))))
215
216(defun bq-simplify-args (x)
217  (do ((args (reverse (cdr x)) (cdr args))
218       (result
219        nil
220        (cond ((atom (car args))
221               (bq-attach-append *bq-append* (car args) result))
222              ((and (eq (caar args) *bq-list*)
223                    (notany #'bq-splicing-frob (cdar args)))
224               (bq-attach-conses (cdar args) result))
225              ((and (eq (caar args) *bq-list**)
226                    (notany #'bq-splicing-frob (cdar args)))
227               (bq-attach-conses
228                (reverse (cdr (reverse (cdar args))))
229                (bq-attach-append *bq-append*
230                                  (car (last (car args)))
231                                  result)))
232              ((and (eq (caar args) *bq-quote*)
233                    (consp (cadar args))
234                    (not (bq-frob (cadar args)))
235                    (null (cddar args)))
236               (bq-attach-conses (list (list *bq-quote*
237                                             (caadar args)))
238                                 result))
239              ((eq (caar args) *bq-clobberable*)
240               (bq-attach-append *bq-nconc* (cadar args) result))
241              (t (bq-attach-append *bq-append*
242                                   (car args)
243                                   result)))))
244      ((null args) result)))
245
246(defun null-or-quoted (x)
247  (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
248
249;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
250;;; or #:BQ-NCONC.  This produces a form (op item result) but
251;;; some simplifications are done on the fly:
252;;;
253;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
254;;;  (op item 'nil) => item, provided item is not a splicable frob
255;;;  (op item 'nil) => (op item), if item is a splicable frob
256;;;  (op item (op a b c)) => (op item a b c)
257
258(defun bq-attach-append (op item result)
259  (cond ((and (null-or-quoted item) (null-or-quoted result))
260         (list *bq-quote* (append (cadr item) (cadr result))))
261        ((or (null result) (equal result *bq-quote-nil*))
262         (if (bq-splicing-frob item) (list op item) item))
263        ((and (consp result) (eq (car result) op))
264         (list* (car result) item (cdr result)))
265        (t (list op item result))))
266
267;;; The effec tof BQ-ATTACH-CONSES is to produce a form as if by
268;;; `(LIST* ,@items ,result) but some simplifications are done
269;;; on the fly.
270;;;
271;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
272;;;  (LIST* a b c 'nil) => (LIST a b c)
273;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
274;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
275
276(defun bq-attach-conses (items result)
277  (cond ((and (every #'null-or-quoted items)
278              (null-or-quoted result))
279         (list *bq-quote*
280               (append (mapcar #'cadr items) (cadr result))))
281        ((or (null result) (equal result *bq-quote-nil*))
282         (cons *bq-list* items))
283        ((and (consp result)
284              (or (eq (car result) *Bq-list*)
285                  (eq (car result) *bq-list**)))
286         (cons (car result) (append items (cdr result))))
287        (t (cons *bq-list** (append items (list result))))))
288
289;;; Removes funny toeksn and changes (#:BQ-LIST* a b) into
290;;; (CONS a b) instead of (LIST* a b), purely for readability.
291
292(defun bq-remove-tokens (x)
293  (cond ((eq x *bq-list*) 'list)
294        ((eq x *bq-append*) 'append)
295        ((eq x *bq-nconc*) 'nconc)
296        ((eq x *bq-list**) 'list*)
297        ((eq x *bq-quote*) 'quote)
298        ((atom x) x)
299        ((eq (car x) *bq-clobberable*)
300         (bq-remove-tokens (cadr x)))
301        ((and (eq (car x) *bq-list**)
302              (consp (cddr x))
303              (null (cdddr x)))
304         (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
305        (t (maptree #'bq-remove-tokens x))))
306
307)
308
309#-nil
310(progn
311(declaim (special *|`,|* *|`,.|* *|`,@|*))
312
313;;;Backquote reads in as a call to the BACKQUOTE-EXPANDER macro.
314;;;This makes it a little obscure to look at raw, but makes it possible for
315;;;the pretty-printer to print things read in with backquote.
316
317(defvar *backquote-expand* t "If non-NIL, expand at read-time")
318
319(defmacro backquote-expander (*|`,|* *|`,.|* *|`,@|* form)
320   (declare (special *|`,|* *|`,.|* *|`,@|*))
321   (multiple-value-bind (form constantp) (backquote-aux form)
322     (backq-form form constantp)))
323
324(defun backquote-aux (form)
325  ;;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up
326  ;;to the compiler.  The code here is mainly concerned with folding
327  ;;constants, since the compiler is not allowed to do that in general.
328  (cond
329   ((simple-vector-p form)
330    (let ((elts ()) (i (length form)))
331      (until (%izerop i) (push (svref form (setq i (%i- i 1))) elts))
332      (multiple-value-bind (elts quotedp) (backquote-aux elts)
333        (if quotedp
334          (values (list-to-vector elts) t)
335          (list 'list-to-vector elts)))))
336   ((self-evaluating-p form) (values form t))
337   ((atom form) (values form t))
338   ((eq (%car form) 'backquote-expander) (backquote-aux (macroexpand-1 form)))
339   ((eq (%car form) *|`,|*) (%cdr form))
340   ((eq (%car form) *|`,@|*) (error "Misplaced ,@~S after backquote" (%cdr form)))
341   ((eq (%car form) *|`,.|*) (error "Misplaced ,.~S after backquote" (%cdr form)))
342   (t (let* ((car (%car form))
343             (splice (and (consp car) (if (eq (%car car) *|`,@|*) 'append
344                                        (if (eq (%car car) *|`,.|*) 'nconc)))))
345        (multiple-value-bind (cdr qd) (backquote-aux (%cdr form))
346          (if splice
347            (cond ((null (%cdr car)) (values cdr qd))
348                  ((null cdr) (values (%cdr car) (self-evaluating-p (%cdr car))))
349                  (t (list splice (%cdr car) (backq-form cdr qd))))
350            (multiple-value-bind (car qa) (backquote-aux car)
351              (cond ((and qa qd) (values (cons car cdr) t))
352                    ((null cdr) (list 'list car))
353                    (t (list 'list*     ; was CONS
354                             (backq-form car qa) (backq-form cdr qd)))))))))))
355
356(defun backq-form (form constantp)
357  (if (and constantp (not (self-evaluating-p form))) (list 'quote form) form))
358
359(defparameter *backquote-stack* ())
360
361(set-macro-character 
362 #\`
363 (nfunction 
364  |` reader|
365  (lambda (stream char &aux form)
366    (declare (ignore char))
367    (setq form
368          (let* ((|`,| (make-symbol "`,"))
369                 (|`,.| (make-symbol "`,."))
370                 (|`,@| (make-symbol "`,@")))
371            (list 'backquote-expander |`,| |`,.| |`,@|
372                  (let ((*backquote-stack* (list* |`,| |`,.| |`,@| *backquote-stack*)))
373                    (read stream t nil t)))))
374    (if *backquote-expand* (values (macroexpand-1 form)) form))))
375
376(set-macro-character 
377 #\, 
378 (nfunction
379  |, reader| 
380  (lambda (stream char &aux (stack *backquote-stack*))
381    (when (null stack)
382      (signal-reader-error stream "Comma not inside backquote"))
383    (let ((*backquote-stack* (cdddr stack)))
384      (setq char (tyi stream))
385      (cond ((eq char #\@)
386             (cons (%caddr stack) (read stream t nil t)))
387            ((eq char #\.)
388             (cons (%cadr stack) (read stream t nil t)))
389            (t
390             (untyi char stream)
391             (cons (%car stack) (read stream t nil t))))))))
392)
393
394(provide 'backquote)
Note: See TracBrowser for help on using the repository browser.