Merge pull request #610 from bloomberg/fix_string_get

bound access check for string

Author: bobzhang

jscomp/common/js_config.ml

@@ -232,6 +232,7 @@ let obj_runtime = "Caml_obj"
 let array = "Caml_array"
 let format = "Caml_format"
 let string = "Caml_string"
+let bytes = "Caml_bytes"  
 let float = "Caml_float"
 let hash = "Caml_hash"
 let oo = "Caml_oo"

jscomp/common/js_config.mli

@@ -137,7 +137,8 @@ val parser : string
 val obj_runtime : string
 val array : string
 val format : string
-val string : string 
+val string : string
+val bytes : string  
 val float : string 
 val curry : string 
 (* val bigarray : string *)

jscomp/lam.ml

@@ -337,75 +337,80 @@ let comparison (cmp : Lambda.comparison) a b : bool =
   | Clt -> a < b 
   | Cge -> a >= b 
 
-let lift_int i : t =
-  Lconst (Const_base (Const_int i))
+module Lift = struct 
+  let int i : t =
+    Lconst (Const_base (Const_int i))
 
 
-let int32 i : t =
-  Lconst (Const_base (Const_int32 i))
+  let int32 i : t =
+    Lconst (Const_base (Const_int32 i))
 
-let lift_bool b = if b then true_ else false_
+  let bool b = if b then true_ else false_
 
-(* ATTENTION: [float, nativeint] constant propogaton is not done
-   yet , due to cross platform problem
-*) 
-let lift_float b  : t = 
-  Lconst (Const_base (Const_float b))
+  (* ATTENTION: [float, nativeint] constant propogaton is not done
+     yet , due to cross platform problem
+  *) 
+  let float b  : t = 
+    Lconst (Const_base (Const_float b))
 
-let lift_nativeint b : t = 
-  Lconst (Const_base (Const_nativeint b))
+  let nativeint b : t = 
+    Lconst (Const_base (Const_nativeint b))
 
-let lift_int32 b : t = 
-  Lconst (Const_base (Const_int32 b))
+  let int32 b : t = 
+    Lconst (Const_base (Const_int32 b))
 
-let lift_int64 b : t =
-  Lconst (Const_base (Const_int64 b))
+  let int64 b : t =
+    Lconst (Const_base (Const_int64 b))
+  let string b : t =
+    Lconst (Const_base (Const_string (b, None)))
+  let char b : t =
+    Lconst (Const_base (Const_char b))    
+end
 
 let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t = 
   let default () : t = Lprim { primitive = prim ;args =  ll } in 
   match ll with 
   | [Lconst a] -> 
     begin match prim, a  with 
       | Pnegint, (Const_base (Const_int a))
-        -> lift_int (- a)
+        -> Lift.int (- a)
       (* | Pfloatofint, (Const_base (Const_int a)) *)
-      (*   -> lift_float (float_of_int a) *)
+      (*   -> Lift.float (float_of_int a) *)
       | Pintoffloat, (Const_base (Const_float a))
         -> 
-        lift_int (int_of_float (float_of_string a))
-        (* | Pnegfloat -> lift_float (-. a) *)
-        (* | Pabsfloat -> lift_float (abs_float a) *)
+        Lift.int (int_of_float (float_of_string a))
+        (* | Pnegfloat -> Lift.float (-. a) *)
+        (* | Pabsfloat -> Lift.float (abs_float a) *)
       | Pstringlength, (Const_base (Const_string (a,_)) ) 
         -> 
-        lift_int (String.length a)
+        Lift.int (String.length a)
       (* | Pnegbint Pnativeint, (Const_base (Const_nativeint i)) *)
       (*   ->   *)
-      (*   lift_nativeint (Nativeint.neg i) *)
+      (*   Lift.nativeint (Nativeint.neg i) *)
       | Pnegbint Pint32, (Const_base (Const_int32 a))
         -> 
-        lift_int32 (Int32.neg a)
+        Lift.int32 (Int32.neg a)
       | Pnegbint Pint64, (Const_base (Const_int64 a))
         -> 
-        lift_int64 (Int64.neg a)
+        Lift.int64 (Int64.neg a)
       | Pnot , Const_pointer (a,_) 
-        -> lift_bool (a = 0 )
-
+        -> Lift.bool (a = 0 )
       | _ -> default ()
     end
 
 
   | [Lconst a ; Lconst b] -> 
     begin match prim, a, b  with 
       | Pbintcomp(_, cmp), Const_base (Const_int32 a), Const_base (Const_int32 b)
-        -> lift_bool (comparison cmp a b)
+        -> Lift.bool (comparison cmp a b)
       | Pbintcomp(_, cmp), Const_base (Const_int64 a), Const_base (Const_int64 b)
-        -> lift_bool (comparison cmp a b)
+        -> Lift.bool (comparison cmp a b)
       | Pbintcomp(_, cmp), Const_base (Const_nativeint a), Const_base (Const_nativeint b)
-        -> lift_bool (comparison cmp a b)
+        -> Lift.bool (comparison cmp a b)
       | Pfloatcomp  cmp, Const_base (Const_nativeint a), Const_base (Const_nativeint b)
-        -> lift_bool (comparison cmp a b)
+        -> Lift.bool (comparison cmp a b)
       | Pintcomp cmp , Const_base (Const_int a), Const_base (Const_int b)
-        -> lift_bool (comparison cmp a b)
+        -> Lift.bool (comparison cmp a b)
 
       | (Paddint
         | Psubint
@@ -421,7 +426,7 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
         ->
             (* WE SHOULD keep it as [int], to preserve types *)
             let aa,bb = Int32.of_int a, Int32.of_int  b in 
-            let int_ v = lift_int (Int32.to_int v ) in 
+            let int_ v = Lift.int (Int32.to_int v ) in 
             begin match prim with 
               | Paddint -> int_ (Int32.add aa bb)
               | Psubint -> int_ (Int32.sub aa bb)
@@ -451,22 +456,22 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
         ), Const_base (Const_int32 aa),  Const_base (Const_int32 bb)
         -> 
         begin match prim with 
-          | Paddbint _  -> lift_int32 (Int32.add aa bb)
-          | Psubbint _  -> lift_int32 (Int32.sub aa bb)
-          | Pmulbint _ -> lift_int32 (Int32.mul aa  bb)
-          | Pdivbint _ ->  (try lift_int32 (Int32.div aa  bb) with _  -> default ())
-          | Pmodbint _ -> (try lift_int32 (Int32.rem aa  bb) with _ -> default ())
-          | Pandbint _ -> lift_int32 (Int32.logand aa bb)
-          | Porbint _ -> lift_int32 (Int32.logor aa bb)
-          | Pxorbint _ -> lift_int32 (Int32.logxor aa bb)
+          | Paddbint _  -> Lift.int32 (Int32.add aa bb)
+          | Psubbint _  -> Lift.int32 (Int32.sub aa bb)
+          | Pmulbint _ -> Lift.int32 (Int32.mul aa  bb)
+          | Pdivbint _ ->  (try Lift.int32 (Int32.div aa  bb) with _  -> default ())
+          | Pmodbint _ -> (try Lift.int32 (Int32.rem aa  bb) with _ -> default ())
+          | Pandbint _ -> Lift.int32 (Int32.logand aa bb)
+          | Porbint _ -> Lift.int32 (Int32.logor aa bb)
+          | Pxorbint _ -> Lift.int32 (Int32.logxor aa bb)
           | _ -> default ()
         end
       | Plslbint Pint32, Const_base (Const_int32 aa), Const_base (Const_int b)
-        -> lift_int32 (Int32.shift_left  aa b )
+        -> Lift.int32 (Int32.shift_left  aa b )
       | Plsrbint Pint32, Const_base (Const_int32 aa), Const_base (Const_int b)
-        -> lift_int32 (Int32.shift_right_logical  aa b )
+        -> Lift.int32 (Int32.shift_right_logical  aa b )
       | Pasrbint Pint32, Const_base (Const_int32 aa), Const_base (Const_int b)
-        -> lift_int32 (Int32.shift_right  aa b )
+        -> Lift.int32 (Int32.shift_right  aa b )
 
       | (Paddbint Pint64
         | Psubbint Pint64
@@ -479,28 +484,38 @@ let prim ~primitive:(prim : Prim.t) ~args:(ll : t list)  : t =
         ), Const_base (Const_int64 aa),  Const_base (Const_int64 bb)
         -> 
         begin match prim with 
-          | Paddbint _  -> lift_int64 (Int64.add aa bb)
-          | Psubbint _  -> lift_int64 (Int64.sub aa bb)
-          | Pmulbint _ -> lift_int64 (Int64.mul aa  bb)
-          | Pdivbint _ -> (try lift_int64 (Int64.div aa  bb) with _ -> default ())
-          | Pmodbint _ -> (try lift_int64 (Int64.rem aa  bb) with _ -> default ())
-          | Pandbint _ -> lift_int64 (Int64.logand aa bb)
-          | Porbint _ -> lift_int64 (Int64.logor aa bb)
-          | Pxorbint _ -> lift_int64 (Int64.logxor aa bb)
+          | Paddbint _  -> Lift.int64 (Int64.add aa bb)
+          | Psubbint _  -> Lift.int64 (Int64.sub aa bb)
+          | Pmulbint _ -> Lift.int64 (Int64.mul aa  bb)
+          | Pdivbint _ -> (try Lift.int64 (Int64.div aa  bb) with _ -> default ())
+          | Pmodbint _ -> (try Lift.int64 (Int64.rem aa  bb) with _ -> default ())
+          | Pandbint _ -> Lift.int64 (Int64.logand aa bb)
+          | Porbint _ -> Lift.int64 (Int64.logor aa bb)
+          | Pxorbint _ -> Lift.int64 (Int64.logxor aa bb)
           | _ -> default ()
         end
       | Plslbint Pint64, Const_base (Const_int64 aa), Const_base (Const_int b)
-        -> lift_int64 (Int64.shift_left  aa b )
+        -> Lift.int64 (Int64.shift_left  aa b )
       | Plsrbint Pint64, Const_base (Const_int64 aa), Const_base (Const_int b)
-        -> lift_int64 (Int64.shift_right_logical  aa b )
+        -> Lift.int64 (Int64.shift_right_logical  aa b )
       | Pasrbint Pint64, Const_base (Const_int64 aa), Const_base (Const_int b)
-        -> lift_int64 (Int64.shift_right  aa b )
+        -> Lift.int64 (Int64.shift_right  aa b )
       | Psequand, Const_pointer (a, _), Const_pointer( b, _)
         -> 
-        lift_bool (a = 1 && b = 1)
+        Lift.bool (a = 1 && b = 1)
       | Psequor, Const_pointer (a, _), Const_pointer( b, _)
         -> 
-        lift_bool (a = 1 || b = 1)
+        Lift.bool (a = 1 || b = 1)
+      | Pstringadd, Const_base(Const_string (a, None)),
+        Const_base (Const_string (b,None))
+        ->
+        Lift.string (a ^ b)
+      | (Pstringrefs | Pstringrefu), Const_base(Const_string(a,None)),
+        (Const_base(Const_int b)| Const_pointer (b,_))
+        ->
+        begin try Lift.char (String.get a b)
+          with  _ -> default ()
+        end                       
       | _ -> default ()
     end
 
@@ -661,7 +676,13 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args  : t =
   | Pbigstring_set_16 x -> prim ~primitive:(Pbigstring_set_16 x) ~args
   | Pbigstring_set_32 x -> prim ~primitive:(Pbigstring_set_32 x) ~args
   | Pbigstring_set_64 x -> prim ~primitive:(Pbigstring_set_64 x) ~args
-  | Pctconst x -> prim ~primitive:(Pctconst x) ~args
+  | Pctconst x ->
+    begin match x with
+      | Word_size ->
+        Lift.int 32 (* TODO: documentation*)        
+      | _ -> prim ~primitive:(Pctconst x) ~args         
+    end
+
   | Pbbswap x -> prim ~primitive:(Pbbswap x) ~args
   | Pcvtbint (a,b) -> prim ~primitive:(Pcvtbint (a,b)) ~args
   | Pbintcomp (a,b) -> prim ~primitive:(Pbintcomp (a,b)) ~args

jscomp/lam_compile_primitive.ml

@@ -443,24 +443,41 @@ let translate
 
       | _ -> assert false
       end
-  | Pbytesrefu 
-  | Pbytesrefs ->
+  | Pbytesrefu ->
       begin match args with
       | [e;e1] -> Js_of_lam_string.ref_byte e e1
       | _ -> assert false
       end
-
+    
+  | Pbytesrefs ->
+    begin match args with
+      | [e ; e1] ->
+        if !Clflags.fast then
+          Js_of_lam_string.ref_byte e e1
+        else E.runtime_call Js_config.bytes "get" args            
+      | _ -> assert false         
+    end
    (* For bytes and string, they both return [int] in ocaml 
        we need tell Pbyteref from Pstringref
        1. Pbyteref -> a[i]
        2. Pstringref -> a.charCodeAt (a[i] is wrong)
     *)
-  | Pstringrefu 
-  | Pstringrefs ->
+  | Pstringrefu  ->
       begin match args with
       | [e;e1] -> Js_of_lam_string.ref_string e e1 
       | _ -> assert false
       end
+
+  | Pstringrefs ->
+      begin match args with
+        | [e;e1] ->
+          if !Clflags.fast then
+            Js_of_lam_string.ref_string e e1             
+          else       
+            E.runtime_call Js_config.string "get" args          
+      | _ -> assert false
+      end
+    
   | Pgetglobal i   -> 
     (* TODO -- check args, case by case -- 
         1. include Array --> let include  = Array 

jscomp/runtime/.runtimedepend

@@ -3,6 +3,7 @@ caml_array.cmi :
 caml_backtrace.cmi :
 caml_basic.cmi : js.cmj
 caml_builtin_exceptions.cmi :
+caml_bytes.cmi :
 caml_exceptions.cmi : caml_builtin_exceptions.cmi
 caml_float.cmi :
 caml_format.cmi :
@@ -37,6 +38,8 @@ caml_basic.cmj : js.cmj caml_basic.cmi
 caml_basic.cmx : js.cmx caml_basic.cmi
 caml_builtin_exceptions.cmj : caml_builtin_exceptions.cmi
 caml_builtin_exceptions.cmx : caml_builtin_exceptions.cmi
+caml_bytes.cmj : caml_bytes.cmi
+caml_bytes.cmx : caml_bytes.cmi
 caml_exceptions.cmj : caml_builtin_exceptions.cmi caml_exceptions.cmi
 caml_exceptions.cmx : caml_builtin_exceptions.cmx caml_exceptions.cmi
 caml_float.cmj : typed_array.cmj js_float.cmj caml_float.cmi
@@ -119,6 +122,8 @@ caml_basic.cmo : js.cmo caml_basic.cmi
 caml_basic.cmj : js.cmj caml_basic.cmi
 caml_builtin_exceptions.cmo : caml_builtin_exceptions.cmi
 caml_builtin_exceptions.cmj : caml_builtin_exceptions.cmi
+caml_bytes.cmo : caml_bytes.cmi
+caml_bytes.cmj : caml_bytes.cmi
 caml_exceptions.cmo : caml_builtin_exceptions.cmi caml_exceptions.cmi
 caml_exceptions.cmj : caml_builtin_exceptions.cmj caml_exceptions.cmi
 caml_float.cmo : typed_array.cmo js_float.cmo caml_float.cmi

jscomp/runtime/Makefile

@@ -2,7 +2,7 @@ include ../Makefile.shared
 
 COMPILER=../bin/bsc
 
-OTHERS= caml_array caml_string \
+OTHERS= caml_array caml_string caml_bytes\
 	caml_obj caml_int64 \
 	caml_exceptions	caml_utils caml_sys caml_io\
 	caml_float caml_lexer caml_parser caml_primitive\
@@ -32,7 +32,7 @@ else
 BS_FLAGS=  $(BS_COMMON_FLAGS) -bs-package-output lib/js 
 endif
 
-COMPFLAGS += $(BS_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -w -40
+COMPFLAGS += $(BS_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -unsafe -w -40
 
 
 

jscomp/runtime/caml_bytes.ml

@@ -0,0 +1,28 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+let get s i =
+  if i < 0 || i >= Bytes.length s then
+    raise (Invalid_argument "index out of bounds")
+  else Bytes.unsafe_get s i      

jscomp/runtime/caml_bytes.mli

@@ -0,0 +1,25 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+val get : bytes -> int -> char