summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2000-03-29 05:06:02 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2000-03-29 05:06:02 +0000
commit06264d6d410fb2e2fa82644bcf81a683b494d07c (patch)
tree8ce6ef519f8898dc526de4d708f3e47b87428623
parent226fbcf2517bedb241265ca251d2bc17c6997aa9 (diff)
erreur de commit
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3011 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rw-r--r--otherlibs/labltk/builtin/builtin_bind.ml2
-rw-r--r--otherlibs/labltk/builtin/builtini_bind.ml4
-rw-r--r--otherlibs/labltk/builtin/builtini_index.ml2
-rw-r--r--otherlibs/labltk/builtin/builtini_text.ml2
-rw-r--r--otherlibs/labltk/builtin/dialog.ml2
-rw-r--r--otherlibs/labltk/builtin/optionmenu.ml2
-rw-r--r--otherlibs/labltk/builtin/selection_handle_set.ml2
-rw-r--r--otherlibs/labltk/compiler/compile.ml108
-rw-r--r--otherlibs/labltk/compiler/intf.ml14
-rw-r--r--otherlibs/labltk/compiler/lexer.mll22
-rw-r--r--otherlibs/labltk/compiler/maincompile.ml98
-rw-r--r--otherlibs/labltk/compiler/printer.ml4
-rw-r--r--otherlibs/labltk/compiler/tables.ml76
-rw-r--r--otherlibs/labltk/compiler/tsort.ml6
-rw-r--r--otherlibs/labltk/jpf/balloon.ml10
-rw-r--r--otherlibs/labltk/jpf/fileselect.ml14
-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
21 files changed, 226 insertions, 226 deletions
diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml
index 83bfe4e22..8cd3194ab 100644
--- a/otherlibs/labltk/builtin/builtin_bind.ml
+++ b/otherlibs/labltk/builtin/builtin_bind.ml
@@ -178,7 +178,7 @@ let wrapeventInfo f (what : eventField list) =
ev_RootY = 0 } in
function args ->
let l = ref args in
- List.iter f:(function field ->
+ List.iter fun:(function field ->
match !l with
| [] -> ()
| v :: rest -> filleventInfo ev v field; l := rest)
diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml
index d6d708d4d..61e0baa61 100644
--- a/otherlibs/labltk/builtin/builtini_bind.ml
+++ b/otherlibs/labltk/builtin/builtini_bind.ml
@@ -44,11 +44,11 @@ let cCAMLtoTKevent (ev : event) =
| `Unmap -> "Unmap"
| `Visibility -> "Visibility"
| `Modified(ml, ev) ->
- String.concat sep:"" (List.map f:cCAMLtoTKmodifier ml)
+ String.concat sep:"" (List.map fun:cCAMLtoTKmodifier ml)
^ convert ev
in "<" ^ convert ev ^ ">"
let cCAMLtoTKeventSequence (l : event list) =
- TkToken(String.concat sep:"" (List.map f:cCAMLtoTKevent l))
+ TkToken(String.concat sep:"" (List.map fun:cCAMLtoTKevent l))
diff --git a/otherlibs/labltk/builtin/builtini_index.ml b/otherlibs/labltk/builtin/builtini_index.ml
index e30160066..5940a27ec 100644
--- a/otherlibs/labltk/builtin/builtini_index.ml
+++ b/otherlibs/labltk/builtin/builtini_index.ml
@@ -28,7 +28,7 @@ let cCAMLtoTKtext_index = (cCAMLtoTKindex : text_index -> tkArgs)
let cTKtoCAMLtext_index s =
try
- let p = String.index s '.' in
+ let p = String.index char:'.' s in
`Linechar (int_of_string (String.sub s pos:0 len:p),
int_of_string (String.sub s pos:(p + 1)
len:(String.length s - p - 1)))
diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml
index 99b85f875..076c29fd5 100644
--- a/otherlibs/labltk/builtin/builtini_text.ml
+++ b/otherlibs/labltk/builtin/builtini_text.ml
@@ -23,7 +23,7 @@ let cCAMLtoTKtextIndex (i : textIndex) =
let ppTextIndex (base, ml : textIndex) =
match cCAMLtoTKtext_index base with
TkToken ppbase ->
- String.concat sep:"" (ppbase :: List.map f:ppTextModifier ml)
+ String.concat sep:"" (ppbase :: List.map fun:ppTextModifier ml)
| _ -> assert false
in
TkToken (ppTextIndex i)
diff --git a/otherlibs/labltk/builtin/dialog.ml b/otherlibs/labltk/builtin/dialog.ml
index bd8262489..257661b5e 100644
--- a/otherlibs/labltk/builtin/dialog.ml
+++ b/otherlibs/labltk/builtin/dialog.ml
@@ -7,6 +7,6 @@ let create :parent :title :message :buttons ?:name
TkToken message;
cCAMLtoTKbitmap bitmap;
TkToken (string_of_int default);
- TkTokenList (List.map f:(fun x -> TkToken x) buttons)|]
+ TkTokenList (List.map fun:(fun x -> TkToken x) buttons)|]
in
int_of_string res
diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml
index 0fcba9b13..3ade5d57d 100644
--- a/otherlibs/labltk/builtin/optionmenu.ml
+++ b/otherlibs/labltk/builtin/optionmenu.ml
@@ -9,7 +9,7 @@ let create :parent :variable ?:name values =
tkEval [|TkToken "tk_optionMenu";
TkToken (Widget.name w);
cCAMLtoTKtextVariable variable;
- TkTokenList (List.map f:(fun x -> TkToken x) values)|] in
+ TkTokenList (List.map fun:(fun x -> TkToken x) values)|] in
if res <> Widget.name mw then
raise (TkError "internal error in Optionmenu.create")
else
diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml
index 2a7fe8b4c..9d05bb059 100644
--- a/otherlibs/labltk/builtin/selection_handle_set.ml
+++ b/otherlibs/labltk/builtin/selection_handle_set.ml
@@ -7,7 +7,7 @@ selection_handle_icccm_optionals (fun opts w ->
cCAMLtoTKwidget w;
let id = register_callback w callback:(function args ->
let a1 = int_of_string (List.hd args) in
- let a2 = int_of_string (List.nth args 1) in
+ let a2 = int_of_string (List.nth args pos:1) in
tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb " ^ id)
|])
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index 769f12bb7..888668d30 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -39,7 +39,7 @@ let small s =
Char.chr(Char.code(s.[i]) - (Char.code 'A' - Char.code 'a'))
else s.[i]
in
- sout := !sout ^ (String.make 1 c)
+ sout := !sout ^ (String.make len:1 c)
done;
!sout
@@ -47,7 +47,7 @@ let small_ident s =
let idents = ["to"; "raise"; "in"; "class"; "new"]
in
let s = small s in
- if List.mem s idents then (String.make 1 s.[0]) ^ s
+ if List.mem item:s idents then (String.make len:1 s.[0]) ^ s
else s
let gettklabel fc =
@@ -61,17 +61,17 @@ let gettklabel fc =
let count item:x l =
let count = ref 0 in
- List.iter f:(fun y -> if x = y then incr count) l;
+ List.iter fun:(fun y -> if x = y then incr count) l;
!count
(* Extract all types from a template *)
let rec types_of_template = function
StringArg _ -> []
| TypeArg (l, t) -> [l, t]
- | ListArg l -> List.flatten (List.map f:types_of_template l)
+ | ListArg l -> List.flatten (List.map fun:types_of_template l)
| OptionalArgs (l, tl, _) ->
begin
- match List.flatten (List.map f:types_of_template tl) with
+ match List.flatten (List.map fun:types_of_template tl) with
["", t] -> ["?" ^ l, t]
| [_, _] -> raise (Failure "0 label required")
| _ -> raise (Failure "0 or more than 1 args in for optionals")
@@ -97,10 +97,10 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
else
begin
try
- let typdef = Hashtbl.find types_table sup in
- let fcl = List.assoc sub typdef.subtypes in
- let tklabels = List.map f:gettklabel fcl in
- let l = List.map fcl f:
+ let typdef = Hashtbl.find types_table key:sup in
+ let fcl = List.assoc key:sub typdef.subtypes in
+ let tklabels = List.map fun:gettklabel fcl in
+ let l = List.map fcl fun:
begin fun fc ->
"?" ^ begin let p = gettklabel fc in
if count item:p tklabels > 1 then small fc.ml_name else p
@@ -113,7 +113,7 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
| l ->
"(" ^ String.concat sep:"*"
(List.map l
- f:(fun lt -> ppMLtype (labeloff lt at:"ppMLtype")))
+ fun:(fun lt -> ppMLtype (labeloff lt at:"ppMLtype")))
^ ")"
end in
String.concat sep:" ->\n" l
@@ -121,14 +121,14 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
end
| List ty -> (ppMLtype ty) ^ " list"
- | Product tyl -> String.concat sep:" * " (List.map f:ppMLtype tyl)
+ | Product tyl -> String.concat sep:" * " (List.map fun:ppMLtype tyl)
| Record tyl ->
String.concat sep:" * "
- (List.map tyl f:(fun (l, t) -> labelstring l ^ ppMLtype t))
+ (List.map tyl fun:(fun (l, t) -> labelstring l ^ ppMLtype t))
| Subtype ("widget", sub) -> sub ^ " widget"
| UserDefined "widget" ->
if any then "any widget" else
- let c = String.make 1 (Char.chr(Char.code 'a' + !counter))
+ let c = String.make len:1 (Char.chr(Char.code 'a' + !counter))
in
incr counter;
"'" ^ c ^ " widget"
@@ -136,19 +136,19 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
(* a bit dirty hack for ImageBitmap and ImagePhoto *)
begin
try
- let typdef = Hashtbl.find types_table s in
+ let typdef = Hashtbl.find types_table key:s in
if typdef.variant then
if return then try
"[>" ^
String.concat sep:"|"
- (List.map typdef.constructors f:
+ (List.map typdef.constructors fun:
begin
fun c ->
"`" ^ c.var_name ^
(match types_of_template c.template with
[] -> ""
| l -> " " ^ ppMLtype (Product (List.map l
- f:(labeloff at:"ppMLtype UserDefined"))))
+ fun:(labeloff at:"ppMLtype UserDefined"))))
end) ^ "]"
with
Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
@@ -163,7 +163,7 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
raise (Failure "Function (Product tyl) ? ppMLtype")
| Function (Record tyl) ->
"(" ^ String.concat sep:" -> "
- (List.map tyl f:(fun (l, t) -> labelstring l ^ ppMLtype t))
+ (List.map tyl fun:(fun (l, t) -> labelstring l ^ ppMLtype t))
^ " -> unit)"
| Function ty ->
"(" ^ (ppMLtype ty) ^ " -> unit)"
@@ -175,13 +175,13 @@ let ppMLtype ?(:any=false) ?(:return=false) ?(:def=false) ?(:counter=ref 0) =
let rec ppTemplate = function
StringArg s -> s
| TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">"
- | ListArg l -> "{" ^ String.concat sep:" " (List.map f:ppTemplate l) ^ "}"
+ | ListArg l -> "{" ^ String.concat sep:" " (List.map fun:ppTemplate l) ^ "}"
| OptionalArgs (l, tl, d) ->
- "?" ^ l ^ "{" ^ String.concat sep:" " (List.map f:ppTemplate tl)
- ^ "}[<" ^ String.concat sep:" " (List.map f:ppTemplate d) ^ ">]"
+ "?" ^ l ^ "{" ^ String.concat sep:" " (List.map fun:ppTemplate tl)
+ ^ "}[<" ^ String.concat sep:" " (List.map fun:ppTemplate d) ^ ">]"
let doc_of_template = function
- ListArg l -> String.concat sep:" " (List.map f:ppTemplate l)
+ ListArg l -> String.concat sep:" " (List.map fun:ppTemplate l)
| t -> ppTemplate t
(*
@@ -195,7 +195,7 @@ let write_constructor :w {ml_name = mlconstr; template = t} =
[] -> ()
| l -> w " of ";
w (ppMLtype any:true (Product (List.map l
- f:(labeloff at:"write_constructor"))))
+ fun:(labeloff at:"write_constructor"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
@@ -204,7 +204,7 @@ let write_constructors :w = function
[] -> fatal_error "empty type"
| x :: l ->
write_constructor :w x;
- List.iter l f:
+ List.iter l fun:
begin fun x ->
w "\n | ";
write_constructor :w x
@@ -219,14 +219,14 @@ let write_variant :w {ml_name = mlconstr; var_name = varname; template = t} =
| l ->
w " ";
w (ppMLtype any:true def:true
- (Product (List.map l f:(labeloff at:"write_variant"))))
+ (Product (List.map l fun:(labeloff at:"write_variant"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
let write_variants :w = function
[] -> fatal_error "empty variants"
| l ->
- List.iter l f:
+ List.iter l fun:
begin fun x ->
w "\n | ";
write_variant :w x
@@ -305,7 +305,7 @@ let rec wrapper_code fname of:ty =
let vnames = varnames prefix:"a" (List.length tyl) in
(* getting the arguments *)
let readarg =
- List.map2 vnames tyl f:
+ List.map2 vnames tyl fun:
begin fun v (l, ty) ->
match type_parser_arity ty with
OneToken ->
@@ -319,7 +319,7 @@ let rec wrapper_code fname of:ty =
end in
String.concat sep:"" readarg ^ fname ^ " " ^
String.concat sep:" "
- (List.map2 f:(fun v (l, _) -> labelstring l ^ v) vnames tyl)
+ (List.map2 fun:(fun v (l, _) -> labelstring l ^ v) vnames tyl)
(* all other types are read in one operation *)
| List ty ->
@@ -359,7 +359,7 @@ type mini_parser =
let can_generate_parser constructors =
let pp = {zeroary = []; intpar = []; stringpar = []} in
- if List.for_all constructors f:
+ if List.for_all constructors pred:
begin fun c ->
match c.template with
ListArg [StringArg s] ->
@@ -398,7 +398,7 @@ let write_TKtoCAML :w name def:typdef =
w (" with _ ->\n")
end;
w (" match n with\n");
- List.iter pp.zeroary f:
+ List.iter pp.zeroary fun:
begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> "; w ml; w "\n"
end;
@@ -413,7 +413,7 @@ let write_TKtoCAML :w name def:typdef =
in
begin
write :name consts:typdef.constructors;
- List.iter typdef.subtypes f: begin
+ List.iter typdef.subtypes fun: begin
fun (subname, consts) -> write name:(subname ^ "_" ^ name) :consts
end
end
@@ -489,14 +489,14 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
let rec coderec = function
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub) as ty)) ->
- let typdef = Hashtbl.find types_table sup in
- let classdef = List.assoc sub typdef.subtypes in
+ let typdef = Hashtbl.find key:sup types_table in
+ let classdef = List.assoc key:sub typdef.subtypes in
let lbl = gettklabel (List.hd classdef) in
catch_opts := (sub ^ "_" ^ sup, lbl);
newvar := newvar2;
"TkTokenList opts"
| TypeArg (l, List ty) ->
- "TkTokenList (List.map f:(function x -> "
+ "TkTokenList (List.map fun:(function x -> "
^ converterCAMLtoTK :context_widget "x" as:ty
^ ") " ^ !newvar l ^ ")"
| TypeArg (l, Function tyarg) ->
@@ -506,12 +506,12 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
| TypeArg (l, ty) -> converterCAMLtoTK :context_widget (!newvar l) as:ty
| ListArg l ->
"TkQuote (TkTokenList ["
- ^ String.concat sep:";\n " (List.map f:coderec l) ^ "])"
+ ^ String.concat sep:";\n " (List.map fun:coderec l) ^ "])"
| OptionalArgs (l, tl, d) ->
let nv = !newvar ("?" ^ l) in
optionvar := Some nv; (* Store *)
- let argstr = String.concat sep:"; " (List.map f:coderec tl) in
- let defstr = String.concat sep:"; " (List.map f:coderec d) in
+ let argstr = String.concat sep:"; " (List.map fun:coderec tl) in
+ let defstr = String.concat sep:"; " (List.map fun:coderec d) in
"TkTokenList (match " ^ nv ^ " with\n"
^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
^ " | None -> [" ^ defstr ^ "])"
@@ -520,14 +520,14 @@ let code_of_template :context_widget ?(func:funtemplate=false) template =
if funtemplate then
match template with
ListArg l ->
- "[|" ^ String.concat sep:";\n " (List.map f:coderec l) ^ "|]"
+ "[|" ^ String.concat sep:";\n " (List.map fun:coderec l) ^ "|]"
| _ -> "[|" ^ coderec template ^ "|]"
else
match template with
ListArg [x] -> coderec x
| ListArg l ->
"TkTokenList [" ^
- String.concat sep:";\n " (List.map f:coderec l) ^
+ String.concat sep:";\n " (List.map fun:coderec l) ^
"]"
| _ -> coderec template
in
@@ -553,7 +553,7 @@ let write_clause :w :context_widget comp =
| [x] -> w " "; w (labeloff x at:"write_clause"); warrow()
| l ->
w " ( ";
- w (String.concat sep:", " (List.map f:(labeloff at:"write_clause") l));
+ w (String.concat sep:", " (List.map fun:(labeloff at:"write_clause") l));
w ")";
warrow()
end;
@@ -576,7 +576,7 @@ let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name =
end;
w (" = function");
List.iter constrs
- f:(fun c -> w "\n | "; write_clause :w :context_widget c);
+ fun:(fun c -> w "\n | "; write_clause :w :context_widget c);
w "\n\n\n"
in
@@ -585,12 +585,12 @@ let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name =
if typdef.subtypes == [] then
write_one name constrs
else
- List.iter constrs f:
+ List.iter constrs fun:
begin fun fc ->
let code, vars, _, (co, _) =
code_of_template context_widget:"dummy" fc.template in
if co <> "" then fatal_error "optionals in optionals";
- let vars = List.map f:snd vars in
+ let vars = List.map fun:snd vars in
w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name);
w " ("; w (String.concat sep:", " vars); w ") =\n ";
w code; w "\n\n"
@@ -601,7 +601,7 @@ let rec write_result_parsing :w = function
List String ->
w "(splitlist res)"
| List ty ->
- w (" List.map f: " ^ converterTKtoCAML "(splitlist res)" as:ty)
+ w (" List.map fun: " ^ converterTKtoCAML "(splitlist res)" as:ty)
| Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl -> (* of course all the labels are "" *)
let rnames = varnames prefix:"r" (List.length tyl) in
@@ -609,7 +609,7 @@ let rec write_result_parsing :w = function
w ("\n if List.length l <> " ^ string_of_int (List.length tyl));
w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
w ("\n else ");
- List.iter2 rnames tyl f:
+ List.iter2 rnames tyl fun:
begin fun r (l, ty) ->
if l <> "" then raise (Failure "lables in return type!!!");
w (" let " ^ r ^ ", l = ");
@@ -653,7 +653,7 @@ let write_function :w def =
in
replace_args u:[] l:[] o:[] (List.rev (variables @ variables2))
in
- List.iter (lv@ov) f:(fun (l, v) -> w " "; w (labelstring l); w v);
+ List.iter (lv@ov) fun:(fun (l, v) -> w " "; w (labelstring l); w v);
if co <> "" then begin
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " =\n";
@@ -661,10 +661,10 @@ let write_function :w def =
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " (fun opts";
if uv = [] then w " ()"
- else List.iter uv f:(fun x -> w " "; w x);
+ else List.iter uv fun:(fun x -> w " "; w x);
w " ->\n"
end else begin
- List.iter uv f:(fun x -> w " "; w x);
+ List.iter uv fun:(fun x -> w " "; w x);
if (ov <> [] || lv = []) && uv = [] then w " ()";
w " =\n"
end;
@@ -727,12 +727,12 @@ let write_external :w def =
let write_catch_optionals :w clas def:typdef =
if typdef.subtypes = [] then () else
- List.iter typdef.subtypes f:
+ List.iter typdef.subtypes fun:
begin fun (subclass, classdefs) ->
w ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n");
- let tklabels = List.map f:gettklabel classdefs in
+ let tklabels = List.map fun:gettklabel classdefs in
let l =
- List.map classdefs f:
+ List.map classdefs fun:
begin fun fc ->
(*
let code, vars, _, (co, _) =
@@ -745,16 +745,16 @@ let write_catch_optionals :w clas def:typdef =
small fc.ml_name
end in
let p =
- List.map l f:
+ List.map l fun:
begin fun (s, si, _) ->
if s = si then " ?:" ^ s
else " ?" ^ s ^ ":" ^ si
end in
let v =
- List.map l f:
+ List.map l fun:
begin fun (_, si, s) ->
(*
- let vars = List.map f:snd vars in
+ let vars = List.map fun:snd vars in
let vars = String.concat sep:"," vars in
"(maycons (fun (" ^ vars ^ ") -> " ^ code ^ ") " ^ si
*)
@@ -765,6 +765,6 @@ let write_catch_optionals :w clas def:typdef =
w " f ";
w (String.concat sep:"\n " v);
w "\n []";
- w (String.make (List.length v) ')');
+ w (String.make len:(List.length v) ')');
w "\n\n"
end
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 4f646df34..d8e8310aa 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -24,24 +24,24 @@ let write_create_p :w wname =
w "val create :\n ?name:string ->\n";
begin
try
- let option = Hashtbl.find types_table "options" in
- let classdefs = List.assoc wname option.subtypes in
- let tklabels = List.map f:gettklabel classdefs in
- let l = List.map classdefs f:
+ let option = Hashtbl.find types_table key:"options" in
+ let classdefs = List.assoc key:wname option.subtypes in
+ let tklabels = List.map fun:gettklabel classdefs in
+ let l = List.map classdefs fun:
begin fun fc ->
begin let p = gettklabel fc in
if count item:p tklabels > 1 then small fc.ml_name else p
end, fc.template
end in
w (String.concat sep:" ->\n"
- (List.map l f:
+ (List.map l fun:
begin fun (s, t) ->
" ?" ^ s ^ ":"
^(ppMLtype
(match types_of_template t with
| [t] -> labeloff t at:"write_create_p"
| [] -> fatal_error "multiple"
- | l -> Product (List.map f:(labeloff at:"write_create_p") l)))
+ | l -> Product (List.map fun:(labeloff at:"write_create_p") l)))
end))
with Not_found -> fatal_error "in write_create_p"
end;
@@ -72,7 +72,7 @@ let write_function_type :w def =
in
let counter = ref 0 in
List.iter (ls @ os @ us)
- f:(fun (l, t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
+ fun:(fun (l, t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
if (os <> [] || ls = []) && us = [] then w "unit -> ";
w (ppMLtype any:true return:true def.result); (* RETURN TYPE !!! *)
w " \n";
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index 337c5cdc2..a2251b902 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -25,10 +25,10 @@ let current_line = ref 1
(* The table of keywords *)
-let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
+let keyword_table = (Hashtbl.create size:149 : (string, token) Hashtbl.t)
let _ = List.iter
- f:(fun (str,tok) -> Hashtbl.add keyword_table key:str data:tok)
+ fun:(fun (str,tok) -> Hashtbl.add keyword_table key:str data:tok)
[
"int", TYINT;
"float", TYFLOAT;
@@ -52,7 +52,7 @@ let _ = List.iter
(* To buffer string literals *)
-let initial_string_buffer = String.create 256
+let initial_string_buffer = String.create len:256
let string_buff = ref initial_string_buffer
let string_index = ref 0
@@ -63,7 +63,7 @@ let reset_string_buffer () =
let store_string_char c =
if !string_index >= String.length (!string_buff) then begin
- let new_buff = String.create (String.length (!string_buff) * 2) in
+ let new_buff = String.create len:(String.length (!string_buff) * 2) in
String.blit src:(!string_buff) src_pos:0 dst:new_buff dst_pos:0
len:(String.length (!string_buff));
string_buff := new_buff
@@ -85,9 +85,9 @@ let char_for_backslash = function
| c -> c
let char_for_decimal_code lexbuf i =
- Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) +
- 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) +
- (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48))
+ Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf pos:i) - 48) +
+ 10 * (Char.code(Lexing.lexeme_char lexbuf pos:(i+1)) - 48) +
+ (Char.code(Lexing.lexeme_char lexbuf pos:(i+2)) - 48))
let saved_string_start = ref 0
@@ -101,7 +101,7 @@ rule main = parse
( '_' ? ['A'-'Z' 'a'-'z' '\192'-'\214' '\216'-'\246' '\248'-'\255' (*'*) '0'-'9' ] ) *
{ let s = Lexing.lexeme lexbuf in
try
- Hashtbl.find keyword_table s
+ Hashtbl.find keyword_table key:s
with Not_found ->
IDENT s }
@@ -134,7 +134,7 @@ and string = parse
| '\\' [' ' '\010' '\013' '\009' '\026' '\012'] +
{ string lexbuf }
| '\\' ['\\' '"' 'n' 't' 'b' 'r']
- { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
+ { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf pos:1));
string lexbuf }
| '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
{ store_string_char(char_for_decimal_code lexbuf 1);
@@ -143,10 +143,10 @@ and string = parse
{ raise (Lexical_error("string not terminated")) }
| '\010'
{ incr current_line;
- store_string_char(Lexing.lexeme_char lexbuf 0);
+ store_string_char(Lexing.lexeme_char lexbuf pos:0);
string lexbuf }
| _
- { store_string_char(Lexing.lexeme_char lexbuf 0);
+ { store_string_char(Lexing.lexeme_char lexbuf pos:0);
string lexbuf }
and comment = parse
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index 23fbd9c47..fd6c7ddc4 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -84,7 +84,7 @@ let parse_file filename =
in an hash table. *)
let elements t =
let elems = ref [] in
- Hashtbl.iter f:(fun key:_ data:d -> elems := d :: !elems) t;
+ Hashtbl.iter fun:(fun key:_ data:d -> elems := d :: !elems) t;
!elems;;
(* Verifies that duplicated clauses are semantically equivalent and
@@ -111,24 +111,24 @@ let uniq_clauses = function
prerr_endline err;
fatal_error err
end in
- let t = Hashtbl.create 11 in
+ let t = Hashtbl.create size:11 in
List.iter l
- f:(fun constr ->
+ fun:(fun constr ->
let c = constr.var_name in
- if Hashtbl.mem t c
- then (check_constr constr (Hashtbl.find t c))
+ if Hashtbl.mem t key:c
+ then (check_constr constr (Hashtbl.find t key:c))
else Hashtbl.add t key:c data:constr);
elements t;;
let option_hack oc =
- if Hashtbl.mem types_table "options" then
- let typdef = Hashtbl.find types_table "options" in
+ if Hashtbl.mem types_table key:"options" then
+ let typdef = Hashtbl.find types_table key:"options" in
let hack =
{ parser_arity = OneToken;
constructors =
begin
let constrs =
- List.map typdef.constructors f:
+ List.map typdef.constructors fun:
begin fun c ->
{ component = Constructor;
ml_name = c.ml_name;
@@ -148,7 +148,7 @@ let option_hack oc =
variant = false }
in
write_CAMLtoTK
- w:(output_string oc) def:hack safetype:false "options_constrs"
+ w:(output_string to:oc) def:hack safetype:false "options_constrs"
let compile () =
verbose_endline "Creating tkgen.ml ...";
@@ -157,25 +157,25 @@ let compile () =
let oc'' = open_out_bin (destfile "tkfgen.ml") in
let sorted_types = Tsort.sort types_order in
verbose_endline " writing types ...";
- List.iter sorted_types f:
+ List.iter sorted_types fun:
begin fun typname ->
verbose_string (" " ^ typname ^ " ");
try
- let typdef = Hashtbl.find types_table typname in
+ let typdef = Hashtbl.find types_table key:typname in
verbose_string "type ";
- write_type intf:(output_string oc)
- impl:(output_string oc')
+ write_type intf:(output_string to:oc)
+ impl:(output_string to:oc')
typname def:typdef;
verbose_string "C2T ";
- write_CAMLtoTK w:(output_string oc') typname def:typdef;
+ write_CAMLtoTK w:(output_string to:oc') typname def:typdef;
verbose_string "T2C ";
- if List.mem typname !types_returned then
- write_TKtoCAML w:(output_string oc') typname def:typdef;
+ if List.mem item:typname !types_returned then
+ write_TKtoCAML w:(output_string to:oc') typname def:typdef;
verbose_string "CO ";
- write_catch_optionals w:(output_string oc') typname def:typdef;
+ write_catch_optionals w:(output_string to:oc') typname def:typdef;
verbose_endline "."
with Not_found ->
- if not (List.mem_assoc typname !types_external) then
+ if not (List.mem_assoc key:typname !types_external) then
begin
verbose_string "Type ";
verbose_string typname;
@@ -186,7 +186,7 @@ let compile () =
verbose_endline " option hacking ...";
option_hack oc';
verbose_endline " writing functions ...";
- List.iter f:(write_function w:(output_string oc'')) !function_table;
+ List.iter fun:(write_function w:(output_string to:oc'')) !function_table;
close_out oc;
close_out oc';
close_out oc'';
@@ -195,21 +195,21 @@ let compile () =
verbose_endline "Creating tkgen.mli ...";
let oc = open_out_bin (destfile "tkgen.mli") in
List.iter (sort_components !function_table)
- f:(write_function_type w:(output_string oc));
+ fun:(write_function_type w:(output_string to:oc));
close_out oc;
verbose_endline "Creating other ml, mli ...";
- Hashtbl.iter module_table f:
+ Hashtbl.iter module_table fun:
begin fun key:wname data:wdef ->
verbose_endline (" "^wname);
let modname = wname in
let oc = open_out_bin (destfile (modname ^ ".ml"))
and oc' = open_out_bin (destfile (modname ^ ".mli")) in
begin match wdef.module_type with
- Widget -> output_string oc' ("(* The "^wname^" widget *)\n")
- | Family -> output_string oc' ("(* The "^wname^" commands *)\n")
+ Widget -> output_string to:oc' ("(* The "^wname^" widget *)\n")
+ | Family -> output_string to:oc' ("(* The "^wname^" commands *)\n")
end;
- output_string oc "open Protocol\n";
- List.iter f:(fun s -> output_string oc s; output_string oc' s)
+ output_string to:oc "open Protocol\n";
+ List.iter fun:(fun s -> output_string s to:oc; output_string s to:oc')
[ "open Tk\n";
"open Tkintf\n";
"open Widget\n";
@@ -217,17 +217,17 @@ let compile () =
];
begin match wdef.module_type with
Widget ->
- write_create w:(output_string oc) wname;
- write_create_p w:(output_string oc') wname
+ write_create w:(output_string to:oc) wname;
+ write_create_p w:(output_string to:oc') wname
| Family -> ()
end;
- List.iter f:(write_function w:(output_string oc))
+ List.iter fun:(write_function w:(output_string to:oc))
(sort_components wdef.commands);
- List.iter f:(write_function_type w:(output_string oc'))
+ List.iter fun:(write_function_type w:(output_string to:oc'))
(sort_components wdef.commands);
- List.iter f:(write_external w:(output_string oc))
+ List.iter fun:(write_external w:(output_string to:oc))
(sort_components wdef.externals);
- List.iter f:(write_external_type w:(output_string oc'))
+ List.iter fun:(write_external_type w:(output_string to:oc'))
(sort_components wdef.externals);
close_out oc;
close_out oc'
@@ -235,27 +235,27 @@ let compile () =
(* write the module list for the Makefile *)
(* and hack to death until it works *)
let oc = open_out_bin (destfile "modules") in
- output_string oc "WIDGETOBJS=";
+ output_string to:oc "WIDGETOBJS=";
Hashtbl.iter module_table
- f:(fun key:name data:_ ->
- output_string oc name;
- output_string oc ".cmo ");
- output_string oc "\n";
+ fun:(fun key:name data:_ ->
+ output_string to:oc name;
+ output_string to:oc ".cmo ");
+ output_string to:oc "\n";
Hashtbl.iter module_table
- f:(fun key:name data:_ ->
- output_string oc name;
- output_string oc ".ml ");
- output_string oc ": tkgen.ml\n\n";
- Hashtbl.iter module_table f:
+ fun:(fun key:name data:_ ->
+ output_string to:oc name;
+ output_string to:oc ".ml ");
+ output_string to:oc ": tkgen.ml\n\n";
+ Hashtbl.iter module_table fun:
begin fun key:name data:_ ->
- output_string oc name;
- output_string oc ".cmo : ";
- output_string oc name;
- output_string oc ".ml\n";
- output_string oc name;
- output_string oc ".cmi : ";
- output_string oc name;
- output_string oc ".mli\n"
+ output_string to:oc name;
+ output_string to:oc ".cmo : ";
+ output_string to:oc name;
+ output_string to:oc ".ml\n";
+ output_string to:oc name;
+ output_string to:oc ".cmi : ";
+ output_string to:oc name;
+ output_string to:oc ".mli\n"
end;
close_out oc
diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
index d4bb5db72..5a74357c3 100644
--- a/otherlibs/labltk/compiler/printer.ml
+++ b/otherlibs/labltk/compiler/printer.ml
@@ -23,7 +23,7 @@ let escape_string s =
| _ -> ()
done;
if !more = 0 then s else
- let res = String.create (String.length s + !more) in
+ let res = String.create len:(String.length s + !more) in
let j = ref 0 in
for i = 0 to String.length s - 1 do
let c = s.[i] in
@@ -33,7 +33,7 @@ let escape_string s =
done;
res;;
-let escape_char c = if c = '\'' then "\\'" else String.make 1 c;;
+let escape_char c = if c = '\'' then "\\'" else String.make len:1 c;;
let print_quoted_string s = printf "\"%s\"" (escape_string s);;
let print_quoted_char c = printf "'%s'" (escape_char c);;
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index 1ab6d36ff..41602b2bf 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -99,7 +99,7 @@ type module_def = {
(******************** The tables ********************)
(* the table of all explicitly defined types *)
-let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t)
+let types_table = (Hashtbl.create size:37 : (string, type_def) Hashtbl.t)
(* "builtin" types *)
let types_external = ref ([] : (string * parser_arity) list)
(* dependancy order *)
@@ -109,7 +109,7 @@ let types_returned = ref ([] : string list)
(* Function table *)
let function_table = ref ([] : fullcomponent list)
(* Widget/Module table *)
-let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
+let module_table = (Hashtbl.create size:37 : (string, module_def) Hashtbl.t)
(* variant name *)
@@ -162,23 +162,23 @@ let new_type typname arity =
let is_subtyped s =
s = "widget" or
try
- let typdef = Hashtbl.find types_table s in
+ let typdef = Hashtbl.find types_table key:s in
typdef.subtypes <> []
with
Not_found -> false
let requires_widget_context s =
try
- (Hashtbl.find types_table s).requires_widget_context
+ (Hashtbl.find types_table key:s).requires_widget_context
with
Not_found -> false
let declared_type_parser_arity s =
try
- (Hashtbl.find types_table s).parser_arity
+ (Hashtbl.find types_table key:s).parser_arity
with
Not_found ->
- try List.assoc s !types_external
+ try List.assoc key:s !types_external
with
Not_found ->
prerr_string "Type "; prerr_string s;
@@ -210,8 +210,8 @@ let enter_external_type s v =
let rec enter_argtype = function
Unit | Int | Float | Bool | Char | String -> ()
| List ty -> enter_argtype ty
- | Product tyl -> List.iter f:enter_argtype tyl
- | Record tyl -> List.iter tyl f:(fun (l,t) -> enter_argtype t)
+ | Product tyl -> List.iter fun:enter_argtype tyl
+ | Record tyl -> List.iter tyl fun:(fun (l,t) -> enter_argtype t)
| UserDefined s -> Tsort.add_element types_order s
| Subtype (s,_) -> Tsort.add_element types_order s
| Function ty -> enter_argtype ty
@@ -220,14 +220,14 @@ let rec enter_argtype = function
let rec enter_template_types = function
StringArg _ -> ()
| TypeArg (l,t) -> enter_argtype t
- | ListArg l -> List.iter f:enter_template_types l
- | OptionalArgs (_,tl,_) -> List.iter f:enter_template_types tl
+ | ListArg l -> List.iter fun:enter_template_types l
+ | OptionalArgs (_,tl,_) -> List.iter fun:enter_template_types tl
(* Find type dependancies on s *)
let rec add_dependancies s =
function
List ty -> add_dependancies s ty
- | Product tyl -> List.iter f:(add_dependancies s) tyl
+ | Product tyl -> List.iter fun:(add_dependancies s) tyl
| Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s)
| UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s)
| Function ty -> add_dependancies s ty
@@ -237,20 +237,20 @@ let rec add_dependancies s =
let rec add_template_dependancies s = function
StringArg _ -> ()
| TypeArg (l,t) -> add_dependancies s t
- | ListArg l -> List.iter f:(add_template_dependancies s) l
- | OptionalArgs (_,tl,_) -> List.iter f:(add_template_dependancies s) tl
+ | ListArg l -> List.iter fun:(add_template_dependancies s) l
+ | OptionalArgs (_,tl,_) -> List.iter fun:(add_template_dependancies s) tl
(* Assumes functions are not nested in products, which is reasonable due to syntax*)
let rec has_callback = function
StringArg _ -> false
| TypeArg (l,Function _ ) -> true
| TypeArg _ -> false
- | ListArg l -> List.exists f:has_callback l
- | OptionalArgs (_,tl,_) -> List.exists f:has_callback tl
+ | ListArg l -> List.exists pred:has_callback l
+ | OptionalArgs (_,tl,_) -> List.exists pred:has_callback tl
(*** Returned types ***)
let really_add ty =
- if List.mem ty !types_returned then ()
+ if List.mem item:ty !types_returned then ()
else types_returned := ty :: !types_returned
let rec add_return_type = function
@@ -261,8 +261,8 @@ let rec add_return_type = function
| Char -> ()
| String -> ()
| List ty -> add_return_type ty
- | Product tyl -> List.iter f:add_return_type tyl
- | Record tyl -> List.iter tyl f:(fun (l,t) -> add_return_type t)
+ | Product tyl -> List.iter fun:add_return_type tyl
+ | Record tyl -> List.iter tyl fun:(fun (l,t) -> add_return_type t)
| UserDefined s -> really_add s
| Subtype (s,_) -> really_add s
| Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
@@ -299,11 +299,11 @@ let rec find_constructor cname = function
(* Enter a type, must not be previously defined *)
let enter_type typname ?(:variant = false) arity constructors =
- if Hashtbl.mem types_table typname then
+ if Hashtbl.mem types_table key:typname then
raise (Duplicate_Definition ("type", typname)) else
let typdef = new_type typname arity in
if variant then typdef.variant <- true;
- List.iter constructors f:
+ List.iter constructors fun:
begin fun c ->
if not (check_duplicate_constr false c typdef.constructors)
then begin
@@ -320,14 +320,14 @@ let enter_type typname ?(:variant = false) arity constructors =
let enter_subtype typ arity subtyp constructors =
(* Retrieve the type if already defined, else add a new one *)
let typdef =
- try Hashtbl.find types_table typ
+ try Hashtbl.find types_table key:typ
with Not_found -> new_type typ arity
in
- if List.mem_assoc subtyp typdef.subtypes
+ if List.mem_assoc key:subtyp typdef.subtypes
then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
else begin
let real_constructors =
- List.map constructors f:
+ List.map constructors fun:
begin function
Full c ->
if not (check_duplicate_constr true c typdef.constructors)
@@ -354,41 +354,41 @@ let enter_subtype typ arity subtyp constructors =
all components are assumed to be in Full form *)
let retrieve_option optname =
let optiontyp =
- try Hashtbl.find types_table "options"
+ try Hashtbl.find types_table key:"options"
with
Not_found -> raise (Invalid_implicit_constructor optname)
in find_constructor optname optiontyp.constructors
(* Sort components by type *)
-let rec add_sort l obj =
+let rec add_sort acc:l obj =
match l with
[] -> [obj.component ,[obj]]
| (s',l)::rest ->
if obj.component = s' then
(s',obj::l)::rest
else
- (s',l)::(add_sort rest obj)
+ (s',l)::(add_sort acc:rest obj)
-let separate_components = List.fold_left f:add_sort init:[]
+let separate_components = List.fold_left fun:add_sort acc:[]
let enter_widget name components =
- if Hashtbl.mem module_table name then
+ if Hashtbl.mem module_table key:name then
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
- List.iter sorted_components f:
+ List.iter sorted_components fun:
begin function
Constructor, l ->
enter_subtype "options" MultipleToken
- name (List.map f:(fun c -> Full c) l)
+ name (List.map fun:(fun c -> Full c) l)
| Command, l ->
- List.iter f:enter_component_types l
+ List.iter fun:enter_component_types l
| External, _ -> ()
end;
let commands =
- try List.assoc Command sorted_components
+ try List.assoc key:Command sorted_components
with Not_found -> []
and externals =
- try List.assoc External sorted_components
+ try List.assoc key:External sorted_components
with Not_found -> []
in
Hashtbl.add module_table key:name
@@ -402,20 +402,20 @@ let enter_function comp =
(******************** Modules ********************)
let enter_module name components =
- if Hashtbl.mem module_table name then
+ if Hashtbl.mem module_table key:name then
raise (Duplicate_Definition ("widget/module", name)) else
let sorted_components = separate_components components in
- List.iter sorted_components f:
+ List.iter sorted_components fun:
begin function
Constructor, l -> fatal_error "unexpected Constructor"
- | Command, l -> List.iter f:enter_component_types l
+ | Command, l -> List.iter fun:enter_component_types l
| External, _ -> ()
end;
let commands =
- try List.assoc Command sorted_components
+ try List.assoc key:Command sorted_components
with Not_found -> []
and externals =
- try List.assoc External sorted_components
+ try List.assoc key:External sorted_components
with Not_found -> []
in
Hashtbl.add module_table key:name
diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index 246eca2db..4f0d49692 100644
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -62,13 +62,13 @@ let sort order =
let q = Queue.create ()
and result = ref [] in
List.iter !order
- f:(function {pred_count = n} as node ->
+ fun:(function {pred_count = n} as node ->
if n = 0 then Queue.add node q);
begin try
while true do
let t = Queue.take q in
result := t.node :: !result;
- List.iter t.successors f:
+ List.iter t.successors fun:
begin fun s ->
let n = s.pred_count - 1 in
s.pred_count <- n;
@@ -78,7 +78,7 @@ let sort order =
with
Queue.Empty ->
List.iter !order
- f:(fun node -> if node.pred_count <> 0
+ fun:(fun node -> if node.pred_count <> 0
then raise Cyclic)
end;
!result
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
index cd8a706e2..c783a0be6 100644
--- a/otherlibs/labltk/jpf/balloon.ml
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -69,17 +69,17 @@ let put on: w ms: millisec mesg =
List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy];
[`KeyPress]; [`KeyRelease]]
- f:(fun events -> bind w :events extend:true action:(fun _ -> reset ()));
- List.iter [[`Enter]; [`Motion]] f:
+ fun:(fun events -> bind w :events extend:true action:(fun _ -> reset ()));
+ List.iter [[`Enter]; [`Motion]] fun:
begin fun events ->
bind w :events extend:true fields:[`RootX; `RootY]
action:(fun ev -> reset (); set ev)
end
let init () =
- let t = Hashtbl.create 101 in
+ let t = Hashtbl.create size:101 in
Protocol.add_destroy_hook (fun w ->
- Hashtbl.remove t w);
+ Hashtbl.remove t key:w);
topw := Toplevel.create default_toplevel;
Wm.overrideredirect_set !topw to: true;
Wm.withdraw !topw;
@@ -88,7 +88,7 @@ let init () =
pack [!popupw];
bind_class "all" events: [`Enter] extend:true fields:[`Widget] action:
begin fun w ->
- try Hashtbl.find t w.ev_Widget
+ try Hashtbl.find t key: w.ev_Widget
with Not_found ->
Hashtbl.add t key:w.ev_Widget data: ();
let x = Option.get w.ev_Widget name: "balloon" class: "Balloon" in
diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
index 0c8ee23c6..e3b08e051 100644
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ b/otherlibs/labltk/jpf/fileselect.ml
@@ -112,11 +112,11 @@ let get_files_in_directory dir =
let rec get_directories_in_files path =
List.filter
- f:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
+ pred:(fun x -> try (stat (path ^ x)).st_kind = S_DIR with _ -> false)
let remove_directories path =
List.filter
- f:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
+ pred:(fun x -> try (stat (path ^ x)).st_kind <> S_DIR with _ -> false)
(************************* a nice interface to listbox - from frx_listbox.ml *)
@@ -238,8 +238,8 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
(* get matched file by subshell call. *)
let matched_files = remove_directories dirname (ls dirname patternname)
in
- Textvariable.set filter_var filter;
- Textvariable.set selection_var (dirname ^ deffile);
+ Textvariable.set filter_var to:filter;
+ Textvariable.set selection_var to:(dirname ^ deffile);
Listbox.delete directory_listbox first:(`Num 0) last:`End;
Listbox.insert directory_listbox index:`End texts:directories;
Listbox.delete filter_listbox first:(`Num 0) last:`End;
@@ -259,7 +259,7 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
if sync then
begin
selected_files := l;
- Textvariable.set sync_var "1"
+ Textvariable.set sync_var to:"1"
end
else
begin
@@ -273,7 +273,7 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
begin fun () ->
let files =
List.map (Listbox.curselection filter_listbox)
- f:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
+ fun:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
in
let files = if files = [] then [Textvariable.get selection_var]
else files in
@@ -294,7 +294,7 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync =
let action _ =
let files =
List.map (Listbox.curselection filter_listbox)
- f:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
+ fun:(fun x -> !current_dir ^ (Listbox.get filter_listbox index:x))
in
activate files ()
in
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index b2710d75c..3fd4243dd 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 37 (* Avoid space leak in callback table *)
+let fd_table = Hashtbl.create size: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 (fd, 'r') in
+ let id = Hashtbl.find fd_table key:(fd, 'r') in
clear_callback id;
- Hashtbl.remove fd_table (fd, 'r');
+ Hashtbl.remove fd_table key:(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 (fd, 'w') in
+ let id = Hashtbl.find fd_table key:(fd, 'w') in
clear_callback id;
- Hashtbl.remove fd_table (fd, 'w');
+ Hashtbl.remove fd_table key:(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 9de095826..9d7cb2e1f 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 f:print_arg l
+ | TkTokenList l -> List.iter fun:print_arg l
| TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
in
- Array.iter f:print_arg args;
+ Array.iter fun:print_arg args;
prerr_newline()
(*
@@ -92,10 +92,10 @@ let cTKtoCAMLwidget = function
let callback_naming_table =
- (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
+ (Hashtbl.create size:401 : (int, callback_buffer -> unit) Hashtbl.t)
let callback_memo_table =
- (Hashtbl.create 401 : (any widget, int) Hashtbl.t)
+ (Hashtbl.create size: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 id
+ Hashtbl.remove callback_naming_table key: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 w in
- List.iter f:clear_callback cb_ids;
+ let cb_ids = Hashtbl.find_all callback_memo_table key:w in
+ List.iter fun:clear_callback cb_ids;
for i = 1 to List.length cb_ids do
- Hashtbl.remove callback_memo_table w
+ Hashtbl.remove callback_memo_table key: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 f:(fun f -> f w) !destroy_hooks
+ List.iter fun:(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 f:(fun x -> prerr_string " "; prerr_string x) args;
+ List.iter fun:(fun x -> prerr_string " "; prerr_string x) args;
prerr_newline()
end;
- (Hashtbl.find callback_naming_table id) args;
+ (Hashtbl.find callback_naming_table key: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 18568988f..adeb85032 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 -> string -> unit = "camltk_setvar"
+external set : string -> to:string -> unit = "camltk_setvar"
external get : string -> string = "camltk_getvar"
type textVariable = string
(* List of handles *)
-let handles = Hashtbl.create 401
+let handles = Hashtbl.create size:401
let add_handle var cbid =
try
- let r = Hashtbl.find handles var in
+ let r = Hashtbl.find handles key: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 var in
+ let r = Hashtbl.find handles key:var in
match exceptq cbid !r with
- [] -> Hashtbl.remove handles var
+ [] -> Hashtbl.remove handles key: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 var in
- List.iter f:(internal_untracevar var) !r;
- Hashtbl.remove handles var
+ let r = Hashtbl.find handles key:var in
+ List.iter fun:(internal_untracevar var) !r;
+ Hashtbl.remove handles key: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 101
+let memo = Hashtbl.create size: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 w
+ try Hashtbl.find memo key:w
with
Not_found ->
let r = ref StringSet.empty in
Hashtbl.add memo key:w data:r;
r in
- r := StringSet.add v !r
+ r := StringSet.add !r item:v
(* to be used with care ! *)
let free v =
rem_all_handles v;
- freelist := StringSet.add v !freelist
+ freelist := StringSet.add item:v !freelist
(* Free variables associated with a widget *)
let freew w =
try
- let r = Hashtbl.find memo w in
- StringSet.iter f:free !r;
- Hashtbl.remove memo w
+ let r = Hashtbl.find memo key:w in
+ StringSet.iter fun:free !r;
+ Hashtbl.remove memo key:w
with
Not_found -> ()
@@ -125,9 +125,9 @@ let getv () =
end
else
let v = StringSet.choose !freelist in
- freelist := StringSet.remove v !freelist;
+ freelist := StringSet.remove item:v !freelist;
v in
- set v "";
+ set v to:"";
v
let create ?on: w () =
@@ -141,7 +141,7 @@ let create ?on: w () =
(* to be used with care ! *)
let free v =
- freelist := StringSet.add v !freelist
+ freelist := StringSet.add item:v !freelist
let cCAMLtoTKtextVariable s = TkToken s
diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
index 0b4a7a535..f2e22a828 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 -> string -> unit
+val set : textVariable -> to: 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 0ec71c09a..883d8624f 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 401 : (string, any widget) Hashtbl.t)
+let table = (Hashtbl.create size: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 (name w)
+ Hashtbl.remove table key:(name w)
(* Retype widgets returned from Tk *)
(* JPF report: sometime s is "", see Protocol.cTKtoCAMLwidget *)
let get_atom s =
try
- Hashtbl.find table s
+ Hashtbl.find table key:s
with
Not_found -> Untyped s
@@ -103,7 +103,7 @@ let naming_scheme = [
"toplevel", "top" ]
-let widget_any_table = List.map f:fst naming_scheme
+let widget_any_table = List.map fun: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 clas naming_scheme) ^ (string_of_int n)
+ (List.assoc key: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 c clas then ()
+ if List.mem clas item:c then ()
else raise (IllegalWidgetType c)
(* Checking membership of constructor in subtype table *)
let chk_sub errname table c =
- if List.mem c table then ()
+ if List.mem table item:c then ()
else raise (Invalid_argument errname)
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-18 10:24:25 +0000