Merge pull request #3157 from BuckleScript/hex_float

part2: add hexstring_of_float support

Author: bobzhang

jscomp/core/lam_dispatch_primitive.ml

@@ -694,7 +694,9 @@ let translate loc (prim_name : string)
 
       end
     | "caml_format_float"
-
+#if OCAML_VERSION =~ ">4.03.0" then
+    | "caml_hexstring_of_float"  
+#end    
     | "caml_nativeint_format"
     | "caml_int32_format"
     | "caml_float_of_string"

jscomp/runtime/caml_format.ml

@@ -570,6 +570,52 @@ let caml_format_float fmt x =
     end;
   finish_formatting f !s
 
+let caml_hexstring_of_float : float -> int -> char -> string =    
+  fun%raw x prec style -> {| 
+  if (!isFinite(x)) {
+    if (isNaN(x)) return "nan";
+    return x > 0 ? "infinity":"-infinity";
+  }
+  var sign = (x==0 && 1/x == -Infinity)?1:(x>=0)?0:1;
+  if(sign) x = -x;
+  var exp = 0;
+  if (x == 0) { }
+  else if (x < 1) {
+    while (x < 1 && exp > -1022)  { x *= 2; exp-- }
+  } else {
+    while (x >= 2) { x /= 2; exp++ }
+  }
+  var exp_sign = exp < 0 ? '' : '+';
+  var sign_str = '';
+  if (sign) sign_str = '-'
+  else {
+    switch(style){
+    case 43 /* '+' */: sign_str = '+'; break;
+    case 32 /* ' ' */: sign_str = ' '; break;
+    default: break;
+    }
+  }
+  if (prec >= 0 && prec < 13) {
+    /* If a precision is given, and is small, round mantissa accordingly */
+      var cst = Math.pow(2,prec * 4);
+      x = Math.round(x * cst) / cst;
+  }
+  var x_str = x.toString(16);
+  if(prec >= 0){
+      var idx = x_str.indexOf('.');
+    if(idx<0) {
+      x_str += '.' +  '0'.repeat(prec);
+    }
+    else {
+      var size = idx+1+prec;
+      if(x_str.length < size)
+        x_str += '0'.repeat(size - x_str.length);
+      else
+        x_str = x_str.substr(0,size);
+    }
+  }
+  return  (sign_str + '0x' + x_str + 'p' + exp_sign + exp.toString(10));
+|}  
 (**
  external float_of_string : string -> float = "caml_float_of_string"
  pervasives.ml
@@ -586,7 +632,7 @@ let caml_format_float fmt x =
 let float_of_string : string -> exn ->  float  = 
 #if OCAML_VERSION =~ ">4.3.0" then
     fun%raw s exn -> {| 
-   {
+
     var res = +s;
     if ((s.length > 0) && (res === res))
         return res;
@@ -609,11 +655,11 @@ let float_of_string : string -> exn ->  float  =
     if (/^-inf(inity)?$/i.test(s))
         return -Infinity;
     throw exn;
-}
+
 |}
 #else
     fun%raw s exn -> {| 
-   {
+
     var res = +s;
     if ((s.length > 0) && (res === res))
         return res;
@@ -627,7 +673,7 @@ let float_of_string : string -> exn ->  float  =
     if (/^-inf(inity)?$/i.test(s))
         return -Infinity;
     throw exn;
-}
+
 |}
 #end
 

jscomp/runtime/caml_format.mli

@@ -31,7 +31,9 @@
 (** *)
 
 val caml_format_float : string -> float -> string
-
+#if OCAML_VERSION =~ ">4.03.0" then
+val caml_hexstring_of_float : float -> int -> char -> string
+#end
 val caml_format_int : string -> nativeint -> string
 val caml_nativeint_format : string -> nativeint -> string     
 val caml_int32_format : string -> nativeint -> string

jscomp/test/format_test.ml

@@ -84,17 +84,51 @@ let () =
 #end     
 ;;
 
+
+#if OCAML_VERSION =~ ">4.03.0" then 
+let sl f = 
+  Printf.sprintf "%h" f 
+
+let aux_list loc ls =   
+  List.iter (fun (a,b) -> 
+    eq loc (sl a ) b 
+  ) ls 
+let literals = 
+  [
+    0x3.fp+1, "0x1.f8p+2" (* (1. +. 0xf8p0 /. 0x1_00p0) *. 4.*);
+    0.3, "0x1.3333333333333p-2";
+    infinity, "infinity";
+    0.4, "0x1.999999999999ap-2";
+    0.5, "0x1p-1";
+    0.6, "0x1.3333333333333p-1";
+    0.7, "0x1.6666666666666p-1";
+    0.8, "0x1.999999999999ap-1";
+    0.9, "0x1.ccccccccccccdp-1";
+  ]
+
+let () =   
+  aux_list __LOC__ literals
+
+let () = 
+  eq __LOC__ (Printf.sprintf "%H" 0x3.fp+1) "0X1.F8P+2"  
+let scan_float loc s expect = 
+    Scanf.sscanf s "%h" (fun result -> eq loc result expect)
+
+let () =     
+  scan_float __LOC__ "0x3f.p1" 0x3f.p1;
+  scan_float __LOC__ "0x1.3333333333333p-2" 0.3;
+  List.iter (fun (a,b) -> 
+  scan_float __LOC__ b a 
+  ) literals
+#end
+
+
 #if 
   (* OCAML_VERSION =~ ">4.03.0" *) 0
 then
 
 
 
 
-let () = eq __LOC__ (Printf.sprintf "%h" 0x3.fp+1) "0x1.f8p+2"
-let () = eq __LOC__ (Printf.sprintf "%H" 0x3.fp+1) "0x1.F8P+2"
-
-let () = eq __LOC__ (Printf.sprintf "%h" 0.3) "0x1.3333333333333p-2"
-
 #end
 let () = Mt.from_pair_suites __FILE__ !suites

lib/js/caml_format.js

@@ -771,29 +771,20 @@ function caml_format_float(fmt, x) {
 }
 
 var float_of_string = function (s,exn){ 
-   {
+
     var res = +s;
     if ((s.length > 0) && (res === res))
         return res;
     s = s.replace(/_/g, "");
     res = +s;
     if (((s.length > 0) && (res === res)) || /^[+-]?nan$/i.test(s)) {
         return res;
-    }
-    ;
-    if (/^ *0x[0-9a-f_]+p[+-]?[0-9_]+/i.test(s)) {
-        var pidx = s.indexOf('p');
-        pidx = (pidx == -1) ? s.indexOf('P') : pidx;
-        var exp = +s.substring(pidx + 1);
-        res = +s.substring(0, pidx);
-        return res * Math.pow(2, exp);
-    }
+    };
     if (/^\+?inf(inity)?$/i.test(s))
         return Infinity;
     if (/^-inf(inity)?$/i.test(s))
         return -Infinity;
     throw exn;
-}
 
 };
 

lib/whole_compiler.ml

@@ -82976,7 +82976,7 @@ module Js_number : sig
 type t  = float 
 
 
-val to_string : t -> string
+(* val to_string : t -> string *)
 
 
 val caml_float_literal_to_js_string : string -> string
@@ -83057,18 +83057,20 @@ let to_string v =
         else  Printf.sprintf "%.18g" v
 
 
+let rec is_hex_format_aux (v : string) cur = 
+    if v.[cur] = '-' || v.[cur]= '+' then 
+      is_hex_format_ox v (cur + 1)
+    else is_hex_format_ox v cur 
+and is_hex_format_ox v cur = 
+  v.[cur] = '0' && 
+  (v.[cur + 1] = 'x' || v.[cur + 1] = 'X')
+
+let is_hex_format (v : string) =   
+  try is_hex_format_aux v 0 with _ -> false
 
-let caml_float_literal_to_js_string v = 
+
+let caml_float_literal_to_js_string (v : string) : string = 
   let len = String.length v in
-  if len >= 2 && 
-    v.[0] = '0' &&
-    (v.[1] = 'x' || v.[1] = 'X') then  
-    assert false 
-   (* TODO: catchup when upgraded to 4.3 
-      it does not make sense too much since js dos not 
-      support it natively
-    *)    
-  else    
 
     let rec aux buf i = 
       if i >= len then buf
@@ -83762,11 +83764,11 @@ and expression_desc cxt (level:int) f x : cxt  =
   | Number v ->
     let s =
       match v with
-      | Float {f = v} ->
-        Js_number.caml_float_literal_to_js_string v
+      | Float {f} ->
+        Js_number.caml_float_literal_to_js_string f
       (* attach string here for float constant folding?*)
-      | Int { i = v; _}
-        -> Int32.to_string v (* check , js convention with ocaml lexical convention *)
+      | Int { i; _}
+        -> Int32.to_string i (* check , js convention with ocaml lexical convention *)
       | Uint i
         -> Format.asprintf "%lu" i
       | Nint i -> Nativeint.to_string i in
@@ -83776,7 +83778,8 @@ and expression_desc cxt (level:int) f x : cxt  =
       else level = 15  (* Parenthesize as well when followed by a dot. *)
            && s.[0] <> 'I' (* Infinity *)
            && s.[0] <> 'N' (* NaN *) in
-    let action = fun _ -> P.string f s  in
+    let action = 
+      fun _ -> P.string f s  in
     (
       if need_paren
       then P.paren f  action
@@ -95390,7 +95393,7 @@ let translate loc (prim_name : string)
 
       end
     | "caml_format_float"
-
+    
     | "caml_nativeint_format"
     | "caml_int32_format"
     | "caml_float_of_string"