Run tests asynchronously so it reports incrementally
[jscl.git] / src / backquote.lisp
1 ;;; backquote.lisp ---
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 (/debug "loading backquote.lisp!")
17
18 ;;; Backquote implementation.
19 ;;;
20 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
21 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
22 ;;;    This software is in the public domain.
23
24 ;;;    The following are unique tokens used during processing.
25 ;;;    They need not be symbols; they need not even be atoms.
26 (defvar *comma* 'unquote)
27 (defvar *comma-atsign* 'unquote-splicing)
28
29 (defvar *bq-list* (make-symbol "BQ-LIST"))
30 (defvar *bq-append* (make-symbol "BQ-APPEND"))
31 (defvar *bq-list** (make-symbol "BQ-LIST*"))
32 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
33 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
34 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
35 (defvar *bq-quote-nil* (list *bq-quote* nil))
36
37 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
38 ;;; the expression foo, looking for occurrences of #:COMMA,
39 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
40 ;;; accordance with the rules on pages 349-350 of the first edition
41 ;;; (pages 528-529 of this second edition).  It then optionally
42 ;;; applies a code simplifier.
43
44 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
45 ;;; processing applies the code simplifier.  If the value is NIL,
46 ;;; then the code resulting from BACKQUOTE is exactly that
47 ;;; specified by the official rules.
48 (defparameter *bq-simplify* t)
49
50 (defmacro backquote (x)
51   (bq-completely-process x))
52
53 ;;; Backquote processing proceeds in three stages:
54 ;;;
55 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
56 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
57 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
58 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
59 ;;; Code is produced that is expressed in terms of functions
60 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
61 ;;; so that the simplifier will simplify only list construction
62 ;;; functions actually generated by BACKQUOTE and will not involve
63 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
64 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
65 ;;; but indicates places where "%." was used and where NCONC may
66 ;;; therefore be introduced by the simplifier for efficiency.
67 ;;;
68 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
69 ;;; BQ-PROCESS to produce equivalent but faster code.  The
70 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
71 ;;; introduced into the code.
72 ;;;
73 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
74 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
75 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
76 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
77 ;;; LIST* or CONS (the latter is used in the two-argument case,
78 ;;; purely to make the resulting code a tad more readable).
79
80 (defun bq-completely-process (x)
81   (let ((raw-result (bq-process x)))
82     (bq-remove-tokens (if *bq-simplify*
83                           (bq-simplify raw-result)
84                           raw-result))))
85
86 (defun bq-process (x)
87   (cond ((atom x)
88          (list *bq-quote* x))
89         ((eq (car x) 'backquote)
90          (bq-process (bq-completely-process (cadr x))))
91         ((eq (car x) *comma*) (cadr x))
92         ((eq (car x) *comma-atsign*)
93          (error ",@~S after `" (cadr x)))
94         ;; ((eq (car x) *comma-dot*)
95         ;;  ;; (error ",.~S after `" (cadr x))
96         ;;  (error "ill-formed"))
97         (t (do ((p x (cdr p))
98                 (q '() (cons (bracket (car p)) q)))
99                ((atom p)
100                 (cons *bq-append*
101                       (nreconc q (list (list *bq-quote* p)))))
102              (when (eq (car p) *comma*)
103                (unless (null (cddr p))
104                  (error "Malformed ,~S" p))
105                (return (cons *bq-append*
106                              (nreconc q (list (cadr p))))))
107              (when (eq (car p) *comma-atsign*)
108                (error "Dotted ,@~S" p))
109              ;; (when (eq (car p) *comma-dot*)
110              ;;   ;; (error "Dotted ,.~S" p)
111              ;;   (error "Dotted"))
112              ))))
113
114 ;;; This implements the bracket operator of the formal rules.
115 (defun bracket (x)
116   (cond ((atom x)
117          (list *bq-list* (bq-process x)))
118         ((eq (car x) *comma*)
119          (list *bq-list* (cadr x)))
120         ((eq (car x) *comma-atsign*)
121          (cadr x))
122         ;; ((eq (car x) *comma-dot*)
123         ;;  (list *bq-clobberable* (cadr x)))
124         (t (list *bq-list* (bq-process x)))))
125
126 ;;; This auxiliary function is like MAPCAR but has two extra
127 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
128 ;;; the result share with the argument x as much as possible.
129 (defun maptree (fn x)
130   (if (atom x)
131       (funcall fn x)
132       (let ((a (funcall fn (car x)))
133             (d (maptree fn (cdr x))))
134         (if (and (eql a (car x)) (eql d (cdr x)))
135             x
136             (cons a d)))))
137
138 ;;; This predicate is true of a form that when read looked
139 ;;; like %@foo or %.foo.
140 (defun bq-splicing-frob (x)
141   (and (consp x)
142        (or (eq (car x) *comma-atsign*)
143            ;; (eq (car x) *comma-dot*)
144            )))
145
146 ;;; This predicate is true of a form that when read
147 ;;; looked like %@foo or %.foo or just plain %foo.
148 (defun bq-frob (x)
149   (and (consp x)
150        (or (eq (car x) *comma*)
151            (eq (car x) *comma-atsign*)
152            ;; (eq (car x) *comma-dot*)
153            )))
154
155 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
156 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
157 ;;; processed from right to left, building up a replacement form.
158 ;;; At each step a number of special cases are handled that,
159 ;;; loosely speaking, look like this:
160 ;;;
161 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
162 ;;;       provided a, b, c are not splicing frobs
163 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
164 ;;;       provided a, b, c are not splicing frobs
165 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
166 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
167 (defun bq-simplify (x)
168   (if (atom x)
169       x
170       (let ((x (if (eq (car x) *bq-quote*)
171                    x
172                    (maptree #'bq-simplify x))))
173         (if (not (eq (car x) *bq-append*))
174             x
175             (bq-simplify-args x)))))
176
177 (defun bq-simplify-args (x)
178   (do ((args (reverse (cdr x)) (cdr args))
179        (result
180          nil
181          (cond ((atom (car args))
182                 (bq-attach-append *bq-append* (car args) result))
183                ((and (eq (caar args) *bq-list*)
184                      (notany #'bq-splicing-frob (cdar args)))
185                 (bq-attach-conses (cdar args) result))
186                ((and (eq (caar args) *bq-list**)
187                      (notany #'bq-splicing-frob (cdar args)))
188                 (bq-attach-conses
189                   (reverse (cdr (reverse (cdar args))))
190                   (bq-attach-append *bq-append*
191                                     (car (last (car args)))
192                                     result)))
193                ((and (eq (caar args) *bq-quote*)
194                      (consp (cadar args))
195                      (not (bq-frob (cadar args)))
196                      (null (cddar args)))
197                 (bq-attach-conses (list (list *bq-quote*
198                                               (caadar args)))
199                                   result))
200                ((eq (caar args) *bq-clobberable*)
201                 (bq-attach-append *bq-nconc* (cadar args) result))
202                (t (bq-attach-append *bq-append*
203                                     (car args)
204                                     result)))))
205       ((null args) result)))
206
207 (defun null-or-quoted (x)
208   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
209
210 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
211 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
212 ;;; some simplifications are done on the fly:
213 ;;;
214 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
215 ;;;  (op item 'nil) => item, provided item is not a splicable frob
216 ;;;  (op item 'nil) => (op item), if item is a splicable frob
217 ;;;  (op item (op a b c)) => (op item a b c)
218 (defun bq-attach-append (op item result)
219   (cond ((and (null-or-quoted item) (null-or-quoted result))
220          (list *bq-quote* (append (cadr item) (cadr result))))
221         ((or (null result) (equal result *bq-quote-nil*))
222          (if (bq-splicing-frob item) (list op item) item))
223         ((and (consp result) (eq (car result) op))
224          (list* (car result) item (cdr result)))
225         (t (list op item result))))
226
227 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
228 ;;; `(LIST* ,@items ,result) but some simplifications are done
229 ;;; on the fly.
230 ;;;
231 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
232 ;;;  (LIST* a b c 'nil) => (LIST a b c)
233 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
234 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
235 (defun bq-attach-conses (items result)
236   (cond ((and (every #'null-or-quoted items)
237               (null-or-quoted result))
238          (list *bq-quote*
239                (append (mapcar #'cadr items) (cadr result))))
240         ((or (null result) (equal result *bq-quote-nil*))
241          (cons *bq-list* items))
242         ((and (consp result)
243               (or (eq (car result) *bq-list*)
244                   (eq (car result) *bq-list**)))
245          (cons (car result) (append items (cdr result))))
246         (t (cons *bq-list** (append items (list result))))))
247
248 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
249 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
250 (defun bq-remove-tokens (x)
251   (cond ((eq x *bq-list*) 'list)
252         ((eq x *bq-append*) 'append)
253         ((eq x *bq-nconc*) 'nconc)
254         ((eq x *bq-list**) 'list*)
255         ((eq x *bq-quote*) 'quote)
256         ((atom x) x)
257         ((eq (car x) *bq-clobberable*)
258          (bq-remove-tokens (cadr x)))
259         ((and (eq (car x) *bq-list**)
260               (consp (cddr x))
261               (null (cdddr x)))
262          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
263         (t (maptree #'bq-remove-tokens x))))