1: ;;
    2: ;; testing macro expansion
    3: ;;
    4: 
    5: (use gauche.test)
    6: 
    7: (test-start "macro")
    8: 
    9: ;; strip off syntactic information from identifiers in the macro output.
   10: (define (unident form)
   11:   (cond
   12:    ((identifier? form) (identifier->symbol form))
   13:    ((pair? form) (cons (unident (car form)) (unident (cdr form))))
   14:    ((vector? form)
   15:     (list->vector (map unident (vector->list form))))
   16:    (else form)))
   17: 
   18: (define-macro (test-macro msg expect form)
   19:   `(test ,msg ',expect (lambda () (unident (%macroexpand ,form)))))
   20: 
   21: ;;----------------------------------------------------------------------
   22: ;; basic tests
   23: 
   24: (test-section "basic expansion")
   25: 
   26: (define-syntax simple (syntax-rules ()
   27:                         ((_ "a" ?a) (a ?a))
   28:                         ((_ "b" ?a) (b ?a))
   29:                         ((_ #f ?a)  (c ?a))
   30:                         ((_ (#\a #\b) ?a) (d ?a))
   31:                         ((_ #(1 2) ?a) (e ?a))
   32:                         ((_ ?b ?a)  (f ?a ?b))))
   33: 
   34: (test-macro "simple" (a z) (simple "a" z))
   35: (test-macro "simple" (b z) (simple "b" z))
   36: (test-macro "simple" (c z) (simple #f z))
   37: (test-macro "simple" (d z) (simple (#\a #\b) z))
   38: (test-macro "simple" (e z) (simple #(1 2) z))
   39: (test-macro "simple" (f z #(1.0 2.0)) (simple #(1.0 2.0) z))
   40: (test-macro "simple" (f z (#\b #\a)) (simple (#\b #\a) z))
   41: (test-macro "simple" (f z #(2 1)) (simple #(2 1) z))
   42: 
   43: (define-syntax repeat (syntax-rules ()
   44:                         ((_ 0 (?a ?b) ...)     ((?a ...) (?b ...)))
   45:                         ((_ 1 (?a ?b) ...)     (?a ... ?b ...))
   46:                         ((_ 2 (?a ?b) ...)     (?a ... ?b ... ?a ...))
   47:                         ((_ 0 (?a ?b ?c) ...)  ((?a ...) (?b ?c) ...))
   48:                         ((_ 1 (?a ?b ?c) ...)  (?a ... (?c 8 ?b) ...))
   49:                         ))
   50: 
   51: (test-macro "repeat" ((a c e) (b d f))
   52:             (repeat 0 (a b) (c d) (e f)))
   53: (test-macro "repeat" (a c e b d f)
   54:             (repeat 1 (a b) (c d) (e f)))
   55: (test-macro "repeat" (a c e b d f a c e)
   56:             (repeat 2 (a b) (c d) (e f)))
   57: (test-macro "repeat" ((a d g) (b c) (e f) (h i))
   58:             (repeat 0 (a b c) (d e f) (g h i)))
   59: (test-macro "repeat" (a d g (c 8 b) (f 8 e) (i 8 h))
   60:             (repeat 1 (a b c) (d e f) (g h i)))
   61: 
   62: (define-syntax nest1 (syntax-rules ()
   63:                        ((_ (?a ...) ...)        ((?a ... z) ...))))
   64: 
   65: (test-macro "nest1" ((a z) (b c d z) (e f g h i z) (z) (j z))
   66:             (nest1 (a) (b c d) (e f g h i) () (j)))
   67: 
   68: (define-syntax nest2 (syntax-rules ()
   69:                        ((_ ((?a ?b) ...) ...)   ((?a ... ?b ...) ...))))
   70: 
   71: (test-macro "nest2" ((a c b d) () (e g i f h j))
   72:             (nest2 ((a b) (c d)) () ((e f) (g h) (i j))))
   73: 
   74: (define-syntax nest3 (syntax-rules ()
   75:                        ((_ ((?a ?b ...) ...) ...) ((((?b ...) ...) ...)
   76:                                                    ((?a ...) ...)))))
   77: 
   78: (test-macro "nest3" ((((b c d e) (g h i)) (() (l m n) (p)) () ((r)))
   79:                      ((a f) (j k o) () (q)))
   80:             (nest3 ((a b c d e) (f g h i)) ((j) (k l m n) (o p)) () ((q r))))
   81: 
   82: (define-syntax mixlevel1 (syntax-rules ()
   83:                            ((_ (?a ?b ...)) ((?a ?b) ...))))
   84: 
   85: (test-macro "mixlevel1" ((1 2) (1 3) (1 4) (1 5) (1 6))
   86:             (mixlevel1 (1 2 3 4 5 6)))
   87: 
   88: (define-syntax mixlevel2 (syntax-rules ()
   89:                            ((_ (?a ?b ...) ...)
   90:                             (((?a ?b) ...) ...))))
   91: 
   92: (test-macro "mixlevel2" (((1 2) (1 3) (1 4)) ((2 3) (2 4) (2 5) (2 6)))
   93:             (mixlevel2 (1 2 3 4) (2 3 4 5 6)))
   94: 
   95: (define-syntax mixlevel3 (syntax-rules ()
   96:                            ((_ ?a (?b ?c ...) ...)
   97:                             (((?a ?b ?c) ...) ...))))
   98: 
   99: (test-macro "mixlevel3" (((1 2 3) (1 2 4) (1 2 5) (1 2 6))
  100:                          ((1 7 8) (1 7 9) (1 7 10)))
  101:             (mixlevel3 1 (2 3 4 5 6) (7 8 9 10)))
  102: 
  103: ;; test that wrong usage of ellipsis is correctly identified
  104: (test "bad epplisis 1" *test-error*
  105:       (lambda () 
  106:         (eval '(define-syntax badellipsis
  107:                  (syntax-rules () (t) (3 ...)))
  108:               (interaction-environment))))
  109: (test "bad epplisis 2" *test-error*
  110:       (lambda ()
  111:         (eval '(define-syntax badellipsis
  112:                  (syntax-rules () (t a) (a ...)))
  113:               (interaction-environment))))
  114: (test "bad epplisis 3" *test-error*
  115:       (lambda ()
  116:         (eval '(define-syntax badellipsis
  117:                  (syntax-rules () (t a b ...) (a ...)))
  118:               (interaction-environment))))
  119: (test "bad epplisis 4" *test-error*
  120:       (lambda ()
  121:         (eval '(define-syntax badellipsis
  122:                  (syntax-rules () (t a ...) ((a ...) ...)))
  123:               (interaction-environment))))
  124: 
  125: (define-syntax hygiene (syntax-rules ()
  126:                          ((_ ?a) (+ ?a 1))))
  127: (test "hygiene" 3
  128:       (lambda () (let ((+ *)) (hygiene 2))))
  129: 
  130: (define-syntax vect1 (syntax-rules ()
  131:                        ((_ #(?a ...)) (?a ...))
  132:                        ((_ (?a ...))  #(?a ...))))
  133: (test-macro "vect1" (1 2 3 4 5)  (vect1 #(1 2 3 4 5)))
  134: (test-macro "vect1" #(1 2 3 4 5) (vect1 (1 2 3 4 5)))
  135: 
  136: (define-syntax vect2 (syntax-rules ()
  137:                        ((_ #(#(?a ?b) ...))  #(?a ... ?b ...))
  138:                        ((_ #((?a ?b) ...))    (?a ... ?b ...))
  139:                        ((_ (#(?a ?b) ...))    (#(?a ...) #(?b ...)))))
  140: 
  141: (test-macro "vect2" #(a c e b d f) (vect2 #(#(a b) #(c d) #(e f))))
  142: (test-macro "vect2"  (a c e b d f) (vect2 #((a b) (c d) (e f))))
  143: (test-macro "vect2"  (#(a c e) #(b d f)) (vect2 (#(a b) #(c d) #(e f))))
  144: 
  145: (define-syntax dot1 (syntax-rules ()
  146:                       ((_ (?a . ?b)) (?a ?b))
  147:                       ((_ ?loser) #f)))
  148: (test-macro "dot1" (1 2)     (dot1 (1 . 2)))
  149: (test-macro "dot1" (1 (2))   (dot1 (1 2)))
  150: (test-macro "dot1" (1 ())    (dot1 (1)))
  151: (test-macro "dot1" (1 (2 3)) (dot1 (1 2 3)))
  152: (test-macro "dot1" #f        (dot1 ()))
  153: 
  154: (define-syntax dot2 (syntax-rules ()
  155:                       ((_ ?a . ?b) (?b . ?a))
  156:                       ((_ . ?loser) #f)))
  157: (test-macro "dot2" (2 . 1)     (dot2 1 . 2))
  158: (test-macro "dot2" ((2) . 1)   (dot2 1 2))
  159: (test-macro "dot2" (() . 1)    (dot2 1))
  160: (test-macro "dot2" ((2 3) . 1) (dot2 1 2 3))
  161: (test-macro "dot2" #f          (dot2))
  162: 
  163: ;; pattern to yield (. x) => x
  164: (define-syntax dot3 (syntax-rules ()
  165:                       ((_ (?a ...) ?b) (?a ... . ?b))))
  166: (test-macro "dot3" (1 2 . 3)   (dot3 (1 2) 3))
  167: (test-macro "dot3" 3           (dot3 () 3))
  168: 
  169: ;; see if effective quote introduced by quasiquote properly unwrap
  170: ;; syntactic enviornment.
  171: (define-syntax unwrap1 (syntax-rules ()
  172:                          ((_ x) `(a ,x))))
  173: (test "unwrap1" '(a 3) (lambda () (unwrap1 3))
  174:       (lambda (x y) (and (eq? (car x) (car y)) (eq? (cadr x) (cadr y)))))
  175: (test "unwrap1" '(a 4) (lambda () (let ((a 4)) (unwrap1 a))) 
  176:       (lambda (x y) (and (eq? (car x) (car y)) (eq? (cadr x) (cadr y)))))
  177: 
  178: ;;----------------------------------------------------------------------
  179: ;; cond, taken from R5RS section 7.3
  180: 
  181: (test-section "recursive expansion")
  182: 
  183: (define-syntax %cond
  184:   (syntax-rules (else =>)
  185:     ((cond (else result1 result2 ...))
  186:      (begin result1 result2 ...))
  187:     ((cond (test => result))
  188:      (let ((temp test))
  189:        (if temp (result temp))))
  190:     ((cond (test => result) clause1 clause2 ...)
  191:      (let ((temp test))
  192:        (if temp
  193:            (result temp)
  194:            (%cond clause1 clause2 ...))))
  195:     ((cond (test)) test)
  196:     ((cond (test) clause1 clause2 ...)
  197:      (let ((temp test))
  198:        (if temp temp (%cond clause1 clause2 ...))))
  199:     ((cond (test result1 result2 ...))
  200:      (if test (begin result1 result2 ...)))
  201:     ((cond (test result1 result2 ...) clause1 clause2 ...)
  202:      (if test (begin result1 result2 ...) (%cond clause1 clause2 ...)))
  203:     ))
  204: 
  205: (test-macro "%cond" (begin a) (%cond (else a)))
  206: (test-macro "%cond" (begin a b c) (%cond (else a b c)))
  207: (test-macro "%cond" (let ((temp a)) (if temp (b temp))) (%cond (a => b)))
  208: (test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c))) (%cond (a => b) c))
  209: (test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c d))) (%cond (a => b) c d))
  210: (test-macro "%cond" (let ((temp a)) (if temp (b temp) (%cond c d e))) (%cond (a => b) c d e))
  211: (test-macro "%cond" a (%cond (a)))
  212: (test-macro "%cond" (let ((temp a)) (if temp temp (%cond b))) (%cond (a) b))
  213: (test-macro "%cond" (let ((temp a)) (if temp temp (%cond b c))) (%cond (a) b c))
  214: (test-macro "%cond" (if a (begin b)) (%cond (a b)))
  215: (test-macro "%cond" (if a (begin b c d)) (%cond (a b c d)))
  216: (test-macro "%cond" (if a (begin b c d) (%cond e f g)) (%cond (a b c d) e f g))
  217: 
  218: ;; test for higiene
  219: (test "%cond" '(if a (begin => b))
  220:       (lambda () (let ((=> #f)) (unident (%macroexpand (%cond (a => b)))))))
  221: (test "%cond" '(if else (begin z))
  222:       (lambda () (let ((else #t)) (unident (%macroexpand (%cond (else z)))))))
  223: 
  224: ;;----------------------------------------------------------------------
  225: ;; letrec, taken from R5RS section 7.3
  226: (define-syntax %letrec
  227:   (syntax-rules ()
  228:     ((_ ((var1 init1) ...) body ...)
  229:      (%letrec "generate_temp_names"
  230:               (var1 ...)
  231:               ()
  232:               ((var1 init1) ...)
  233:               body ...))
  234:     ((_ "generate_temp_names" () (temp1 ...) ((var1 init1) ...) body ...)
  235:      (let ((var1 :undefined) ...)
  236:        (let ((temp1 init1) ...)
  237:          (set! var1 temp1) ...
  238:          body ...)))
  239:     ((_ "generate_temp_names" (x y ...) (temp ...) ((var1 init1) ...) body ...)
  240:      (%letrec "generate_temp_names"
  241:               (y ...)
  242:               (newtemp temp ...)
  243:               ((var1 init1) ...)
  244:               body ...))))
  245: 
  246: ;; Note: if you "unident" the expansion result of %letrec, you see a symbol
  247: ;; "newtemp" appears repeatedly in the let binding, seemingly expanding
  248: ;; into invalid syntax.  Internally, however, those symbols are treated 
  249: ;; as identifiers with the correct identity, so the expanded code works
  250: ;; fine (as tested in the second test).
  251: (test-macro "%letrec"
  252:             (let ((a :undefined)
  253:                   (c :undefined))
  254:               (let ((newtemp b)
  255:                     (newtemp d))
  256:                 (set! a newtemp)
  257:                 (set! c newtemp)
  258:                 e f g))
  259:             (%letrec ((a b) (c d)) e f g))
  260: (test "%letrec" '(1 2 3)
  261:       (lambda () (%letrec ((a 1) (b 2) (c 3)) (list a b c))))
  262: 
  263: ;;----------------------------------------------------------------------
  264: ;; do, taken from R5RS section 7.3
  265: (define-syntax %do
  266:   (syntax-rules ()
  267:     ((_ ((var init step ...) ...)
  268:         (test expr ...)
  269:         command ...)
  270:      (letrec
  271:          ((loop
  272:            (lambda (var ...)
  273:              (if test
  274:                  (begin
  275:                    (if #f #f)
  276:                    expr ...)
  277:                  (begin
  278:                    command
  279:                    ...
  280:                    (loop (%do "step" var step ...)
  281:                          ...))))))
  282:        (loop init ...)))
  283:     ((_ "step" x)
  284:      x)
  285:     ((_ "step" x y)
  286:      y)))
  287: 
  288: (test-macro "%do"
  289:             (letrec ((loop (lambda (x y)
  290:                              (if (>= x 10)
  291:                                  (begin (if #f #f) y)
  292:                                  (begin (loop (%do "step" x (+ x 1))
  293:                                               (%do "step" y (* y 2))))))))
  294:               (loop 0 1))
  295:             (%do ((x 0 (+ x 1))
  296:                   (y 1 (* y 2)))
  297:                  ((>= x 10) y)))
  298: (test "%do" 1024
  299:       (lambda () (%do ((x 0 (+ x 1))
  300:                        (y 1 (* y 2)))
  301:                       ((>= x 10) y))))
  302: 
  303: (test-macro "%do"
  304:             (letrec ((loop (lambda (y x)
  305:                              (if (>= x 10)
  306:                                  (begin (if #f #f) y)
  307:                                  (begin (set! y (* y 2))
  308:                                         (loop (%do "step" y)
  309:                                               (%do "step" x (+ x 1))))))))
  310:               (loop 1 0))
  311:             (%do ((y 1)
  312:                   (x 0 (+ x 1)))
  313:                  ((>= x 10) y)
  314:                  (set! y (* y 2))))
  315: (test "%do" 1024
  316:       (lambda () (%do ((y 1)
  317:                        (x 0 (+ x 1)))
  318:                       ((>= x 10) y)
  319:                       (set! y (* y 2)))))
  320: 
  321: ;;----------------------------------------------------------------------
  322: ;; local syntactic bindings.
  323: 
  324: (test-section "local syntactic bindings")
  325: 
  326: (test "let-syntax"                      ; R5RS 4.3.1
  327:       'now
  328:       (lambda ()
  329:         (let-syntax ((%when (syntax-rules ()
  330:                              ((_ test stmt1 stmt2 ...)
  331:                               (if test (begin stmt1 stmt2 ...))))))
  332:           (let ((if #t))
  333:             (%when if (set! if 'now))
  334:             if))))
  335: 
  336: (test "let-syntax"                      ; R5RS 4.3.1
  337:       'outer
  338:       (lambda ()
  339:         (let ((x 'outer))
  340:           (let-syntax ((m (syntax-rules () ((m) x))))
  341:             (let ((x 'inner))
  342:               (m))))))
  343: 
  344: (test "let-syntax (multi)"
  345:       81
  346:       (lambda ()
  347:         (let ((+ *))
  348:           (let-syntax ((a (syntax-rules () ((_ ?x) (+ ?x ?x))))
  349:                        (b (syntax-rules () ((_ ?x) (* ?x ?x)))))
  350:             (let ((* -)
  351:                   (+ /))
  352:               (a (b 3)))))))
  353: 
  354: (test "let-syntax (nest)"
  355:       19
  356:       (lambda ()
  357:         (let-syntax ((a (syntax-rules () ((_ ?x ...) (+ ?x ...)))))
  358:           (let-syntax ((a (syntax-rules ()
  359:                             ((_ ?x ?y ...) (a ?y ...))
  360:                             ((_) 2))))
  361:             (a 8 9 10)))))
  362: 
  363: (test "let-syntax (nest)"
  364:       '(-6 11)
  365:       (lambda ()
  366:         (let-syntax ((a (syntax-rules () ((_ ?x) (+ ?x 8))))
  367:                      (b (syntax-rules () ((_ ?x) (- ?x 8)))))
  368:           (let-syntax ((a (syntax-rules () ((_ ?x) (b 2))))
  369:                        (b (syntax-rules () ((_ ?x) (a 3)))))
  370:             (list (a 7) (b 8))))))
  371: 
  372: (test "letrec-syntax"                   ; R5RS 4.3.1
  373:       7
  374:       (lambda ()
  375:         (letrec-syntax ((%or (syntax-rules ()
  376:                                ((_) #f)
  377:                                ((_ e) e)
  378:                                ((_ e f ...)
  379:                                 (let ((temp e))
  380:                                   (if temp temp (%or f ...)))))))
  381:            (let ((x #f)
  382:                  (y 7)
  383:                  (temp 8)
  384:                  (let odd?)
  385:                  (if even?))
  386:              (%or x (let temp) (if y) y)))))
  387: 
  388: (test "letrec-syntax (nest)"
  389:       2
  390:       (lambda ()
  391:         (letrec-syntax ((a (syntax-rules () ((_ ?x ...) (+ ?x ...)))))
  392:           (letrec-syntax ((a (syntax-rules ()
  393:                                ((_ ?x ?y ...) (a ?y ...))
  394:                                ((_) 2))))
  395:             (a 8 9 10)))))
  396:       
  397: (test "letrec-syntax (nest)"
  398:       '(9 11)
  399:       (lambda ()
  400:         (letrec-syntax ((a (syntax-rules () ((_ ?x) (+ ?x 8))))
  401:                         (b (syntax-rules () ((_ ?x) (- ?x 8)))))
  402:           (letrec-syntax ((a (syntax-rules ()
  403:                                ((_ ?x)    (b ?x 2))
  404:                                ((_ ?x ?y) (+ ?x ?y))))
  405:                           (b (syntax-rules ()
  406:                                ((_ ?x)    (a ?x 3))
  407:                                ((_ ?x ?y) (+ ?x ?y)))))
  408:             (list (a 7) (b 8))))))
  409: 
  410: (test "letrec-syntax (recursive)"
  411:       #t
  412:       (lambda ()
  413:         (letrec-syntax ((o? (syntax-rules ()
  414:                               ((o? ()) #f)
  415:                               ((o? (x . xs)) (e? xs))))
  416:                         (e? (syntax-rules ()
  417:                               ((e? ()) #t)
  418:                               ((e? (x . xs)) (o? xs)))))
  419:           (e? '(a a a a)))))
  420: 
  421: ;; This is from comp.lang.scheme posting by Antti Huima
  422: ;; http://groups.google.com/groups?hl=ja&selm=7qpu5ncg2l.fsf%40divergence.tcs.hut.fi
  423: (test "let-syntax (huima)" '(1 3 5 9)
  424:       (lambda ()
  425:         (define the-procedure
  426:           (let-syntax((l(syntax-rules()((l((x(y ...))...)b ...)(let-syntax((x (syntax-rules()y ...))...) b ...)))))(l('(('(a b ...)(lambda a b ...)))`((`(a b c)(if a b c))(`(a)(car a))),((,(a b)(set! a b))(,(a)(cdr a))),@((,@z(call-with-current-continuation z))))'((ls)('((s)('((i) ('((d)('((j)('((c)('((p)('((l)('(()(l l))))'((k)`((pair?,(p))('((c) ,(p(append,(,(p))(d c)))(k k))(c`(p)`(,(p))c))`(p)))))(cons(d)(map d ls))))'((x y c),@'((-)(s x y null? - s)(j x y c)))))'((x y c)('((q)('((f)(cons`(q)(c((f x)x)((f y)y)c)))'((h)`((eq? q h)'((x),(x)) i)))),@'((-)(s x y'((z)(>=`(z)(sqrt(*`(x)`(y)))))- s))))))list)) '((z)z)))'((x y p k l),@'((-)`((p x)(k y)(l y x'((z)`((p z)-(- #f)))k l)))))))))
  427:         (the-procedure '(5 1 9 3))))
  428: 
  429: ;;----------------------------------------------------------------------
  430: ;; macro and internal define
  431: 
  432: (test-section