Remove naked pointers and Obj.truncate for compatibility with 5.00 [l…

…ablgtk2] (#145)

* wrap lookup_info when returning it to ocaml, to please GC in 5.00
* remove Gpointer.raw_null/optstring
* allow warning 6
* use caml_sys_modify_argv in place of Object.truncate

Co-authored-by: Takafumi Saikawa <[email protected]>

CHANGES

@@ -1,5 +1,8 @@
 LablGTK changes log
 
+2021.12.24[Jacques]
+  * Remove naked pointers and Obj.truncate for compatibility with 5.00 (#145)
+
 2021.12.18 [Jacques]
   * Add WRAP_WIDTH, WRAP_MODE tags to cell_properties_text (#146)
    [Nathan Guermond]

src/Makefile

@@ -44,7 +44,7 @@ GTKCFLAGS += -Iabsvalue -DABSVALUE
 endif
 
 ifdef DEBUG
-COMPILER += -warn-error A-52
+COMPILER += -warn-error A-52-6
 CFLAGS = -g $(GTKCFLAGS)
 CUSTOM = -custom
 #MLLINK += -cclib -lcamlrund

src/check_externals.ml

@@ -116,8 +116,7 @@ let rec token (strm__ : _ Stream.t) =
           Stream.Failure -> raise (Stream.Error "")
       in
       String s
-  | Some (' ' | '\n' | '\r' | '\t') ->
-      Stream.junk strm__; let s = strm__ in token s
+  | Some (' ' | '\n' | '\r' | '\t') -> Stream.junk strm__; token strm__
   | Some c -> Stream.junk strm__; Sym c
   | _ -> raise End_of_file
 and may_comment (strm__ : _ Stream.t) =
@@ -166,15 +165,15 @@ let rec skip_type (strm__ : _ Stream.t) =
         try skip (Sym ')') strm__ with
           Stream.Failure -> raise (Stream.Error "")
       in
-      let s = strm__ in skip_type s
+      skip_type strm__
   | Some (Sym '[') ->
       Stream.junk strm__;
       let _ =
         try skip (Sym ']') strm__ with
           Stream.Failure -> raise (Stream.Error "")
       in
-      let s = strm__ in skip_type s
-  | Some _ -> Stream.junk strm__; let s = strm__ in skip_type s
+      skip_type strm__
+  | Some _ -> Stream.junk strm__; skip_type strm__
   | _ -> raise Stream.Failure
 
 let check_external (strm__ : _ Stream.t) =

src/gpointer.ml

@@ -32,16 +32,6 @@ let optaddr : 'a option -> 'a optaddr =
       None -> Obj.magic 0
     | Some x -> Obj.magic x
 
-(* naked pointers *)
-type optstring
-
-let raw_null = snd (Obj.magic Nativeint.zero)
-
-let optstring : string option -> optstring =
-  function
-      None -> raw_null
-    | Some x -> Obj.magic x
-
 (* boxed pointers *)
 type boxed
 let boxed_null : boxed = Obj.magic Nativeint.zero

src/gpointer.mli

@@ -28,11 +28,6 @@
 type 'a optaddr
 val optaddr : 'a option -> 'a optaddr
 
-(** Naked pointers *)
-type optstring
-val raw_null : optstring
-val optstring : string option -> optstring
-
 (** Boxed pointers *)
 type boxed
 val boxed_null : boxed

src/gtkList.ml

@@ -180,15 +180,15 @@ module CList = struct
   external set_shift :
       [>`clist] obj -> int -> int -> vertical:int -> horizontal:int -> unit
       = "ml_gtk_clist_set_shift"
-  external insert : [>`clist] obj -> row:int -> Gpointer.optstring array -> int
+  external insert : [>`clist] obj -> row:int -> string option array -> int
       = "ml_gtk_clist_insert"
   let insert w ~row texts =
     let len = get_columns w in
     if List.length texts > len then invalid_arg "CList.insert";
     let arr = Array.make (get_columns w) None in
     List.fold_left texts ~init:0
       ~f:(fun pos text -> arr.(pos) <- text; pos+1);
-    let r = insert w ~row (Array.map ~f:Gpointer.optstring arr) in
+    let r = insert w ~row arr in
     if r = -1 then invalid_arg "GtkCList::insert";
     r
   external remove : [>`clist] obj -> row:int -> unit

src/gtkMain.ml

@@ -33,6 +33,8 @@ module Main = struct
   (* external set_locale : unit -> string = "ml_gtk_set_locale" *)
   external disable_setlocale : unit -> unit = "ml_gtk_disable_setlocale"
   (* external main : unit -> unit = "ml_gtk_main" *)
+  external _caml_sys_modify_argv : string array -> unit =
+    "caml_sys_modify_argv"
   let init ?(setlocale=true) () =
     let setlocale =
       try Sys.getenv "GTK_SETLOCALE" <> "0" with Not_found -> setlocale in
@@ -44,9 +46,7 @@ module Main = struct
         raise (Error ("GtkMain.init: initialization failed\n" ^ err))
     in
     if setlocale then ignore (Glib.Main.setlocale `NUMERIC (Some "C"));
-    Array.blit ~src:argv ~dst:Sys.argv ~len:(Array.length argv)
-      ~src_pos:0 ~dst_pos:0;
-    Obj.truncate (Obj.repr Sys.argv) (Array.length argv);
+    _caml_sys_modify_argv argv;
     if setlocale then Glib.Main.setlocale `ALL None else ""
   open Glib
   let loops = ref []

src/ml_gtklist.c

@@ -167,7 +167,17 @@ ML_2 (gtk_clist_get_selectable, GtkCList_val, Int_val, Val_bool)
 ML_5 (gtk_clist_set_shift, GtkCList_val, Int_val, Int_val, Int_val, Int_val,
       Unit)
 /* ML_2 (gtk_clist_append, GtkCList_val, (char **), Val_int) */
-ML_3 (gtk_clist_insert, GtkCList_val, Int_val, (char **), Val_int)
+/* ML_3 (gtk_clist_insert, GtkCList_val, Int_val, (char **), Val_int) */
+CAMLprim value ml_gtk_clist_insert (value w, value n, value arr)
+{
+     CAMLparam3 (w,n,arr);
+     int i, len = Wosize_val(arr);
+     char** arr0 = (char**) caml_alloc (len, Abstract_tag);
+
+     for (i = 0; i < len; i++) arr0[i] = (char*)String_option_val(Field(arr,i));
+     i = gtk_clist_insert (GtkCList_val(w), Int_val(n), arr0);
+     CAMLreturn (Val_int(i));
+}
 ML_2 (gtk_clist_remove, GtkCList_val, Int_val, Unit)
 CAMLprim value ml_gtk_clist_set_row_data (value w, value row, value data)
 {

src/propcc.ml

@@ -157,7 +157,7 @@ let string (strm__ : _ Stream.t) =
 
 let may_colon p def (strm__ : _ Stream.t) =
   match Stream.peek strm__ with
-    Some (Kwd ":") -> Stream.junk strm__; let s = strm__ in p s
+    Some (Kwd ":") -> Stream.junk strm__; p strm__
   | _ -> def
 
 let may_string def (strm__ : _ Stream.t) =
@@ -241,7 +241,7 @@ let marshaller (strm__ : _ Stream.t) =
         try star label_type strm__ with
           Stream.Failure -> raise (Stream.Error "")
       in
-      let s = strm__ in return_type (List.split types) s
+      return_type (List.split types) strm__
   | _ -> Types ([], [], "")
 
 let simple_attr (strm__ : _ Stream.t) =

src/varcc.ml

@@ -57,7 +57,7 @@ let rec ident_list (strm__ : _ Stream.t) =
           let _ =
             try may_bar strm__ with Stream.Failure -> raise (Stream.Error "")
           in
-          let s = strm__ in (x, trans) :: ident_list s
+          (x, trans) :: ident_list strm__
       | _ -> raise (Stream.Error "")
       end
   | _ -> []
@@ -255,15 +255,22 @@ let process ic ~hc ~cc =
     End_of_file ->
       if !all_convs <> [] && !package <> "" then
         let oc x = fprintf cc x in
-        oc "CAMLprim value ml_%s_get_tables ()\n{\n" (camlize !package);
-        oc "  static const lookup_info *ml_lookup_tables[] = {\n";
         let convs = List.rev !all_convs in
-        List.iter convs ~f:(fun (s, _, _, _) -> oc "    ml_table_%s,\n" s);
-        oc "  };\n";
-        (* When he have only one conversion, we must return it directly instead of       * an array that would be converted to a tuple *)
+        let len = List.length convs in
+        oc "CAMLprim value ml_%s_get_tables ()\n{\n" (camlize !package);
+        oc "  CAMLparam0 ();\n";
+        oc "  CAMLlocal1 (ml_lookup_tables);\n";
+        oc "  ml_lookup_tables = caml_alloc_tuple(%d);\n" len;
+        List.iteri convs
+          ~f:(fun i (s, _, _, _) ->
+             oc
+               "  Field(ml_lookup_tables,%d) = Val_lookup_info(ml_table_%s);\n"
+               i s);
+        (* When we have only one conversion, we must return it directly instead
+           of a one-value array that would be invalid as a tuple *)
         if List.length convs = 1 then
-          oc "  return (value)ml_lookup_tables[0];"
-        else oc "  return (value)ml_lookup_tables;";
+          oc "  CAMLreturn (Field(ml_lookup_tables,0));\n"
+        else oc "  CAMLreturn (ml_lookup_tables);\n";
         oc "}\n";
         let mlc = open_out (!package ^ "Enums.ml") in
         let ppf = Format.formatter_of_out_channel mlc in

src/varcc.ml4

@@ -162,16 +162,23 @@ let process ic ~hc ~cc =
   with End_of_file ->
     if !all_convs <> [] && !package <> "" then begin
       let oc x = fprintf cc x in
-      oc "CAMLprim value ml_%s_get_tables ()\n{\n" (camlize !package);
-      oc "  static const lookup_info *ml_lookup_tables[] = {\n";
       let convs = List.rev !all_convs in
-      List.iter convs ~f:(fun (s,_,_,_) -> oc "    ml_table_%s,\n" s);
-      oc "  };\n";
-      (* When he have only one conversion, we must return it directly instead of       * an array that would be converted to a tuple *)
+      let len = List.length convs in
+      oc "CAMLprim value ml_%s_get_tables ()\n{\n" (camlize !package);
+      oc "  CAMLparam0 ();\n";
+      oc "  CAMLlocal1 (ml_lookup_tables);\n";
+      oc "  ml_lookup_tables = caml_alloc_tuple(%d);\n" len;
+      List.iteri convs ~f:
+        begin fun i (s,_,_,_) ->
+          oc "  Field(ml_lookup_tables,%d) = Val_lookup_info(ml_table_%s);\n"
+            i s
+        end;
+      (* When we have only one conversion, we must return it directly instead
+         of a one-value array that would be invalid as a tuple *)
       if List.length convs = 1 then
-        oc "  return (value)ml_lookup_tables[0];"
+        oc "  CAMLreturn (Field(ml_lookup_tables,0));\n"
       else
-        oc "  return (value)ml_lookup_tables;";
+        oc "  CAMLreturn (ml_lookup_tables);\n";
       oc "}\n";
       let mlc = open_out (!package ^ "Enums.ml") in
       let ppf = Format.formatter_of_out_channel mlc in

src/wrappers.c

@@ -177,8 +177,8 @@ CAMLexport value ml_lookup_flags_getter (const lookup_info table[], int data)
   CAMLreturn(l);
 }
 
-ML_2 (ml_lookup_from_c, (lookup_info*), Int_val, 0+)
-ML_2 (ml_lookup_to_c, (lookup_info*), 0+, Val_int)
+ML_2 (ml_lookup_from_c, Lookup_info_val, Int_val, 0+)
+ML_2 (ml_lookup_to_c, Lookup_info_val, 0+, Val_int)
 
 gchar **
 strv_of_string_list (value list)

src/wrappers.h

@@ -60,8 +60,19 @@ char ** strv_of_string_list (value list);
 CAMLprim value *ml_global_root_new (value v);
 CAMLexport void ml_global_root_destroy (void *data);
 
+/* Pointer conversions */
+#define Pointer_val(val) ((void*)Field(val,1))
+#define Store_pointer(val,p) (Field(val,1)=Val_bp(p))
+#define MLPointer_val(val) \
+        ((int)Field(val,1) == 2 ? &Field(val,2) : (void*)Field(val,1))
+
+#define Val_addr(ptr) (1+(value)ptr)
+#define Addr_val(val) ((void*)(val-1))
+
 /* enums <-> polymorphic variants */
 typedef struct { value key; int data; } lookup_info;
+#define Val_lookup_info(v) Val_pointer((void*)v)
+#define Lookup_info_val(v) ((const lookup_info*)Pointer_val(v))
 CAMLexport value ml_lookup_from_c (const lookup_info table[], int data);
 CAMLexport int ml_lookup_to_c (const lookup_info table[], value key);
 CAMLexport value ml_lookup_flags_getter (const lookup_info table[], int data);
@@ -323,14 +334,6 @@ CAMLprim value Val_##type (type *p) \
   ret = ml_alloc_custom (&ml_custom_##type, sizeof(value), adv, 1000); \
   caml_initialize (&Field(ret,1), (value) p); init(p); return ret; }
 
-#define Pointer_val(val) ((void*)Field(val,1))
-#define Store_pointer(val,p) (Field(val,1)=Val_bp(p))
-#define MLPointer_val(val) \
-        ((int)Field(val,1) == 2 ? &Field(val,2) : (void*)Field(val,1))
-
-#define Val_addr(ptr) (1+(value)ptr)
-#define Addr_val(val) ((void*)(val-1))
-
 #define Wosize_asize(x) ((x-1)/sizeof(value)+1)
 #define Wosizeof(x) Wosize_asize(sizeof(x))