From 3a08648dabadc3719f34d08629375022245a774e Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 5 Feb 2010 03:22:09 +0000
Subject: [PATCH] Added a `running' state, which is visible only from inside
 the generator.  (Also considered making it an error when the generator is
 called while it is running, but that doesn't allow (yield (yield X)) fun.)

svn: r17982
---
 collects/scheme/generator.ss   | 28 +++++++++++++++++++---------
 collects/tests/mzscheme/for.ss |  9 ++++++++-
 2 files changed, 27 insertions(+), 10 deletions(-)

diff --git a/collects/scheme/generator.ss b/collects/scheme/generator.ss
index 03cc85c53c..068afb5b6e 100644
--- a/collects/scheme/generator.ss
+++ b/collects/scheme/generator.ss
@@ -55,10 +55,14 @@
   (let ([state 'fresh])
     (define (cont)
       (define yielder
+        ;; this `case-lambda' is ... um ... for "speed"...
         (case-lambda
-          [()  (shift-at yield-tag k (set! cont k) (values))]
-          [(v) (shift-at yield-tag k (set! cont k) v)]
-          [vs  (shift-at yield-tag k (set! cont k) (apply values vs))]))
+          [()  (set! state 'suspended)
+               (shift-at yield-tag k (set! cont k) (values))]
+          [(v) (set! state 'suspended)
+               (shift-at yield-tag k (set! cont k) v)]
+          [vs  (set! state 'suspended)
+               (shift-at yield-tag k (set! cont k) (apply values vs))]))
       (set! state 'running)
       (reset-at yield-tag
         (parameterize ([current-yielder yielder])
@@ -75,16 +79,22 @@
                 [rs  (set! cont (lambda () (apply values rs)))]))
           (set! state 'done)
           (cont))))
-    (define (err)
-      (error 'generator "cannot send a value to a ~a generator" state))
+    (define (err [what "send a value to"])
+      (error 'generator "cannot ~a a ~a generator" what state))
     (define generator
       (case-lambda
-        [()  (cont)]
+        [()  (if #t ; (memq state '(fresh suspended done))
+               (begin (set! state 'running) (cont))
+               (err "call"))]
         ;; yield-tag means return the state (see `generator-state' below)
         [(x) (cond [(eq? x yield-tag) state]
-                   [(eq? state 'running) (cont x)]
+                   [(memq state '(suspended running))
+                    (set! state 'running)
+                    (cont x)]
                    [else (err)])]
-        [xs  (if (eq? state 'running) (apply cont xs) (err))]))
+        [xs  (if (memq state '(suspended running))
+               (begin (set! state 'running) (apply cont xs))
+               (err))]))
     generator))
 
 ;; Get the state -- this is a hack: uses yield-tag as a hidden value that makes
@@ -93,7 +103,7 @@
 ;; deceived, but that will be harmless).
 (define (generator-state g)
   (let ([s (and (procedure? g) (procedure-arity-includes? g 1) (g yield-tag))])
-    (if (memq s '(fresh running done))
+    (if (memq s '(fresh running suspended done))
       s
       (raise-type-error 'generator-state "generator" g))))
 
diff --git a/collects/tests/mzscheme/for.ss b/collects/tests/mzscheme/for.ss
index 6b503b6c00..1d61983e4d 100644
--- a/collects/tests/mzscheme/for.ss
+++ b/collects/tests/mzscheme/for.ss
@@ -241,9 +241,16 @@
   (let ([g (generator (yield (yield (yield 1))))])
     (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g)))
   (let ([g (g)])
-    (test '(fresh 1 running 2 running 3 running last done)
+    (test '(fresh 1 suspended 2 suspended 3 suspended last done)
           list (generator-state g) (g)
                (generator-state g) (g)
+               (generator-state g) (g)
+               (generator-state g) (g 'last)
+               (generator-state g)))
+  (letrec ([g (generator (yield (generator-state g))
+                         (yield (generator-state g)))])
+    (test '(fresh running suspended running suspended last done)
+          list (generator-state g) (g)
                (generator-state g) (g)
                (generator-state g) (g 'last)
                (generator-state g))))