; 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))))