(load "macromod.scm")

(define match-expansion
  (let ()
    (define (symbol-variable? x)
      (and (symbol? x)
	   (eqv? #\? (string-ref (symbol->string x) 0))))

    (define (match v p env)
      (and env
	   ;;(or (pretty-print `(match (v ,v) (p ,p) (env ,env))) #t)
	   (cond ((and (pair? v) (pair? p))
		  (match (cdr v) (cdr p) (match (car v) (car p) env)))
		 ((symbol-variable? p)
		  (cond
		   ((assq p env) => (lambda (cell)
				      (if (equal? (cdr cell) v)
					  env
					  #f)))
		   (else (cons (cons p v) env))))
		 ;; Have to be careful here - was using eqv?, but that
		 ;; didn't unify string literals. The only potential
		 ;; future problem here is vectors.
		 ((equal? v p) env)
		 (else #f))))

    (lambda (k source target . maybe-error)
      (call-with-current-continuation
       (lambda (return0)
	 (let* ((old-syntax-error syntax-error)
		(return (lambda (value)
			  (set! syntax-error old-syntax-error)
			  (return0 value))))
	   (set! syntax-error (lambda args
				(return
				 (if (null? maybe-error)
				     (k `(unexpected-syntax-error ,@args) #f)
				     (k `(expected-syntax-error ,@args)
					(match args (car maybe-error) '()))))))
	   (let* ((expanded (expand source (initial-eenv)))
		  (datum (parsed-expression->datum expanded)))
	     (return (k `(expanded-datum ,datum) (match datum target '()))))))))))

(define (match-dispatch k stx pat expected)
  (let ((result (syntax-dispatch stx (syntax-pattern-strip
				      (stx->syntax-pattern '() pat)))))
    (k result (equal? expected result))))

(define (match-dispatch/keys k stx keys pat expected)
  (let ((result (syntax-dispatch stx (syntax-pattern-strip
				      (stx->syntax-pattern keys pat)))))
    (k result (equal? expected result))))

(define (match-dispatch-levels k pat expected)
  (let ((result (syntax-pattern-result-levels (stx->syntax-pattern '() pat))))
    (k result (equal? expected result))))

(define *all-tests*
  `((rewriting-affects-lexicals-not-globals
     ,match-expansion
     (lambda (a b) (+ a b))
     (lambda (?a ?b) (+ ?a ?b)))

    (rewriting-affects-lexicals-not-literals
     ,match-expansion
     (lambda (a) (list a 'a))
     (lambda (?a) (list ?a 'a)))

    (rewriting-affects-lexicals-not-literals-2
     ,match-expansion
     (let-syntax ((x (lambda (s)
		       (syntax-case s ()
			 ((_ y) (syntax (lambda (y) (list y 'y))))))))
       (x a))
     (lambda (?y) (list ?y 'a)))

    (rewriting-affects-lexicals-not-literals-3
     ,match-expansion
     (lambda (a)
       (let-syntax ((x (lambda (s)
			 (syntax-case s ()
			   ((_ y) (syntax (list y 'y)))))))
	 (x a)))
     (lambda (?y) (list ?y 'a)))

    (rewriting-affects-lexicals-not-literals-3a
     ,match-expansion
     (lambda (a)
       (let-syntax ((x (lambda (s)
			 (syntax (list a 'a)))))
	 (x)))
     (lambda (?y) (list ?y 'a)))

    (rewriting-affects-lexicals-not-literals-3b
     ,match-expansion
     (lambda (a)
       (letrec-syntax ((x (lambda (s)
			    (syntax-case s ()
			      ((_ z) (syntax (x)))
			      ((_) (syntax 'a))))))
	 (x)))
     (lambda (?avar) 'a))

    (rewriting-affects-lexicals-not-literals-3c
     ,match-expansion
     (lambda (a)
       (let-syntax ((x (lambda (s)
			 (syntax (lambda (s2) (syntax (list a 'a)))))))
	 (let-syntax ((y (x)))
	   (y))))
     (lambda (?avar) (list ?avar 'a)))

    (rewriting-affects-lexicals-not-literals-4
     ,match-expansion
     (lambda (a)
       (let-syntax ((x (lambda (s)
			 (syntax-case s ()
			   ((_ y) (syntax (list y 'y a 'a)))))))
	 (lambda (a)
	   (x a))))
     (lambda (?aouter) (lambda (?ainner) (list ?ainner 'a ?aouter 'a))))

    (match-literal-in-shadowing-quote
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       ((plambda ((y 0))
				 (if (free-identifier=? (syntax y) 'a)
				     (syntax 'hello)
				     (syntax 'y)))
			(cadr (syntax->list y))))))
       (lambda (f) (f 'x (x x) (y y) y 'y (x y) (x f) (x (a)) (x a))))
     (lambda (?f) (?f 'x 'x (y y) y 'y 'y 'f '(a) 'hello)))

    (match-literal-in-shadowing-quote/syntax-case
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       (syntax-case y (a)
			 ((_ a) (syntax 'hello))
			 ((_ v) (syntax 'v))))))
       (lambda (f) (f 'x (x x) (y y) y 'y (x y) (x f) (x (a)) (x a))))
     (lambda (?f) (?f 'x 'x (y y) y 'y 'y 'f '(a) 'hello)))

    (match-with-shadowing-quote
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       ((plambda ((y 0))
				 (if (free-identifier=? (syntax y) 'a)
				     (syntax 'hello)
				     (syntax 'y)))
			(cadr (syntax->list y))))))
       (lambda (quote) (quote (x x) (y y) (x y) (x quote))))
     (lambda (?f) (?f 'x (y y) 'y 'quote)))

    (match-with-shadowing-quote/syntax-case
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       (syntax-case y (a)
			 ((_ a) (syntax 'hello))
			 ((_ v) (syntax 'v))))))
       (lambda (quote) (quote (x x) (y y) (x y) (x quote))))
     (lambda (?f) (?f 'x (y y) 'y 'quote)))

    (shadow-lambda-1
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       ((plambda ((y 0))
				 (syntax (lambda (x) y)))
			(cadr (syntax->list y))))))
       (lambda (lambda)
	 (x (lambda (lambda) lambda))))
     (lambda (?lambda) (lambda (?x) (?lambda (?lambda) ?lambda))))

    (shadow-lambda-1/syntax-case
     ,match-expansion
     (let-syntax ((x (lambda (y)
		       (syntax-case y ()
			 ((_ v) (syntax (lambda (x) v)))))))
       (lambda (lambda)
	 (x (lambda (lambda) lambda))))
     (lambda (?lambda) (lambda (?x) (?lambda (?lambda) ?lambda))))

    (syntax-case-1
     ,match-expansion
     (lambda (x)
       (syntax-case x ()
	 ((_ a (c ...) (b ...) ...)
	  (syntax '(((a b c) ...) ...)))))
     (lambda (?xouter)
       ((lambda (?x)
	  ((lambda (?dispatch-results)
	     (if ?dispatch-results
		 (apply (lambda (?_ ?a ?c ?b)
			  (cons (make-syntax-wrap 'quote '() '())
				(cons (map (lambda (?b)
					     (map (lambda (?c ?b)
						    (cons ?a (cons ?b (cons ?c '()))))
						  ?c
						  ?b))
					   ?b)
				      '())))
			?dispatch-results)
		 (syntax-error '"nonexhaustive match failure" ?x)))
	   (syntax-dispatch
	    ?x
	    '(any any #(list-of any) . #(list-of #(list-of any))))))
	?xouter)))

    (syntax-case-1a
     ,match-expansion
     (let-syntax ((foo (lambda (x)
			 (syntax-case x ()
			   ((_ a (c ...) (b ...) ...)
			    (syntax '(((a b c) ...) ...)))))))
       (foo 1 (2 3) (4 5) (6 7)))
     '(((1 4 2) (1 5 3)) ((1 6 2) (1 7 3))))

    (syntax-case-2
     ,match-expansion
     (lambda (x)
       (syntax-case x ()
	 ((_)
	  (even? 2)
	  x)))
     (lambda (?x)
       ((lambda (?y)
	  ((lambda (?z)
	     (if (if ?z (apply (lambda (?d2) (even? '2)) ?z) '#f)
		 (apply (lambda (?d) ?x) ?z)
		 (syntax-error '"nonexhaustive match failure" ?y)))
	   (syntax-dispatch ?y '(any . #(atom ())))))
	?x)))

    (syntax-case-2a
     ,match-expansion
     (let-syntax ((foo (lambda (x)
			 (syntax-case x ()
			   ((_ a)
			    (if (number? (syntax-object->datum (syntax a)))
				(even? (syntax-object->datum (syntax a)))
				#f)
			    (syntax 'yes))
			   ((_ a)
			    (number? (syntax-object->datum (syntax a)))
			    (syntax 'no))
			   ((_ a)
			    (syntax 'non-number))))))
       (foo 2)
       (foo f)
       (foo 3))
     (begin 'yes 'non-number 'no))

;     (syntax-case-3
;      ,match-expansion
;      (lambda (x)
;        (syntax-case x ()
; 	 ((_ a (c ...) (b ...) ...)
; 	  (syntax '(((a b c) ...) ...)))
; 	 ((ff)
; 	  (syntax ((lambda (r) (r 'ff)) 123)))))
;      ())

    (lambda-1
     ,match-expansion
     (lambda (x) x)
     (lambda (?x) ?x))

    (nested-lambda-1
     ,match-expansion
     (lambda (x) (lambda (y) x))
     (lambda (?x) (lambda (?y) ?x)))

    (if-1
     ,match-expansion
     (lambda (x y z) (if x y z))
     (lambda (?x ?y ?z) (if ?x ?y ?z)))

    (r5rs-pitfall-8-3
     ,match-expansion
     (let-syntax ((let (lambda (s)
			 (syntax-case s ()
			   ((_ ((var val) ...) body ...)
			    (syntax ((lambda (var ...) body ...) val ...))))))
		  (syntax-rules (lambda (s)
				  (syntax-case s ()
				    ((_ (key ...) (pattern template) ...)
				     (syntax (lambda (stx)
					       (syntax-case stx (key ...)
						 (pattern
						  (syntax template))
						 ...))))))))
       (let ((x 1))
	 (let-syntax ((foo (syntax-rules () ((_) 2))))
	   (define x (foo))
	   3)
	 x))
     ((lambda (?xouter) (begin (letrec ((?xinner '2)) '3) ?xouter)) '1))

    (internal-definitions
     ,match-expansion
     ((lambda ()
	(define (even? x) (if (zero? x) #t (odd? (- x 1))))
	(define (odd? x) (if (zero? x) #f (even? (- x 1))))
	(even? 3)))
     ((lambda ()
	(letrec ((?o (lambda (?x) (if (zero? ?x) '#f (?e (- ?x '1)))))
		 (?e (lambda (?y) (if (zero? ?y) '#t (?o (- ?y '1))))))
	  (?e '3)))))

    (syntax-deconstruction-1
     ,match-dispatch
     (1 (2 3))
     (a (b ...) (c d) ...)
     (1 (2 3) () ()))

    (syntax-deconstruction-2
     ,match-dispatch
     (1 (2 3) (4 5) (6 7))
     (a (b ...) (c d) ...)
     (1 (2 3) (4 6) (5 7)))

    (syntax-deconstruction-3
     ,match-dispatch
     (1 2 3)
     (a ...)
     ((1 2 3)))

    (syntax-deconstruction-4
     ,match-dispatch
     (1 2 3)
     (a b ...)
     (1 (2 3)))

    (syntax-deconstruction-5
     ,match-dispatch
     (1 2 3)
     (a (b ...) ...)
     #f)

    (syntax-deconstruction-6
     ,match-dispatch
     (1 (2 3) (4 5) (6 7))
     (a (b ...) ...)
     (1 ((2 3) (4 5) (6 7))))

    (syntax-deconstruction-7
     ,match-dispatch
     (1 (2 3) (4 5 "hi") (6 7))
     (a (b ...) ...)
     (1 ((2 3) (4 5 "hi") (6 7))))

    (syntax-deconstruction-8
     ,match-dispatch
     (1 (2 3) (4 5) (6 7))
     (a (b ...) (c ...) ...)
     (1 (2 3) ((4 5) (6 7))))

    (syntax-deconstruction-9
     ,match-dispatch
     (1 #(2 3) (#(4 re) hi 5) (#(6) 7))
     (a #(b ...) (#(c ...) x ...) ...)
     (1 (2 3) ((4 re) (6)) ((hi 5) (7))))

    (syntax-deconstruction-10
     ,match-dispatch
     ()
     (a ...)
     (()))

    (syntax-deconstruction-11
     ,match-dispatch
     (1 2 3)
     (a b c)
     (1 2 3))

    (syntax-deconstruction-12
     ,match-dispatch
     (1 2 3)
     (1 2 3)
     ())

    (syntax-deconstruction-13
     ,match-dispatch
     ("hi" "there")
     ("hi" "there")
     ())

    (syntax-deconstruction-14
     ,match-dispatch
     ("hi" "there")
     ("hi" a)
     ("there"))

    (syntax-deconstruction-15
     ,match-dispatch
     ("hi" "there")
     ("hi" a ...)
     (("there")))

    (syntax-deconstruction-16
     ,match-dispatch
     (test)
     ((x))
     #f)

    (syntax-deconstruction/keys-1
     ,match-dispatch/keys
     (((even? x) x) (else 3))
     (else)
     ((else exp ...) ...)
     #f)

    (syntax-deconstruction/keys-2
     ,match-dispatch/keys
     (((even? x) x) (else 3))
     (else)
     ((exp0 exp ...) (else exp1 ...))
     ((even? x) (x) (3)))

    (syntax-deconstruction/keys-3
     ,match-dispatch/keys
     (((even? x) x) (else 3))
     (even?)
     ((exp0 exp ...) (else exp1 ...))
     ((even? x) (x) else (3)))

    (syntax-deconstruction/levels-1
     ,match-dispatch-levels
     (a (b ...) (c d) ...)
     ((a 0) (b 1) (c 1) (d 1)))

    (syntax-deconstruction/levels-2
     ,match-dispatch-levels
     (a ...)
     ((a 1)))

    (syntax-deconstruction/levels-3
     ,match-dispatch-levels
     (a b ...)
     ((a 0) (b 1)))

    (syntax-deconstruction/levels-4
     ,match-dispatch-levels
     (a (b ...) ...)
     ((a 0) (b 2)))

    (syntax-deconstruction/levels-5
     ,match-dispatch-levels
     (a (b ...) (c ...) ...)
     ((a 0) (b 1) (c 2)))

    (syntax-deconstruction/levels-6
     ,match-dispatch-levels
     (a b c)
     ((a 0) (b 0) (c 0)))

    (syntax-deconstruction/levels-7
     ,match-dispatch-levels
     (1 2 3)
     ())

    (syntax-deconstruction/levels-8
     ,match-dispatch-levels
     ("hi" a)
     ((a 0)))

    (macro-in-macro
     ,match-expansion
     (let-syntax ((x (lambda (s)
		       (syntax-case s ()
			 ((_ y) (syntax y))))))
       (let-syntax ((z (lambda (s)
			 (syntax-case s ()
			   ((_ w) (syntax (x w)))))))
	 (z '1)))
     '1)

    (olegs-symbol-predicate-macro
     ,match-expansion
     (let-syntax ((syntax-rules (lambda (s)
				  (syntax-case s ()
				    ((_ (key ...) (pattern template) ...)
				     (syntax (lambda (stx)
					       (syntax-case stx (key ...)
						 (pattern
						  (syntax template))
						 ...))))))))
       (let-syntax ((symbol??
		     (syntax-rules ()
		       ((symbol?? (x . y) kt kf) kf)	; It's a pair, not a symbol
		       ((symbol?? #(x ...) kt kf) kf)	; It's a vector, not a symbol
		       ((symbol?? maybe-symbol kt kf)
			(let-syntax
			    ((test
			      (syntax-rules ()
				((test maybe-symbol t f) t)
				((test x t f) f))))
			  (test abracadabra kt kf))))))
	 (begin
	   (symbol?? "no" 'incorrect 'correct)
	   (symbol?? yes 'correct 'incorrect)
	   (symbol?? (no no) 'incorrect 'correct)
	   (symbol?? 'no 'incorrect 'correct)
	   (symbol?? #(no) 'incorrect 'correct)
	   (symbol?? 123 'incorrect 'correct))))
     (begin 'correct 'correct 'correct 'correct 'correct 'correct))

    (petrofsky-1
     ,match-expansion
     (let-syntax ((let (lambda (s)
			 (syntax-case s ()
			   ((_ ((var val) ...) body ...)
			    (syntax ((lambda (var ...) body ...) val ...))))))
		  (syntax-rules (lambda (s)
				  (syntax-case s ()
				    ((_ (key ...) (pattern template) ...)
				     (syntax (lambda (stx)
					       (syntax-case stx (key ...)
						 (pattern
						  (syntax template))
						 ...))))))))
       (let ((a 1))
	 (letrec-syntax
	     ((foo (syntax-rules ()
		     ((_ b)
		      (bar a b))))
	      (bar (syntax-rules ()
		     ((_ c d)
		      (cons c (let ((c 3))
				(list d c 'c)))))))
	   (let ((a 2))
	     (foo a)))))
     ((lambda (?aouter)
	((lambda (?ainner) (cons ?aouter ((lambda (?c) (list ?ainner ?c 'a)) '3)))
	 '2))
      '1))

    (simple-syntax-error
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax-case s () ((_ y) (syntax y))))))
       (x))
     #f
     ("nonexhaustive match failure" ?stx))

    (missing-body-in-lambda
     ,match-expansion
     (lambda ())
     #f
     ("No expression in body"))

    (missing-body-in-variable-definition
     ,match-expansion
     (lambda () (define x) x)
     #f
     ("Missing body in definition" ?x))

    (missing-body-in-function-definition
     ,match-expansion
     (lambda () (define (x)) x)
     #f
     ("No expression in body"))

    (nonsymbol-in-definition
     ,match-expansion
     (lambda () (define "x" 3) x)
     #f
     ("Definition must be variable or function def" ?xstx ?valstx))

    (illegal-syntax-for-definition
     ,match-expansion
     (lambda () (define) 1)
     #f
     ("Illegal syntax for definition" ?deftailstx))

    (pattern-variable-in-expression-context
     ,match-expansion
     (lambda () (let-syntax ((x (lambda (s) (syntax-case s () ((_ a) a))))) (x 123)))
     #f
     ("use of pattern-variable in expression context" ?varstx))

    (bad-if
     ,match-expansion
     (if)
     #f
     ("Illegal syntax in special form" (if)))

    (bad-if-no-branches
     ,match-expansion
     (if test)
     #f
     ("if needs at least one branch" (if test)))

    (bad-if-three-branches
     ,match-expansion
     (if test exp1 exp2 exp3)
     #f
     ("if needs two or fewer alternative branches" (if test exp1 exp2 exp3)))

    (set-string-identifier
     ,match-expansion
     (set! "hi" 3)
     #f
     ("set!: needs identifier to set" (set! "hi" 3)))

    (set-pair-identifier
     ,match-expansion
     (set! (foo) 3)
     #f
     ("set!: needs identifier to set" (set! (foo) 3)))

    (set-missing-expr
     ,match-expansion
     (set! foo)
     #f
     ("missing expression in set!" foo ()))

    (set-too-many-exprs
     ,match-expansion
     (set! foo bar baz)
     #f
     ("too many expressions in set!" foo (bar baz)))

    (pattern-too-few-ellipses
     ,match-expansion
     (syntax-case foo ()
       ((_ a ...) (syntax a)))
     #f
     ("pattern variable used with too few ellipses" ?varstx))

    (illegal-syntax-case-clause-1
     ,match-expansion
     (syntax-case foo ()
       "hi")
     #f
     ("Illegal syntax case clause" "hi"))

    (illegal-syntax-case-clause-2
     ,match-expansion
     (syntax-case foo ()
       (pat . rest))
     #f
     ("Illegal syntax case clause" (pat . rest)))

    (illegal-syntax-case-clause-2a
     ,match-expansion
     (syntax-case foo ()
       (pat))
     #f
     ("Illegal syntax case clause" (pat)))

    (illegal-syntax-case-clause-3
     ,match-expansion
     (syntax-case foo ()
       (pat guard template bogus))
     #f
     ("Too many forms in syntax-case clause" (pat guard template bogus)))

    (quote-too-long
     ,match-expansion
     (quote form bogus)
     #f
     ("quote expects single form" (quote form bogus)))

    (quote-too-short
     ,match-expansion
     (quote)
     #f
     ("Illegal syntax in special form" (quote)))

    (syntax-too-long
     ,match-expansion
     (syntax form bogus)
     #f
     ("syntax expects single form" (syntax form bogus)))

    (syntax-too-short
     ,match-expansion
     (syntax)
     #f
     ("Illegal syntax in special form" (syntax)))

    (body-contains-define
     ,match-expansion
     (lambda ()
       (x)
       (define y 3)
       (z))
     #f
     ("Define only valid at start of block" ?deftailstx))

    (illegal-position-for-define
     ,match-expansion
     (define a b)
     #f
     ("illegal location for definition" (define a b)))

    (non-identifier-macro-identifier
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax 'a))))
       (+ x 1))
     #f
     ("use of macro-transformer identifier as expression" ?identstx))

    (special-form-identifier-expression
     ,match-expansion
     (+ lambda 1)
     #f
     ("use of special-form as expression" ?identstx))

    (keywords-with-non-id
     ,match-expansion
     (syntax-case x (y "hi")
       ((_) (syntax 'a)))
     #f
     ("Illegal keyword list in syntax-case" (y "hi")))

    (keywords-with-ellipsis
     ,match-expansion
     (syntax-case x (y hi ...)
       ((_) (syntax 'a)))
     #f
     ("Illegal keyword list in syntax-case" (y hi ...)))

    (duplicate-pattern-vars
     ,match-expansion
     (syntax-case x ()
       ((_ ((a b) ...) ((c a))) (syntax (b ...))))
     #f
     ("Duplicate pattern-variable names in syntax-case clause"
      ((_ ((a b) ...) ((c a))) (syntax (b ...)))))

    (naked-ellipsis-in-template-1
     ,match-expansion
     (syntax ...)
     #f
     ("Ellipsis not preceded by template"))

    (naked-ellipsis-in-template-2
     ,match-expansion
     (syntax (a (...)))
     #f
     ("Ellipsis not preceded by template"))

    (naked-ellipsis-in-template-3
     ,match-expansion
     (syntax (a . ...))
     #f
     ("Ellipsis not preceded by template"))

    (ellipsis-twice-in-pattern
     ,match-expansion
     (syntax-case s ()
       ((_ ("hi" ... "there" ...)) (syntax 'what)))
     #f
     ("Ellipsis must not be followed by any pattern" ("hi" ... "there" ...)))

    (match-literal-repeat-ok
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax-case s ()
				   ((_ "hi" ...) (syntax 'ok))))))
       (x "hi" "hi" "hi")
       (x "hi")
       (x))
     (begin 'ok 'ok 'ok))

    (template-ellipsis-closes-no-variables
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax-case s ()
				   ((_ a ...) (syntax (list 'foo ...)))))))
       (x "hi" "hi" "hi"))
     #f
     ("Template ellipsis closes no variables"))

    (vars-in-vector-pattern
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax-case s ()
				   ((_ #(a ...)) (syntax (list 'a ...)))))))
       (x #(f g h)))
     (list 'f 'g 'h))

    (vars-in-vector-template
     ,match-expansion
     (let-syntax ((x (lambda (s) (syntax-case s ()
				   ((_ (a ...)) (syntax '#(a ...)))))))
       (x (f g h)))
     '#(f g h))

    (ellipsis-escaping
     ;; Interesting! This test case works fine with this expander, and
     ;; works fine with psyntax-in-chicken and psyntax-in-sisc, but
     ;; doesn't work with mzscheme. Mzscheme complains:
     ;;   "identifier used out of context in: x"
     ,match-expansion
     (let-syntax ((x (lambda (s)
		       (syntax-case s ()
			 ((_) (syntax (lambda (v)
					(syntax-case v ()
					  ((_ b (... ...))
					   (syntax (list 'b (... ...))))))))))))
       (let-syntax ((y (x)))
	 (y e f)))
     (list 'e 'f))

    (illegal-macro-in-binding
     ,match-expansion
     (let-syntax ((x 3))
       (+ 1 1))
     #f
     ("Invalid transformer in macro binding" (x 3)))

    (set-of-special
     ,match-expansion
     (set! lambda 6)
     #f
     ("use of special form identifier in set!" (set! lambda 6)))

    (set-of-macro
     ,match-expansion
     (let-syntax ((x (lambda (stx) (syntax '1))))
       (set! x 3))
     #f
     ("use of macro-transformer identifier in set!" ?setstx))

    (set-of-pattern-variable
     ,match-expansion
     (let-syntax ((x (lambda (stx)
		       (syntax-case stx ()
			 ((_ a b)
			  (begin (set! a 1)
				 (syntax b)))))))
       (x '123 '234))
     #f
     ("use of pattern-variable in expression context" ?setstx))

    (identifier-macro
     ,match-expansion
     (let-syntax ((x (cons 'macro! (lambda (s)
				     (syntax-case s ()
				       ((set! _ v) (syntax (list 'ha v)))
				       (_ (syntax 33)))))))
       (list 'x x 'y y)
       (x y)
       (set! y 1)
       (set! x 2)
       'done)
     (begin (list 'x '33 'y y) ('33 y) (set! y '1) (list 'ha '2) 'done))

    ))

(define *slow-tests*
  `((syntax-rule-stress-test
     ,match-expansion
     (letrec-syntax ((syntax-rules (lambda (s)
				     (syntax-case s ()
				       ((_ (key ...) (pattern template) ...)
					(syntax (lambda (stx)
						  (syntax-case stx (key ...)
						    (pattern
						     (syntax template))
						    ...)))))))
		     (aux
		      (lambda (s)
			(syntax-case s (define-syntax)
			  ((_ ((define-syntax name def) rest ...) (defelt ...))
			   (syntax (aux (rest ...) ((name def) defelt ...))))
			  ((_ (rest ...) ((name def) ...))
			   (syntax (letrec-syntax ((name def) ...)
				     rest ...))))))
		     (syntax-definitions
		      (lambda (s)
			(syntax-case s ()
			  ((_ def-or-expr ...)
			   (syntax (aux (def-or-expr ...) ())))))))
       (syntax-definitions
	(define-syntax ??!apply (syntax-rules (??!lambda) ((_ (??!lambda (bound-var . other-bound-vars) body) oval . other-ovals) (letrec-syntax ((subs (syntax-rules (??! bound-var ??!lambda) ((_ val k (??! bound-var)) (appl k val)) ((_ val k (??!lambda bvars int-body)) (subs-in-lambda val bvars (k bvars) int-body)) ((_ val k (x)) (subs val (recon-pair val k ()) x)) ((_ val k (x . y)) (subs val (subsed-cdr val k x) y)) ((_ val k x) (appl k x)))) (subsed-cdr (syntax-rules () ((_ val k x new-y) (subs val (recon-pair val k new-y) x)))) (recon-pair (syntax-rules () ((_ val k new-y new-x) (appl k (new-x . new-y))))) (subs-in-lambda (syntax-rules (bound-var) ((_ val () kp int-body) (subs val (recon-l kp ()) int-body)) ((_ val (bound-var . obvars) (k bvars) int-body) (appl k (??!lambda bvars int-body))) ((_ val (obvar . obvars) kp int-body) (subs-in-lambda val obvars kp int-body)))) (recon-l (syntax-rules () ((_ (k bvars) () result) (appl k (??!lambda bvars result))))) (appl (syntax-rules () ((_ (a b c d) result) (a b c d result)) ((_ (a b c) result) (a b c result)))) (finish (syntax-rules () ((_ () () exp) exp) ((_ rem-bvars rem-ovals exps) (??!apply (??!lambda rem-bvars exps) . rem-ovals))))) (subs oval (finish other-bound-vars other-ovals) body)))))
	(define-syntax ?car (syntax-rules () ((_ (x . y) k) (??!apply k x))))
	(define-syntax ?cdr (syntax-rules () ((_ (x . y) k) (??!apply k y))))
	(define-syntax ?cons (syntax-rules () ((_ x y k) (??!apply k (x . y)))))
	(define-syntax ?null? (syntax-rules () ((_ () k) (??!apply k #t)) ((_ x k) (??!apply k #f))))
	(define-syntax ?ifnull? (syntax-rules () ((_ () kt kf) (??!apply kt #t)) ((_ x kt kf) (??!apply kf #f))))
	(define-syntax ?pair? (syntax-rules () ((_ (a . b) k) (??!apply k #t)) ((_ not-pair k) (??!apply k #f))))
	(define-syntax ?ifpair? (syntax-rules () ((_ (a . b) kt kf) (??!apply kt #t)) ((_ not-pair kt kf) (??!apply kf #f))))
	(define-syntax ?true? (syntax-rules () ((_ x k) (??!apply k x))))
	(define-syntax ?iftrue? (syntax-rules () ((_ #f kt kf) (??!apply kf #f)) ((_ x kt kf) (??!apply kt #t))))
	(define-syntax ?append (syntax-rules () ((_ (x ...) (y ...) k) (??!apply k (x ... y ...)))))
	(define-syntax ?ifeq? (syntax-rules () ((_ (x . y) b kt kf) (??!apply kf #f)) ((_ () b kt kf) (??!apply kf #f)) ((_ a b _kt _kf) (let-syntax ((aux (syntax-rules (a) ((_ a kt kf) (??!apply kt #t)) ((_ other kt kf) (??!apply kf #f))))) (aux b _kt _kf)))))
	(define-syntax ?ifmemq? (syntax-rules () ((_ a lst kt kf) (?ifpair? lst (??!lambda (_) (?car lst (??!lambda (x) (?ifeq? a (??! x) (??!lambda (_) (??!apply kt #t)) (??!lambda (_) (?cdr lst (??!lambda (tail) (?ifmemq? a (??! tail) kt kf)))))))) (??!lambda (_) (??!apply kf #f))))))
	(define-syntax ?number-zero (syntax-rules () ((_ k) (??!apply k ()))))
	(define-syntax ?number-two (syntax-rules () ((_ k) (??!apply k ((()))))))
	(define-syntax ?incr (syntax-rules () ((_ n k) (??!apply k (n)))))
	(define-syntax ?decr (syntax-rules () ((_ (n) k) (??!apply k n))))
	(define-syntax ?less-than-two? (syntax-rules () ((_ ((n)) k) (??!apply k #f)) ((_ x k) (??!apply k #t))))
	(define-syntax ?ifless-than-two? (syntax-rules () ((_ ((n)) kt kf) (??!apply kf #f)) ((_ x kt kf) (??!apply kt #t))))
	(define-syntax ?number-zero? (syntax-rules () ((_ () k) (??!apply k #t)) ((_ x k) (??!apply k #f))))
	(define-syntax ?ifnumber-zero? (syntax-rules () ((_ () kt kf) (??!apply kt #t)) ((_ x kt kf) (??!apply kf #f))))
	(define-syntax ?iota (syntax-rules () ((_ _?n _?kg1029) (letrec-syntax ((?loop (syntax-rules () ((_ _?currg1031 _?counterg1032 _?kg1030) (?ifless-than-two? _?counterg1032 (??!lambda (g1033) (??!apply _?kg1030 ())) (??!lambda (g1034) (?incr _?currg1031 (??!lambda (g1036) (?decr _?counterg1032 (??!lambda (g1037) (?loop (??! g1036) (??! g1037) (??!lambda (g1035) (?cons _?currg1031 (??! g1035) _?kg1030))))))))))))) (?number-two (??!lambda (g1038) (?loop (??! g1038) _?n _?kg1029)))))))
	(define-syntax ?sieve (syntax-rules () ((_ _?lst _?kg1039) (letrec-syntax ((?choose-pivot (syntax-rules () ((_ _?lstg1041 _?kg1040) (?ifnull? _?lstg1041 (??!lambda (g1042) (??!apply _?kg1040 _?lstg1041)) (??!lambda (g1043) (?car _?lstg1041 (??!lambda (g1057) (?number-zero? (??! g1057) (??!lambda (g1044) (?iftrue? (??! g1044) (??!lambda (g1045) (?car _?lstg1041 (??!lambda (g1046) (?cdr _?lstg1041 (??!lambda (g1048) (?choose-pivot (??! g1048) (??!lambda (g1047) (?cons (??! g1046) (??! g1047) _?kg1040)))))))) (??!lambda (g1049) (?car _?lstg1041 (??!lambda (g1050) (?car _?lstg1041 (??!lambda (g1053) (?car _?lstg1041 (??!lambda (g1056) (?decr (??! g1056) (??!lambda (g1054) (?cdr _?lstg1041 (??!lambda (g1055) (?do-sieve (??! g1053) (??! g1054) (??! g1055) (??!lambda (g1052) (?choose-pivot (??! g1052) (??!lambda (g1051) (?cons (??! g1050) (??! g1051) _?kg1040)))))))))))))))))))))))))) (?do-sieve (syntax-rules () ((_ _?stepg1059 _?currentg1060 _?lstg1061 _?kg1058) (?ifnull? _?lstg1061 (??!lambda (g1062) (??!apply _?kg1058 _?lstg1061)) (??!lambda (g1063) (?ifnumber-zero? _?currentg1060 (??!lambda (g1064) (?number-zero (??!lambda (g1065) (?decr _?stepg1059 (??!lambda (g1067) (?cdr _?lstg1061 (??!lambda (g1068) (?do-sieve _?stepg1059 (??! g1067) (??! g1068) (??!lambda (g1066) (?cons (??! g1065) (??! g1066) _?kg1058)))))))))) (??!lambda (g1069) (?car _?lstg1061 (??!lambda (g1070) (?decr _?currentg1060 (??!lambda (g1072) (?cdr _?lstg1061 (??!lambda (g1073) (?do-sieve _?stepg1059 (??! g1072) (??! g1073) (??!lambda (g1071) (?cons (??! g1070) (??! g1071) _?kg1058))))))))))))))))) (?choose-pivot _?lst _?kg1039)))))
	(define-syntax ?is-prime (syntax-rules () ((_ _?n _?kg1074) (?iota _?n (??!lambda (g1081) (?sieve (??! g1081) (??!lambda (g1080) (?reverse (??! g1080) (??!lambda (g1079) (?car (??! g1079) (??!lambda (g1078) (?number-zero? (??! g1078) (??!lambda (g1075) (?iftrue? (??! g1075) (??!lambda (g1076) (??!apply _?kg1074 composite)) (??!lambda (g1077) (??!apply _?kg1074 prime))))))))))))))))
	(define-syntax ?reverse (syntax-rules () ((_ _?lst _?kg1082) (letrec-syntax ((?loop (syntax-rules () ((_ _?lstg1084 _?accumg1085 _?kg1083) (?ifnull? _?lstg1084 (??!lambda (g1086) (??!apply _?kg1083 _?accumg1085)) (??!lambda (g1087) (?cdr _?lstg1084 (??!lambda (g1088) (?car _?lstg1084 (??!lambda (g1090) (?cons (??! g1090) _?accumg1085 (??!lambda (g1089) (?loop (??! g1088) (??! g1089) _?kg1083))))))))))))) (?loop _?lst () _?kg1082)))))
	(?is-prime (((((()))))) (??!lambda (x) (display (quote (??! x)))))
	(newline)))
     ;; This is the expected result:
     (begin (display 'prime) (newline)))

    ))

(define (run-tests include-slow-tests tests-to-run)
  (define (report passes fails)
    (let ((n-pass (length passes))
	  (n-fail (length fails)))
      (for-each pretty-print (map (lambda (entry)
				    `((name ,(cadr entry))
				      (result ,(car entry))
				      (args ,(cdddr entry))))
				  fails))
      (newline)
      (display `(,n-pass passes and ,n-fail fails))
      (newline)
      (zero? n-fail)))

  (let loop ((tests (if include-slow-tests
			(append *all-tests* *slow-tests*)
			*all-tests*))
	     (passes '())
	     (fails '()))
    (if (null? tests)
	(report passes fails)
	(let* ((test (car tests))
	       (rest (cdr tests))
	       (test-name (car test))
	       (driver (cadr test))
	       (args (cddr test)))
	  (if (or (null? tests-to-run)
		  (member test-name tests-to-run))
	      (apply driver
		     (lambda (datum matched)
		       (if matched
			   (loop rest (cons (cons datum test) passes) fails)
			   (loop rest passes (cons (cons datum test) fails))))
		     args)
	      (loop rest passes fails))))))

(define (read-from-string str)
  (read (open-input-string str)))

(let ((run-slow-tests? (member "+slow" (command-line-arguments))))
  (exit (if (run-tests run-slow-tests?
		       (map read-from-string (command-line-arguments)))
	    0
	    1)))