Merge pull request #110 from ocaml-wasm/float_of_string

Stricter float_of_string
ocsigen · Oct 24, 2024 · 102f8dd · 102f8dd
2 parents 15bea92 + 48c22c6
commit 102f8dd
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 8 deletions.
diff --git a/compiler/tests-jsoo/test_floats.ml b/compiler/tests-jsoo/test_floats.ml
@@ -177,10 +177,38 @@ let%expect_test "log2" =
   p 1024.0;
   [%expect {| 10.000000 |}]
 
+let print' f = try print (f ()) with e -> print_endline (Printexc.to_string e)
+
 let%expect_test "of_string" =
   let x = "0x1.1" in
-  print (float_of_string x);
+  print' (fun () -> float_of_string x);
   [%expect {| 1.062500 |}];
   let x = "0x1.1p-1" in
-  print (float_of_string x);
-  [%expect {| 0.531250 |}]
+  print' (fun () -> float_of_string x);
+  [%expect {| 0.531250 |}];
+  let x = "  0x1.1" in
+  print' (fun () -> float_of_string x);
+  [%expect {| 1.062500 |}];
+  let x = "  0x1.1 " in
+  print' (fun () -> float_of_string x);
+  [%expect {| Failure("float_of_string") |}];
+  let x = "0x1.1 p-1" in
+  print' (fun () -> float_of_string x);
+  [%expect {| Failure("float_of_string") |}]
+
+let%expect_test "of_string" =
+  let x = "3.14" in
+  print' (fun () -> float_of_string x);
+  [%expect {| 3.140000 |}];
+  let x = " 3.14" in
+  print' (fun () -> float_of_string x);
+  [%expect {| 3.140000 |}];
+  let x = "3. 14" in
+  print' (fun () -> float_of_string x);
+  [%expect {| Failure("float_of_string") |}];
+  let x = "3.1 4" in
+  print' (fun () -> float_of_string x);
+  [%expect {| Failure("float_of_string") |}];
+  let x = "3.14 " in
+  print' (fun () -> float_of_string x);
+  [%expect {| Failure("float_of_string") |}]
diff --git a/runtime/ieee_754.js b/runtime/ieee_754.js
@@ -567,13 +567,16 @@ function caml_format_float(fmt, x) {
 //Requires: caml_failwith, caml_jsbytes_of_string
 function caml_float_of_string(s) {
   var res;
+  var r_float = /^ *[-+]?(?:\d*\.?\d+|\d+\.?\d*)(?:[eE][-+]?\d+)?$/;
   s = caml_jsbytes_of_string(s);
   res = +s;
-  if (s.length > 0 && res === res) return res;
+  //Fast path
+  if (!Number.isNaN(res) && r_float.test(s)) return res;
   s = s.replace(/_/g, "");
   res = +s;
-  if ((s.length > 0 && res === res) || /^[+-]?nan$/i.test(s)) return res;
-  var m = /^ *([+-]?)0x([0-9a-f]+)\.?([0-9a-f]*)(p([+-]?[0-9]+))?/i.exec(s);
+  if ((!Number.isNaN(res) && r_float.test(s)) || /^[+-]?nan$/i.test(s))
+    return res;
+  var m = /^ *([+-]?)0x([0-9a-f]+)\.?([0-9a-f]*)(p([+-]?[0-9]+))?$/i.exec(s);
   //          1        2             3           5
   if (m) {
     var m3 = m[3].replace(/0+$/, "");

diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat
@@ -483,6 +483,12 @@
          (array.new_data $string $float_of_string (i32.const 0) (i32.const 15)))
       (f64.const 0))
 
+   (func $on_whitespace (param $s (ref $string)) (param $i i32) (result i32)
+      (local $c i32)
+      (local.set $c (array.get_u $string (local.get $s) (local.get $i)))
+      (i32.or (i32.eq (local.get $c) (i32.const 32)) ;; ' '
+         (i32.le_u (i32.sub (local.get $c) (i32.const 9)) (i32.const 4))))
+
    (func (export "caml_float_of_string") (param (ref eq)) (result (ref eq))
       (local $s (ref $string)) (local $len i32) (local $i i32) (local $j i32)
       (local $s' (ref $string))
@@ -525,13 +531,15 @@
       (loop $skip_spaces
          (if (i32.lt_u (local.get $i) (local.get $len))
             (then
-               (if (i32.eq (i32.const 32) ;; ' '
-                           (array.get_u $string (local.get $s) (local.get $i)))
+               (if (call $on_whitespace (local.get $s) (local.get $i))
                   (then
                      (local.set $i (i32.add (local.get $i) (i32.const 1)))
                      (br $skip_spaces))))))
       (block $error
          (br_if $error (i32.eq (local.get $i) (local.get $len)))
+         (br_if $error
+            (call $on_whitespace
+               (local.get $s) (i32.sub (local.get $len) (i32.const 1))))
          (local.set $c (array.get_u $string (local.get $s) (i32.const 0)))
          (if (i32.eq (local.get $c) (i32.const 45)) ;; '-'
             (then