#!/usr/local/bin/gsi-script (include "~~/lang@coptix.com/corps.scm") (define-macro (debug . stuff) `(warning-message "debug" #f ,@stuff #\newline)) (define (with-threads fn catcher-thread) (lambda (x) (thread-start! (make-thread (lambda () (thread-send catcher-thread (fn x))))))) (define (make-reporting-thread fn! . timeout) (let* ((sleep-time (if (null? timeout) 1 (car timeout))) (th (make-thread (lambda () (thread-report fn! (lambda () (thread-sleep! sleep-time))))))) (thread-specific-set! th -1) (thread-start! th))) (define (thread-report fn! pause!) (let ((nada (gensym)) (total (lambda () (thread-specific (current-thread))))) (let lp ((count 0) (debug '())) (pause!) (cond ((= count (total)) debug) (else (lp (fold-lazy (lambda (x acc) (fn! x) (++ acc)) count (make-lazy (lambda (exit) (let ((r (thread-receive 0 nada))) (cond ((eqv? r nada) (exit)) (else r)))))) (cons (list count: count total: (total)) debug))))))) (define (reporter-total! th total) (thread-specific-set! th total)) ;;;; Specifics (define queue (make-lazy (lambda (exit) (or (get-recips-sql) (exit))))) (define kermit (make-reporting-thread (lambda (x) (sql-send-reports x)))) (define (main2) (reporter-total! kermit (for-each-lazy (with-threads (lambda (r) (send-message helo sender r message)) kermit) queue)) (thread-join! kermit))