summaryrefslogtreecommitdiffstats
path: root/scmactst.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scmactst.scm')
-rw-r--r--scmactst.scm160
1 files changed, 160 insertions, 0 deletions
diff --git a/scmactst.scm b/scmactst.scm
new file mode 100644
index 0000000..3b71341
--- /dev/null
+++ b/scmactst.scm
@@ -0,0 +1,160 @@
+;;;"scmactst.scm" test syntactic closures macros
+;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
+
+(define errs '())
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (set! errs (cons (list res expect (cons fun args)) errs))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+
+(require 'syntactic-closures)
+
+(macro:expand
+ '(define-syntax push
+ (syntax-rules ()
+ ((push item list)
+ (set! list (cons item list))))))
+
+(test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo)))
+
+(macro:expand
+ '(define-syntax push1
+ (transformer
+ (lambda (exp env)
+ (let ((item
+ (make-syntactic-closure env '() (cadr exp)))
+ (list
+ (make-syntactic-closure env '() (caddr exp))))
+ `(set! ,list (cons ,item ,list)))))))
+
+(test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo)))
+
+(macro:expand
+ '(define-syntax loop
+ (transformer
+ (lambda (exp env)
+ (let ((body (cdr exp)))
+ `(call-with-current-continuation
+ (lambda (exit)
+ (let f ()
+ ,@(map (lambda (exp)
+ (make-syntactic-closure env '(exit)
+ exp))
+ body)
+ (f)))))))))
+
+(macro:expand
+ '(define-syntax let1
+ (transformer
+ (lambda (exp env)
+ (let ((id (cadr exp))
+ (init (caddr exp))
+ (exp (cadddr exp)))
+ `((lambda (,id)
+ ,(make-syntactic-closure env (list id) exp))
+ ,(make-syntactic-closure env '() init)))))))
+
+(test 93 'let1 (macro:eval '(let1 a 90 (+ a 3))))
+
+(macro:expand
+ '(define-syntax loop-until
+ (syntax-rules
+ ()
+ ((loop-until id init test return step)
+ (letrec ((loop
+ (lambda (id)
+ (if test return (loop step)))))
+ (loop init))))))
+
+(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
+ (loop 3)))
+ 'loop
+ (macro:expand '(loop-until foo 3 #t 12 33)))
+
+(macro:expand
+ '(define-syntax loop-until1
+ (transformer
+ (lambda (exp env)
+ (let ((id (cadr exp))
+ (init (caddr exp))
+ (test (cadddr exp))
+ (return (cadddr (cdr exp)))
+ (step (cadddr (cddr exp)))
+ (close
+ (lambda (exp free)
+ (make-syntactic-closure env free exp))))
+ `(letrec ((loop
+ ,(capture-syntactic-environment
+ (lambda (env)
+ `(lambda (,id)
+ (,(make-syntactic-closure env '() `if)
+ ,(close test (list id))
+ ,(close return (list id))
+ (,(make-syntactic-closure env '()
+ `loop)
+ ,(close step (list id)))))))))
+ (loop ,(close init '()))))))))
+
+(test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
+ (loop 3)))
+ 'loop1
+ (macro:expand '(loop-until1 foo 3 #t 12 33)))
+
+(test '#t 'identifier (identifier? 'a))
+;;; this needs to setup ENV.
+;;;(test '#t 'identifier
+;;; (identifier? (macro:expand (make-syntactic-closure env '() 'a))))
+(test #f 'identifier (identifier? "a"))
+(test #f 'identifier (identifier? #\a))
+(test #f 'identifier (identifier? 97))
+(test #f 'identifier (identifier? #f))
+(test #f 'identifier (identifier? '(a)))
+(test #f 'identifier (identifier? '#(a)))
+
+(test '(#t #f)
+ 'syntax
+ (macro:eval
+ '(let-syntax
+ ((foo
+ (transformer
+ (lambda (form env)
+ (capture-syntactic-environment
+ (lambda (transformer-env)
+ (identifier=? transformer-env 'x env 'x)))))))
+ (list (foo)
+ (let ((x 3))
+ (foo))))))
+
+
+(test '(#f #t)
+ 'syntax
+ (macro:eval
+ '(let-syntax ((bar foo))
+ (let-syntax
+ ((foo
+ (transformer
+ (lambda (form env)
+ (capture-syntactic-environment
+ (lambda (transformer-env)
+ (identifier=? transformer-env 'foo
+ env (cadr form))))))))
+ (list (foo foo)
+ (foo bar))))))
+
+(newline)
+(cond ((null? errs) (display "Passed all tests"))
+ (else (display "errors were:") (newline)
+ (display "(got expected (call))") (newline)
+ (for-each (lambda (l) (write l) (newline)) errs)))
+(newline)