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