~ chicken-r7rs (master) /r7rs-support.scm

 1;;;
 2;;; Support code for building the R7RS extension.
 3;;;
 4
 5(module r7rs-support *
 6  (import scheme chicken.base chicken.syntax)
 7
 8  (define (macro-handler name)
 9    (cond ((assq name (##sys#macro-environment)) => caddr)
10          (else #f)))
11
12  (define (wrap-er-macro-transformer name handler)
13    (er-macro-transformer
14     (let ((orig (macro-handler name)))
15       (lambda (x r c)
16         (let ((e (##sys#current-environment)))
17           (handler x r c (lambda (x*) (orig x* '() e))))))))
18
19  (define-syntax define-extended-arity-comparator
20    (syntax-rules ()
21      ((_ name comparator check-type)
22       (define name
23         (let ((c comparator))
24           (lambda (o1 o2 . os)
25             (check-type o1 'name)
26             (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
27               (check-type o2 'name)
28               (if (null? os)
29                   (and eq (c o1 o2))
30                   (lp o2 (car os) (cdr os) (and eq (c o1 o2))))))))))))