remove doublonsstrict_labels

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/strict_labels@3687 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

17 files changed, 66 insertions, 51 deletions

diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index b1900c6765..279098d3da 100644
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -113,7 +113,7 @@ let select_shell txt =
       begin fun () ->
         try
           let name = Listbox.get box ~index:`Active in
-          txt.shell <- Some (name, List.assoc name shells);
+          txt.shell <- Some (name, List.assoc name ~map:shells);
           destroy tl
         with Not_found -> txt.shell <- None; destroy tl
       end
@@ -392,7 +392,7 @@ class editor ~top ~menus = object (self)
     try
       if Sys.file_exists name then
         if txt.name = name then
-          Sys.rename' ~src:name ~dst:(name ^ "~")
+          Sys.rename name (name ^ "~")
         else begin match
           Jg_message.ask ~master:top ~title:"Save"
             ("File `" ^ name ^ "' exists. Overwrite it?")
@@ -434,7 +434,7 @@ class editor ~top ~menus = object (self)
       and buf = String.create 4096 in
       Text.delete tw ~start:tstart ~stop:tend;
       while
-        len := input' file ~buf ~pos:0 ~len:4096;
+        len := input file buf 0 4096;
         !len > 0
       do
         Jg_text.output tw ~buf ~pos:0 ~len:!len
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 18e01e531e..e5c222d6da 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -14,6 +14,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 open Tk
 open Jg_tk
 open Parsetree
@@ -235,7 +236,7 @@ let filter_modules () =
         Hashtbl.remove shown_modules key)
     shown_modules
 let add_shown_module path ~widgets =
-  Hashtbl.add' shown_modules ~key:path ~data:widgets
+  Hashtbl'.add shown_modules ~key:path ~data:widgets
 let find_shown_module path =
   try
     filter_modules ();
diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
index 6b215dcbfd..302ad25880 100644
--- a/otherlibs/labltk/compiler/Makefile
+++ b/otherlibs/labltk/compiler/Makefile
@@ -1,7 +1,7 @@
 include ../support/Makefile.common
 
-OBJS=tsort.cmo tables.cmo printer.cmo lexer.cmo parser.cmo \
- compile.cmo intf.cmo maincompile.cmo
+OBJS=	../support/support.cmo tsort.cmo tables.cmo printer.cmo lexer.cmo \
+	parser.cmo compile.cmo intf.cmo maincompile.cmo
 
 tkcompiler : $(OBJS)
 	$(LABLC) $(LINKFLAGS) -o tkcompiler $(OBJS)
@@ -25,10 +25,10 @@ install:
 .SUFFIXES : .mli .ml .cmi .cmo .mlp
 
 .mli.cmi:
-	$(LABLCOMP) $(COMPFLAGS) $<
+	$(LABLCOMP) $(COMPFLAGS) -I ../support $<
 
 .ml.cmo:
-	$(LABLCOMP) $(COMPFLAGS) $<
+	$(LABLCOMP) $(COMPFLAGS) -I ../support $<
 
 depend: parser.ml parser.mli lexer.ml
 	$(LABLDEP) *.mli *.ml > .depend
diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index ca51bafcf9..66cfcf7a7d 100644
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -52,7 +52,7 @@ let gettklabel fc =
         else s
       in begin
         if List.mem s forbidden then
-          try List.assoc s nicknames
+          try List.assoc s ~map:nicknames
           with Not_found -> small fc.var_name
         else s
       end
@@ -97,7 +97,7 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
      begin
        try 
         let typdef = Hashtbl.find types_table sup in
-        let fcl = List.assoc sub typdef.subtypes in
+        let fcl = List.assoc sub ~map:typdef.subtypes in
         let tklabels = List.map ~f:gettklabel fcl in
         let l = List.map fcl ~f:
           begin fun fc ->
@@ -499,7 +499,7 @@ let code_of_template ~context_widget ?func:(funtemplate=false) template =
     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 classdef = List.assoc sub ~map:typdef.subtypes in
       let lbl = gettklabel (List.hd classdef) in
       catch_opts := (sub ^ "_" ^ sup, lbl);
       newvar := newvar2;
diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 489fa3930e..fdeac2edbb 100644
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -27,7 +27,7 @@ let write_create_p ~w wname =
   begin
     try 
       let option = Hashtbl.find types_table "options" in
-      let classdefs = List.assoc wname option.subtypes in
+      let classdefs = List.assoc wname ~map:option.subtypes in
       let tklabels = List.map ~f:gettklabel classdefs in
       let l = List.map classdefs ~f:
         begin fun fc ->
diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index 6daa17fc16..8de3956810 100644
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -19,6 +19,7 @@
 open StdLabels
 open Lexing
 open Parser
+open Support
 
 exception Lexical_error of string
 let current_line = ref 1
@@ -29,7 +30,7 @@ let current_line = ref 1
 let keyword_table = (Hashtbl.create 149 : (string, token) Hashtbl.t)
 
 let _ = List.iter
-  ~f:(fun (str,tok) -> Hashtbl.add' keyword_table ~key:str ~data:tok)
+  ~f:(fun (str,tok) -> Hashtbl'.add keyword_table ~key:str ~data:tok)
   [
   "int", TYINT;
   "float", TYFLOAT;
diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index 146c5f08b5..65535df790 100644
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 open Tables
 open Printer
 open Compile
@@ -118,7 +119,7 @@ let uniq_clauses = function
        let c = constr.var_name in
        if Hashtbl.mem t c
        then (check_constr constr (Hashtbl.find t c))
-       else Hashtbl.add' t ~key:c ~data:constr);
+       else Hashtbl'.add t ~key:c ~data:constr);
      elements t;;
 
 let option_hack oc =
@@ -268,11 +269,11 @@ let main () =
     (fun filename -> input_name := filename)
     "Usage: tkcompiler <source file>" ;
   try
-    verbose_string "Parsing... ";
+    verbose_endline "Parsing...";
     parse_file !input_name;
-    verbose_string "Compiling... ";
+    verbose_endline "Compiling...";
     compile ();
-    verbose_string "Finished";
+    verbose_endline "Finished";
     exit 0
   with
   | Lexer.Lexical_error s ->
diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index fa8aa502ca..85029b7726 100644
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 
 (* Internal compiler errors *)
 
@@ -155,7 +156,7 @@ let new_type typname arity =
                 subtypes = []; 
                 requires_widget_context = false;
                 variant = false} in
-    Hashtbl.add' types_table ~key:typname ~data:typdef;
+    Hashtbl'.add types_table ~key:typname ~data:typdef;
     typdef
 
 
@@ -180,7 +181,7 @@ let declared_type_parser_arity s =
     (Hashtbl.find types_table s).parser_arity
   with
     Not_found -> 
-      try List.assoc s !types_external
+      try List.assoc s ~map:!types_external
       with
         Not_found ->
            prerr_string "Type "; prerr_string s;
@@ -387,13 +388,13 @@ let enter_widget name components =
     | External, _ -> ()
     end;
   let commands = 
-      try List.assoc Command sorted_components
+      try List.assoc Command ~map:sorted_components
       with Not_found -> [] 
   and externals = 
-      try List.assoc External sorted_components
+      try List.assoc External ~map:sorted_components
       with Not_found -> []
   in
-  Hashtbl.add' module_table ~key:name 
+  Hashtbl'.add module_table ~key:name 
     ~data:{module_type = Widget; commands = commands; externals = externals}
   
 (******************** Functions ********************)
@@ -414,12 +415,11 @@ let enter_module name components =
     | External, _ -> ()
     end;
   let commands = 
-      try List.assoc Command sorted_components
+      try List.assoc Command ~map:sorted_components
       with Not_found -> [] 
   and externals = 
-      try List.assoc External sorted_components
+      try List.assoc External ~map:sorted_components
       with Not_found -> []
   in
-    Hashtbl.add' module_table ~key:name 
+    Hashtbl'.add module_table ~key:name 
       ~data:{module_type = Family; commands = commands; externals = externals}
-
diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
index 2ee8177bd4..7b2f2e074f 100644
--- a/otherlibs/labltk/jpf/balloon.ml
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -20,6 +20,7 @@ open StdLabels
 open Tk
 open Widget
 open Protocol
+open Support
 
 (* switch -- if you do not want balloons, set false *)
 let flag = ref true
@@ -92,7 +93,7 @@ let init () =
     begin fun w ->
       try Hashtbl.find t w.ev_Widget
       with Not_found ->
-        Hashtbl.add' t ~key:w.ev_Widget ~data: ();
+        Hashtbl'.add t ~key:w.ev_Widget ~data: ();
         let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
         if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
     end
diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend
index 8c7b959bf6..c10b37a920 100644
--- a/otherlibs/labltk/support/.depend
+++ b/otherlibs/labltk/support/.depend
@@ -1,16 +1,16 @@
 protocol.cmi: widget.cmi 
 textvariable.cmi: protocol.cmi widget.cmi 
-fileevent.cmo: protocol.cmi fileevent.cmi 
-fileevent.cmx: protocol.cmx fileevent.cmi 
-protocol.cmo: widget.cmi protocol.cmi 
-protocol.cmx: widget.cmx protocol.cmi 
+fileevent.cmo: protocol.cmi support.cmi fileevent.cmi 
+fileevent.cmx: protocol.cmx support.cmx fileevent.cmi 
+protocol.cmo: support.cmi widget.cmi protocol.cmi 
+protocol.cmx: support.cmx widget.cmx protocol.cmi 
 slave.cmo: widget.cmi 
 slave.cmx: widget.cmx 
 support.cmo: support.cmi 
 support.cmx: support.cmi 
-textvariable.cmo: protocol.cmi widget.cmi textvariable.cmi 
-textvariable.cmx: protocol.cmx widget.cmx textvariable.cmi 
-timer.cmo: protocol.cmi timer.cmi 
-timer.cmx: protocol.cmx timer.cmi 
-widget.cmo: widget.cmi 
-widget.cmx: widget.cmi 
+textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi 
+textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi 
+timer.cmo: protocol.cmi support.cmi timer.cmi 
+timer.cmx: protocol.cmx support.cmx timer.cmi 
+widget.cmo: support.cmi widget.cmi 
+widget.cmx: support.cmx widget.cmi 
diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index f6d6e76aad..1e907c7684 100644
--- a/otherlibs/labltk/support/fileevent.ml
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open Unix
+open Support
 open Protocol
 
 external add_file_input : file_descr -> cbid -> unit
@@ -33,8 +34,8 @@ let fd_table = Hashtbl.create 37 (* Avoid space leak in callback table *)
 
 let add_fileinput ~fd ~callback:f =
   let id = new_function_id () in
-  Hashtbl.add' callback_naming_table ~key:id ~data:(fun _ -> f());
-  Hashtbl.add' fd_table ~key:(fd, 'r') ~data:id;
+  Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f());
+  Hashtbl'.add fd_table ~key:(fd, 'r') ~data:id;
   if !Protocol.debug then begin
     Protocol.prerr_cbid id; prerr_endline " for fileinput"
   end;
@@ -56,8 +57,8 @@ let remove_fileinput ~fd =
 
 let add_fileoutput ~fd ~callback:f =
   let id = new_function_id () in
-  Hashtbl.add' callback_naming_table ~key:id ~data:(fun _ -> f());
-  Hashtbl.add' fd_table ~key:(fd, 'w') ~data:id;
+  Hashtbl'.add callback_naming_table ~key:id ~data:(fun _ -> f());
+  Hashtbl'.add fd_table ~key:(fd, 'w') ~data:id;
   if !Protocol.debug then begin
     Protocol.prerr_cbid id; prerr_endline " for fileoutput"
   end;
diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
index 68e2eb993a..7ad8b317e6 100644
--- a/otherlibs/labltk/support/protocol.ml
+++ b/otherlibs/labltk/support/protocol.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 open Widget
 
 type callback_buffer = string list
@@ -108,9 +109,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 ~key:id ~data:f;
+    Hashtbl'.add callback_naming_table ~key:id ~data:f;
     if (forget_type w) <> (forget_type Widget.dummy) then 
-      Hashtbl.add' callback_memo_table ~key:(forget_type w) ~data:id;
+      Hashtbl'.add callback_memo_table ~key:(forget_type w) ~data:id;
     (string_of_cbid id)
 
 let clear_callback id =
@@ -144,7 +145,7 @@ let install_cleanup () =
          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;
+  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}")
 
diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
index ded07ee995..b6cd5e8c32 100644
--- a/otherlibs/labltk/support/support.ml
+++ b/otherlibs/labltk/support/support.ml
@@ -47,3 +47,7 @@ let maycons f x l =
   match x with
     Some x -> f x :: l
   | None -> l
+
+(* Get some labels on Hashtbl.add *)
+module Hashtbl' =
+  struct let add tbl ~key ~data = Hashtbl.add tbl key data end
diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
index 78007e4eff..2eaf9b5e52 100644
--- a/otherlibs/labltk/support/support.mli
+++ b/otherlibs/labltk/support/support.mli
@@ -18,3 +18,5 @@
 val split_str : pred:(char -> bool) -> string -> string list
 val may : ('a -> 'b) -> 'a option -> 'b option
 val maycons : ('a -> 'b) -> 'a option -> 'b list -> 'b list
+module Hashtbl' :
+  sig val add : ('a, 'b) Hashtbl.t -> key:'a -> data:'b -> unit end
diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
index e9dd514772..df4c3b92dc 100644
--- a/otherlibs/labltk/support/textvariable.ml
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 open Protocol
 
 external internal_tracevar : string -> cbid -> unit
@@ -37,7 +38,7 @@ let add_handle var cbid =
     r := cbid :: !r
   with
     Not_found -> 
-      Hashtbl.add' handles var (ref [cbid])
+      Hashtbl'.add handles var (ref [cbid])
 
 let exceptq x =
   let rec ex acc = function
@@ -75,7 +76,7 @@ let handle vname ~callback:f =
     clear_callback id;
     rem_handle vname id;
     f() in
-  Hashtbl.add' callback_naming_table ~key:id ~data:wrapped;
+  Hashtbl'.add callback_naming_table ~key:id ~data:wrapped;
   add_handle vname id;
   if !Protocol.debug then begin
     prerr_cbid id; prerr_string " for variable "; prerr_endline vname
@@ -96,7 +97,7 @@ let add w v =
     with
       Not_found -> 
         let r = ref StringSet.empty in
-          Hashtbl.add' memo ~key:w ~data:r;
+          Hashtbl'.add memo ~key:w ~data:r;
           r in
    r := StringSet.add v !r
 
diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
index 9bae936344..349bf6a2e3 100644
--- a/otherlibs/labltk/support/timer.ml
+++ b/otherlibs/labltk/support/timer.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 (* Timers *)
+open Support
 open Protocol
 
 type tkTimer = int
@@ -33,7 +34,7 @@ let add ~ms ~callback =
   let wrapped _ =
     clear_callback id; (* do it first in case f raises exception *)
     callback() in
-  Hashtbl.add' callback_naming_table ~key:id ~data:wrapped;
+  Hashtbl'.add callback_naming_table ~key:id ~data:wrapped;
   if !Protocol.debug then begin
     prerr_cbid id; prerr_endline " for timer"
   end;
diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
index 1c89bb5d90..6cc7c74743 100644
--- a/otherlibs/labltk/support/widget.ml
+++ b/otherlibs/labltk/support/widget.ml
@@ -16,6 +16,7 @@
 (* $Id$ *)
 
 open StdLabels
+open Support
 
 (*
  * Widgets
@@ -68,7 +69,7 @@ let known_class = function
 let default_toplevel =
   let wname = "." in
   let w = Typed (wname, "toplevel") in
-    Hashtbl.add' table ~key:wname ~data:w;
+    Hashtbl'.add table ~key:wname ~data:w;
     w
 
 (* Dummy widget to which global callbacks are associated *)
@@ -125,7 +126,7 @@ and widget_toplevel_table = [ "toplevel" ]
 
 let new_suffix clas n =
   try 
-    (List.assoc clas naming_scheme) ^ (string_of_int n)
+    (List.assoc clas ~map:naming_scheme) ^ (string_of_int n)
   with
     Not_found -> "w" ^ (string_of_int n)
   
@@ -147,7 +148,7 @@ let new_atom ~parent ?name:nom clas =
           else parentpath ^ "." ^ name
     in
       let w = Typed(path,clas) in
-        Hashtbl.add' table ~key:path ~data:w;
+        Hashtbl'.add table ~key:path ~data:w;
         w
 
 (* Just create a path. Only to check existence of widgets *)