; incremental sieve of eratosthenes

(define-syntax while
  (syntax-rules ()
    ((while pred? body ...)
      (do () ((not pred?)) body ...))))

(define (identity x) x)

(define-syntax define-generator
  (lambda (x)
    (syntax-case x (lambda)
      ((stx name (lambda formals e0 e1 ...))
         (with-syntax ((yield (datum->syntax (syntax stx) 'yield)))
           (syntax (define name
             (lambda formals
               (let ((resume #f) (return #f))
                 (define yield
                   (lambda args
                     (call-with-current-continuation
                      (lambda (cont)
                        (set! resume cont)
                        (apply return args)))))
                 (lambda ()
                   (call-with-current-continuation
                    (lambda (cont)
                      (set! return cont)
                      (cond (resume (resume))
                      (else (let () e0 e1 ...)
                            (error 'name "unexpected return"))))))))))))
        ((stx (name . formals) e0 e1 ...)
          (syntax (stx name (lambda formals e0 e1 ...)))))))

(define-generator (primegen)
  (yield 2) (yield 3)
  (let* ((ps (primegen))
         (p (and (ps) (ps)))
         (q (* p p))
         (d (make-hashtable identity =)))
    (define (add x s)
      (while (hashtable-contains? d x)
        (set! x (+ x s)))
      (hashtable-set! d x s))
    (do ((c (+ p 2) (+ c 2))) (#f)
      (cond ((hashtable-contains? d c)
              (let ((s (hashtable-ref d c #f)))
                (hashtable-delete! d c)
                (add (+ c s) s)))
            ((< c q) (yield c))
            (else (add (+ c p p) (+ p p))
                  (set! p (ps))
                  (set! q (* p p)))))))

(let ((ps (primegen)))
  (do ((i 0 (+ i 1)) (p 0 (ps)))
    ((= i 10000) (display p) (newline))))