diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm index 5ee429fc..5eeca5e7 100644 --- a/tests/syntax-tests.scm +++ b/tests/syntax-tests.scm @@ -1,6 +1,9 @@ (cond-expand - (modules (import (chibi) (only (chibi test) test-begin test test-end))) + (modules + (import (chibi) + (only (chibi test) test-begin test test-error test-end) + (only (meta) environment))) (else #f)) (test-begin "syntax") @@ -75,3 +78,74 @@ (test '(2 1) (asd 1 2))) (test-end) + +(cond-expand + ;; can only test identifier-syntax with access to modules (though + ;; this could be fixed in theory) + (modules + (test-begin "identifier syntax") + (define syntax-test-env (environment '(chibi))) + + (eval + '(define-syntax low-level-id-macro + (er-macro-transformer* + (lambda (expr rename compare) + (if (pair? expr) + (list (rename 'quote) 'operator) + (list (rename 'quote) 'operand))))) + syntax-test-env) + + (test 'operator (eval '(low-level-id-macro) syntax-test-env)) + (test 'operand (eval 'low-level-id-macro syntax-test-env)) + (test-error (eval '(set! low-level-id-macro 'foo) syntax-test-env)) + + (eval + '(define-syntax low-level-vt + (make-variable-transformer + (er-macro-transformer* + (lambda (expr rename compare) + (list (rename 'quote) + (if (pair? expr) + (if (compare (car expr) (rename 'set!)) + 'set + 'app) + 'ref)))))) + syntax-test-env) + + (test 'set (eval '(set! low-level-vt 'foo) syntax-test-env)) + (test 'app (eval '(low-level-vt) syntax-test-env)) + (test 'ref (eval 'low-level-vt syntax-test-env)) + + (eval '(define p (cons 1 2)) syntax-test-env) + (eval '(define-syntax p.car (identifier-syntax (car p))) syntax-test-env) + (eval + '(define-syntax p.cdr + (identifier-syntax + (_ (cdr p)) + ((set! _ v) (set-cdr! p v)))) + syntax-test-env) + + (test 1 (eval 'p.car syntax-test-env)) + (test-error (eval '(set! p.car 0) syntax-test-env)) + (test 2 (eval 'p.cdr syntax-test-env)) + (test 3 (eval + '(begin + (set! p.cdr 3) + (cdr p)) + syntax-test-env)) + + ;; weirdnesses: syntax that refers to its own name and uses ellipsis + (eval + '(define-syntax sr-id-macro + (identifier-syntax + (name 'name) + ((set! name (val ...)) (cons 'name '(val ...))))) + syntax-test-env) + + (test 'sr-id-macro (eval 'sr-id-macro syntax-test-env)) + (test '(sr-id-macro 1 2 3) + (eval '(set! sr-id-macro (1 2 3)) + syntax-test-env)) + + (test-end)) + (else #f))