~ chicken-core (master) /synrules.scm

  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;;; [Hacked slightly by Taylor R. Campbell to make it work in his
 27;;; macro expander `riaxpander'.]
 28
 29;; [Hacked even more by Felix L. Winkelmann to make it work in the
 30;; Hi-Lo expander]
 31
 32; Example:
 33;
 34; (define-syntax or
 35;   (syntax-rules ()
 36;     ((or)          #f)
 37;     ((or e)        e)
 38;     ((or e1 e ...) (let ((temp e1))
 39;		       (if temp temp (or e ...))))))
 40
 41(##sys#extend-macro-environment
 42 'syntax-rules
 43 '()
 44 (##sys#er-transformer
 45  (lambda (exp r c)
 46    (##sys#check-syntax 'syntax-rules exp '#(_ 2))
 47    (let ((subkeywords (cadr exp))
 48	  (rules (cddr exp))
 49	  (ellipsis '...))
 50      (when (symbol? subkeywords)
 51	(##sys#check-syntax 'syntax-rules exp '(_ _ list . #(_ 0)))
 52	(set! ellipsis subkeywords)
 53	(set! subkeywords (car rules))
 54	(set! rules (cdr rules)))
 55      (chicken.internal.syntax-rules#process-syntax-rules
 56       ellipsis rules subkeywords r c #t)))))
 57
 58;; Runtime internal support module exclusively for syntax-rules
 59(module chicken.internal.syntax-rules
 60    (drop-right take-right safe-length syntax-rules-mismatch)
 61
 62(import scheme)
 63
 64(define (syntax-rules-mismatch input)
 65  (##sys#syntax-error "no rule matches form" input))
 66
 67(define (drop-right input temp)
 68  (let loop ((len (safe-length input))
 69	     (input input))
 70    (cond
 71     ((> len temp)
 72      (cons (car input)
 73	    (loop (- len 1) (cdr input))))
 74     (else '()))))
 75
 76(define (take-right input temp)
 77  (let loop ((len (safe-length input))
 78	     (input input))
 79    (cond
 80     ((> len temp)
 81      (loop (- len 1) (cdr input)))
 82     (else input))))
 83
 84(define (safe-length lst)
 85  (let loop ((lst lst) (len 0))
 86    (if (pair? lst) 
 87        (loop (cdr lst) (+ 1 len))
 88        len)))
 89
 90(define (process-syntax-rules ellipsis rules subkeywords r c r7ext)
 91
 92  (define %append '##sys#append)
 93  (define %apply '##sys#apply)
 94  (define %and (r 'and))
 95  (define %car '##sys#car)
 96  (define %cdr '##sys#cdr)
 97  (define %length '##sys#length)
 98  (define %vector? '##sys#vector?)
 99  (define %vector-length '##sys#vector-length)
100  (define %vector-ref '##sys#vector-ref)
101  (define %vector->list '##sys#vector->list)
102  (define %list->vector '##sys#list->vector)
103  (define %>= '##sys#>=)
104  (define %= '##sys#=)
105  (define %+ '##sys#+)
106  (define %compare (r 'compare))
107  (define %cond (r 'cond))
108  (define %cons '##sys#cons)
109  (define %else (r 'else))
110  (define %eq? '##sys#eq?)
111  (define %equal? '##sys#equal?)
112  (define %input (r 'input))
113  (define %l (r 'l))
114  (define %len (r 'len))
115  (define %lambda (r 'lambda))
116  (define %let (r 'let))
117  (define %let* (r 'let*))
118  (define %loop (r 'loop))
119  (define %map1 '##sys#map)
120  (define %map '##sys#map-n)
121  (define %null? '##sys#null?)
122  (define %or (r 'or))
123  (define %pair? '##sys#pair?)
124  (define %quote (r 'quote))
125  (define %rename (r 'rename))
126  (define %tail (r 'tail))
127  (define %temp (r 'temp))
128  (define %syntax-error '##sys#syntax-error)
129  (define %ellipsis (r ellipsis))
130  (define %safe-length (r 'chicken.internal.syntax-rules#safe-length))
131  (define %take-right (r 'chicken.internal.syntax-rules#take-right))
132  (define %drop-right (r 'chicken.internal.syntax-rules#drop-right))
133  (define %syntax-rules-mismatch
134    (r 'chicken.internal.syntax-rules#syntax-rules-mismatch))
135
136  (define (ellipsis? x)
137    (c x %ellipsis))
138
139  ;; R7RS support: underscore matches anything
140  (define (underscore? x)
141    (c x (r '_)))
142
143  (define (make-transformer rules)
144    `(##sys#er-transformer
145      (,%lambda (,%input ,%rename ,%compare)
146	(,%let ((,%tail (,%cdr ,%input)))
147	  (,%cond ,@(map process-rule rules)
148		  (,%else (,%syntax-rules-mismatch ,%input)))))))
149
150  (define (process-rule rule)
151    (if (and (pair? rule)
152	     (pair? (cdr rule))
153	     (null? (cddr rule)))
154	(let ((pattern (cdar rule))
155	      (template (cadr rule)))
156	  `((,%and ,@(process-match %tail pattern #f ellipsis?))
157	    (,%let* ,(process-pattern pattern
158				      %tail
159				      (lambda (x) x) #f ellipsis?)
160		    ,(process-template template
161				       0 ellipsis?
162				       (meta-variables pattern 0 ellipsis? '() #f)))))
163	(##sys#syntax-error "ill-formed syntax rule" rule)))
164
165  ;; Generate code to test whether input expression matches pattern
166
167  (define (process-match input pattern seen-segment? el?)
168    (cond ((symbol? pattern)
169	   (if (memq pattern subkeywords)
170	       `((,%compare ,input (,%rename (##core#syntax ,pattern))))
171	       `()))
172	  ((segment-pattern? pattern seen-segment? el?)
173	   (process-segment-match input pattern el?))
174	  ((pair? pattern)
175	   `((,%let ((,%temp ,input))
176               (,%and (,%pair? ,%temp)
177                      ,@(process-match `(,%car ,%temp) (car pattern) #f el?)
178                      ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f el?)))))
179	  ((vector? pattern)
180           `((,%let ((,%temp ,input))
181              (,%and (,%vector? ,%temp)
182                     ,@(process-match `(,%vector->list ,%temp)
183                                      (vector->list pattern) #f el?)))))
184	  ((or (null? pattern) (boolean? pattern) (char? pattern))
185	   `((,%eq? ,input ',pattern)))
186	  (else
187	   `((,%equal? ,input ',pattern)))))
188
189  (define (process-segment-match input pattern el?)
190    (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f el?))
191          (plen (safe-length (cddr pattern))))
192      `((,%let ((,%len (,%safe-length ,input)))
193               (,%and (,%>= ,%len ,plen)
194                      (,%let ,%loop ((,%l ,input)
195                                     (,%len ,%len))
196                             (,%cond ((,%= ,%len ,plen)
197                                      ,@(process-match %l (cddr pattern) #t el?))
198                                     (,%else (,%and ,@conjuncts
199                                                    (,%loop (,%cdr ,%l) 
200                                                            (,%+ ,%len -1)))))))))))
201
202  ;; Generate code to take apart the input expression
203  ;; This is pretty bad, but it seems to work (can't say why).
204
205  (define (process-pattern pattern path mapit seen-segment? el?)
206    (cond ((symbol? pattern)
207	   (if (or (memq pattern subkeywords)
208                   (and r7ext (underscore? pattern)))
209	       '()
210	       (list (list pattern (mapit path)))))
211	  ((segment-pattern? pattern seen-segment? el?)
212           (let* ((tail-length (safe-length (cddr pattern)))
213                  (%match (if (and (list? (cddr pattern))
214                                   (zero? tail-length) ) ; Simple segment?
215                              path  ; No list traversing overhead at runtime!
216                              `(,%drop-right ,path ,tail-length))))
217             (append
218              (process-pattern (car pattern)
219                               %temp
220                               (lambda (x) ;temp is free in x
221                                 (mapit
222                                  (if (eq? %temp x)
223                                      %match ; Optimization: no map+lambda
224                                      `(,%map1 (,%lambda (,%temp) ,x) ,%match))))
225                               #f el?)
226              (process-pattern (cddr pattern)
227                               `(,%take-right ,path ,tail-length) 
228                               mapit #t el?))))
229	  ((pair? pattern)
230	   (append (process-pattern (car pattern) `(,%car ,path) mapit #f el?)
231		   (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f el?)))
232          ((vector? pattern)
233           (process-pattern (vector->list pattern)
234                            `(,%vector->list ,path) 
235                            mapit #f el?))
236	  (else '())))
237
238  ;; Generate code to compose the output expression according to template
239
240  (define (process-template template dim el? env)
241    (cond ((symbol? template)
242	   (let ((probe (assq template env)))
243	     (if probe
244		 (if (<= (cdr probe) dim)
245		     template
246		     (##sys#syntax-error "template dimension error (too few ellipses?)"
247					      template))
248		 `(,%rename (##core#syntax ,template)))))
249          ((and r7ext
250                (ellipsis-escaped-pattern? template el?))
251            (if (or (not (pair? (cdr template))) (pair? (cddr template)))
252                (##sys#syntax-error "Invalid escaped ellipsis template" template)
253                (process-template (cadr template) dim (lambda _ #f) env)))
254	  ((segment-template? template el?)
255	   (let* ((depth (segment-depth template el?))
256		  (seg-dim (+ dim depth))
257		  (vars
258		   (free-meta-variables (car template) seg-dim el? env '())))
259	     (if (null? vars)
260		 (##sys#syntax-error "too many ellipses" template)
261		 (let* ((x (process-template (car template)
262					     seg-dim el?
263					     env))
264			(gen (if (and (pair? vars)
265				      (null? (cdr vars))
266				      (symbol? x)
267				      (eq? x (car vars)))
268				 x	;+++
269				 `(,%map (,%lambda ,vars ,x)
270					 ,@vars)))
271			(gen (do ((d depth (- d 1))
272				  (gen gen `(,%apply ,%append ,gen)))
273				 ((= d 1)
274				  gen))))
275		   (if (null? (segment-tail template el?))
276		       gen		;+++
277		       `(,%append ,gen ,(process-template (segment-tail template el?)
278							  dim el? env)))))))
279	  ((pair? template)
280	   `(,%cons ,(process-template (car template) dim el? env)
281		    ,(process-template (cdr template) dim el? env)))
282	  ((vector? template)
283	   `(,%list->vector
284	     ,(process-template (vector->list template) dim el? env)))
285	  (else
286	   `(,%quote ,template))))
287
288  ;; Return an association list of (var . dim)
289
290  (define (meta-variables pattern dim el? vars seen-segment?)
291    (cond ((symbol? pattern)
292	   (if (or (memq pattern subkeywords)
293                   (and r7ext (underscore? pattern))) 
294	       vars
295	       (cons (cons pattern dim) vars)))
296	  ((segment-pattern? pattern seen-segment? el?)
297	   (meta-variables (car pattern) (+ dim 1) el?
298                           (meta-variables (cddr pattern) dim el? vars #t) #f))
299	  ((pair? pattern)
300	   (meta-variables (car pattern) dim el?
301			   (meta-variables (cdr pattern) dim el? vars #f) #f))
302	  ((vector? pattern)
303	   (meta-variables (vector->list pattern) dim el? vars #f))
304	  (else vars)))
305
306  ;; Return a list of meta-variables of given higher dim
307
308  (define (free-meta-variables template dim el? env free)
309    (cond ((symbol? template)
310	   (if (and (not (memq template free))
311		    (let ((probe (assq template env)))
312		      (and probe (>= (cdr probe) dim))))
313	       (cons template free)
314	       free))
315	  ((segment-template? template el?)
316	   (free-meta-variables (car template)
317				dim el? env
318				(free-meta-variables (cddr template)
319						     dim el? env free)))
320	  ((pair? template)
321	   (free-meta-variables (car template)
322				dim el? env
323				(free-meta-variables (cdr template)
324						     dim el? env free)))
325	  ((vector? template)
326	   (free-meta-variables (vector->list template) dim el? env free))
327	  (else free)))
328
329  (define (ellipsis-escaped-pattern? pattern el?)
330     (and (pair? pattern) (el? (car pattern))))
331
332  (define (segment-pattern? p seen-segment? el?)
333    (and (segment-template? p el?)
334         (if seen-segment?
335             (##sys#syntax-error "Only one segment per level is allowed" p)
336             #t)))
337
338  (define (segment-template? pattern el?)
339    (and (pair? pattern)
340	 (pair? (cdr pattern))
341         ((if r7ext el? ellipsis?) (cadr pattern))))
342
343  ;; Count the number of `...'s in PATTERN.
344
345  (define (segment-depth pattern el?)
346    (if (segment-template? pattern el?)
347	(+ 1 (segment-depth (cdr pattern) el?))
348	0))
349
350  ;; Get whatever is after the `...'s in PATTERN.
351
352  (define (segment-tail pattern el?)
353    (let loop ((pattern (cdr pattern)))
354      (if (and (pair? pattern)
355	       ((if r7ext el? ellipsis?) (car pattern)))
356	  (loop (cdr pattern))
357	  pattern)))
358
359  (make-transformer rules))
360
361) ; chicken.internal.syntax-rules