~ chicken-core (chicken-5) 8f254e8ddb7edb50976463df99c9246a15e8c9fb
commit 8f254e8ddb7edb50976463df99c9246a15e8c9fb
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Sep 26 09:26:20 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Sep 26 09:26:20 2010 +0200
applied ir-transformer patch by sjamaan
diff --git a/chicken.import.scm b/chicken.import.scm
index 07cf416e..acb2b413 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -226,6 +226,7 @@
warning
eval-handler
er-macro-transformer
+ ir-macro-transformer
dynamic-load-libraries
with-exception-handler)
##sys#chicken-macro-environment) ;*** incorrect - won't work in compiled executable that does expansion
diff --git a/expand.scm b/expand.scm
index 52de4cff..0ada41fd 100644
--- a/expand.scm
+++ b/expand.scm
@@ -748,9 +748,7 @@
;;; explicit-renaming transformer
-(define (er-macro-transformer x) x)
-
-(define ((##sys#er-transformer handler) form se dse)
+(define ((make-er/ir-transformer handler explicit-renaming?) form se dse)
(let ((renv '())) ; keep rename-environment for this expansion
(define (rename sym)
(cond ((pair? sym)
@@ -820,8 +818,38 @@
r)
")")
r))
- (handler form rename compare) ) )
+ (define (mirror-rename sym)
+ (cond ((pair? sym)
+ (cons (mirror-rename (car sym)) (mirror-rename (cdr sym))))
+ ((vector? sym)
+ (list->vector (mirror-rename (vector->list sym))))
+ ((not (symbol? sym)) sym)
+ (else ; Code stolen from ##sys#strip-syntax
+ (let ((renamed (lookup sym se) ) )
+ (cond ((getp sym '##core#real-name) =>
+ (lambda (name)
+ (dd "STRIP SYNTAX ON " sym " ---> " name)
+ name))
+ ((not renamed)
+ (dd "IMPLICITLY RENAMED: " sym) (rename sym))
+ ((pair? renamed)
+ (dd "MACRO: " sym) (rename sym))
+ (else (dd "BUILTIN ALIAS:" renamed) renamed))))))
+ (if explicit-renaming?
+ ;; Let the user handle renaming
+ (handler form rename compare)
+ ;; Implicit renaming:
+ ;; Rename everything in the input first, feed it to the transformer
+ ;; and then swap out all renamed identifiers by their non-renamed
+ ;; versions, and vice versa. User can decide when to inject code
+ ;; unhygienically this way.
+ (mirror-rename (handler (rename form) rename compare)) ) ) )
+
+(define (##sys#er-transformer handler) (make-er/ir-transformer handler #t))
+(define (##sys#ir-transformer handler) (make-er/ir-transformer handler #f))
+(define (er-macro-transformer x) x)
+(define ir-macro-transformer ##sys#ir-transformer)
;;; Macro definitions:
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index cf352365..65242530 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -402,6 +402,138 @@
(let-syntax ((s1 (syntax-rules () ((_ x) x))))
(assert (equal? '#((99)) (s2 99))))
+;; IR macros
+
+(define-syntax loop2
+ (ir-macro-transformer
+ (lambda (x i c)
+ (let ((body (cdr x)))
+ `(call/cc
+ (lambda (,(i 'exit))
+ (let f () ,@body (f))))))))
+
+(let ((n 10))
+ (loop2
+ (print* n " ")
+ (set! n (sub1 n))
+ (when (zero? n) (exit #f)))
+ (newline))
+
+(define-syntax while20
+ (syntax-rules ()
+ ((_ t b ...)
+ (loop2 (if (not t) (exit #f))
+ b ...))))
+
+(f (while20 #f (print "no.")))
+
+(define-syntax while2
+ (ir-macro-transformer
+ (lambda (x i c)
+ `(loop
+ (if (not ,(cadr x)) (,(i 'exit) #f))
+ ,@(cddr x)))))
+
+(let ((n 10))
+ (while2 (not (zero? n))
+ (print* n " ")
+ (set! n (- n 1)) )
+ (newline))
+
+(module m2 (s3 s4)
+
+ (import chicken scheme)
+
+ (define-syntax s3 (syntax-rules () ((_ x) (list x))))
+
+ (define-syntax s4
+ (ir-macro-transformer
+ (lambda (x r c)
+ `(vector (s3 ,(cadr x)))))) ) ; without implicit renaming the local version
+ ; of `s3' below would be captured
+
+(import m2)
+
+(let-syntax ((s3 (syntax-rules () ((_ x) x))))
+ (t '#((99)) (s4 99)))
+
+(let ((vector list))
+ (t '#((one)) (s4 'one)))
+
+(define-syntax nest-me
+ (ir-macro-transformer
+ (lambda (x i c)
+ `(let ((,(i 'captured) 1))
+ ,@(cdr x)))))
+
+(t '(1 #(1 #(1)))
+ (nest-me (list captured
+ (let ((captured 2)
+ (let 'not-captured)
+ (list vector))
+ (nest-me (list captured
+ (nest-me (list captured))))))))
+
+(define-syntax cond-test
+ (ir-macro-transformer
+ (lambda (x i c)
+ (let lp ((exprs (cdr x)))
+ (cond
+ ((null? exprs) '(void))
+ ((c (caar exprs) 'else)
+ `(begin ,@(cdar exprs)))
+ ((c (cadar exprs) '=>)
+ `(let ((tmp ,(caar exprs)))
+ (if tmp
+ (,(caddar exprs) tmp)
+ ,(lp (cdr exprs)))))
+ ((c (cadar exprs) (i '==>)) ;; ==> is an Unhygienic variant of =>
+ `(let ((tmp ,(caar exprs)))
+ (if tmp
+ (,(caddar exprs) tmp)
+ ,(lp (cdr exprs)))))
+ (else
+ `(if ,(caar exprs)
+ (begin ,@(cdar exprs))
+ ,(lp (cdr exprs)))))))))
+
+(t 'yep
+ (cond-test
+ (#f 'false)
+ (else 'yep)))
+
+(t 1
+ (cond-test
+ (#f 'false)
+ (1 => (lambda (x) x))
+ (else 'yep)))
+
+(let ((=> #f))
+ (t 'a-procedure
+ (cond-test
+ (#f 'false)
+ (1 => 'a-procedure)
+ (else 'yep))))
+
+(let ((else #f))
+ (t (void)
+ (cond-test
+ (#f 'false)
+ (else 'nope))))
+
+(t 1
+ (cond-test
+ (#f 'false)
+ (1 ==> (lambda (x) x))
+ (else 'yep)))
+
+(let ((==> #f))
+ (t 1
+ (cond-test
+ (#f 'false)
+ (1 ==> (lambda (x) x))
+ (else 'yep))))
+
;;; local definitions
Trap