~ chicken-r7rs (master) /synrules.scm

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