X-Git-Url: https://git.distorted.org.uk/~mdw/fringe/blobdiff_plain/2bd37ef118cb1e41cb0e9e2332a9eb69ac2f2df4..HEAD:/scheme-fringe.scm

diff --git a/scheme-fringe.scm b/scheme-fringe.scm
index 53417dd..47b1266 100644
--- a/scheme-fringe.scm
+++ b/scheme-fringe.scm
@@ -3,8 +3,6 @@
 ;;; Scheme implementation of a `same-fringe' solver.  Assumes Chicken, but
 ;;; should port easily.
 
-(use syntax-case)			; Chicken-specfic
-
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 
@@ -52,7 +50,7 @@
   ;; this is #f.
   %calling-coroutine)
 
-(define (switch-cr coroutine . args)
+(define (resume coroutine . args)
   ;; Switch to COROUTINE, passing it ARGS.  When this coroutine is resumed
   ;; (by calling `switch', naturally) it will return the values passed as
   ;; arguments.  A new coroutine (made by `make-coroutine') receives these
@@ -76,32 +74,41 @@
     ((define-generator (name . args) . body)
      (define (name . args)
        (make-coroutine (lambda ()
-                         (begin . body)
-                         (switch-cr (calling-coroutine) #f #f)))))))
+			 (begin . body)
+			 (resume (calling-coroutine) #f #f)))))))
 
 (define (yield object)
   ;; Yield OBJECT from a generator.  The generator protocol returns two
   ;; values each time: either an object and #t, or #f twice to mark the end
   ;; of the sequence.
 
-  (with-values () (switch-cr (calling-coroutine) object #t) #f))
+  (with-values () (resume (calling-coroutine) object #t) #f))
+
+(define (reduce-generator func init gen)
+  ;; Call FUNC for each item in the generator GEN.
+  ;;
+  ;; We maintain a STATE, which is initially INIT.  For each ITEM produced by
+  ;; the generator, we replace the state by (FUNC ITEM STATE); finally, we
+  ;; return the final state.
+
+  (let loop ((state init))
+    (with-values (item any?) (resume gen)
+      (if any?
+	  (loop (func item state))
+	  state))))
 
 (define (list-generator gen)
   ;; Collect the elements generated by GEN into a list and return it.
 
-  (let loop ((l '()))
-    (with-values (it any?) (switch-cr gen)
-      (if any?
-	  (loop (cons it l))
-	  (reverse l)))))
+  (reverse (reduce-generator cons '() gen)))
 
 (define (same-generators? gen-a gen-b)
   ;; Return whether GEN-A and GEN-B generate the same elements in the same
   ;; order.
 
   (let loop ()
-    (with-values (a any-a?) (switch-cr gen-a)
-      (with-values (b any-b?) (switch-cr gen-b)
+    (with-values (a any-a?) (resume gen-a)
+      (with-values (b any-b?) (resume gen-b)
 	(cond ((not any-a?) (not any-b?))
 	      ((not any-b?) #f)
 	      ((eqv? a b) (loop))
@@ -161,9 +168,8 @@
 (define (main args)
   (cond ((null? args) (error "bad args"))
 	((null? (cdr args))
-	 (do ((l (list-generator (fringe (parse-tree (car args)))) (cdr l)))
-	     ((null? l))
-	   (write-char (car l)))
+	 (reduce-generator (lambda (ch ?) (write-char ch)) #f
+			   (fringe (parse-tree (car args))))
 	 (newline))
 	((null? (cddr args))
 	 (display (if (same-generators? (fringe (parse-tree (car args)))