[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

prompt and generator

From: amirouche
Subject: prompt and generator
Date: Sun, 05 May 2019 18:48:52 +0200
User-agent: Roundcube Webmail/1.3.8

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)))
  (lambda ()
    (call-with-prompt tag
                      (lambda (k ret)
                        (set! run k)

Its unit tests pass correctly e.g.:

      (define g
         (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)
       ((eof-object? item1)
       ((eof-object? item2)
        (let ((key1 (car item1)) (value1 (cadr item1))
              (key2 (car item2)) (value2 (cadr item2)))
           ((less? key1 key2)
           ((less? key2 key1)
            (loop item1 (gen2)))
           ((equality-predicate value1 value2)
            (let* ((item1 (gen1))
                  (item2 (gen2)))
              (loop item1 item2)))

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 r7rs
  $ cd r7rs
  $ git checkout wip-delimited-continuation
  $ ./bootstrap && ./configure && make
  $ ./pre-inst-env guile tests.scm

reply via email to

[Prev in Thread] Current Thread [Next in Thread]