source: project/chicken/trunk/synrules.scm @ 12359

Last change on this file since 12359 was 12359, checked in by felix winkelmann, 12 years ago

fixed ellipsis check (srfi-46 extension); chicken-install removes failed http locations from defaults list

File size: 11.1 KB
Line 
1;; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees.
2;; All rights reserved.
3
4;; Redistribution and use in source and binary forms, with or without
5;; modification, are permitted provided that the following conditions
6;; are met:
7;; 1. Redistributions of source code must retain the above copyright
8;;    notice, this list of conditions and the following disclaimer.
9;; 2. Redistributions in binary form must reproduce the above copyright
10;;    notice, this list of conditions and the following disclaimer in the
11;;    documentation and/or other materials provided with the distribution.
12;; 3. The name of the authors may not be used to endorse or promote products
13;;    derived from this software without specific prior written permission.
14
15;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
16;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
17;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
18;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
19;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
20;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
21;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
24;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25
26; The syntax-rules macro (new in R5RS)
27
28;;; [Hacked slightly by Taylor R. Campbell to make it work in his
29;;; macro expander `riaxpander'.]
30
31;; [Hacked even more by Felix L. Winkelmann to make it work in his
32;; Hi-Lo expander]
33
34; Example:
35;
36; (define-syntax or
37;   (syntax-rules ()
38;     ((or)          #f)
39;     ((or e)        e)
40;     ((or e1 e ...) (let ((temp e1))
41;                      (if temp temp (or e ...))))))
42
43
44(##sys#extend-macro-environment
45 'syntax-rules
46 '()
47 (##sys#er-transformer
48  (lambda (exp r c)
49    (##sys#check-syntax 'syntax-rules exp '#(_ 2))
50    (let ((subkeywords (cadr exp))
51          (rules (cddr exp))
52          (ellipsis '...))
53      (when (symbol? subkeywords)
54        (##sys#check-syntax 'syntax-rules exp '(_ _ list . #(_ 0)))
55        (set! ellipsis subkeywords)
56        (set! subkeywords (car rules))
57        (set! rules (cdr rules)))
58      (##sys#process-syntax-rules ellipsis rules subkeywords r c)))))
59
60
61(define (##sys#process-syntax-rules ellipsis rules subkeywords r c)
62
63  (define %append '##sys#append)
64  (define %apply '##sys#apply)
65  (define %and (r 'and))
66  (define %car '##sys#car)
67  (define %cdr '##sys#cdr)
68  (define %vector? '##sys#vector?)
69  (define %vector-length '##sys#vector-length)
70  (define %vector-ref '##sys#vector-ref)
71  (define %vector->list '##sys#vector->list)
72  (define %list->vector '##sys#list->vector)
73  (define %>= '##sys#>=)
74  (define %= '##sys#=)
75  (define %+ '##sys#+)
76  (define %i (r 'i))
77  (define %compare (r 'compare))
78  (define %cond (r 'cond))
79  (define %cons '##sys#cons)
80  (define %else (r 'else))
81  (define %eq? '##sys#eq?)
82  (define %equal? '##sys#equal?)
83  (define %input (r 'input))
84  (define %l (r 'l))
85  (define %lambda (r 'lambda))
86  (define %let (r 'let))
87  (define %let* (r 'let*))
88  (define %list? '##sys#list?)
89  (define %list (r 'list))
90  (define %loop (r 'loop))
91  (define %map1 '##sys#map)
92  (define %map '##sys#map-n)
93  (define %null? '##sys#null?)
94  (define %or (r 'or))
95  (define %pair? '##sys#pair?)
96  (define %quote (r 'quote))
97  (define %rename (r 'rename))
98  (define %tail (r 'tail))
99  (define %temp (r 'temp))
100  (define %syntax-error '##sys#syntax-error-hook)
101  (define %ellipsis (r ellipsis))
102
103  (define (ellipsis? x)
104    (c x %ellipsis))
105
106  (define (make-transformer rules)
107    `(,%lambda (,%input ,%rename ,%compare)
108               (,%let ((,%tail (,%cdr ,%input)))
109                      (,%cond ,@(map process-rule rules)
110                              (,%else 
111                               (,%syntax-error
112                                "no rule matches form"
113                                ,%input))))))
114
115  (define (process-rule rule)
116    (if (and (pair? rule)
117             (pair? (cdr rule))
118             (null? (cddr rule)))
119        (let ((pattern (cdar rule))
120              (template (cadr rule)))
121          `((,%and ,@(process-match %tail pattern))
122            (,%let* ,(process-pattern pattern
123                                      %tail
124                                      (lambda (x) x))
125                    ,(process-template template
126                                       0
127                                       (meta-variables pattern 0 '())))))
128        (##sys#syntax-error-hook "ill-formed syntax rule" rule)))
129
130  ;; Generate code to test whether input expression matches pattern
131
132  (define (process-match input pattern)
133    (cond ((symbol? pattern)
134           (if (memq pattern subkeywords)
135               `((,%compare ,input (,%rename (syntax ,pattern))))
136               `()))
137          ((segment-pattern? pattern)
138           (process-segment-match input (car pattern)))
139          ((pair? pattern)
140           `((,%let ((,%temp ,input))
141                    (,%and (,%pair? ,%temp)
142                           ,@(process-match `(,%car ,%temp) (car pattern))
143                           ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
144          ((vector? pattern)
145           (process-vector-match input pattern))
146          ((or (null? pattern) (boolean? pattern) (char? pattern))
147           `((,%eq? ,input ',pattern)))
148          (else
149           `((,%equal? ,input ',pattern)))))
150
151  (define (process-segment-match input pattern)
152    (let ((conjuncts (process-match `(,%car ,%l) pattern)))
153      (if (null? conjuncts)
154          `((,%list? ,input))           ;+++
155          `((,%let ,%loop ((,%l ,input))
156                   (,%or (,%null? ,%l)
157                         (,%and (,%pair? ,%l)
158                                (,%loop (,%cdr ,%l)))))))))
159
160   (define (process-vector-match input pattern)
161     (let* ((len (vector-length pattern))
162            (segment? (and (>= len 2)
163                           (ellipsis? (vector-ref pattern (- len 1))))))
164       `((,%let ((,%temp ,input))
165          (,%and (,%vector? ,%temp)
166                 ,(if segment?
167                      `(,%>= (,%vector-length ,%temp) ,(- len 2))
168                      `(,%= (,%vector-length ,%temp) ,len))
169                 ,@(let lp ((i 0))
170                     (cond
171                      ((>= i len)
172                       '())
173                      ((and (= i (- len 2)) segment?)
174                       `((,%let ,%loop ((,%i ,i))
175                            (,%or (,%>= ,%i ,len)
176                                  (,%and ,@(process-match
177                                            `(,%vector-ref ,%temp ,%i)
178                                            (vector-ref pattern (- len 2)))
179                                         (,%loop (,%+ ,%i 1)))))))
180                      (else
181                       (append (process-match `(,%vector-ref ,%temp ,i)
182                                              (vector-ref pattern i))
183                               (lp (+ i 1)))))))))))
184 
185  ;; Generate code to take apart the input expression
186  ;; This is pretty bad, but it seems to work (can't say why).
187
188  (define (process-pattern pattern path mapit)
189    (cond ((symbol? pattern)
190           (if (memq pattern subkeywords)
191               '()
192               (list (list pattern (mapit path)))))
193          ((segment-pattern? pattern)
194           (process-pattern (car pattern)
195                            %temp
196                            (lambda (x) ;temp is free in x
197                              (mapit (if (eq? %temp x)
198                                         path ;+++
199                                         `(,%map1 (,%lambda (,%temp) ,x)
200                                                  ,path))))))
201          ((pair? pattern)
202           (append (process-pattern (car pattern) `(,%car ,path) mapit)
203                   (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
204          ((vector? pattern)
205           (let* ((len (vector-length pattern))
206                  (segment? (and (>= len 2)
207                                 (ellipsis? (vector-ref pattern (- len 1))))))
208             (if segment?
209                 (process-pattern (vector->list pattern) 
210                                  `(,%vector->list ,path)
211                                  mapit)
212                 (let lp ((i 0))
213                   (cond
214                    ((>= i len)
215                     '())
216                    (else
217                     (append (process-pattern (vector-ref pattern i)
218                                              `(,%vector-ref ,path ,i)
219                                              mapit)
220                             (lp (+ i 1)))))))))
221          (else '())))
222
223  ;; Generate code to compose the output expression according to template
224
225  (define (process-template template dim env)
226    (cond ((symbol? template)
227           (let ((probe (assq template env)))
228             (if probe
229                 (if (<= (cdr probe) dim)
230                     template
231                     (##sys#syntax-error-hook "template dimension error (too few ellipses?)"
232                                              template))
233                 `(,%rename (syntax ,template)))))
234          ((segment-template? template)
235           (let* ((depth (segment-depth template))
236                  (seg-dim (+ dim depth))
237                  (vars
238                   (free-meta-variables (car template) seg-dim env '())))
239             (if (null? vars)
240                 (##sys#syntax-error-hook "too many ellipses" template)
241                 (let* ((x (process-template (car template)
242                                             seg-dim
243                                             env))
244                        (gen (if (and (pair? vars)
245                                      (null? (cdr vars))
246                                      (symbol? x)
247                                      (eq? x (car vars)))
248                                 x      ;+++
249                                 `(,%map (,%lambda ,vars ,x)
250                                         ,@vars)))
251                        (gen (do ((d depth (- d 1))
252                                  (gen gen `(,%apply ,%append ,gen)))
253                                 ((= d 1)
254                                  gen))))
255                   (if (null? (segment-tail template))
256                       gen              ;+++
257                       `(,%append ,gen ,(process-template (segment-tail template)
258                                                          dim env)))))))
259          ((pair? template)
260           `(,%cons ,(process-template (car template) dim env)
261                    ,(process-template (cdr template) dim env)))
262          ((vector? template)
263           `(,%list->vector
264             ,(process-template (vector->list template) dim env)))
265          (else
266           `(,%quote ,template))))
267
268  ;; Return an association list of (var . dim)
269
270  (define (meta-variables pattern dim vars)
271    (cond ((symbol? pattern)
272           (if (memq pattern subkeywords)
273               vars
274               (cons (cons pattern dim) vars)))
275          ((segment-pattern? pattern)
276           (meta-variables (car pattern) (+ dim 1) vars))
277          ((pair? pattern)
278           (meta-variables (car pattern) dim
279                           (meta-variables (cdr pattern) dim vars)))
280          ((vector? pattern)
281           (meta-variables (vector->list pattern) dim vars))
282          (else vars)))
283
284  ;; Return a list of meta-variables of given higher dim
285
286  (define (free-meta-variables template dim env free)
287    (cond ((symbol? template)
288           (if (and (not (memq template free))
289                    (let ((probe (assq template env)))
290                      (and probe (>= (cdr probe) dim))))
291               (cons template free)
292               free))
293          ((segment-template? template)
294           (free-meta-variables (car template)
295                                dim env
296                                (free-meta-variables (cddr template)
297                                                     dim env free)))
298          ((pair? template)
299           (free-meta-variables (car template)
300                                dim env
301                                (free-meta-variables (cdr template)
302                                                     dim env free)))
303          ((vector? template)
304           (free-meta-variables (vector->list template) dim env free))
305          (else free)))
306
307  (define (segment-pattern? pattern)
308    (and (segment-template? pattern)
309         (or (null? (cddr pattern))
310             (##sys#syntax-error-hook "segment matching not implemented" pattern))))
311
312  (define (segment-template? pattern)
313    (and (pair? pattern)
314         (pair? (cdr pattern))
315         (ellipsis? (cadr pattern))))
316
317  ;; Count the number of `...'s in PATTERN.
318
319  (define (segment-depth pattern)
320    (if (segment-template? pattern)
321        (+ 1 (segment-depth (cdr pattern)))
322        0))
323
324  ;; Get whatever is after the `...'s in PATTERN.
325
326  (define (segment-tail pattern)
327    (let loop ((pattern (cdr pattern)))
328      (if (and (pair? pattern)
329               (ellipsis? (car pattern)))
330          (loop (cdr pattern))
331          pattern)))
332
333  (make-transformer rules))
Note: See TracBrowser for help on using the repository browser.