Issue rescript-lang#1351 : bug fix (rescript-lang#1396)

* Issue rescript-lang#1351 : bug fix

* Issue rescript-lang#1351 : bug fix
* Issue rescript-lang#1351 : intercept Parrayrefs and Parraysets

Author: Bob Fang

jscomp/bin/all_ounit_tests.i.ml

@@ -69099,7 +69099,7 @@ let small_int i : t =
   | i -> int (Int32.of_int i) 
 
 
-let access ?comment (e0 : t)  (e1 : t) : t = 
+let access ?comment (e0 : t)  (e1 : t) : t =
   match e0.expression_desc, e1.expression_desc with
   | Array (l,_mutable_flag) , Number (Int {i; _}) when no_side_effect e0-> 
     List.nth l  (Int32.to_int i)  (* Float i -- should not appear here *)
@@ -88083,7 +88083,6 @@ val set_array : J.expression -> J.expression -> J.expression -> J.expression
  *)
 
 val ref_array :  J.expression -> J.expression -> J.expression
-
 end = struct
 #1 "js_of_lam_array.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -88155,7 +88154,6 @@ let set_array  e e0 e1 =
 
 let ref_array  e e0 = 
   E.access  e  e0
-
 end
 module Js_of_lam_record : sig 
 #1 "js_of_lam_record.mli"
@@ -91235,7 +91233,8 @@ let translate (prim_name : string)
     | _ ->  assert false 
     end
 
-  | "caml_array_get"
+  | "caml_array_get" -> 
+    call Js_config.array
   | "caml_array_get_addr"
   | "caml_array_get_float"
   | "caml_array_unsafe_get"
@@ -91244,7 +91243,8 @@ let translate (prim_name : string)
     | [e0;e1] -> Js_of_lam_array.ref_array e0 e1
     | _ -> assert false
     end
-  | "caml_array_set"
+  | "caml_array_set" ->
+    call Js_config.array
   | "caml_array_set_addr"
   | "caml_array_set_float"
   | "caml_array_unsafe_set"
@@ -92609,20 +92609,23 @@ let translate  loc
           (Int32.of_int i) 
       | _ -> assert false 
     end
-  | Parrayrefu _kind
-  | Parrayrefs _kind ->  
+  | Parrayrefu _kind ->  
     begin match args with
       | [e;e1] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *)
       | _ -> assert false
     end
+  | Parrayrefs _kind ->
+    Lam_dispatch_primitive.translate "caml_array_get" args
   | Pmakearray kind -> 
     Js_of_lam_array.make_array Mutable kind args 
-  | Parraysetu _kind
-  | Parraysets _kind -> 
+  | Parraysetu _kind -> 
     begin match args with (* wrong*)
       | [e;e0;e1] -> decorate_side_effect cxt @@ Js_of_lam_array.set_array  e e0 e1
       | _ -> assert false
     end
+
+  | Parraysets _kind -> 
+    Lam_dispatch_primitive.translate "caml_array_set" args
   | Pccall prim -> 
     Lam_dispatch_primitive.translate prim.prim_name  args
   (* Lam_compile_external_call.translate loc cxt prim args *)

jscomp/bin/whole_compiler.ml

@@ -293,7 +293,7 @@ let small_int i : t =
   | i -> int (Int32.of_int i) 
 
 
-let access ?comment (e0 : t)  (e1 : t) : t = 
+let access ?comment (e0 : t)  (e1 : t) : t =
   match e0.expression_desc, e1.expression_desc with
   | Array (l,_mutable_flag) , Number (Int {i; _}) when no_side_effect e0-> 
     List.nth l  (Int32.to_int i)  (* Float i -- should not appear here *)

jscomp/core/js_exp_make.ml

@@ -66,4 +66,4 @@ let set_array  e e0 e1 =
   E.assign (E.access e e0)  e1
 
 let ref_array  e e0 = 
-  E.access  e  e0
+  E.access  e  e0

jscomp/core/js_of_lam_array.ml

@@ -39,4 +39,4 @@ val set_array : J.expression -> J.expression -> J.expression -> J.expression
     In the future, we might used TypedArray for FloatArray
  *)
 
-val ref_array :  J.expression -> J.expression -> J.expression
+val ref_array :  J.expression -> J.expression -> J.expression

jscomp/core/js_of_lam_array.mli

@@ -640,20 +640,23 @@ let translate  loc
           (Int32.of_int i) 
       | _ -> assert false 
     end
-  | Parrayrefu _kind
-  | Parrayrefs _kind ->  
+  | Parrayrefu _kind ->  
     begin match args with
       | [e;e1] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *)
       | _ -> assert false
     end
+  | Parrayrefs _kind ->
+    Lam_dispatch_primitive.translate "caml_array_get" args
   | Pmakearray kind -> 
     Js_of_lam_array.make_array Mutable kind args 
-  | Parraysetu _kind
-  | Parraysets _kind -> 
+  | Parraysetu _kind -> 
     begin match args with (* wrong*)
       | [e;e0;e1] -> decorate_side_effect cxt @@ Js_of_lam_array.set_array  e e0 e1
       | _ -> assert false
     end
+
+  | Parraysets _kind -> 
+    Lam_dispatch_primitive.translate "caml_array_set" args
   | Pccall prim -> 
     Lam_dispatch_primitive.translate prim.prim_name  args
   (* Lam_compile_external_call.translate loc cxt prim args *)

jscomp/core/lam_compile_primitive.ml

@@ -147,7 +147,8 @@ let translate (prim_name : string)
     | _ ->  assert false 
     end
 
-  | "caml_array_get"
+  | "caml_array_get" -> 
+    call Js_config.array
   | "caml_array_get_addr"
   | "caml_array_get_float"
   | "caml_array_unsafe_get"
@@ -156,7 +157,8 @@ let translate (prim_name : string)
     | [e0;e1] -> Js_of_lam_array.ref_array e0 e1
     | _ -> assert false
     end
-  | "caml_array_set"
+  | "caml_array_set" ->
+    call Js_config.array
   | "caml_array_set_addr"
   | "caml_array_set_float"
   | "caml_array_unsafe_set"

jscomp/core/lam_dispatch_primitive.ml

@@ -30,7 +30,6 @@ external append : 'a array -> 'a array -> 'a array = "concat" [@@bs.send]
 
 external make : int -> 'a -> 'a array = "caml_make_vect"
 
-
 let caml_array_sub (x : 'a array) (offset : int) (len : int) = 
   let result = new_uninitialized len  in
   let j = ref 0 and i = ref offset in

jscomp/runtime/caml_array.ml

@@ -36,3 +36,7 @@ val caml_array_concat : 'a array list -> 'a array
 val caml_make_vect : int -> 'a -> 'a array
 
 val caml_array_blit : 'a array -> int -> 'a array -> int -> int -> unit
+
+val caml_array_get: 'a array -> int -> 'a
+
+val caml_array_set: 'a array -> int -> 'a -> unit

jscomp/runtime/caml_array.mli

@@ -0,0 +1,3 @@
+let x = [|1; 2|]
+let y = try Array.get x 3 with
+        Invalid_argument msg -> print_endline msg; 0

jscomp/test/array_safe_get.js

@@ -2,6 +2,7 @@
 
 var Mt           = require("./mt");
 var Block        = require("../../lib/js/block");
+var Caml_array   = require("../../lib/js/caml_array");
 var Js_primitive = require("../../lib/js/js_primitive");
 
 var suites = [/* [] */0];
@@ -56,14 +57,14 @@ eq('File "array_subtle_test.ml", line 17, characters 5-12', /* tuple */[
 
 eq('File "array_subtle_test.ml", line 21, characters 5-12', /* tuple */[
       3,
-      v[2]
+      Caml_array.caml_array_get(v, 2)
     ]);
 
-v[2] = 4;
+Caml_array.caml_array_set(v, 2, 4);
 
 eq('File "array_subtle_test.ml", line 23, characters 5-12', /* tuple */[
       4,
-      v[2]
+      Caml_array.caml_array_get(v, 2)
     ]);
 
 while(v.length > 0) {

jscomp/test/array_safe_get.ml

@@ -15,7 +15,7 @@ function is_sorted(x) {
     if (i >= (len - 1 | 0)) {
       return /* true */1;
     }
-    else if (Caml_obj.caml_lessthan(x[i], x[i + 1 | 0])) {
+    else if (Caml_obj.caml_lessthan(Caml_array.caml_array_get(x, i), Caml_array.caml_array_get(x, i + 1 | 0))) {
       _i = i + 1 | 0;
       continue ;
 

jscomp/test/array_subtle_test.js

@@ -15,7 +15,7 @@ function $$eval(_bdd, vars) {
         return /* true */1;
       }
     }
-    else if (vars[bdd[1]]) {
+    else if (Caml_array.caml_array_get(vars, bdd[1])) {
       _bdd = bdd[3];
       continue ;
 
@@ -75,10 +75,10 @@ function resize(newSize) {
         }
         else {
           var ind = hashVal(getId(n[0]), getId(n[3]), n[1]) & newSz_1;
-          newArr[ind] = /* :: */[
-            n,
-            newArr[ind]
-          ];
+          Caml_array.caml_array_set(newArr, ind, /* :: */[
+                n,
+                Caml_array.caml_array_get(newArr, ind)
+              ]);
           _bucket = bucket[1];
           continue ;
 
@@ -90,7 +90,7 @@ function resize(newSize) {
     };
   };
   for(var n = 0 ,n_finish = sz_1[0]; n <= n_finish; ++n){
-    copyBucket(arr[n]);
+    copyBucket(Caml_array.caml_array_get(arr, n));
   }
   htab[0] = newArr;
   sz_1[0] = newSz_1;
@@ -99,20 +99,19 @@ function resize(newSize) {
 
 function insert(idl, idh, v, ind, bucket, newNode) {
   if (n_items[0] <= sz_1[0]) {
-    htab[0][ind] = /* :: */[
-      newNode,
-      bucket
-    ];
+    Caml_array.caml_array_set(htab[0], ind, /* :: */[
+          newNode,
+          bucket
+        ]);
     return n_items[0] = n_items[0] + 1 | 0;
   }
   else {
     resize((sz_1[0] + sz_1[0] | 0) + 2 | 0);
     var ind$1 = hashVal(idl, idh, v) & sz_1[0];
-    htab[0][ind$1] = /* :: */[
-      newNode,
-      htab[0][ind$1]
-    ];
-    return /* () */0;
+    return Caml_array.caml_array_set(htab[0], ind$1, /* :: */[
+                newNode,
+                Caml_array.caml_array_get(htab[0], ind$1)
+              ]);
   }
 }
 
@@ -132,7 +131,7 @@ function mkNode(low, v, high) {
   }
   else {
     var ind = hashVal(idl, idh, v) & sz_1[0];
-    var bucket = htab[0][ind];
+    var bucket = Caml_array.caml_array_get(htab[0], ind);
     var _b = bucket;
     while(true) {
       var b = _b;
@@ -220,13 +219,13 @@ function not(n) {
   else {
     var id = n[2];
     var h = id % 1999;
-    if (id === notslot1[h]) {
-      return notslot2[h];
+    if (id === Caml_array.caml_array_get(notslot1, h)) {
+      return Caml_array.caml_array_get(notslot2, h);
     }
     else {
       var f = mkNode(not(n[0]), n[1], not(n[3]));
-      notslot1[h] = id;
-      notslot2[h] = f;
+      Caml_array.caml_array_set(notslot1, h, id);
+      Caml_array.caml_array_set(notslot2, h, f);
       return f;
     }
   }
@@ -260,8 +259,8 @@ function and2(n1, n2) {
       var v2 = n2[1];
       var l2 = n2[0];
       var h = hash(i1, i2);
-      if (i1 === andslot1[h] && i2 === andslot2[h]) {
-        return andslot3[h];
+      if (i1 === Caml_array.caml_array_get(andslot1, h) && i2 === Caml_array.caml_array_get(andslot2, h)) {
+        return Caml_array.caml_array_get(andslot3, h);
       }
       else {
         var match = cmpVar(v1, v2);
@@ -278,9 +277,9 @@ function and2(n1, n2) {
               break;
 
         }
-        andslot1[h] = i1;
-        andslot2[h] = i2;
-        andslot3[h] = f;
+        Caml_array.caml_array_set(andslot1, h, i1);
+        Caml_array.caml_array_set(andslot2, h, i2);
+        Caml_array.caml_array_set(andslot3, h, f);
         return f;
       }
     }
@@ -315,8 +314,8 @@ function xor(n1, n2) {
       var v2 = n2[1];
       var l2 = n2[0];
       var h = hash(i1, i2);
-      if (i1 === andslot1[h] && i2 === andslot2[h]) {
-        return andslot3[h];
+      if (i1 === Caml_array.caml_array_get(andslot1, h) && i2 === Caml_array.caml_array_get(andslot2, h)) {
+        return Caml_array.caml_array_get(andslot3, h);
       }
       else {
         var match = cmpVar(v1, v2);
@@ -333,9 +332,9 @@ function xor(n1, n2) {
               break;
 
         }
-        andslot1[h] = i1;
-        andslot2[h] = i2;
-        andslot3[h] = f;
+        Caml_array.caml_array_set(andslot1, h, i1);
+        Caml_array.caml_array_set(andslot2, h, i2);
+        Caml_array.caml_array_set(andslot3, h, f);
         return f;
       }
     }
@@ -372,7 +371,7 @@ function random() {
 function random_vars(n) {
   var vars = Caml_array.caml_make_vect(n, /* false */0);
   for(var i = 0 ,i_finish = n - 1 | 0; i <= i_finish; ++i){
-    vars[i] = random(/* () */0);
+    Caml_array.caml_array_set(vars, i, random(/* () */0));
   }
   return vars;
 }
@@ -397,12 +396,12 @@ function bool_equal(a, b) {
 function test_hwb(bdd, vars) {
   var ntrue = 0;
   for(var i = 0 ,i_finish = vars.length - 1 | 0; i <= i_finish; ++i){
-    if (vars[i]) {
+    if (Caml_array.caml_array_get(vars, i)) {
       ntrue = ntrue + 1 | 0;
     }
 
   }
-  return bool_equal($$eval(bdd, vars), ntrue > 0 ? vars[ntrue - 1 | 0] : /* false */0);
+  return bool_equal($$eval(bdd, vars), ntrue > 0 ? Caml_array.caml_array_get(vars, ntrue - 1 | 0) : /* false */0);
 }
 
 function main() {