diff --git a/define-library.scm b/define-library.scm index 03cfbe9..e7f54fb 100644 --- a/define-library.scm +++ b/define-library.scm @@ -16,6 +16,8 @@ (##include "syntax.scm") (##include "syntaxrulesxform.scm") +(##include "syntaxcasexform.scm") +(##include "syntaxxform.scm") (define-runtime-syntax define-syntax (lambda (src) @@ -28,6 +30,20 @@ (define-runtime-syntax syntax-rules syn#syntax-rules-form-transformer) +(define-runtime-syntax syntax-case + syn#syntax-case-form-transformer) + +(define-runtime-syntax syntax + (lambda (src) (syn#syntax-form-transformer src '()))) + +(define-runtime-syntax macro + (lambda (src) + (let ((locat (##source-locat src))) + (##make-source + `(##lambda (##src) + (##apply (##lambda ,@(cdr (##source-strip src))) (##cdr (##source-strip ##src)))) + locat)))) + ;;;============================================================================ (define (keep keep? lst) @@ -582,29 +598,25 @@ (pair? (cdr expr)) (symbol? (##source-strip (cadr expr))) (pair? (cddr expr)) - (let ((x (##source-strip (caddr expr)))) - (and (pair? x) - (eq? (##source-strip (car x)) 'syntax-rules))) (null? (cdddr expr)))) (done) (let ((id (##source-strip (cadr expr))) - (crules (syn#syntax-rules->crules (caddr expr)))) + (form (caddr expr))) - (define (generate-local-macro-def id crules expr-src) + (define (generate-local-macro-def id form expr-src) (let ((locat (##source-locat expr-src))) (##make-source `(##define-syntax ,id - (##lambda (##src) - (syn#apply-rules ',crules ##src))) + ,form) locat))) ;; replace original define-syntax by local macro def ;; to avoid having to load syntax-rules implementation (set-car! expr-srcs - (generate-local-macro-def id crules expr-src)) + (generate-local-macro-def id form expr-src)) (loop (cdr expr-srcs) - (cons (cons id crules) + (cons (cons id form) rev-macros)))))))) (let ((form (##source-strip src))) @@ -684,10 +696,7 @@ (string-append (idmap-namespace idmap) (symbol->string id))) - (##lambda (src) - (syn#apply-rules - (##quote ,(cdr m)) - src)))) + ,(cdr m))) '()))) (idmap-macros idmap)))))) diff --git a/test.scm b/test.scm index d702dfc..46f746b 100644 --- a/test.scm +++ b/test.scm @@ -15,6 +15,7 @@ (begin (define skip-test #f) + (define z 10) (unless skip-test @@ -22,4 +23,7 @@ (pp (digest-string "" 'sha-1 'hex)) ;; should give "a9993e364706816aba3e25717850c26c9cd0d89d" - (pp (digest-string "abc" 'sha-1 'hex))))) + (pp (digest-string "abc" 'sha-1 'hex))) + + (when z + (pp (addn 5 z))))) diff --git a/when-unless.scm b/when-unless.scm index c38f650..f68b20e 100644 --- a/when-unless.scm +++ b/when-unless.scm @@ -7,14 +7,18 @@ (import (only (gambit) if not begin)) ;; required by expansions of when and unless - (export when unless) + (export when unless addn) (begin + (define-syntax addn + (macro args + `(##+ ,(car args) ,(cadr args)))) (define-syntax when - (syntax-rules () - ((_ test expr expr* ...) - (if test (begin expr expr* ...))))) + (lambda (x) + (syntax-case x () + ((_ test e e* ...) + #'(if test (begin e e* ...)))))) (define-syntax unless (syntax-rules ()