Added `generator-state', implemented using a local state (which also

simplifies the code that raises an error from the last change).

svn: r17980

collects/scheme/generator.ss

@@ -4,7 +4,7 @@
          scheme/control
          scheme/stxparam scheme/splicing)
 
-(provide yield generator in-generator infinite-generator
+(provide yield generator generator-state in-generator infinite-generator
          sequence->generator sequence->repeated-generator)
 
 ;; (define-syntax-parameter yield
@@ -50,36 +50,48 @@
 (define yield-tag (make-continuation-prompt-tag))
 
 (define-syntax-rule (generator body0 body ...)
-  (let ()
+  (let ([state 'fresh])
-    (define cont
+    (define (cont)
-      (case-lambda
-        [()
       (define (yielder value)
         (shift-at yield-tag k (set! cont k) value))
+      (set! state 'running)
       (reset-at yield-tag
         (parameterize ([current-yielder yielder])
-             (define ret
           (call-with-values
               (lambda () (begin body0 body ...))
               ;; get here only on at the end of the generator
               (case-lambda
-                     ;; Note: in this case, the generator was invoked with no
+                ;; Note: in the first case, the generator was invoked with no
-                     ;; arguments, so returning no values is more symmetric.
+                ;; arguments, so returning no values is more symmetric.  But
-                     ;; But this is a common case, and probably people would
+                ;; this is a common case, and probably people would expect a
-                     ;; expect a void result more than no values.
+                ;; void result more than no values.
-                     [() void]
+                [()  (set! cont void)]
-                     [(r) (lambda () r)]
+                [(r) (set! cont (lambda () r))]
-                     [rs (lambda () (apply values rs))])))
+                [rs  (set! cont (lambda () (apply values rs)))]))
-             (set! cont (case-lambda
+          (set! state 'done)
-                          [() (ret)]
+          (cont))))
-                          [_ (error 'generator "cannot send values to a ~a"
+    (define (err)
-                                    "generator that has terminated")]))
+      (error 'generator "cannot send a value to a ~a generator" state))
-             (ret)))]
+    (define generator
-        [_ (error 'generator
+      (case-lambda
-                  "cannot send a value to a generator before it starts")]))
+        [()  (cont)]
-    (define (generator . xs) (apply cont xs))
+        ;; yield-tag means return the state (see `generator-state' below)
+        [(x) (cond [(eq? x yield-tag) state]
+                   [(eq? state 'running) (cont x)]
+                   [else (err)])]
+        [xs  (if (eq? state 'running) (apply cont xs) (err))]))
     generator))
 
+;; Get the state -- this is a hack: uses yield-tag as a hidden value that makes
+;; the generator return its state.  Protect against grabbing this tag (eg, with
+;; (generator-state values)) by inspecting the result (so it can still be
+;; 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))
+      s
+      (raise-type-error 'generator-state "generator" g))))
+
 (define-syntax-rule (infinite-generator body0 body ...)
   (generator (let loop () body0 body ... (loop))))
 

collects/tests/mzscheme/for.ss

@@ -239,7 +239,14 @@
   (let ([g (g)]) (test '(1 2 3) list (g) (g) (g)))
   (let ([g (g)]) (test '(1 2 3 10 10) list (g) (g) (g) (g 10) (g)))
   (let ([g (generator (yield (yield (yield 1))))])
-    (test '(1 2 3 4 4 4) list (g) (g 2) (g 3) (g 4) (g) (g))))
+    (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)
+          list (generator-state g) (g)
+               (generator-state g) (g)
+               (generator-state g) (g)
+               (generator-state g) (g 'last)
+               (generator-state g))))
 
 (let* ([helper (lambda (pred num)
                  (for ([i (in-range 0 3)]) (yield (pred (+ i num)))))]