scheme-test-programs/logic/term-rewrite.scm

(define no-match (vector))

(define (compile-system system)
  (let* ((sys (compile-system^ system))
	 (step (lambda (term)
		 (sys (list term) '())))
	 (step? (lambda (term box)
		  (let ((res (step term)))
		    (if (eq? res no-match)
			term
			(begin (set-box! box #t)
			       res))))))
    (letrec ((deep-step (lambda (term box)
			  (if (pair? term)
			      (step? (cons (car term)
					   (map (lambda (t) (deep-step t box))
						(cdr term)))
				     box)
			      term))))
      (lambda (term)
	(let ((b (box #t)))
	  (let loop ((term term))
	    (if (unbox b)
		(begin (set-box! b #f)
		       (loop (deep-step term b)))
		term)))))))

(define (compile-system^ system)
  (if (null? system)
      (lambda (terms env) no-match)
      (let* ((pattern (compile-pattern (car (car system)) (box '())))
	     (result (evaluate (cadr (car system))))
	     (fk (compile-system^ (cdr system))))
	(lambda (terms env)
	  ((pattern
	    (lambda (nil env)
	      (if (null? nil)
		  (result env)
		  (fk terms '())))
	    (lambda ()
	      (fk terms '())))
	   terms env)))))

(define (compile-pattern pat seen)
  (cond ((or (boolean? pat) (number? pat))
	 (lambda (sk fk)
	   (lambda (terms env)
	     (if (null? terms)
		 (fk)
		 (if (equal? (car terms) pat)
		     (sk (cdr terms) env)
		     (fk))))))
	((symbol? pat)
	 (if (member pat (unbox seen))
	     (lambda (sk fk)
	       (lambda (terms env)
		 (if (null? terms)
		     (fk)
		     (cond ((assoc pat env) =>
			    (lambda (entry)
			      (if (equal? (car terms) (cdr entry))
				  (sk (cdr terms)
				      env)
				  (fk))))
			   (else (fk))))))
	     (begin
	       (set-box! seen (cons pat (unbox seen)))
	       (lambda (sk fk)
		 (lambda (terms env)
		   (if (null? terms)
		       (fk)
		       (sk (cdr terms)
			   (cons (cons pat (car terms)) env))))))))
	((pair? pat)
	 (let loop ((head (lambda (sk fk)
			    (lambda (terms env)
			      (if (null? terms)
				  (fk)
				  (let ((term (car terms))
					(terms (cdr terms)))
				    (if (and (pair? term)
					     (eq? (car term) (car pat))
					     (= (length term) (length pat)))
					(sk (append (cdr term) terms)
					    env)
					(fk)))))))
		    (tail (map* (lambda (pat) (compile-pattern pat seen)) (cdr pat))))
	   (if (null? tail)
	       head
	       (loop (lambda (sk fk) (head ((car tail) sk fk) fk))
		     (cdr tail)))))))

(define (lookup v env)
  (cond ((assoc v env) => cdr)
	(else (error 'lookup "unbound variable" v))))
(define (evaluate term)
  (cond ((or (boolean? term) (number? term))
	 (lambda (env) term))
	((symbol? term)
	 (lambda (env) (lookup term env)))
	((pair? term)
	 (let ((head (car term))
	       (tail (map evaluate (cdr term))))
	   (lambda (env)
	     (cons head (map (lambda (arg) (arg env)) tail)))))))