3.09.1 updategcaml3090

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

8 files changed, 54 insertions, 62 deletions

diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index 1e6e3c0ee2..617cdfa855 100644
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -287,8 +287,8 @@ class editor ~top ~menus = object (self)
   val compiler_menu = new Jg_menu.c "Compiler" ~parent:menus
   val module_menu = new Jg_menu.c "Modules" ~parent:menus
   val window_menu = new Jg_menu.c "Windows" ~parent:menus
-  val label =
-    Checkbutton.create menus ~state:`Disabled
+  initializer
+    Menu.add_checkbutton menus ~state:`Disabled
       ~onvalue:"modified" ~offvalue:"unchanged"
   val mutable current_dir = Unix.getcwd ()
   val mutable error_messages = []
@@ -314,14 +314,18 @@ class editor ~top ~menus = object (self)
           ~command:(fun () -> self#set_edit txt)
       end
 
+  method set_file_name txt =
+    Menu.configure_checkbutton menus `Last
+      ~label:(Filename.basename txt.name)
+      ~variable:txt.modified
+
   method set_edit txt  =
     if windows <> [] then
       Pack.forget [(List.hd windows).frame];
     windows <- txt :: exclude txt windows;
     self#reset_window_menu;
     current_tw <- txt.tw;
-    Checkbutton.configure label ~text:(Filename.basename txt.name)
-      ~variable:txt.modified;
+    self#set_file_name txt;
     Textvariable.set vwindow txt.number;
     Text.yview txt.tw ~scroll:(`Page 0);
     pack [txt.frame] ~fill:`Both ~expand:true ~side:`Bottom
@@ -381,7 +385,7 @@ class editor ~top ~menus = object (self)
     pack [sb] ~fill:`Y ~side:`Right;
     pack [tw] ~fill:`Both ~expand:true ~side:`Left;
     self#set_edit txt;
-    Checkbutton.deselect label;
+    Textvariable.set txt.modified "unchanged";
     Lexical.init_tags txt.tw
 
   method clear_errors () =
@@ -429,9 +433,8 @@ class editor ~top ~menus = object (self)
       let text = Text.get txt.tw ~start:tstart ~stop:(tposend 1) in
       output_string file text;
       close_out file;
-      Checkbutton.configure label ~text:(Filename.basename name);
-      Checkbutton.deselect label;
-      txt.name <- name
+      txt.name <- name;
+      self#set_file_name txt
     with
       Sys_error _ ->
         Jg_message.info ~master:top ~title:"Error"
@@ -453,7 +456,7 @@ class editor ~top ~menus = object (self)
             | `No -> ()
             | `Cancel -> raise Exit
             end;
-          Checkbutton.deselect label;
+          Textvariable.set txt.modified "unchanged";
           (Text.index current_tw ~index:(`Mark"insert", []), [])
         with Not_found -> self#new_window name; tstart
       in
@@ -629,13 +632,6 @@ class editor ~top ~menus = object (self)
       ~command:Viewer.search_symbol;
     module_menu#add_command "Close all"
       ~command:Viewer.close_all_views;
-
-    (* pack everything *)
-    pack (List.map ~f:(fun m -> coe m#button)
-            [file_menu; edit_menu; compiler_menu; module_menu; window_menu]
-          @ [coe label])
-      ~side:`Left ~ipadx:5 ~anchor:`W;
-    pack [menus] ~before:(List.hd windows).frame ~side:`Top ~fill:`X
 end
 
 (* The main function starts here ! *)
@@ -658,7 +654,7 @@ let editor ?file ?(pos=0) ?(reuse=false) () =
       false
   then () else
     let top = Jg_toplevel.titled "OCamlBrowser Editor" in
-    let menus = Frame.create top ~name:"menubar" in
+    let menus = Jg_menu.menubar top in
     let ed = new editor ~top ~menus in
     already_open := !already_open @ [ed];
     if file <> None then ed#reopen ~file ~pos
diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
index 62712f36db..b399d10d87 100644
--- a/otherlibs/labltk/browser/jg_menu.ml
+++ b/otherlibs/labltk/browser/jg_menu.ml
@@ -16,15 +16,12 @@
 
 open Tk
 
-class c ~parent ?underline:(n=0) text = object (self)
-  val pair =
-    let button =
-      Menubutton.create parent ~text ~underline:n in
-    let menu =  Menu.create button in
-    Menubutton.configure button ~menu;
-    button, menu
-  method button = fst pair
-  method menu = snd pair
+class c ~parent ?(underline=0) label = object (self)
+  val menu =
+    let menu =  Menu.create parent in
+    Menu.add_cascade parent ~menu ~label ~underline;
+    menu
+  method menu = menu
   method virtual add_command :
       ?underline:int ->
       ?accelerator:string ->     ?activebackground:color ->
@@ -33,10 +30,15 @@ class c ~parent ?underline:(n=0) text = object (self)
       ?font:string ->            ?foreground:color ->
       ?image:image ->            ?state:state ->
       string -> unit
-  method add_command ?underline:(n=0) ?accelerator ?activebackground
+  method add_command ?(underline=0) ?accelerator ?activebackground
       ?activeforeground ?background ?bitmap ?command ?font ?foreground
       ?image ?state label =
-    Menu.add_command (self#menu) ~label ~underline:n ?accelerator
+    Menu.add_command menu ~label ~underline ?accelerator
       ?activebackground ?activeforeground ?background ?bitmap
       ?command ?font ?foreground ?image ?state
 end
+
+let menubar tl =
+  let menu = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+  Toplevel.configure tl ~menu;
+  menu
diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 2bc122fe92..8866f8d0e6 100644
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -67,7 +67,7 @@ let _ =
 
   let path = ref [] in
   let st = ref true in
-  let spec =
+  (*let spec =
     [ "-I", Arg.String (fun s -> path := s :: !path),
       "<dir>  Add <dir> to the list of include directories";
       "-labels", Arg.Clear Clflags.classic, " <obsolete>";
@@ -100,7 +100,7 @@ let _ =
   if not (check ~spec Sys.argv) then fatal_error (usage ~spec errmsg);
   Arg.parse spec
     (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
-    errmsg;
+    errmsg;*)
   Config.load_path :=
     Sys.getcwd ()
     :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
@@ -135,5 +135,6 @@ let _ =
     try
       if is_win32 then mainLoop ()
       else Printexc.print mainLoop ()
-    with Protocol.TkError _ -> ()
+    with Protocol.TkError _ ->
+      if not is_win32 then flush stderr
   done
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 1464a44437..1f07888a01 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -816,7 +816,7 @@ and search_pos_expr ~pos exp =
       search_pos_expr exp ~pos
   | Texp_object (cls, _, _) ->
       	search_pos_class_structure ~pos cls
-  | Texp_generic _ | Texp_typedecl _ | Texp_rtype _ -> (* FIXME *) assert false
+  | Texp_generic _ | Texp_typedecl _ | Texp_rtype _ | Texp_regexp _ -> (* FIXME *) assert false
   end;
   add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc
   end
diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 18e1f34945..ec0a61868c 100644
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -279,13 +279,11 @@ let f ~prog ~title =
         if res = "" then may_exec (Filename.concat dir prog) else res) in
   if progpath = "" then program_not_found prog else
   let tl = Jg_toplevel.titled title in
-  let menus = Frame.create tl ~name:"menubar" in
+  let menus = Menu.create tl ~name:"menubar" ~typ:`Menubar in
+  Toplevel.configure tl ~menu:menus;
   let file_menu = new Jg_menu.c "File" ~parent:menus
   and history_menu = new Jg_menu.c "History" ~parent:menus
   and signal_menu = new Jg_menu.c "Signal" ~parent:menus in
-  pack [menus] ~side:`Top ~fill:`X;
-  pack [file_menu#button; history_menu#button; signal_menu#button]
-    ~side:`Left ~ipadx:5 ~anchor:`W;
   let frame, tw, sb = Jg_text.create_with_scrollbar tl in
   Text.configure tw ~background:`White;
   pack [sb] ~fill:`Y ~side:`Right;
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index 17c3ba584a..41353d8c19 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -316,19 +316,19 @@ let show_help () =
 (* Launch the classical viewer *)
 
 let f ?(dir=Unix.getcwd()) ?on () =
-  let tl = match on with
+  let (top, tl) = match on with
     None ->
       let tl = Jg_toplevel.titled "Module viewer" in
-      ignore (Jg_bind.escape_destroy tl); coe tl
+      ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
   | Some top ->
       Wm.title_set top "OCamlBrowser";
       Wm.iconname_set top "OCamlBrowser";
       let tl = Frame.create top in
       bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
       pack [tl] ~expand:true ~fill:`Both;
-      coe tl
+      (top, coe tl)
   in
-  let menus = Frame.create tl ~name:"menubar" in
+  let menus = Jg_menu.menubar top in
   let filemenu = new Jg_menu.c "File" ~parent:menus
   and modmenu = new Jg_menu.c "Modules" ~parent:menus in
   let fmbox, mbox, msb = Jg_box.create_with_scrollbar tl in
@@ -366,8 +366,6 @@ let f ?(dir=Unix.getcwd()) ?on () =
     ~command:(fun () -> reset_modules mbox; Env.reset_cache ());
   modmenu#add_command "Search symbol..." ~command:search_symbol;
 
-  pack [filemenu#button; modmenu#button] ~side:`Left ~ipadx:5 ~anchor:`W;
-  pack [menus] ~side:`Top ~fill:`X;      
   pack [close; search] ~fill:`X ~side:`Right ~expand:true;
   pack [coe buttons; coe ew] ~fill:`X ~side:`Bottom;
   pack [msb] ~side:`Right ~fill:`Y;
@@ -378,19 +376,20 @@ let f ?(dir=Unix.getcwd()) ?on () =
 (* Smalltalk-like version *)
 
 class st_viewer ?(dir=Unix.getcwd()) ?on () =
-  let tl = match on with
+  let (top, tl) = match on with
     None ->
       let tl = Jg_toplevel.titled "Module viewer" in
-      ignore (Jg_bind.escape_destroy tl); coe tl
+      ignore (Jg_bind.escape_destroy tl); (tl, coe tl)
   | Some top ->
       Wm.title_set top "OCamlBrowser";
       Wm.iconname_set top "OCamlBrowser";
       let tl = Frame.create top in
       bind tl ~events:[`Destroy] ~action:(fun _ -> exit 0);
-      pack [tl] ~expand:true ~fill:`Both;
-      coe tl
+      pack [tl] ~side:`Bottom ~expand:true ~fill:`Both;
+      (top, coe tl)
   in
-  let menus = Frame.create tl ~name:"menubar" in
+  let menus = Menu.create top ~name:"menubar" ~typ:`Menubar in
+  let () = Toplevel.configure top ~menu:menus in
   let filemenu = new Jg_menu.c "File" ~parent:menus
   and modmenu = new Jg_menu.c "Modules" ~parent:menus
   and viewmenu = new Jg_menu.c "View" ~parent:menus
@@ -490,10 +489,6 @@ object (self)
     (* Help menu *)
     helpmenu#add_command "Manual..." ~command:show_help;
 
-    pack [filemenu#button; viewmenu#button; modmenu#button]
-      ~side:`Left ~ipadx:5 ~anchor:`W;
-    pack [helpmenu#button] ~side:`Right ~anchor:`E ~ipadx:5;
-    pack [menus] ~fill:`X;      
     pack [search_frame] ~fill:`X;      
     pack [boxes_frame] ~fill:`Both ~expand:true;
     pack [buttons] ~fill:`X ~side:`Bottom;
diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml
index b7bd163f37..927c24851e 100644
--- a/otherlibs/labltk/examples_camltk/fileopen.ml
+++ b/otherlibs/labltk/examples_camltk/fileopen.ml
@@ -25,7 +25,7 @@ let b =
   Button.create cvs
     [Text "Save";
      Command
-       (function _ -> 
+       (function _ ->
          let s =
            getSaveFile
              [Title "SAVE FILE TEST";
@@ -33,7 +33,7 @@ let b =
               FileTypes [ { typename= "just test";
                             extensions= [".foo"; ".test"];
                             mactypes= ["FOOO"; "BARR"] } ];
-              InitialDir "/tmp";
+              InitialDir Filename.temp_dir_name;
               InitialFile "hogehoge" ] in
          Label.configure t [Text s])];;
 
diff --git a/otherlibs/labltk/tkanim/tkanim.ml b/otherlibs/labltk/tkanim/tkanim.ml
index cc859e1cfd..d4d693f670 100644
--- a/otherlibs/labltk/tkanim/tkanim.ml
+++ b/otherlibs/labltk/tkanim/tkanim.ml
@@ -65,7 +65,7 @@ let cTKtoCAMLanimatedGif s =
 
 (* check Tkanim package is in the interpreter *)
 let available () =
-  let packages = 
+  let packages =
     splitlist (Protocol.tkEval [| TkToken "package";
                                   TkToken "names" |])
   in
@@ -96,22 +96,22 @@ let image_existence_check img =
   (* But just do some operation. And sometimes it causes Seg-fault.     *)
   (* So, before using Imagephoto.copy, I should check the source image  *)
   (* really exists. *)
-  try ignore (Imagephoto.height img) with 
+  try ignore (Imagephoto.height img) with
     TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
 
 let imagephoto_copy dst src opts =
   image_existence_check src;
   Imagephoto.copy dst src opts
 
-let animate_gen w i anim = 
+let animate_gen w i anim =
   let length = List.length anim.frames in
   let frames = Array.of_list anim.frames in
   let current = ref 0 in
   let loop = ref anim.loop in
   let f = frames.(!current) in
-    imagephoto_copy i f.imagephoto 
-      [ImgTo (f.left, f.top, f.left + f.frameWidth, 
-                             f.top + f.frameHeight)]; 
+    imagephoto_copy i f.imagephoto
+      [ImgTo (f.left, f.top, f.left + f.frameWidth,
+                             f.top + f.frameHeight)];
   let visible = ref true in
   let animated = ref false in
   let timer = ref None in
@@ -208,9 +208,9 @@ let animate_canvas_item canvas tag anim =
     animate_gen canvas i anim
 
 let gifdata s =
-  let tmp_dir = ref "/tmp" in
+  let tmp_dir = ref Filename.temp_dir_name in
   let mktemp =
-    let cnter = ref 0 
+    let cnter = ref 0
     and pid = Unix.getpid() in
       (function prefx ->
                incr cnter;
@@ -227,4 +227,4 @@ let gifdata s =
           anim
       with
         e -> begin Unix.unlink fname; raise e end
-      
+