diff options
Diffstat (limited to 'otherlibs/labltk/support/protocol.ml')
| -rw-r--r-- | otherlibs/labltk/support/protocol.ml | 144 |
1 files changed, 35 insertions, 109 deletions
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index e6c378504..cb8bcbb33 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -1,21 +1,22 @@ -(***********************************************************************) -(* *) -(* MLTk, Tcl/Tk interface of Objective Caml *) -(* *) -(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *) -(* projet Cristal, INRIA Rocquencourt *) -(* Jacques Garrigue, Kyoto University RIMS *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique and Kyoto University. All rights reserved. *) -(* This file is distributed under the terms of the GNU Library *) -(* General Public License, with the special exception on linking *) -(* described in file LICENSE found in the Objective Caml source tree. *) -(* *) -(***********************************************************************) +(*************************************************************************) +(* *) +(* Objective Caml LablTk library *) +(* *) +(* Francois Rouaix, Francois Pessaux and Jun Furuse *) +(* projet Cristal, INRIA Rocquencourt *) +(* Jacques Garrigue, Kyoto University RIMS *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique and Kyoto University. All rights reserved. *) +(* This file is distributed under the terms of the GNU Library *) +(* General Public License, with the special exception on linking *) +(* described in file ../../../LICENSE. *) +(* *) +(*************************************************************************) (* $Id$ *) +open StdLabels open Support open Widget @@ -29,7 +30,7 @@ type tkArgs = type cbid = int -external opentk_low : string list -> unit +external opentk : display:string -> clas:string -> unit = "camltk_opentk" external tcl_eval : string -> string = "camltk_tcl_eval" @@ -43,11 +44,6 @@ external tkreturn : string -> unit = "camltk_return" external callback_init : unit -> unit = "camltk_init" -external finalizeTk : unit -> unit - = "camltk_finalize" - (* Finalize tcl/tk before exiting. This function will be automatically - called when you call [Pervasives.exit ()] (This is installed at - [install_cleanup ()] *) let tcl_command s = ignore (tcl_eval s);; @@ -64,10 +60,10 @@ let debug = let dump_args args = let rec print_arg = function TkToken s -> prerr_string s; prerr_string " " - | TkTokenList l -> List.iter print_arg l + | TkTokenList l -> List.iter ~f:print_arg l | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} " in - Array.iter print_arg args; + Array.iter ~f:print_arg args; prerr_newline() (* @@ -90,15 +86,14 @@ let tkCommand args = ignore (tkEval args) * Callbacks *) -(* LablTk only *) let cCAMLtoTKwidget w = - (* Widget.check_class w table; (* with subtyping, it is redundant *) *) TkToken (Widget.name w) let cTKtoCAMLwidget = function "" -> raise (Invalid_argument "cTKtoCAMLwidget") | s -> Widget.get_atom s + let callback_naming_table = (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t) @@ -115,9 +110,9 @@ let string_of_cbid = string_of_int (* The callback should be cleared when w is destroyed *) let register_callback w ~callback:f = let id = new_function_id () in - Hashtbl.add callback_naming_table id f; + Hashtbl'.add callback_naming_table ~key:id ~data:f; if (forget_type w) <> (forget_type Widget.dummy) then - Hashtbl.add callback_memo_table (forget_type w) id; + Hashtbl'.add callback_memo_table ~key:(forget_type w) ~data:id; (string_of_cbid id) let clear_callback id = @@ -127,7 +122,7 @@ let clear_callback id = let remove_callbacks w = let w = forget_type w in let cb_ids = Hashtbl.find_all callback_memo_table w in - List.iter clear_callback cb_ids; + List.iter ~f:clear_callback cb_ids; for i = 1 to List.length cb_ids do Hashtbl.remove callback_memo_table w done @@ -148,13 +143,13 @@ let install_cleanup () = let call_destroy_hooks = function [wname] -> let w = cTKtoCAMLwidget wname in - List.iter (fun f -> f w) !destroy_hooks + List.iter ~f:(fun f -> f w) !destroy_hooks | _ -> raise (TkError "bad cleanup callback") in let fid = new_function_id () in - Hashtbl.add callback_naming_table fid call_destroy_hooks; + Hashtbl'.add callback_naming_table ~key:fid ~data:call_destroy_hooks; (* setup general destroy callback *) - tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}"); - at_exit finalizeTk + tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}") + let prerr_cbid id = prerr_string "camlcb "; prerr_int id @@ -163,7 +158,7 @@ let prerr_cbid id = let dispatch_callback id args = if !debug then begin prerr_cbid id; - List.iter (fun x -> prerr_string " "; prerr_string x) args; + List.iter ~f:(fun x -> prerr_string " "; prerr_string x) args; prerr_newline() end; (Hashtbl.find callback_naming_table id) args; @@ -171,16 +166,11 @@ let dispatch_callback id args = let protected_dispatch id args = try - dispatch_callback id args + Printexc.print (dispatch_callback id) args with - | e -> - try - Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); - flush stderr; - (* raise x *) - with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break + Out_of_memory -> raise Out_of_memory + | Sys.Break -> raise Sys.Break + | e -> flush Pervasives.stderr let _ = Callback.register "camlcb" protected_dispatch @@ -188,76 +178,12 @@ let _ = Callback.register "camlcb" protected_dispatch let _ = callback_init () (* Different version of initialisation functions *) -let default_display_name = ref "" -let default_display () = !default_display_name - -let camltk_argv = ref [] - -(* options for Arg.parse *) -let keywords = [ - "-display", Arg.String (fun s -> - camltk_argv := "-display" :: s :: !camltk_argv), - "<disp> : X server to contact (CamlTk)"; - "-colormap", Arg.String (fun s -> - camltk_argv := "-colormap" :: s :: !camltk_argv), - "<colormap> : colormap to use (CamlTk)"; - "-geometry", Arg.String (fun s -> - camltk_argv := "-geometry" :: s :: !camltk_argv), - "<geom> : size and position (CamlTk)"; - "-name", Arg.String (fun s -> - camltk_argv := "-name" :: s :: !camltk_argv), - "<name> : application class (CamlTk)"; - "-sync", Arg.Unit (fun () -> - camltk_argv := "-sync" :: !camltk_argv), - ": sync mode (CamlTk)"; - "-use", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - "<id> : parent window id (CamlTk)"; - "-window", Arg.String (fun s -> - camltk_argv := "-use" :: s :: !camltk_argv), - "<id> : parent window id (CamlTk)"; - "-visual", Arg.String (fun s -> - camltk_argv := "-visual" :: s :: !camltk_argv), - "<visual> : visual to use (CamlTk)" ] - -let opentk_with_args argv (* = [argv1;..;argvn] *) = - (* argv must be command line for wish *) - let argv0 = Sys.argv.(0) in - let rec find_display = function - | "-display" :: s :: xs -> s - | "-colormap" :: s :: xs -> find_display xs - | "-geometry" :: s :: xs -> find_display xs - | "-name" :: s :: xs -> find_display xs - | "-sync" :: xs -> find_display xs - | "-use" :: s :: xs -> find_display xs - | "-window" :: s :: xs -> find_display xs - | "-visual" :: s :: xs -> find_display xs - | "--" :: _ -> "" - | _ :: xs -> find_display xs - | [] -> "" - in - default_display_name := find_display argv; - opentk_low (argv0 :: argv); +(* Native opentk is [opentk display class] *) +let openTk ?(display = "") ?(clas = "LablTk") () = + opentk ~display ~clas; install_cleanup(); Widget.default_toplevel -let opentk () = - let argv0 = Sys.argv.(0) in - Arg.parse keywords (fun _ -> ()) argv0; - opentk_with_args !camltk_argv - -let openTkClass s = opentk_with_args ["-name"; s] -let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl] - -(*JPF CAMLTK/LABLTK? *) -let openTk ?(display = "") ?(clas = "LablTk") () = - let dispopt = - match display with - | "" -> [] - | _ -> ["-display"; display] - in - opentk_with_args (dispopt @ ["-name"; clas]) - (* Destroy all widgets, thus cleaning up table and exiting the loop *) let closeTk () = tcl_command "destroy ." |