Incorporation des améliorations de la dernière version de ocamltk41,

en particulier gestion des alertes du compilateur Caml.


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

7 files changed, 78 insertions, 85 deletions

diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml
index 78735d513..50c434011 100644
--- a/otherlibs/labltk/builtin/builtinf_GetPixel.ml
+++ b/otherlibs/labltk/builtin/builtinf_GetPixel.ml
@@ -1,6 +1,8 @@
 let pixels units =
-let res = tkEval [|TkToken"winfo";
-    TkToken"pixels";
-    cCAMLtoTKwidget default_toplevel;
-    cCAMLtoTKunits units|] in 
-int_of_string res
+  let res =
+    tkEval
+     [|TkToken"winfo";
+       TkToken"pixels";
+       cCAMLtoTKwidget default_toplevel;
+       cCAMLtoTKunits units|] in 
+  int_of_string res
diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml
index 7a3e1e770..7f39b0798 100644
--- a/otherlibs/labltk/builtin/builtinf_bind.ml
+++ b/otherlibs/labltk/builtin/builtinf_bind.ml
@@ -1,26 +1,24 @@
 let bind_class :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
     ?:action ?(on:widget) name =
   let widget = match widget with None -> Widget.dummy | Some w -> coe w in
-  ignore begin
-    tkEval
-      [| TkToken "bind";
-         TkToken name;
-         cCAMLtoTKeventSequence events;
-         begin match action with None -> TkToken ""
-         | Some f ->
-             let cbId =
-               register_callback widget callback: (wrapeventInfo f fields) in
-             let cb = if extend then "+camlcb " else "camlcb " in
-             let cb = cb ^ cbId ^ writeeventField fields in
-             let cb =
-               if breakable then 
-                 cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
-                 ^ " ; set BreakBindingsSequence 0"
-               else cb in
-             TkToken cb
-         end
-       |]
-  end
+  tkCommand
+    [| TkToken "bind";
+       TkToken name;
+       cCAMLtoTKeventSequence events;
+       begin match action with None -> TkToken ""
+       | Some f ->
+           let cbId =
+             register_callback widget callback: (wrapeventInfo f fields) in
+           let cb = if extend then "+camlcb " else "camlcb " in
+           let cb = cb ^ cbId ^ writeeventField fields in
+           let cb =
+             if breakable then 
+               cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+               ^ " ; set BreakBindingsSequence 0"
+             else cb in
+           TkToken cb
+       end
+     |]
 
 let bind :events ?:extend ?:breakable ?:fields ?:action widget =
   bind_class :events ?:extend ?:breakable ?:fields ?:action on:widget
@@ -34,6 +32,4 @@ FUNCTION
 /FUNCTION
 *)
 let break = function () ->
-  ignore begin
-    tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
-  end
+  tkCommand [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]
diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml
index ed646fe47..3f999b8aa 100644
--- a/otherlibs/labltk/builtin/canvas_bind.ml
+++ b/otherlibs/labltk/builtin/canvas_bind.ml
@@ -1,23 +1,21 @@
 let bind :tag :events ?(:extend = false) ?(:breakable = false) ?(:fields = [])
     ?:action widget =
-  ignore begin
-    tkEval
-      [| cCAMLtoTKwidget widget;
-         TkToken "bind";
-         cCAMLtoTKtagOrId tag;
-         cCAMLtoTKeventSequence events;
-         begin match action with None -> TkToken ""
-         | Some f ->
-             let cbId =
-               register_callback widget callback: (wrapeventInfo f fields) in
-             let cb = if extend then "+camlcb " else "camlcb " in
-             let cb = cb ^ cbId ^ writeeventField fields in
-             let cb =
-               if breakable then 
-                 cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
-                 ^ " ; set BreakBindingsSequence 0"
-               else cb in
-             TkToken cb
-         end
-       |]
-  end
+  tkCommand
+    [| cCAMLtoTKwidget widget;
+       TkToken "bind";
+       cCAMLtoTKtagOrId tag;
+       cCAMLtoTKeventSequence events;
+       begin match action with None -> TkToken ""
+       | Some f ->
+           let cbId =
+             register_callback widget callback: (wrapeventInfo f fields) in
+           let cb = if extend then "+camlcb " else "camlcb " in
+           let cb = cb ^ cbId ^ writeeventField fields in
+           let cb =
+             if breakable then 
+               cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+               ^ " ; set BreakBindingsSequence 0"
+             else cb in
+           TkToken cb
+       end
+     |]
diff --git a/otherlibs/labltk/builtin/optionmenu.ml b/otherlibs/labltk/builtin/optionmenu.ml
index c4090d25a..3ade5d57d 100644
--- a/otherlibs/labltk/builtin/optionmenu.ml
+++ b/otherlibs/labltk/builtin/optionmenu.ml
@@ -13,4 +13,4 @@ let create :parent :variable ?:name values =
    if res <> Widget.name mw then
      raise (TkError "internal error in Optionmenu.create")
    else
-     w,mw
+     w, mw
diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml
index f773a7a6d..6cc54ff8c 100644
--- a/otherlibs/labltk/builtin/selection_handle_set.ml
+++ b/otherlibs/labltk/builtin/selection_handle_set.ml
@@ -1,14 +1,13 @@
 (* The function *must* use tkreturn *)
 let handle_set command: cmd =
 selection_handle_icccm_optionals (fun opts w ->
-tkEval [|TkToken"selection";
-         TkToken"handle";
-         TkTokenList opts;
-         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 pos:1) in
-           tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb "^id)
-       |];
-  ())
+  tkCommand [|TkToken"selection";
+              TkToken"handle";
+              TkTokenList opts;
+              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 pos:1) in
+                tkreturn (cmd pos:a1 len:a2)) in TkToken ("camlcb "^id)
+            |])
 
diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml
index 22b2af52f..648cddf41 100644
--- a/otherlibs/labltk/builtin/selection_own_set.ml
+++ b/otherlibs/labltk/builtin/selection_own_set.ml
@@ -1,9 +1,8 @@
 (* builtin to handle callback association to widget *)
 let own_set ?:command =
 selection_ownset_icccm_optionals ?:command (fun opts w ->
-tkEval [|TkToken"selection";
+tkCommand [|TkToken"selection";
          TkToken"own";
          TkTokenList opts;
-        cCAMLtoTKwidget w|];
-())
+        cCAMLtoTKwidget w|])
 
diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml
index ac23bc2e3..597c938cb 100644
--- a/otherlibs/labltk/builtin/text_tag_bind.ml
+++ b/otherlibs/labltk/builtin/text_tag_bind.ml
@@ -1,24 +1,23 @@
 let tag_bind :tag :events ?(:extend = false) ?(:breakable = false)
     ?(:fields = []) ?:action widget =
-  ignore begin
-    tkEval
-      [| cCAMLtoTKwidget widget;
-         TkToken "tag";
-         TkToken "bind";
-         cCAMLtoTKtextTag tag;
-         cCAMLtoTKeventSequence events;
-         begin match action with None -> TkToken ""
-         | Some f ->
-             let cbId =
-               register_callback widget callback: (wrapeventInfo f fields) in
-             let cb = if extend then "+camlcb " else "camlcb " in
-             let cb = cb ^ cbId ^ writeeventField fields in
-             let cb =
-               if breakable then 
-                 cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
-                 ^ " ; set BreakBindingsSequence 0"
-               else cb in
-             TkToken cb
-         end
-       |]
-  end
+  tkCommand
+    [| cCAMLtoTKwidget widget;
+       TkToken "tag";
+       TkToken "bind";
+       cCAMLtoTKtextTag tag;
+       cCAMLtoTKeventSequence events;
+       begin match action with
+       | None -> TkToken ""
+       | Some f ->
+           let cbId =
+             register_callback widget callback: (wrapeventInfo f fields) in
+           let cb = if extend then "+camlcb " else "camlcb " in
+           let cb = cb ^ cbId ^ writeeventField fields in
+           let cb =
+             if breakable then 
+               cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}"
+               ^ " ; set BreakBindingsSequence 0"
+             else cb in
+           TkToken cb
+       end
+     |]