~ chicken-core (chicken-5) /tests/compiler-syntax-tests.scm

 1(define (foo) 1)
 2
 3(assert (= 1 (foo)))
 4
 5(define-compiler-syntax foo
 6  (syntax-rules ()
 7    ((_ x) 2) ) )
 8
 9(assert (= 2 (foo 42)))
10(assert (= 1 (foo)))
11
12(let-compiler-syntax ((foo (syntax-rules () ((_ x) 3))))
13  (assert (= 3 (foo 42))))
14
15(assert (= 2 (foo 42)))
16
17(module m1 (bar)
18  (import (prefix scheme s:) (chicken syntax))
19  (define-compiler-syntax s:+
20    (syntax-rules ()
21      ((_ x y) (s:- x y))))
22  (define-compiler-syntax bar
23    (syntax-rules ()
24      ((_ x y) "oink!")))
25  (s:define (bar x) (s:+ x 1)) )
26
27(module m2 ()
28  (import scheme (chicken base) (prefix m1 m-))
29  (print (m-bar 10))
30  (assert (= 9 (m-bar 10)))
31  (print (+ 4 3)))
32
33(define (goo x) `(goo ,x))
34
35(assert (eq? 'goo (car (goo 1))))
36
37(define-compiler-syntax goo
38  (syntax-rules ()
39    ((_ x) `(cs-goo ,x))))
40
41(print (goo 2))
42(assert (eq? 'cs-goo (car (goo 2))))
43
44(define-compiler-syntax goo)
45
46(assert (eq? 'goo (car (goo 3))))
47
48(define-compiler-syntax goo
49  (syntax-rules ()
50    ((_ x) `(cs-goo2 ,x))))
51
52(let-compiler-syntax ((goo))
53		     (assert (eq? 'goo (car (goo 4)))))
54
55(assert (eq? 'cs-goo2 (car (goo 5))))
56
57(module bar (xxx)
58  (import scheme (chicken syntax) (chicken base))
59  (define (xxx) 'yyy)			; ineffective - suboptimal
60  ;(assert (eq? 'yyy (xxx)))
61  (define-compiler-syntax xxx
62    (syntax-rules ()
63      ((_) 'zzz)))
64  (define-syntax alias
65    (syntax-rules ()
66      ((_ name x)
67       (define-compiler-syntax name
68	 (syntax-rules ()
69	   ((_ . args) (x . args)))))))
70  (alias pof +)
71  (alias pif xxx)
72  (assert (= 7 (pof 3 4)))
73  (assert (eq? 'zzz (pif)))
74  (print (xxx))
75  (assert (eq? 'zzz (xxx))))
76
77;;; local to module
78
79(define (f1 x) x)
80
81(module m3 ()
82(import scheme (chicken syntax))
83(define-compiler-syntax f1
84  (syntax-rules () ((_ x) (list x))))
85)
86
87(assert (= 2 (f1 2)))