|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* MLTk, Tcl/Tk interface of OCaml *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Jacques Garrigue, Nagoya University Mathematics Dept. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(* Copyright 2004 Institut National de Recherche en Informatique et *)
|
|
Packit |
bd2e5d |
(* en Automatique and Kyoto University. All rights reserved. *)
|
|
Packit |
bd2e5d |
(* This file is distributed under the terms of the GNU Library *)
|
|
Packit |
bd2e5d |
(* General Public License, with the special exception on linking *)
|
|
Packit |
bd2e5d |
(* described in file LICENSE found in the OCaml source tree. *)
|
|
Packit |
bd2e5d |
(* *)
|
|
Packit |
bd2e5d |
(***********************************************************************)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
(* $Id$ *)
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let jobs : (unit -> unit) Queue.t = Queue.create ()
|
|
Packit |
bd2e5d |
let m = Mutex.create ()
|
|
Packit |
bd2e5d |
let with_jobs f =
|
|
Packit |
bd2e5d |
Mutex.lock m; let y = f jobs in Mutex.unlock m; y
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let loop_id = ref None
|
|
Packit |
bd2e5d |
let gui_safe () =
|
|
Packit |
bd2e5d |
!loop_id = Some(Thread.id (Thread.self ()))
|
|
Packit |
bd2e5d |
let running () =
|
|
Packit |
bd2e5d |
!loop_id <> None
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let has_jobs () = not (with_jobs Queue.is_empty)
|
|
Packit |
bd2e5d |
let n_jobs () = with_jobs Queue.length
|
|
Packit |
bd2e5d |
let do_next_job () = with_jobs Queue.take ()
|
|
Packit |
bd2e5d |
let async j x = with_jobs (Queue.add (fun () -> j x))
|
|
Packit |
bd2e5d |
let sync f x =
|
|
Packit |
bd2e5d |
if !loop_id = None then failwith "Tkthread.sync";
|
|
Packit |
bd2e5d |
if gui_safe () then f x else
|
|
Packit |
bd2e5d |
let m = Mutex.create () in
|
|
Packit |
bd2e5d |
let res = ref None in
|
|
Packit |
bd2e5d |
Mutex.lock m;
|
|
Packit |
bd2e5d |
let c = Condition.create () in
|
|
Packit |
bd2e5d |
let j x =
|
|
Packit |
bd2e5d |
let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m;
|
|
Packit |
bd2e5d |
Condition.signal c
|
|
Packit |
bd2e5d |
in
|
|
Packit |
bd2e5d |
async j x;
|
|
Packit |
bd2e5d |
Condition.wait c m;
|
|
Packit |
bd2e5d |
match !res with Some y -> y | None -> assert false
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let rec job_timer () =
|
|
Packit |
bd2e5d |
Timer.set ~ms:10 ~callback:
|
|
Packit |
bd2e5d |
(fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer())
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let thread_main () =
|
|
Packit |
bd2e5d |
try
|
|
Packit |
bd2e5d |
loop_id := Some (Thread.id (Thread.self ()));
|
|
Packit |
bd2e5d |
ignore (Protocol.openTk());
|
|
Packit |
bd2e5d |
job_timer();
|
|
Packit |
bd2e5d |
Protocol.mainLoop();
|
|
Packit |
bd2e5d |
loop_id := None;
|
|
Packit |
bd2e5d |
with exn ->
|
|
Packit |
bd2e5d |
loop_id := None;
|
|
Packit |
bd2e5d |
raise exn
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let start () =
|
|
Packit |
bd2e5d |
let th = Thread.create thread_main () in
|
|
Packit |
bd2e5d |
loop_id := Some (Thread.id th);
|
|
Packit |
bd2e5d |
th
|
|
Packit |
bd2e5d |
|
|
Packit |
bd2e5d |
let top = Widget.default_toplevel
|