diff options
Diffstat (limited to 'syntest1.scm')
| -rw-r--r-- | syntest1.scm | 166 |
1 files changed, 166 insertions, 0 deletions
diff --git a/syntest1.scm b/syntest1.scm new file mode 100644 index 0000000..f10be86 --- /dev/null +++ b/syntest1.scm @@ -0,0 +1,166 @@ +;Most of the tests themselves are taken from William Clinger's reference +;implementation of syntax-rules, `macros.will' in the Scheme repository +;at ftp.cs.indiana.edu + +;Copyright 1992 William Clinger + +;Permission to copy this software, in whole or in part, to use this +;software for any lawful purpose, and to redistribute this software +;is granted subject to the restriction that all copies made of this +;software must include this copyright notice in full. + +;I also request that you send me a copy of any improvements that you +;make to this software so that they may be incorporated within it to +;the benefit of the Scheme community. + + +(require 'macro) + +(define synerrs '()) + +(define-syntax test + (syntax-rules () + ((test ?exp ?ans) + (begin + (display '?exp) + (display " ==> ") + (let* ((exp (copy-tree '?exp)) + (x ?exp) + #+f(x (eval (macro:expand '?exp))) + ) + (display x) + (newline) + (or (equal? x ?ans) + (begin + (set! synerrs + (cons (list x ?ans '?exp) synerrs)) + (display "ERROR: expected ") + (display ?ans) + (newline)))))) + ((test ?exp0 ?exp1 ?exp2 ...) + (begin (display '?exp0) + (newline) + ?exp0 (test ?exp1 ?exp2 ...))))) + +(test (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m)))) + 'outer) + +(test (let-syntax ((when (syntax-rules + () + ((when ?test ?stmt1 ?stmt2 ...) + (if ?test (begin ?stmt1 ?stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if)) + 'now) + +(test (letrec-syntax + ((or (syntax-rules + () + ((or) #f) + ((or ?e) ?e) + ((or ?e1 ?e2 ...) + (let ((temp ?e1)) + (if temp temp (or ?e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (or x + (let temp) + (if y) + y))) + 7) + +(test (let ((=> #f)) + (cond (#t => 'ok))) + 'ok) + +; This syntax of set*! matches that of an example in the R4RS. +; That example was put forth as an example of a hygienic macro +; that supposedly couldn't be written using syntax-rules. Hah! + +(test (define-syntax set*! + (syntax-rules + () + ((set*! (?var ?val) ...) + (set*!-help (?val ...) () (?var ?val) ...)))) + (define-syntax set*!-help + (syntax-rules + () + ((set*!-help () (?temp ...) (?var ?val) ...) + (let ((?temp ?val) ...) + (set! ?var ?temp) ...)) + ((set*!-help (?var1 ?var2 ...) ?temps ?assignments ...) + (set*!-help (?var2 ...) (temp . ?temps) ?assignments ...)))) + (let ((x 3) + (y 4) + (z 5)) + (set*! (x (+ x y z)) + (y (- x y z)) + (z (* x y z))) + (list x y z)) + + '(12 -6 60)) + +(test (let ((else #f)) + (cond (#f 3) + (else 4) + (#t 5))) + 5) + +(test (define-syntax push + (syntax-rules () + ((push item place) + (set! place (cons item place))))) + (let* ((cons (lambda (name) + (case name + ((phil) '("three-card monte")) + ((dick) '("secret plan to end the war" + "agnew" + "not a crook")) + ((jimmy) '("why not the best")) + ((ron) '("abolish the draft" + "balance the budget")) + (else '())))) + (scams (cons 'phil))) + (push (car (cons 'jimmy)) scams) + (push (cadr (cons 'ron)) scams) + scams) + '("balance the budget" "why not the best" "three-card monte")) + +(test (define-syntax replic + (syntax-rules () + ((_ (?x ...) (?y ...)) + (let ((?x (list ?y ...)) ...) + (list ?x ...))))) + (replic (x y z) (1 2)) + '((1 2) (1 2) (1 2))) + +;; The behavior of this one is one is not specified by R5RS, below +;; is what SCM does. +;(test (define-syntax spread +; (syntax-rules () +; ((_ ?x (?y ...)) +; '(((?x ?y) ...))))) +; (spread x (1 2 3)) +; '(((x 1) (x 2) (x 3)))) + +(cond + ((null? synerrs) + (newline) + (display "Passed all tests\n") + (display "Load \"syntest2\" to rewrite derived expressions and test\n")) + (else + (newline) + (display "FAILED, errors were:") + (newline) + (display "(got expected call)") + (newline) + (for-each (lambda (l) (write l) (newline)) synerrs) + (newline))) + |