summaryrefslogtreecommitdiffstats
path: root/otherlibs/labltk/support
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs/labltk/support')
-rw-r--r--otherlibs/labltk/support/fileevent.ml10
-rw-r--r--otherlibs/labltk/support/protocol.ml22
-rw-r--r--otherlibs/labltk/support/textvariable.ml36
-rw-r--r--otherlibs/labltk/support/textvariable.mli2
-rw-r--r--otherlibs/labltk/support/widget.ml14
5 files changed, 42 insertions, 42 deletions
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index 3fd4243dd..b2710d75c 100644
--- a/otherlibs/labltk/support/fileevent.ml
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -29,7 +29,7 @@ external rem_file_output : file_descr -> unit
(* File input handlers *)
-let fd_table = Hashtbl.create size:37 (* Avoid space leak in callback table *)
+let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
let add_fileinput :fd callback:f =
let id = new_function_id () in
@@ -42,9 +42,9 @@ let add_fileinput :fd callback:f =
let remove_fileinput :fd =
try
- let id = Hashtbl.find fd_table key:(fd, 'r') in
+ let id = Hashtbl.find fd_table (fd, 'r') in
clear_callback id;
- Hashtbl.remove fd_table key:(fd, 'r');
+ Hashtbl.remove fd_table (fd, 'r');
if !Protocol.debug then begin
prerr_string "clear ";
Protocol.prerr_cbid id;
@@ -65,9 +65,9 @@ let add_fileoutput :fd callback:f =
let remove_fileoutput :fd =
try
- let id = Hashtbl.find fd_table key:(fd, 'w') in
+ let id = Hashtbl.find fd_table (fd, 'w') in
clear_callback id;
- Hashtbl.remove fd_table key:(fd, 'w');
+ Hashtbl.remove fd_table (fd, 'w');
if !Protocol.debug then begin
prerr_string "clear ";
Protocol.prerr_cbid id;
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
index 9d7cb2e1f..9de095826 100644
--- a/otherlibs/labltk/support/protocol.ml
+++ b/otherlibs/labltk/support/protocol.ml
@@ -57,10 +57,10 @@ let debug =
let dump_args args =
let rec print_arg = function
TkToken s -> prerr_string s; prerr_string " "
- | TkTokenList l -> List.iter fun:print_arg l
+ | TkTokenList l -> List.iter f:print_arg l
| TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
in
- Array.iter fun:print_arg args;
+ Array.iter f:print_arg args;
prerr_newline()
(*
@@ -92,10 +92,10 @@ let cTKtoCAMLwidget = function
let callback_naming_table =
- (Hashtbl.create size:401 : (int, callback_buffer -> unit) Hashtbl.t)
+ (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
let callback_memo_table =
- (Hashtbl.create size:401 : (any widget, int) Hashtbl.t)
+ (Hashtbl.create 401 : (any widget, int) Hashtbl.t)
let new_function_id =
let counter = ref 0 in
@@ -113,15 +113,15 @@ let register_callback w callback:f =
(string_of_cbid id)
let clear_callback id =
- Hashtbl.remove callback_naming_table key:id
+ Hashtbl.remove callback_naming_table id
(* Clear callbacks associated to a given widget *)
let remove_callbacks w =
let w = forget_type w in
- let cb_ids = Hashtbl.find_all callback_memo_table key:w in
- List.iter fun:clear_callback cb_ids;
+ let cb_ids = Hashtbl.find_all callback_memo_table w in
+ List.iter f:clear_callback cb_ids;
for i = 1 to List.length cb_ids do
- Hashtbl.remove callback_memo_table key:w
+ Hashtbl.remove callback_memo_table w
done
(* Hand-coded callback for destroyed widgets
@@ -140,7 +140,7 @@ let install_cleanup () =
let call_destroy_hooks = function
[wname] ->
let w = cTKtoCAMLwidget wname in
- List.iter fun:(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 key:fid data:call_destroy_hooks;
@@ -155,10 +155,10 @@ let prerr_cbid id =
let dispatch_callback id args =
if !debug then begin
prerr_cbid id;
- List.iter fun:(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 key:id) args;
+ (Hashtbl.find callback_naming_table id) args;
if !debug then prerr_endline "<<-"
let protected_dispatch id args =
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
index adeb85032..18568988f 100644
--- a/otherlibs/labltk/support/textvariable.ml
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -21,18 +21,18 @@ external internal_tracevar : string -> cbid -> unit
= "camltk_trace_var"
external internal_untracevar : string -> cbid -> unit
= "camltk_untrace_var"
-external set : string -> to:string -> unit = "camltk_setvar"
+external set : string -> string -> unit = "camltk_setvar"
external get : string -> string = "camltk_getvar"
type textVariable = string
(* List of handles *)
-let handles = Hashtbl.create size:401
+let handles = Hashtbl.create 401
let add_handle var cbid =
try
- let r = Hashtbl.find handles key:var in
+ let r = Hashtbl.find handles var in
r := cbid :: !r
with
Not_found ->
@@ -48,9 +48,9 @@ let exceptq x =
let rem_handle var cbid =
try
- let r = Hashtbl.find handles key:var in
+ let r = Hashtbl.find handles var in
match exceptq cbid !r with
- [] -> Hashtbl.remove handles key:var
+ [] -> Hashtbl.remove handles var
| remaining -> r := remaining
with
Not_found -> ()
@@ -60,9 +60,9 @@ let rem_handle var cbid =
*)
let rem_all_handles var =
try
- let r = Hashtbl.find handles key:var in
- List.iter fun:(internal_untracevar var) !r;
- Hashtbl.remove handles key:var
+ let r = Hashtbl.find handles var in
+ List.iter f:(internal_untracevar var) !r;
+ Hashtbl.remove handles var
with
Not_found -> ()
@@ -85,31 +85,31 @@ let handle vname f =
module StringSet =
Set.Make(struct type t = string let compare = compare end)
let freelist = ref (StringSet.empty)
-let memo = Hashtbl.create size:101
+let memo = Hashtbl.create 101
(* Added a variable v referenced by widget w *)
let add w v =
let w = Widget.forget_type w in
let r =
- try Hashtbl.find memo key:w
+ try Hashtbl.find memo w
with
Not_found ->
let r = ref StringSet.empty in
Hashtbl.add memo key:w data:r;
r in
- r := StringSet.add !r item:v
+ r := StringSet.add v !r
(* to be used with care ! *)
let free v =
rem_all_handles v;
- freelist := StringSet.add item:v !freelist
+ freelist := StringSet.add v !freelist
(* Free variables associated with a widget *)
let freew w =
try
- let r = Hashtbl.find memo key:w in
- StringSet.iter fun:free !r;
- Hashtbl.remove memo key:w
+ let r = Hashtbl.find memo w in
+ StringSet.iter f:free !r;
+ Hashtbl.remove memo w
with
Not_found -> ()
@@ -125,9 +125,9 @@ let getv () =
end
else
let v = StringSet.choose !freelist in
- freelist := StringSet.remove item:v !freelist;
+ freelist := StringSet.remove v !freelist;
v in
- set v to:"";
+ set v "";
v
let create ?on: w () =
@@ -141,7 +141,7 @@ let create ?on: w () =
(* to be used with care ! *)
let free v =
- freelist := StringSet.add item:v !freelist
+ freelist := StringSet.add v !freelist
let cCAMLtoTKtextVariable s = TkToken s
diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
index f2e22a828..0b4a7a535 100644
--- a/otherlibs/labltk/support/textvariable.mli
+++ b/otherlibs/labltk/support/textvariable.mli
@@ -25,7 +25,7 @@ type textVariable
val create : ?on: 'a widget -> unit -> textVariable
(* Allocation of a textVariable with lifetime associated to widget
if a widget is specified *)
-val set : textVariable -> to: string -> unit
+val set : textVariable -> string -> unit
(* Setting the val of a textVariable *)
val get : textVariable -> string
(* Reading the val of a textVariable *)
diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
index 883d8624f..0ec71c09a 100644
--- a/otherlibs/labltk/support/widget.ml
+++ b/otherlibs/labltk/support/widget.ml
@@ -50,7 +50,7 @@ let forget_type w = (Obj.magic (w : 'a widget) : any widget)
let coe = forget_type
(* table of widgets *)
-let table = (Hashtbl.create size:401 : (string, any widget) Hashtbl.t)
+let table = (Hashtbl.create 401 : (string, any widget) Hashtbl.t)
let name = function
Untyped s -> s
@@ -75,13 +75,13 @@ let dummy =
Untyped "dummy"
let remove w =
- Hashtbl.remove table key:(name w)
+ Hashtbl.remove table (name w)
(* Retype widgets returned from Tk *)
(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *)
let get_atom s =
try
- Hashtbl.find table key:s
+ Hashtbl.find table s
with
Not_found -> Untyped s
@@ -103,7 +103,7 @@ let naming_scheme = [
"toplevel", "top" ]
-let widget_any_table = List.map fun:fst naming_scheme
+let widget_any_table = List.map f:fst naming_scheme
(* subtypes *)
let widget_button_table = [ "button" ]
and widget_canvas_table = [ "canvas" ]
@@ -123,7 +123,7 @@ and widget_toplevel_table = [ "toplevel" ]
let new_suffix clas n =
try
- (List.assoc key:clas naming_scheme) ^ (string_of_int n)
+ (List.assoc clas naming_scheme) ^ (string_of_int n)
with
Not_found -> "w" ^ (string_of_int n)
@@ -165,11 +165,11 @@ let check_class w clas =
match w with
Untyped _ -> () (* assume run-time check by tk*)
| Typed(_,c) ->
- if List.mem clas item:c then ()
+ if List.mem c clas then ()
else raise (IllegalWidgetType c)
(* Checking membership of constructor in subtype table *)
let chk_sub errname table c =
- if List.mem table item:c then ()
+ if List.mem c table then ()
else raise (Invalid_argument errname)
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-31 20:39:58 +0000