Unnamed Fossil Project

;
;       THREADS-TESTS
;               Test methods for THREADS module.
;       HISTORY
;               10.11.2011              vasalvit
;                       First version
;
(load "threads.scm")

(let ()
        (threads-init)
        (letrec (
                [print (lambda (text)
                        (display text) (newline))]
                [third (lambda ()
                        (thread-need-main)
                        (print "Third from MAIN")
                        (main-send #f))]
                [second (lambda ()
                        (thread-need-background)
                        (print "Second from BACKGROUND")
                        (execute-on-main third))]
                [first (lambda ()
                        (thread-need-main)
                        (print "First from MAIN")
                        (execute-in-background second))]
                [loop (lambda ()
                        (print "Started")
                        (assert (eq? #f (main-loop)))
                        (print "Completed"))])
                (execute-on-main first)
                (loop)
        )
        (threads-term)
)

;
;       THREADS
;               Methods for working with threads.
;       HISTORY
;               10.11.2011              vasalvit
;                       First version.
;
(require-extension mailbox)
(require-extension srfi-18)
(require-extension defstruct)

;       THREAD-IS-MAIN
;               Return TRUE if current thread is MAIN thread.
;       THREAD-NEED-MAIN
;               Verify that current thread is MAIN thread.
(define _main-thread_ #f)
(define (thread-is-main)
        (eq? _main-thread_ (current-thread)))
(define (thread-need-main)
        (assert (thread-is-main) "Required MAIN thread"))
(define (thread-need-background)
        (assert (not (thread-is-main)) "Required BACKGROUND thread"))

;       THREADS-READY
;               TRUE if library initialized.
(define _main-mailbox_ #f)
(define (threads-ready)
        (not (eq? _main-mailbox_ #f)))
(define (threads-verify)
        (assert (threads-ready) "Threads library not initialized"))

;       THREADS-INIT
;       THREADS-TERM
;               Initialization and termination threads.
(define (threads-init)
        (assert (not (threads-ready)) "Threads library already initialized")
        (set! _main-thread_ (current-thread))
        (set! _main-mailbox_ (make-mailbox "MAIN")))
(define (threads-term)
        (threads-verify)
        (set! _main-thread_ #f)
        (set! _main-mailbox_ #f))

;       MAIN-LOOP
;               Returns next event from MAIN thread.
(define (main-loop)
        (threads-verify)
        (thread-need-main)
        (let ((object (mailbox-receive! _main-mailbox_)))
                (cond
                        [(procedure? object) (begin
                                (object)
                                (main-loop))]
                        [else object])))

;       MAIN-SEND
;               Send specified object to MAIN thread.
(define (main-send object)
        (threads-verify)
        (mailbox-send! _main-mailbox_ object))

;       EXECUTE-IN-BACKGROUND
;               Create new thread, execute one function, destroy thread.
(define (execute-in-background proc)
        (threads-verify)
        (assert (procedure? proc))
        (thread-start! (make-thread proc)))

;       EXECUTE-ON-MAIN
;               Send function to main thread for executing.
(define (execute-on-main proc)
        (threads-verify)
        (assert (procedure? proc))
        (mailbox-send! _main-mailbox_ proc))