;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo)
(use goo/boot)
(use goo/loc)
(use goo/conditions)
(use time/%threads.c)

(dl %thread-create)
(dl %thread-yield)
(dl %thread-priority)
(dl %thread-priority-setter)
(dl %thread-detach)
(dl %thread-join)
(dl %thread-current)
(dl %thread-sleep)
(dl %thread-goo-thread)
(dl %thread-goo-thread-setter)

(dc <thread> (<any>))
  (dp thread-name (<thread> => (t? <sym>)) #f)
  (dp thread-priority (<thread> => <int>) 0)
  (dp thread-function (<thread> => <fun>) (fun ()))
  (dp! thread-handle (<thread> => <loc>))

(dm thread-yield () (%thread-yield))

(df main-thread-key ())

(dm new (x|(t< <thread>) args|... => <thread>)
  (def t (app-sup x args))
  (unless (== (thread-function t) main-thread-key)
    (def f (fun () 
             (set *current-handlers* '())
             (try <condition> 
               (fun (c r) (post "ERROR: %s" (describe-condition c)))
               ((thread-function t)))))
    (def h (%lb (%thread-create (tup f t))))
    (set (thread-handle t) h)
    (set (%thread-priority h) (%iu (thread-priority t))))
  t)

(set (%thread-goo-thread)
  (new <thread> 
    thread-name     'main
    thread-function main-thread-key
    thread-handle   (%lb (%thread-current))))

(ds spawn (,@body)
  `(new <thread> thread-function (fun () ,@body)))

(dm sleep (secs|<flo>)
  (%thread-sleep (%fu secs)))

(dm thread-current (=> <thread>)
  (%thread-goo-thread (%lb (%thread-current)))) 

(dm thread-join (t|<thread>)
  (%thread-join (%lu (thread-handle t))))

(df test-thread-1 ()
  (spawn (for ((i (below 3000))) (post "%d\n" i))))

(df test-thread-2 ()
  (spawn (for ((i (below 100))) (post "%d\n" i) (sleep 1.0))))

;; (df all-threads () (as <tup> (map 2nd (items *threads*))))

(export 
  <thread>
  thread-name
  thread-current
  thread-function
  thread-priority
  ;; thread-detach
  thread-yield
  ;; all-threads
  spawn
  sleep
  test-thread-1
  test-thread-2
  )
