promote broken tests

example/lib/README.md

@@ -5,13 +5,14 @@
 Given a file `quickstart.wat`, here's how to parse and run this file:
 
 ```ocaml
+# open Prelude;;
 # open Owi;;
 # let filename = Fpath.v "quickstart.wat";;
 val filename : Fpath.t = <abstr>
 # let m =
     match Parse.Text.Module.from_file filename with
     | Ok script -> script
-    | Error e -> Result.failwith e;;
+    | Error e -> assert false;;
 val m : Text.modul =
 ...
 # let module_to_run, link_state =

example/lib/dune

@@ -1,4 +1,4 @@
 (mdx
- (libraries fpath owi)
+ (libraries fpath owi prelude)
  (deps %{bin:owi} quickstart.wat)
  (files README.md))

src/ast/text.ml

@@ -118,8 +118,8 @@ type result_const =
 
 let pp_result_const fmt = function
   | Literal c -> pp_const fmt c
-  | Nan_canon n -> pf fmt "float%a.const nan:canonical" pp_nn n
-  | Nan_arith n -> pf fmt "float%a.const nan:arithmetic" pp_nn n
+  | Nan_canon n -> pf fmt "f%a.const nan:canonical" pp_nn n
+  | Nan_arith n -> pf fmt "f%a.const nan:arithmetic" pp_nn n
 
 type result =
   | Result_const of result_const

src/ast/types.ml

@@ -26,6 +26,8 @@ type text = < with_string_indices ; with_ind_bt >
 
 type binary = < without_string_indices ; without_ind_bt >
 
+let sp ppf () = Fmt.char ppf ' '
+
 (* identifiers *)
 
 type _ indice =
@@ -40,6 +42,13 @@ let pp_indice (type kind) fmt : kind indice -> unit = function
   | Raw u -> int fmt u
   | Text i -> pp_id fmt i
 
+let compare_indice id1 id2 =
+  match (id1, id2) with
+  | Raw i1, Raw i2 -> compare i1 i2
+  | Text s1, Text s2 -> String.compare s1 s2
+  | Raw _, Text _ -> -1
+  | Text _, Raw _ -> 1
+
 let pp_indice_opt fmt = function None -> () | Some i -> pp_indice fmt i
 
 let pp_indices fmt ids = list ~sep:sp pp_indice fmt ids
@@ -62,12 +71,8 @@ let num_type_eq t1 t2 =
   | _, _ -> false
 
 let compare_num_type t1 t2 =
-  match (t1, t2) with
-  | I32, I32 | I64, I64 | F32, F32 | F64, F64 -> 0
-  | I32, _ -> 1
-  | I64, _ -> 1
-  | F32, _ -> 1
-  | F64, _ -> 1
+  let to_int = function I32 -> 0 | I64 -> 1 | F32 -> 2 | F64 -> 3 in
+  compare (to_int t1) (to_int t2)
 
 type nullable =
   | No_null
@@ -312,6 +317,23 @@ let heap_type_eq t1 t2 =
   | Def_ht _, Def_ht _ -> assert false
   | _, _ -> false
 
+let compare_heap_type t1 t2 =
+  (* TODO: this is wrong *)
+  let to_int = function
+    | Any_ht -> 0
+    | None_ht -> 1
+    | Eq_ht -> 2
+    | I31_ht -> 3
+    | Struct_ht -> 4
+    | Array_ht -> 5
+    | Func_ht -> 6
+    | No_func_ht -> 7
+    | Extern_ht -> 8
+    | No_extern_ht -> 9
+    | Def_ht _ -> assert false
+  in
+  Int.compare (to_int t1) (to_int t2)
+
 type nonrec 'a ref_type = nullable * 'a heap_type
 
 let pp_ref_type fmt (n, ht) =
@@ -324,7 +346,12 @@ let ref_type_eq t1 t2 =
   | (Null, t1), (Null, t2) | (No_null, t1), (No_null, t2) -> heap_type_eq t1 t2
   | _ -> false
 
-let compare_ref_type _ _ = assert false
+let compare_ref_type t1 t2 =
+  match (t1, t2) with
+  | (Null, t1), (Null, t2) | (No_null, t1), (No_null, t2) ->
+    compare_heap_type t1 t2
+  | (Null, _), (No_null, _) -> -1
+  | (No_null, _), (Null, _) -> 1
 
 type nonrec 'a val_type =
   | Num_type of num_type
@@ -553,7 +580,7 @@ type 'a instr =
 
 and 'a expr = 'a instr list
 
-let pp_newline ppf () = string ppf "@\n"
+let pp_newline ppf () = pf ppf "@\n"
 
 let rec pp_instr fmt = function
   | I32_const i -> pf fmt "i32.const %ld" i

src/cmd/cmd_conc.ml

@@ -431,18 +431,7 @@ let cmd profiling debug unsafe optimize _workers _no_stop_at_failure no_values
 
   let testcase model =
     if not no_values then
-      let testcase =
-        let compare_pair fx fy (x1, y1) (x2, y2) =
-          let cx = fx x1 x2 in
-          if cx = 0 then fy y1 y2 else cx
-        in
-        (* TODO: add a function for this in smtml *)
-        (* TODO: merge this code with cmd_sym, it's almost the same.. *)
-        List.sort
-          (compare_pair Smtml.Symbol.compare Smtml.Value.compare)
-          (Smtml.Model.get_bindings model)
-        |> List.map snd
-      in
+      let testcase = Smtml.Model.get_bindings model |> List.map snd in
       Cmd_utils.write_testcase ~dir:workspace testcase
     else Ok ()
   in

src/cmd/cmd_sym.ml

@@ -101,17 +101,7 @@ let cmd profiling debug unsafe optimize workers no_stop_at_failure no_values
       let count_acc = succ count_acc in
       let* () =
         if not no_values then
-          let testcase =
-            let compare_pair fx fy (x1, y1) (x2, y2) =
-              let cx = fx x1 x2 in
-              if cx = 0 then fy y1 y2 else cx
-            in
-            (* TODO: add a function for this in smtml *)
-            List.sort
-              (compare_pair Smtml.Symbol.compare Smtml.Value.compare)
-              (Smtml.Model.get_bindings model)
-            |> List.map snd
-          in
+          let testcase = Smtml.Model.get_bindings model |> List.map snd in
           Cmd_utils.write_testcase ~dir:workspace testcase
         else Ok ()
       in

src/parser/text_lexer.ml

@@ -455,6 +455,7 @@ let rec token buf =
     NAME name
   | eof -> EOF
   (* | "" -> EOF *)
+  | any -> unexpected_character buf
   | _ -> unexpected_character buf
 
 and comment buf =

src/parser/text_parser.mly

@@ -33,23 +33,23 @@ let failwith msg = raise @@ Parse_fail msg
 
 let u32 s =
   try Unsigned.UInt32.to_int (Unsigned.UInt32.of_string s)
-  with Failure _msg -> failwith "constant out of range"
+  with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg
 
 let i32 s =
   try Int32.of_string s
-  with Failure _msg -> failwith "constant out of range"
+  with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg
 
 let i64 s =
   try Int64.of_string s
-  with Failure _msg -> failwith "constant out of range"
+  with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg
 
 let f64 s =
   try Float64.of_string s
-  with Failure _msg -> failwith "constant out of range"
+  with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg
 
 let f32 s =
   try Float32.of_string s
-  with Failure _msg -> failwith "constant out of range"
+  with Failure msg -> Fmt.kstr failwith "constant out of range %s (%s)" s msg
 
 %}
 
@@ -543,19 +543,24 @@ let call_instr_results_instr_list :=
 
 let block_instr ==
   | BLOCK; id = option(id); (bt, es) = block; END; id2 = option(id); {
-    if not @@ Option.equal String.equal id id2 then Fmt.failwith "mismatching label";
+    if Option.is_some id2 && not @@ Option.equal String.equal id id2
+    then failwith "mismatching label";
     Block (id, bt, es)
   }
   | LOOP; id = option(id); (bt, es) = block; END; id2 = option(id); {
-    if not @@ Option.equal String.equal id id2 then Fmt.failwith "mismatching label";
+    if Option.is_some id2 && not @@ Option.equal String.equal id id2
+    then failwith "mismatching label";
     Loop (id, bt, es)
   }
   | IF; id = option(id); (bt, es) = block; END; id2 = option(id); {
-    if not @@ Option.equal String.equal id id2 then Fmt.failwith "mismatching label";
+    if Option.is_some id2 && not @@ Option.equal String.equal id id2
+    then failwith "mismatching label";
     If_else (id, bt, es, [])
   }
   | IF; id = option(id); (bt, es1) = block; ELSE; id2 = option(id); ~ = instr_list; END; id3 = option(id); {
-    if not @@ Option.equal String.equal id id2 || not @@ Option.equal String.equal id id3 then Fmt.failwith "mismatching label";
+    if (Option.is_some id2 && not @@ Option.equal String.equal id id2)
+    || (Option.is_some id3 && not @@ Option.equal String.equal id id3)
+    then failwith "mismatching label";
     If_else (id, bt, es1, instr_list)
   }
 

src/primitives/convert.ml

@@ -18,7 +18,7 @@ module MInt32 = struct
       if
         let xf = Float64.of_float xf in
         let mif = Int32.(to_float min_int) in
-        Float64.(ge xf (of_float ~-.mif)) || Float64.(le xf (of_float mif))
+        Float64.(ge xf (of_float ~-.mif)) || Float64.(lt xf (of_float mif))
       then raise @@ Types.Trap "integer overflow"
       else Int32.of_float xf
 
@@ -29,7 +29,7 @@ module MInt32 = struct
       if
         let xf = Float64.of_float xf in
         Float64.(ge xf (of_float @@ (-.Int32.(to_float min_int) *. 2.0)))
-        || Float64.(ge xf (Float64.of_float ~-.1.0))
+        || Float64.(le xf (Float64.of_float ~-.1.0))
       then raise @@ Types.Trap "integer overflow"
       else Int64.(to_int32 (of_float xf))
 
@@ -45,8 +45,8 @@ module MInt32 = struct
   let trunc_f64_u x =
     if Float64.ne x x then raise @@ Types.Trap "invalid conversion to integer"
     else if
-      Float64.(
-        ge x (mul (of_float @@ -.Int32.(to_float min_int)) (of_float 2.0)) )
+      let mif = Int32.to_float Int32.min_int in
+      Float64.(ge x (of_float @@ (-.mif *. 2.0)))
       || Float64.(le x (of_float ~-.1.0))
     then raise @@ Types.Trap "integer overflow"
     else Int64.(to_int32 (of_float (Float64.to_float x)))
@@ -109,7 +109,7 @@ module MInt64 = struct
       Float32.(ge x @@ of_float ~-.(mif *. 2.0))
       || Float32.(le x @@ of_float ~-.1.0)
     then raise @@ Types.Trap "integer overflow"
-    else if Float32.(le x @@ of_float ~-.mif) then
+    else if Float32.(ge x @@ of_float ~-.mif) then
       Int64.(logxor (of_float (Float32.to_float x -. 0x1p63)) min_int)
     else Int64.of_float @@ Float32.to_float x
 
@@ -146,7 +146,7 @@ module MInt64 = struct
       let mif = Int64.(to_float min_int) in
       if Float32.(le x @@ of_float ~-.1.0) then 0L
       else if Float32.(ge x @@ of_float (~-.mif *. 2.0)) then -1L
-      else if Float32.(le x @@ of_float ~-.mif) then
+      else if Float32.(ge x @@ of_float ~-.mif) then
         Int64.(
           logxor
             (of_float (Float32.to_float x -. 9223372036854775808.0))

src/primitives/float32.ml

@@ -163,25 +163,38 @@ let copy_sign x y = Int32.logor (abs x) (Int32.logand y Int32.min_int)
 let eq x y =
   let x = to_float x in
   let y = to_float y in
-  Float.compare x y = 0 && (not @@ Float.is_nan x)
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y = 0
 
-let ne x y = Float.compare (to_float x) (to_float y) <> 0
+let ne x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then true else Float.compare x y <> 0
 
-let lt x y = Float.compare (to_float x) (to_float y) < 0
+let lt x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y < 0
 
-let gt x y = Float.compare (to_float x) (to_float y) > 0
+let gt x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y > 0
 
-let le x y = Float.compare (to_float x) (to_float y) <= 0
+let le x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y <= 0
 
-let ge x y = Float.compare (to_float x) (to_float y) >= 0
+let ge x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y >= 0
 
 (*
  * Compare mantissa of two floats in string representation (hex or dec).
  * This is a gross hack to detect rounding during parsing of floats.
  *)
-let is_hex c =
-  (Char.compare '0' c <= 0 && Char.compare c '9' <= 0)
-  || (Char.compare 'A' c <= 0 && Char.compare c 'F' <= 0)
+let is_hex = function '0' .. '9' -> true | 'A' .. 'F' -> true | _ -> false
 
 let is_exp hex c = Char.compare c (if hex then 'P' else 'E') = 0
 
@@ -280,7 +293,7 @@ let of_signless_string s =
     if Int32.eq x Int32.zero then Fmt.failwith "nan payload must not be zero"
     else if Int32.ne (Int32.logand x bare_nan) Int32.zero then
       Fmt.failwith "nan payload must not overlap with exponent bits"
-    else if Int32.ne x Int32.zero then
+    else if Int32.lt x Int32.zero then
       Fmt.failwith "nan payload must not overlap with sign bit"
     else Int32.logor x bare_nan
   else

src/primitives/float64.ml

@@ -77,11 +77,11 @@ let binary x op y =
   let xf = to_float x in
   let yf = to_float y in
   let t = op xf yf in
-  if Float.is_nan t then of_float t else determine_binary_nan x y
+  if not @@ Float.is_nan t then of_float t else determine_binary_nan x y
 
 let unary op x =
   let t = op (to_float x) in
-  if Float.is_nan t then of_float t else determine_unary_nan x
+  if not @@ Float.is_nan t then of_float t else determine_unary_nan x
 
 let zero = of_float 0.0
 
@@ -157,17 +157,35 @@ let neg x = Int64.logxor x Int64.min_int
 
 let copy_sign x y = Int64.logor (abs x) (Int64.logand y Int64.min_int)
 
-let eq x y = Float.compare (to_float x) (to_float y) = 0
-
-let ne x y = Float.compare (to_float x) (to_float y) <> 0
-
-let lt x y = Float.compare (to_float x) (to_float y) < 0
-
-let gt x y = Float.compare (to_float x) (to_float y) > 0
-
-let le x y = Float.compare (to_float x) (to_float y) <= 0
-
-let ge x y = Float.compare (to_float x) (to_float y) >= 0
+let eq x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y = 0
+
+let ne x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then true else Float.compare x y <> 0
+
+let lt x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y < 0
+
+let gt x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y > 0
+
+let le x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y <= 0
+
+let ge x y =
+  let x = to_float x in
+  let y = to_float y in
+  if Float.is_nan x || Float.is_nan y then false else Float.compare x y >= 0
 
 (*
  * Compare mantissa of two floats in string representation (hex or dec).

src/primitives/int32.ml

@@ -37,9 +37,9 @@ let lt (x : int32) y = compare x y < 0
 
 let gt (x : int32) y = compare x y > 0
 
-let le (x : int32) y = compare x y >= 0
+let le (x : int32) y = compare x y <= 0
 
-let ge (x : int32) y = compare x y <= 0
+let ge (x : int32) y = compare x y >= 0
 
 let lt_u x y = cmp_u x lt y