diff options
Diffstat (limited to 'scmactst.scm')
| -rw-r--r-- | scmactst.scm | 160 |
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) |