New Upstream Release - labltk

Ready changes

Summary

Merged new upstream version: 8.06.13 (was: 8.06.11).

Resulting package

Built on 2022-12-18T07:25 (took 4m9s)

The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:

apt install -t fresh-releases labltkapt install -t fresh-releases liblabltk-ocaml-dbgsymapt install -t fresh-releases liblabltk-ocaml-devapt install -t fresh-releases liblabltk-ocaml

Lintian Result

Diff

diff --git a/Changes b/Changes
index 45ba7c8..e2e1494 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,20 @@
+2022-11-01:
+-----------
+* Release labltk-8.06.13 for OCaml 5.0
+
+2022-10-13:
+-----------
+* Fix compatibility with OCaml 5.0
+
+2022-10-06:
+-----------
+* Update OCamlBrowser for OCaml 5.0
+
+2022-03-30:
+-----------
+* Release labltk-8.06.12 for OCaml 4.14
+* Update OCamlBrowser
+
 2021-09-17:
 -----------
 * Release labltk-8.06.11 for ocaml 4.13
diff --git a/INSTALL b/INSTALL
index 6f68868..47e383c 100644
--- a/INSTALL
+++ b/INSTALL
@@ -3,7 +3,7 @@
 
 PREREQUISITES
 
-* OCaml (>= 4.08) should be installed  (4.13 for ocamlbrowser)
+* OCaml (>= 4.08) should be installed  (5.0 for ocamlbrowser)
 
 * Tcl/Tk (>= 8.03) should be installed
 
diff --git a/browser/Makefile.shared b/browser/Makefile.shared
index 2cea45f..004b256 100644
--- a/browser/Makefile.shared
+++ b/browser/Makefile.shared
@@ -14,8 +14,8 @@ include ../support/Makefile.common
 #                                                                       #
 #########################################################################
 
-LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs
-INCLUDES=$(LABLTKLIB)
+LABLTKLIB=-I ../labltk -I ../lib -I ../support -I +compiler-libs -I +str -I +unix
+INCLUDES=$(LABLTKLIB) -I +unix -I +str
 
 OBJ =	list2.cmo	useunix.cmo	setpath.cmo	lexical.cmo	\
 	fileselect.cmo	searchid.cmo	searchpos.cmo	\
diff --git a/browser/main.ml b/browser/main.ml
index aca631c..e8e830a 100644
--- a/browser/main.ml
+++ b/browser/main.ml
@@ -83,8 +83,6 @@ let _ =
       "<command>  Pipe sources through preprocessor <command>";
       "-rectypes", Arg.Set Clflags.recursive_types,
       " Allow arbitrary recursive types";
-      "-safe-string", Arg.Clear Clflags.unsafe_string,
-      " Make strings immutable";
       "-short-paths", Arg.Clear Clflags.real_paths, " Shorten paths in types";
       "-version", Arg.Unit print_version,
         " Print version and exit";
@@ -96,7 +94,7 @@ let _ =
   Arg.parse spec
     (fun name -> raise(Arg.Bad("don't know what to do with " ^ name)))
     errmsg;
-  Load_path.init
+  Load_path.init ~auto_include:Load_path.no_auto_include
     (Sys.getcwd ()
      :: List.rev_map ~f:(Misc.expand_directory Config.standard_library) !path
      @ [Config.standard_library]);
diff --git a/browser/searchid.ml b/browser/searchid.ml
index e87852b..ebbf363 100644
--- a/browser/searchid.ml
+++ b/browser/searchid.ml
@@ -95,27 +95,25 @@ let rec arr p ~card:n =
   if p = 0 then 1 else n * arr (p-1) ~card:(n-1)
 
 let rec all_args ty =
-  let ty = repr ty in
-  match ty.desc with
+  match get_desc ty with
     Tarrow(l, ty1, ty2, _) -> let (tl,ty) = all_args ty2 in ((l,ty1)::tl, ty)
   | _ -> ([], ty)
 
 let rec equal ~prefix t1 t2 =
-  match (repr t1).desc, (repr t2).desc with
+  match get_desc t1, get_desc t2 with
     Tvar _, Tvar _ -> true
   | Tvariant row1, Tvariant row2 ->
-      let row1 = row_repr row1 and row2 = row_repr row2 in
-      let fields1 = filter_row_fields false row1.row_fields
-      and fields2 = filter_row_fields false row1.row_fields
+      let fields1 = filter_row_fields false (row_fields row1)
+      and fields2 = filter_row_fields false (row_fields row1)
       in
       let r1, r2, pairs = merge_row_fields fields1 fields2 in
-      row1.row_closed = row2.row_closed && r1 = [] && r2 = [] &&
+      row_closed row1 = row_closed row2 && r1 = [] && r2 = [] &&
       List.for_all pairs ~f:
            begin fun (_,f1,f2) ->
              match row_field_repr f1, row_field_repr f2 with
                Rpresent None, Rpresent None -> true
              | Rpresent(Some t1), Rpresent (Some t2) -> equal t1 t2 ~prefix
-             | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+             | Reither(c1, tl1, _), Reither(c2, tl2, _) ->
                  c1 = c2 && List.length tl1 = List.length tl2 &&
                  List.for_all2 tl1 tl2 ~f:(equal ~prefix)
              | _ -> false
@@ -143,12 +141,11 @@ let rec equal ~prefix t1 t2 =
 let get_options = List.filter ~f:Btype.is_optional
 
 let rec included ~prefix t1 t2 =
-  match (repr t1).desc, (repr t2).desc with
+  match get_desc t1, get_desc t2 with
     Tvar _, _ -> true
   | Tvariant row1, Tvariant row2 ->
-      let row1 = row_repr row1 and row2 = row_repr row2 in
-      let fields1 = filter_row_fields false row1.row_fields
-      and fields2 = filter_row_fields false row2.row_fields
+      let fields1 = filter_row_fields false (row_fields row1)
+      and fields2 = filter_row_fields false (row_fields row2)
       in
       let r1, r2, pairs = merge_row_fields fields1 fields2 in
       r1 = [] &&
@@ -157,7 +154,7 @@ let rec included ~prefix t1 t2 =
              match row_field_repr f1, row_field_repr f2 with
                Rpresent None, Rpresent None -> true
              | Rpresent(Some t1), Rpresent (Some t2) -> included t1 t2 ~prefix
-             | Reither(c1, tl1, _, _), Reither(c2, tl2, _, _) ->
+             | Reither(c1, tl1, _), Reither(c2, tl2, _) ->
                  c1 = c2 && List.length tl1 = List.length tl2 &&
                  List.for_all2 tl1 tl2 ~f:(included ~prefix)
              | _ -> false
@@ -207,7 +204,7 @@ let mkpath = function
 let get_fields ~prefix ~sign self =
   (*let env = open_signature Fresh (mkpath prefix) sign !start_env in*)
   let env = add_signature sign !start_env in
-  match (expand_head env self).desc with
+  match get_desc (expand_head env self) with
     Tobject (ty_obj, _) ->
       let l,_ = flatten_fields ty_obj in l
   | _ -> []
@@ -270,12 +267,12 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
   end
 
 let search_all_types t ~mode =
-  let tl = match mode, t.desc with
+  let tl = match mode, get_desc t with
       `Exact, _ -> [t]
     | `Included, Tarrow _ -> [t]
     | `Included, _ ->
-      [t; newty(Tarrow(Nolabel,t,newvar(),Cok));
-          newty(Tarrow(Nolabel,newvar(),t,Cok))]
+      [t; newty(Tarrow(Nolabel,t,newvar(),commu_ok));
+          newty(Tarrow(Nolabel,newvar(),t,commu_ok))]
   in List2.flat_map !module_list ~f:
     begin fun modname ->
     let mlid = Lident modname in
diff --git a/browser/searchpos.ml b/browser/searchpos.ml
index 564e164..2755cdc 100644
--- a/browser/searchpos.ml
+++ b/browser/searchpos.ml
@@ -195,7 +195,7 @@ let search_pos_type_decl td ~pos ~env =
 
 let search_pos_extension ext ~pos ~env =
   begin match ext.pext_kind with
-    Pext_decl (l, _) -> search_pos_arguments l ~pos ~env
+    Pext_decl (_, l, _) -> search_pos_arguments l ~pos ~env
   | Pext_rebind _ -> ()
   end
   
@@ -502,16 +502,18 @@ and view_module_id id ~env =
 and view_type_decl path ~env =
   let td = find_type path env in
   try match td.type_manifest with None -> raise Not_found
-    | Some ty -> match (Ctype.repr ty).desc with
+    | Some ty -> match get_desc ty with
         Tobject _ ->
           let clt = find_cltype path env in
           view_signature_item ~path ~env
             [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first,
                             Exported);
              dummy_item; dummy_item]
-      | Tvariant ({row_name = Some _} as row) ->
-          let td = {td with type_manifest = Some(
-                    Btype.newgenty (Tvariant {row with row_name = None}))} in
+      | Tvariant row when row_name row <> None ->
+          let Row {fields; more; closed; fixed} = row_repr row in
+          let row = create_row ~fields ~more ~closed ~fixed ~name:None in
+          let td =
+            {td with type_manifest = Some(Btype.newgenty (Tvariant row))} in
           view_signature_item ~path ~env
             [Sig_type(ident_of_path path ~default:"t", td, Trec_first,
                       Exported)]
@@ -697,8 +699,7 @@ let view_type_menu kind ~env ~parent =
       Format.set_formatter_output_functions buf#out ignore;
       Format.set_margin 60;
       Format.open_hbox ();
-      Printtyp.reset ();
-      Printtyp.mark_loops ty;
+      Printtyp.prepare_for_printing [ty];
       Printtyp.wrap_printing_env ~error:false env
         (fun () -> Printtyp.type_expr Format.std_formatter ty);
       Format.close_box (); Format.print_flush ();
@@ -712,11 +713,12 @@ let view_type_menu kind ~env ~parent =
       in
       (* Menu.add_separator menu; *)
       List.iter l ~f:
-        begin fun label -> match (Ctype.repr ty).desc with
+        begin fun label -> match get_desc ty with
           Tconstr (path,_,_) ->
             Menu.add_command menu ~label ~font
               ~command:(fun () -> view_type_decl path ~env)
-        | Tvariant {row_name = Some (path, _)} ->
+        | Tvariant row when row_name row <> None ->
+            let path, _ = Stdlib.Option.get (row_name row) in
             Menu.add_command menu ~label ~font
               ~command:(fun () -> view_type_decl path ~env)
         | _ ->
@@ -864,7 +866,7 @@ and search_pos_expr ~pos exp =
       search_pos_expr a ~pos; search_pos_expr b ~pos
   | Texp_for (_, _, a, b, _, c) ->
       List.iter [a;b;c] ~f:(search_pos_expr ~pos)
-  | Texp_send (exp, _, _) -> search_pos_expr exp ~pos
+  | Texp_send (exp, _) -> search_pos_expr exp ~pos
   | Texp_new (path, _, _) ->
       add_found_str (`Exp(`New path, exp.exp_type))
         ~env:exp.exp_env ~loc:exp.exp_loc
diff --git a/browser/setpath.ml b/browser/setpath.ml
index fad9eea..3278b16 100644
--- a/browser/setpath.ml
+++ b/browser/setpath.ml
@@ -31,7 +31,7 @@ let exec_update_hooks () =
       end
 
 let set_load_path l =
-  Load_path.init l;
+  Load_path.init l ~auto_include:Load_path.no_auto_include;
   exec_update_hooks ();
   Env.reset_cache ()
 
diff --git a/browser/shell.ml b/browser/shell.ml
index c5672a0..c87e651 100644
--- a/browser/shell.ml
+++ b/browser/shell.ml
@@ -45,7 +45,7 @@ let dump_handle (h : Unix.file_descr) =
   let obj = Obj.repr h in
   if Obj.is_int obj || Obj.tag obj <> Obj.custom_tag then
     invalid_arg "Shell.dump_handle";
-  Nativeint.format "%x" (Obj.obj obj)
+  Printf.sprintf "%nx" (Obj.obj obj)
 
 (* The shell class. Now encapsulated *)
 
diff --git a/browser/typecheck.ml b/browser/typecheck.ml
index 99ef48a..e6c4261 100644
--- a/browser/typecheck.ml
+++ b/browser/typecheck.ml
@@ -116,7 +116,7 @@ let f txt =
     List.iter psl ~f:
     begin function
       Ptop_def pstr ->
-        let str, sign, _names, env' = Typemod.type_structure !env pstr in
+        let str, sign, _names, _, env' = Typemod.type_structure !env pstr in
         txt.structure <- txt.structure @ str.str_items;
         txt.signature <- txt.signature @ sign;
         env := env'
diff --git a/browser/viewer.ml b/browser/viewer.ml
index 590da6f..7c96707 100644
--- a/browser/viewer.ml
+++ b/browser/viewer.ml
@@ -65,13 +65,13 @@ let view_symbol ~kind ~env ?path id =
         [Sig_value (Ident.create_local name, vd, Exported)]
   | Ptype -> view_type_id id ~env
   | Plabel -> let ld = find_label_by_name id env in
-      begin match ld.lbl_res.desc with
+      begin match get_desc ld.lbl_res with
         Tconstr (path, _, _) -> view_type_decl path ~env
       | _ -> ()
       end
   | Pconstructor ->
       let cd = find_constructor_by_name id env in
-      begin match cd.cstr_tag, cd.cstr_res.desc with
+      begin match cd.cstr_tag, get_desc cd.cstr_res with
 	Cstr_extension _, Tconstr (cpath, args, _) ->
           view_signature ~title:(string_of_longident id) ~env ?path
             [Sig_typext (Ident.create_local name,
diff --git a/camltk/Makefile b/camltk/Makefile
index ed4b3a0..29e3a81 100644
--- a/camltk/Makefile
+++ b/camltk/Makefile
@@ -16,7 +16,7 @@
 
 include ../support/Makefile.common
 
-COMPFLAGS= -I ../support -no-alias-deps
+COMPFLAGS= -I ../support -no-alias-deps -I +unix
 
 all: camltkobjs
 
diff --git a/debian/changelog b/debian/changelog
index 1f40ede..b913c22 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+labltk (8.06.13-1) UNRELEASED; urgency=low
+
+  * New upstream release.
+
+ -- Debian Janitor <janitor@jelmer.uk>  Sun, 18 Dec 2022 07:22:12 -0000
+
 labltk (8.06.11-2) unstable; urgency=medium
 
   * Fix paths in labltk script (Closes: #1023867)
diff --git a/examples_camltk/Makefile b/examples_camltk/Makefile
index e9c4c6a..3eeee08 100644
--- a/examples_camltk/Makefile
+++ b/examples_camltk/Makefile
@@ -17,8 +17,9 @@
 include ../support/Makefile.common
 
 # We are using the non-installed library !
-BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -dllpath ../support
-BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s
+BYT_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -dllpath ../support \
+	  -I +unix
+BIN_COMPFLAGS=-I ../lib -I ../camltk -I ../support -w s -I +unix
 
 WITH_BYT_CAMLTK=labltk.cma camltk.cmo
 WITH_BIN_CAMLTK=labltk.cmxa camltk.cmx
diff --git a/examples_camltk/taquin.ml b/examples_camltk/taquin.ml
new file mode 100644
index 0000000..70ac934
--- /dev/null
+++ b/examples_camltk/taquin.ml
@@ -0,0 +1,146 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                        Caml examples                                *)
+(*                                                                     *)
+(*            Pierre Weis                                              *)
+(*                                                                     *)
+(*                        INRIA Rocquencourt                           *)
+(*                                                                     *)
+(*  Copyright (c) 1994-2011, INRIA                                     *)
+(*  All rights reserved.                                               *)
+(*                                                                     *)
+(*  Distributed under the BSD license.                                 *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: taquin.ml,v 1.4 2011-08-08 19:31:17 weis Exp $ *)
+
+open Camltk;;
+
+let d�coupe_image img nx ny =
+  let l = Imagephoto.width img
+  and h = Imagephoto.height img in
+  let tx = l / nx and ty = h / ny in
+  let pi�ces = ref [] in
+  for x = 0 to nx - 1 do
+    for y = 0 to ny - 1 do
+      let pi�ce =
+        Imagephoto.create [Width (Pixels tx); Height (Pixels ty)] in
+      Imagephoto.copy pi�ce img
+        [ImgFrom(x * tx, y * ty, (x + 1) * tx, (y + 1) * ty)];
+      pi�ces := pi�ce :: !pi�ces
+    done
+  done;
+  (tx, ty, List.tl !pi�ces)
+;;
+
+let remplir_taquin c nx ny tx ty pi�ces =
+  let trou_x = ref (nx - 1)
+  and trou_y = ref (ny - 1) in
+  let trou =
+    Canvas.create_rectangle c
+      (Pixels (!trou_x * tx)) (Pixels (!trou_y * ty))
+      (Pixels tx) (Pixels ty) [] in
+  let taquin = Array.make_matrix nx ny trou in
+  let p = ref pi�ces in
+  for x = 0 to nx - 1 do
+    for y = 0 to ny - 1 do
+      match !p with
+      | [] -> ()
+      | pi�ce :: reste ->
+          taquin.(x).(y) <-
+            Canvas.create_image c
+              (Pixels (x * tx)) (Pixels (y * ty))
+              [ImagePhoto pi�ce; Anchor NW; Tags [Tag "pi�ce"]];
+          p := reste
+    done
+  done;
+  let d�placer x y =
+    let pi�ce = taquin.(x).(y) in
+    Canvas.coords_set c pi�ce
+      [Pixels (!trou_x * tx); Pixels(!trou_y * ty)];
+    Canvas.coords_set c trou
+      [Pixels (x * tx); Pixels(y * ty); Pixels tx; Pixels ty];
+    taquin.(!trou_x).(!trou_y) <- pi�ce;
+    taquin.(x).(y) <- trou;
+    trou_x := x; trou_y := y in
+  let jouer ei =
+    let x = ei.ev_MouseX / tx and y = ei.ev_MouseY / ty in
+    if x = !trou_x && (y = !trou_y - 1 || y = !trou_y + 1)
+    || y = !trou_y && (x = !trou_x - 1 || x = !trou_x + 1)
+    then d�placer x y in
+  Canvas.bind c (Tag "pi�ce") [[], ButtonPress]
+                (BindSet ([Ev_MouseX; Ev_MouseY], jouer));;
+
+let rec permutation = function
+  | [] -> []
+  | l  -> let n = Random.int (List.length l) in
+          let (�l�ment, reste) = partage l n in
+          �l�ment :: permutation reste
+
+and partage l n =
+  match l with
+  | [] -> failwith "partage"
+  | t�te :: reste ->
+      if n = 0 then (t�te, reste) else
+      let (�l�ment, reste') = partage reste (n - 1) in
+      (�l�ment, t�te :: reste')
+;;
+
+let create_filled_text parent lines =
+  let lnum = List.length lines
+  and lwidth =
+    List.fold_right
+     (fun line max ->
+       let l = String.length line in
+       if l > max then l else max)
+     lines 1 in
+  let txtw = Text.create parent [TextWidth lwidth; TextHeight lnum] in
+  List.iter
+   (fun line ->
+     Text.insert txtw (TextIndex (End, [])) line [];
+     Text.insert txtw (TextIndex (End, [])) "\n" [])
+   lines;
+  txtw
+;;
+
+let give_help parent lines () =
+ let help_window = Toplevel.create parent [] in
+ Wm.title_set help_window "Help";
+
+ let help_frame = Frame.create help_window [] in
+
+ let help_txtw = create_filled_text help_frame lines in
+
+ let quit_help () = destroy help_window in
+ let ok_button = Button.create help_frame [Text "Ok"; Command quit_help] in
+
+ pack [help_txtw; ok_button ] [Side Side_Bottom];
+ pack [help_frame] []
+;;
+
+let taquin nom_fichier nx ny =
+  let fp = openTk () in
+  Wm.title_set fp "Taquin";
+  let img = Imagephoto.create [File nom_fichier] in
+  let c =
+    Canvas.create fp
+     [Width(Pixels(Imagephoto.width img));
+      Height(Pixels(Imagephoto.height img))] in
+  let (tx, ty, pi�ces) = d�coupe_image img nx ny in
+  remplir_taquin c nx ny tx ty (permutation pi�ces);
+  pack [c] [];
+
+  let quit = Button.create fp [Text "Quit"; Command closeTk] in
+  let help_lines =
+   ["Pour jouer, cliquer sur une des pi�ces";
+    "entourant le trou";
+    "";
+    "To play, click on a part around the hole"] in
+  let help =
+    Button.create fp [Text "Help"; Command (give_help fp help_lines)] in
+  pack [quit; help] [Side Side_Left; Fill Fill_X];
+  mainLoop ()
+;;
+
+if !Sys.interactive then () else begin taquin "joconde.gif" 3 5; exit 0 end;;
diff --git a/examples_camltk/tetris.ml b/examples_camltk/tetris.ml
new file mode 100644
index 0000000..a46de60
--- /dev/null
+++ b/examples_camltk/tetris.ml
@@ -0,0 +1,542 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                        Caml examples                                *)
+(*                                                                     *)
+(*            Pierre Weis                                              *)
+(*                                                                     *)
+(*                        INRIA Rocquencourt                           *)
+(*                                                                     *)
+(*  Copyright (c) 1994-2011, INRIA                                     *)
+(*  All rights reserved.                                               *)
+(*                                                                     *)
+(*  Distributed under the BSD license.                                 *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: tetris.ml,v 1.6 2011-08-08 19:31:17 weis Exp $ *)
+
+(* A Tetris game for CamlTk.
+   Written by Jun P. Furuse.
+   Adapted to the oc examples repository by P. Weis *)
+
+open Camltk;;
+
+(* The directory where images will be found. *)
+let baseurl = "images/";;
+
+exception Done;;
+
+type cell = {
+ mutable color : int;
+ tag : tagOrId * tagOrId * tagOrId;
+}
+;;
+
+type falling_block = {
+  mutable pattern : int array list;
+  mutable bcolor : int;
+  mutable x : int;
+  mutable y : int;
+  mutable d : int;
+  mutable alive: bool;
+}
+;;
+
+let stop_a_bit = 300;;
+
+let colors = [|
+  NamedColor "red"; NamedColor "yellow"; NamedColor "blue";
+  NamedColor "orange"; NamedColor "magenta"; NamedColor "green";
+  NamedColor "cyan";
+|]
+;;
+
+let backgrounds =
+  List.map (fun s -> baseurl ^ s)
+    [ "dojoji.back.gif"; "Lambda2.back.gif"; "CamlBook.gif"; ];;
+
+(* blocks *)
+let block_size = 16
+and cell_border = 2
+;;
+
+let blocks = [
+  [ [|"0000"; "0000"; "1111"; "0000" |];
+    [|"0010"; "0010"; "0010"; "0010" |];
+    [|"0000"; "0000"; "1111"; "0000" |];
+    [|"0010"; "0010"; "0010"; "0010" |] ];
+
+  [ [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |];
+    [|"0000"; "0110"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "0111"; "0100"; "0000" |];
+    [|"0000"; "0110"; "0010"; "0010" |];
+    [|"0000"; "0010"; "1110"; "0000" |];
+    [|"0100"; "0100"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "0100"; "0111"; "0000" |];
+    [|"0000"; "0110"; "0100"; "0100" |];
+    [|"0000"; "1110"; "0010"; "0000" |];
+    [|"0010"; "0010"; "0110"; "0000" |] ];
+
+  [ [|"0000"; "1100"; "0110"; "0000" |];
+    [|"0010"; "0110"; "0100"; "0000" |];
+    [|"0000"; "1100"; "0110"; "0000" |];
+    [|"0010"; "0110"; "0100"; "0000" |] ];
+
+  [ [|"0000"; "0011"; "0110"; "0000" |];
+    [|"0100"; "0110"; "0010"; "0000" |];
+    [|"0000"; "0011"; "0110"; "0000" |];
+    [|"0000"; "0100"; "0110"; "0010" |] ];
+
+  [ [|"0000"; "0000"; "1110"; "0100" |];
+    [|"0000"; "0100"; "1100"; "0100" |];
+    [|"0000"; "0100"; "1110"; "0000" |];
+    [|"0000"; "0100"; "0110"; "0100" |] ];
+]
+;;
+
+let line_empty = int_of_string "0b1110000000000111"
+and line_full = int_of_string  "0b1111111111111111"
+;;
+
+let decode_block dvec =
+  let btoi d = int_of_string ("0b" ^ d) in
+  Array.map btoi dvec
+;;
+
+let init fw =
+  let scorev = Textvariable.create ()
+  and linev = Textvariable.create ()
+  and levv = Textvariable.create ()
+  and _namev = Textvariable.create () in
+  let f = Frame.create fw [BorderWidth (Pixels 2)] in
+  let c =
+    Canvas.create f
+     [Width (Pixels (block_size * 10));
+      Height (Pixels (block_size * 20));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black]
+  and r = Frame.create f []
+  and r' = Frame.create f [] in
+
+  let nl = Label.create r [Text "Next"; Font "variable"] in
+  let nc =
+    Canvas.create r
+     [Width (Pixels (block_size * 4));
+      Height (Pixels (block_size * 4));
+      BorderWidth (Pixels cell_border);
+      Relief Sunken;
+      Background Black] in
+  let scl = Label.create r [Text "Score"; Font "variable"] in
+  let sc = Label.create r [TextVariable scorev; Font "variable"] in
+  let lnl = Label.create r [Text "Lines"; Font "variable"] in
+  let ln = Label.create r [TextVariable linev; Font "variable"] in
+  let levl = Label.create r [Text "Level"; Font "variable"] in
+  let lev = Label.create r [TextVariable levv; Font "Variable"] in
+  let newg = Button.create r [Text "New Game"; Font "variable"] in
+  let exitg = Button.create r [Text "Quit"; Font "variable"] in
+
+  pack [f] [];
+  pack [c; r; r'] [Side Side_Left; Fill Fill_Y];
+  pack [nl; nc] [Side Side_Top];
+  pack [scl; sc; lnl; ln; levl; lev; newg; exitg] [Side Side_Top];
+
+  let cells_src = Array.make_matrix 20 10 () in
+  let cells = Array.map (Array.map (fun () ->
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle c
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
+          Canvas.create_rectangle c
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
+          Canvas.create_rectangle c
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top c t1;
+       Canvas.raise_top c t2;
+       Canvas.lower_bot c t3;
+       t1, t2, t3);
+     color = 0})) cells_src in
+  let nexts_src = Array.make_matrix 4 4 () in
+  let nexts =
+   Array.map (Array.map (fun () ->
+    {tag =
+      (let t1, t2, t3 =
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 8)) (Pixels (-block_size - 8))
+           (Pixels (-9)) (Pixels (-9)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 10)) (Pixels (-block_size - 10))
+           (Pixels (-11)) (Pixels (-11)) [],
+         Canvas.create_rectangle nc
+           (Pixels (-block_size - 12)) (Pixels (-block_size - 12))
+           (Pixels (-13)) (Pixels (-13)) [] in
+       Canvas.raise_top nc t1;
+       Canvas.raise_top nc t2;
+       Canvas.lower_bot nc t3;
+       t1, t2, t3);
+     color = 0})) nexts_src in
+  let game_over () = ()
+  in
+  [f; c; r; nl; nc; scl; sc; levl; lev; lnl; ln], newg, exitg,
+  (c, cells), (nc, nexts), scorev, linev, levv, game_over
+;;
+
+let cell_get (c, cf) x y = cf.(y).(x).color;;
+
+let cell_set (c, cf) x y col =
+  let cur = cf.(y).(x) in
+  let t1, t2, t3 = cur.tag in
+  if cur.color = col then () else
+  if cur.color <> 0 && col = 0 then begin
+    Canvas.move c t1
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t2
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2));
+    Canvas.move c t3
+      (Pixels (- block_size * (x + 1) -10 - cell_border * 2))
+      (Pixels (- block_size * (y + 1) -10 - cell_border * 2))
+
+  end else begin
+    Canvas.configure_rectangle c t2
+      [FillColor (Array.get colors (col - 1));
+       Outline (Array.get colors (col - 1))];
+    Canvas.configure_rectangle c t1
+      [FillColor Black;
+       Outline Black];
+    Canvas.configure_rectangle c t3
+      [FillColor (NamedColor "light gray");
+       Outline (NamedColor "light gray")];
+    if cur.color = 0 && col <> 0 then begin
+      Canvas.move c t1
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
+      Canvas.move c t2
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2));
+      Canvas.move c t3
+        (Pixels (block_size * (x + 1) + 10 + cell_border * 2))
+        (Pixels (block_size * (y + 1) + 10 + cell_border * 2))
+    end
+  end;
+  cur.color <- col
+;;
+
+let draw_block field col d x y =
+  for iy = 0 to 3 do
+    let base = ref 1 in
+    let xd = Array.get d iy in
+    for ix = 0 to 3 do
+      if xd land !base <> 0 then begin
+        try cell_set field (ix + x) (iy + y) col with _ -> ()
+      end;
+      base := !base lsl 1
+    done
+  done
+;;
+
+let timer_ref = (ref None : Timer.t option ref);;
+
+let remove_timer () =
+  match !timer_ref with
+  | None -> ()
+  | Some t -> Timer.remove t
+;;
+
+let do_after milli f = timer_ref := Some (Timer.add milli f);;
+
+let copy_block c =
+  { pattern = !c.pattern;
+    bcolor = !c.bcolor;
+    x = !c.x;
+    y = !c.y;
+    d = !c.d;
+    alive = !c.alive }
+;;
+
+let start_game () =
+  let top = openTk () in
+  Wm.title_set top "";
+  let lb = Label.create top []
+  and fw = Frame.create top [] in
+  let set_message s = Label.configure lb [Text s] in
+  pack [lb; fw] [Side Side_Top];
+  let score = ref 0 in
+  let line = ref 0 in
+  let level = ref 0 in
+  let time = ref 1000 in
+  let blocks = List.map (List.map decode_block) blocks in
+  let field = Array.make 26 0 in
+  let widgets, newg, exitg, cell_field, next_field,
+      scorev, linev, levv, game_over = init fw in
+  let canvas = fst cell_field in
+
+  let init_field () =
+    for i = 0 to 25 do
+      field.(i) <- line_empty
+    done;
+    field.(23) <- line_full;
+    for i = 0 to 19 do
+      for j = 0 to 9 do
+        cell_set cell_field j i 0
+      done
+    done;
+    for i = 0 to 3 do
+      for j = 0 to 3 do
+        cell_set next_field j i 0
+      done
+    done in
+
+  let draw_falling_block fb =
+    draw_block cell_field fb.bcolor
+      (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3)
+  and erase_falling_block fb =
+    draw_block cell_field 0 (List.nth fb.pattern fb.d) (fb.x - 3) (fb.y - 3) in
+
+  let stone fb =
+    for i = 0 to 3 do
+      let cur = field.(i + fb.y) in
+      field.(i + fb.y) <-
+         cur lor ((List.nth fb.pattern fb.d).(i) lsl fb.x)
+    done;
+    for i = 0 to 2 do field.(i) <- line_empty done
+
+  and clear fb =
+    let l = ref 0 in
+    for i = 0 to 3 do
+      if i + fb.y >= 3 && i + fb.y <= 22 &&
+         field.(i + fb.y) = line_full then begin
+        incr l;
+        field.(i + fb.y) <- line_empty;
+        for j = 0 to 9 do cell_set cell_field j (i + fb.y - 3) 0 done
+      end
+    done;
+    !l
+
+  and fall_lines () =
+    let eye = ref 22 (* bottom *)
+    and cur = ref 22 (* bottom *) in
+    try
+      while !eye >= 3 do
+        while field.(!eye) = line_empty do
+          decr eye;
+          if !eye = 2 then raise Done
+        done;
+        field.(!cur) <- field.(!eye);
+        for j = 0 to 9 do
+          cell_set cell_field j (!cur-3) (cell_get cell_field j (!eye-3))
+        done;
+        decr eye;
+        decr cur
+      done
+    with Done -> ();
+      for i = 3 to !cur do
+        field.(i) <- line_empty;
+        for j = 0 to 9 do cell_set cell_field j (i - 3) 0 done
+      done in
+
+  let next = ref 42 (* THE ANSWER *)
+  and current =
+    ref { pattern= [[|0; 0; 0; 0|]];
+          bcolor = 0; x = 0; y = 0; d = 0; alive = false} in
+
+  let draw_next () =
+    draw_block next_field (!next + 1) (List.hd (List.nth blocks !next)) 0 0
+
+  and erase_next () =
+    draw_block next_field 0 (List.hd (List.nth blocks !next)) 0 0 in
+
+  let set_nextblock () =
+    current :=
+       { pattern = (List.nth blocks !next);
+         bcolor = !next + 1;
+         x = 6; y = 1; d = 0; alive = true};
+    erase_next ();
+    next := Random.int 7;
+    draw_next () in
+
+  let death_check fb =
+    try
+      for i=0 to 3 do
+        let cur = field.(i + fb.y) in
+        if cur land ((List.nth fb.pattern fb.d).(i) lsl fb.x) <> 0
+        then raise Done
+      done;
+      false
+    with
+      Done -> true in
+
+  let try_to_move m =
+    if !current.alive then
+      let sub m =
+        if death_check m then false
+        else
+          begin
+            erase_falling_block !current;
+            draw_falling_block m;
+            current := m;
+            true
+          end in
+      if sub m then () else begin
+        m.x <- m.x + 1;
+        if sub m then () else begin
+          m.x <- m.x - 2;
+          ignore (sub m)
+        end
+      end
+    else () in
+
+  let image_load =
+    let i =
+      Canvas.create_image canvas
+        (Pixels (block_size * 5 + block_size / 2))
+        (Pixels (block_size * 10 + block_size / 2))
+        [Anchor Center] in
+    Canvas.lower_bot canvas i;
+    let img = Imagephoto.create [] in
+    fun file ->
+      try
+        Imagephoto.configure img [File file];
+        Canvas.configure_image canvas i [ImagePhoto img]
+      with _ -> Printf.eprintf "%s : No such image...\n" file; flush stderr in
+
+  let add_score l =
+    let pline = !line in
+    if l <> 0 then
+      begin
+        line := !line + l;
+        score := !score + l * l;
+        set_message (Printf.sprintf "%d pts" (1 lsl ((l - 1) * 2)))
+      end;
+    Textvariable.set linev (string_of_int !line);
+    Textvariable.set scorev (string_of_int !score);
+
+    if !line / 10 <> pline / 10 then
+      (* update the background every 10 lines. *)
+      begin
+        let num_image = List.length backgrounds - 1 in
+        let n = !line / 10 in
+        let n = if n > num_image then num_image else n in
+        let file = List.nth backgrounds n in
+        image_load file;
+        (* Future work: We should gain level after an image is put... *)
+        incr level;
+        Textvariable.set levv (string_of_int !level)
+      end in
+
+  let rec newblock () =
+    set_message "TETRIS";
+    set_nextblock ();
+    draw_falling_block !current;
+    if death_check !current then begin
+        !current.alive <- false;
+        set_message "GAME OVER";
+        game_over ()
+    end else begin
+      time := 1100 - (!level / 4 * 300) - ((!level mod 4) * 200);
+      if !time < 60 - !level * 3 then time := 60 - !level * 3;
+      do_after stop_a_bit loop
+    end
+
+  and loop () =
+    let m = copy_block current in
+    m.y <- m.y + 1;
+    if death_check m then begin
+      !current.alive <- false;
+      stone !current;
+      do_after stop_a_bit (fun () ->
+        let l = clear !current in
+        if l > 0 then
+          do_after stop_a_bit (fun () ->
+            fall_lines ();
+            add_score l;
+            do_after stop_a_bit newblock)
+        else newblock ())
+    end else begin
+      erase_falling_block !current;
+      draw_falling_block m;
+      current := m;
+      do_after !time loop
+    end in
+
+  let bind_game w =
+    bind w [([], KeyPress)] (BindSet ([Ev_KeySymString],
+      fun e ->
+        match e.ev_KeySymString with
+        | "h" ->
+            let m = copy_block current in
+            m.x <- m.x - 1;
+            try_to_move m
+        | "j" ->
+            let m = copy_block current in
+            m.d <- m.d + 1;
+            if m.d = List.length m.pattern then m.d <- 0;
+            try_to_move m
+        | "k" ->
+            let m = copy_block current in
+            m.d <- m.d - 1;
+            if m.d < 0 then m.d <- List.length m.pattern - 1;
+            try_to_move m
+        | "l" ->
+            let m = copy_block current in
+            m.x <- m.x + 1;
+            try_to_move m
+        | "m" ->
+            remove_timer ();
+            loop ()
+        | "space" ->
+            if !current.alive then
+              begin
+                let m = copy_block current
+                and n = copy_block current in
+                while
+                  m.y <- m.y + 1;
+                  if death_check m then false
+                  else begin n.y <- m.y; true end
+                do () done;
+                erase_falling_block !current;
+                draw_falling_block n;
+                current := n;
+                remove_timer ();
+                loop ()
+              end
+        | _ -> ()
+      )) in
+
+  let game_init () =
+    (* Game Initialization *)
+    set_message "Initializing ...";
+    remove_timer ();
+    image_load (List.hd backgrounds);
+    time := 1000;
+    score := 0;
+    line := 0;
+    level := 1;
+    add_score 0;
+    init_field ();
+    next := Random.int 7;
+    set_message "Welcome to TETRIS";
+    set_nextblock ();
+    draw_falling_block !current;
+    do_after !time loop in
+
+  bind_game top;
+  Button.configure newg [Command game_init];
+  Button.configure exitg [Command (fun () -> exit 0)];
+  game_init ()
+;;
+
+let tetris () =
+ start_game ();
+ Printexc.print mainLoop ()
+;;
+
+if !Sys.interactive then () else begin tetris (); exit 0 end;;
diff --git a/examples_labltk/Makefile b/examples_labltk/Makefile
index 798d363..b363c4a 100644
--- a/examples_labltk/Makefile
+++ b/examples_labltk/Makefile
@@ -35,11 +35,12 @@ calc: calc.cmo
 	$(CAMLC) $(COMPFLAGS) -o calc $(LIBNAME).cma calc.cmo
 
 clock: clock.cmo
-	$(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma unix.cma clock.cmo
+	$(CAMLC) $(COMPFLAGS) -o clock $(LIBNAME).cma \
+	  -I +unix unix.cma clock.cmo
 
 clock.opt: clock.cmx
 	$(CAMLOPT) $(COMPFLAGS) -o clock.opt \
-	      $(LIBNAME).cmxa unix.cmxa clock.cmx
+	      $(LIBNAME).cmxa -I +unix unix.cmxa clock.cmx
 
 tetris: tetris.cmo
 	$(CAMLC) $(COMPFLAGS) -o tetris $(LIBNAME).cma tetris.cmo
diff --git a/jpf/Makefile b/jpf/Makefile
index 4ba354d..dccf9db 100644
--- a/jpf/Makefile
+++ b/jpf/Makefile
@@ -16,7 +16,7 @@
 
 include ../support/Makefile.common
 
-COMPFLAGS=-I ../labltk -I ../support
+COMPFLAGS=-I ../labltk -I ../support -I +str -I +unix
 
 OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo
 
diff --git a/labltk/Makefile b/labltk/Makefile
index 8fb58db..1d22c0a 100644
--- a/labltk/Makefile
+++ b/labltk/Makefile
@@ -16,7 +16,7 @@
 
 include ../support/Makefile.common
 
-COMPFLAGS= -I ../support -no-alias-deps
+COMPFLAGS= -I ../support -no-alias-deps -I +unix
 
 all: labltkobjs
 
diff --git a/lib/Makefile b/lib/Makefile
index db46b7f..d4a1f65 100644
--- a/lib/Makefile
+++ b/lib/Makefile
@@ -67,9 +67,8 @@ $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src
 $(LIBNAME)top$(EXE) : $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
 	$(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \
 	       $(TOPLEVELLIBS) \
-	       -I +compiler-libs unix.cma \
+	       -I +compiler-libs -I +unix -I +str unix.cma str.cma \
 	       -I ../labltk -I ../camltk $(LIBNAME).cma \
-	       str.cma \
 	       $(TOPLEVELSTART)
 
 $(LIBNAME): Makefile
@@ -114,4 +113,4 @@ installopt:
 	cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A)
 	chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa
 	chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A)
-endif
\ No newline at end of file
+endif
diff --git a/support/Makefile b/support/Makefile
index 75ccdc1..5915418 100644
--- a/support/Makefile
+++ b/support/Makefile
@@ -30,7 +30,7 @@ COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \
 
 CCFLAGS=-I$(LIBDIR)/caml $(TK_DEFS) $(SHAREDCCCOMPOPTS)
 
-COMPFLAGS=
+COMPFLAGS=-I +unix
 THFLAGS=-I +threads -I vmthreads
 TKLDOPTS=$(TK_LINK:%=-ldopt "%")
 
diff --git a/support/Makefile.common b/support/Makefile.common
index 7aac0a2..f3b818d 100644
--- a/support/Makefile.common
+++ b/support/Makefile.common
@@ -35,3 +35,6 @@ LINKFLAGS=
 CAMLOPTLIBR=$(CAMLOPT) -a
 MKLIB=$(BINDIR)/ocamlmklib
 CAMLRUNGEN=$(BINDIR)/ocamlrun
+ifeq (x$(RANLIB),x)
+RANLIB=":"
+endif

More details

Full run details