prompt and generator

[amirouche@hyper.dev]

I am trying to replace the use call/cc with prompts.

Here is the definition of 'make-coroutine-generator':

(define (make-coroutine-generator thunk)
   (define tag (make-prompt-tag))
   (define (run)
     (thunk (lambda (val) (abort-to-prompt tag val)))
     (eof-object))
   (lambda ()
     (call-with-prompt tag
                       run
                       (lambda (k ret)
                         (set! run k)
                         ret))))

Its unit tests pass correctly e.g.:

       (define g
         (make-coroutine-generator
          (lambda (yield) (let loop ((i 0))
                            (when (< i 3) (yield i) (loop (+ i 1)))))))

       (test '(0 1 2) (generator->list g))

Somewhere else, I have the following procedure:

(define (%mapping<=? comparator mapping1 mapping2)
   (assume (comparator? comparator))
   (assume (mapping? mapping1))
   (assume (mapping? mapping2))
   (pk 'gen1 (generator->list (tree-generator (mapping-tree mapping1))))
   ;;(pk 'gen2 (generator->list (tree-generator (mapping-tree 
mapping2))))
   (let ((less? (comparator-ordering-predicate (mapping-key-comparator 
mapping1)))
         (equality-predicate (comparator-equality-predicate comparator))
         (gen1 (tree-generator (mapping-tree mapping1)))
         (gen2 (tree-generator (mapping-tree mapping2))))
     (let loop ((item1 (gen1))
                (item2 (gen2)))
       (pk 'loop item1 item2)
       (cond
        ((eof-object? item1)
         #t)
        ((eof-object? item2)
         #f)
        (else
         (let ((key1 (car item1)) (value1 (cadr item1))
               (key2 (car item2)) (value2 (cadr item2)))
           (cond
            ((less? key1 key2)
             #f)
            ((less? key2 key1)
             (loop item1 (gen2)))
            ((equality-predicate value1 value2)
             (let* ((item1 (gen1))
                   (item2 (gen2)))
               (loop item1 item2)))
            (else
             #f))))))))

The above rely on a procedure 'generator-fold':

(define (generator-fold f seed . gs)
   (define (inner-fold seedx)
     (pk 'inner-fold seedx)
     (let ((vs (map (lambda (g) (g)) gs)))
       (pk 'inner-fold-vs vs)
       (if (any eof-object? vs)
           (pk 'out seedx)
           (inner-fold (pk 'new (apply f (pk 'args f seedx (append vs 
(list seedx)))))))))
   (pk 'generator-fold f seed gs)
   (inner-fold seed))

Which outputs the following:

;;; (generator-fold #<procedure cons (_ _)> () (#<procedure 22e9600 at 
scheme/generator.scm:132:2 ()>))

;;; (inner-fold ())

;;; (inner-fold-vs ((a 1)))

;;; (args #<procedure cons (_ _)> () ((a 1) ()))

;;; (new ((a 1)))

;;; (inner-fold ((a 1)))

;;; (inner-fold-vs ((b 2)))

;;; (args #<procedure cons (_ _)> () ((b 2) ()))

;;; (new ((b 2)))

;;; (inner-fold ((b 2)))

;;; (inner-fold-vs ((c 3)))

;;; (args #<procedure cons (_ _)> ((b 2)) ((c 3) ((b 2))))

;;; (new ((c 3) (b 2)))

;;; (inner-fold ((c 3) (b 2)))

;;; (inner-fold-vs (#<eof>))

;;; (out ())

;;; (gen1 ())

;;; (loop (a 1) (a 1))

;;; (loop (a 1) (b 2))

;;; (mapping=? #f)

The lines starting with ``;;; inner-fold'' should display the 
accumulator
of ``generator-fold'' called seedx. Here is only those:

;;; (inner-fold ())

;;; (inner-fold ((a 1)))

;;; (inner-fold ((b 2)))

;;; (inner-fold ((c 3) (b 2)))

At some point the (a 1) is lost.

Also in the end 'generator-fold' returns the empty list:

;;; (out ())

Is my definition of 'make-coroutine-generator' buggy or is it something 
else?

If you want to reproduce the issue live you can do the following:

   $ git clone https://git.sr.ht/~amz3/guile-r7rs r7rs
   $ cd r7rs
   $ git checkout wip-delimited-continuation
   $ ./bootstrap && ./configure && make
   $ ./pre-inst-env guile tests.scm