Yet another batch of tests

ml-proto/host/lexer.mll

@@ -88,18 +88,19 @@ let escape = ['n''t''\\''\'''\"']
 let character =
   [^'"''\\''\x00'-'\x1f''\x7f'] | '\\'escape | '\\'hexdigit hexdigit
 
-let sign = ('+' | '-')?
-let num = sign digit+
-let hexnum = sign "0x" hexdigit+
-let int = num | hexnum
+let sign = ('+' | '-')
+let num = digit+
+let hexnum = "0x" hexdigit+
+let nat = num | hexnum
+let int = sign nat
 let float =
-    (num '.' digit*)
-  | num ('.' digit*)? ('e' | 'E') num
-  | sign "0x" hexdigit+ '.'? hexdigit* 'p' sign digit+
-  | sign "inf"
-  | sign "infinity"
-  | sign "nan"
-  | sign "nan:0x" hexdigit+
+    sign? num '.' digit*
+  | sign? num ('.' digit*)? ('e' | 'E') sign? num
+  | sign? "0x" hexdigit+ '.'? hexdigit* 'p' sign? digit+
+  | sign? "inf"
+  | sign? "infinity"
+  | sign? "nan"
+  | sign? "nan:0x" hexdigit+
 let text = '"' character* '"'
 let name = '$' (letter | digit | '_' | tick | symbol)+
 
@@ -115,6 +116,7 @@ let mem_size = "8" | "16" | "32"
 rule token = parse
   | "(" { LPAR }
   | ")" { RPAR }
+  | nat as s { NAT s }
   | int as s { INT s }
   | float as s { FLOAT s }
   | text as s { TEXT (text s) }

ml-proto/host/parser.mly

@@ -124,7 +124,7 @@ let implicit_decl c t at =
 
 %}
 
-%token INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR
+%token NAT INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR
 %token NOP BLOCK IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE
 %token CALL CALL_IMPORT CALL_INDIRECT RETURN
 %token GET_LOCAL SET_LOCAL LOAD STORE OFFSET ALIGN
@@ -136,6 +136,7 @@ let implicit_decl c t at =
 %token INPUT OUTPUT
 %token EOF
 
+%token<string> NAT
 %token<string> INT
 %token<string> FLOAT
 %token<string> TEXT
@@ -190,12 +191,13 @@ func_type :
 /* Expressions */
 
 literal :
+  | NAT { $1 @@ at () }
   | INT { $1 @@ at () }
   | FLOAT { $1 @@ at () }
 ;
 
 var :
-  | INT { let at = at () in fun c lookup -> int_of_string $1 @@ at }
+  | NAT { let at = at () in fun c lookup -> int_of_string $1 @@ at }
   | VAR { let at = at () in fun c lookup -> lookup c ($1 @@ at) @@ at }
 ;
 var_list :
@@ -345,7 +347,7 @@ start :
     { fun c -> $3 c func }
 
 segment :
-  | LPAR SEGMENT INT text_list RPAR
+  | LPAR SEGMENT NAT text_list RPAR
     { {Memory.addr = Int64.of_string $3; Memory.data = $4} @@ at () }
 ;
 segment_list :
@@ -354,10 +356,10 @@ segment_list :
 ;
 
 memory :
-  | LPAR MEMORY INT INT segment_list RPAR
+  | LPAR MEMORY NAT NAT segment_list RPAR
     { {min = Int64.of_string $3; max = Int64.of_string $4; segments = $5}
         @@ at () }
-  | LPAR MEMORY INT segment_list RPAR
+  | LPAR MEMORY NAT segment_list RPAR
     { {min = Int64.of_string $3; max = Int64.of_string $3; segments = $4}
         @@ at () }
 ;

ml-proto/spec/check.ml

@@ -225,9 +225,9 @@ let rec check_expr c et e =
     check_type out et e.at
 
 and check_exprs c ts es at =
+  require (List.length ts = List.length es) at "arity mismatch";
   let ets = List.map (fun x -> Some x) ts in
-  try List.iter2 (check_expr c) ets es
-  with Invalid_argument _ -> error at "arity mismatch"
+  List.iter2 (check_expr c) ets es
 
 and check_expr_opt c et eo at =
   match eo with

ml-proto/test/br.wast

@@ -362,4 +362,3 @@
   (module (func $large-label (br 0x100000001)))
   "unknown label"
 )
-

ml-proto/test/call.wast

@@ -0,0 +1,255 @@
+;; Test `call` operator
+
+(module
+  ;; Auxiliary definitions
+  (func $const-i32 (result i32) (i32.const 0x132))
+  (func $const-i64 (result i64) (i64.const 0x164))
+  (func $const-f32 (result f32) (f32.const 0xf32))
+  (func $const-f64 (result f64) (f64.const 0xf64))
+
+  (func $id-i32 (param i32) (result i32) (get_local 0))
+  (func $id-i64 (param i64) (result i64) (get_local 0))
+  (func $id-f32 (param f32) (result f32) (get_local 0))
+  (func $id-f64 (param f64) (result f64) (get_local 0))
+
+  (func $f32-i32 (param f32 i32) (result i32) (get_local 1))
+  (func $i32-i64 (param i32 i64) (result i64) (get_local 1))
+  (func $f64-f32 (param f64 f32) (result f32) (get_local 1))
+  (func $i64-f64 (param i64 f64) (result f64) (get_local 1))
+
+  ;; Typing
+
+  (func "type-i32" (result i32) (call $const-i32))
+  (func "type-i64" (result i64) (call $const-i64))
+  (func "type-f32" (result f32) (call $const-f32))
+  (func "type-f64" (result f64) (call $const-f64))
+
+  (func "type-first-i32" (result i32) (call $id-i32 (i32.const 32)))
+  (func "type-first-i64" (result i64) (call $id-i64 (i64.const 64)))
+  (func "type-first-f32" (result f32) (call $id-f32 (f32.const 1.32)))
+  (func "type-first-f64" (result f64) (call $id-f64 (f64.const 1.64)))
+
+  (func "type-second-i32" (result i32)
+    (call $f32-i32 (f32.const 32.1) (i32.const 32))
+  )
+  (func "type-second-i64" (result i64)
+    (call $i32-i64 (i32.const 32) (i64.const 64))
+  )
+  (func "type-second-f32" (result f32)
+    (call $f64-f32 (f64.const 64) (f32.const 32))
+  )
+  (func "type-second-f64" (result f64)
+    (call $i64-f64 (i64.const 64) (f64.const 64.1))
+  )
+
+  ;; Recursion
+
+  (func "fac" $fac (param i64) (result i64)
+    (if (i64.eqz (get_local 0))
+      (i64.const 1)
+      (i64.mul (get_local 0) (call $fac (i64.sub (get_local 0) (i64.const 1))))
+    )
+  )
+
+  (func "fac-acc" $fac-acc (param i64 i64) (result i64)
+    (if (i64.eqz (get_local 0))
+      (get_local 1)
+      (call $fac-acc
+        (i64.sub (get_local 0) (i64.const 1))
+        (i64.mul (get_local 0) (get_local 1))
+      )
+    )
+  )
+
+  (func "fib" $fib (param i64) (result i64)
+    (if (i64.le_u (get_local 0) (i64.const 1))
+      (i64.const 1)
+      (i64.add
+        (call $fib (i64.sub (get_local 0) (i64.const 2)))
+        (call $fib (i64.sub (get_local 0) (i64.const 1)))
+      )
+    )
+  )
+
+  (func "even" $even (param i64) (result i32)
+    (if (i64.eqz (get_local 0))
+      (i32.const 44)
+      (call $odd (i64.sub (get_local 0) (i64.const 1)))
+    )
+  )
+  (func "odd" $odd (param i64) (result i32)
+    (if (i64.eqz (get_local 0))
+      (i32.const 99)
+      (call $even (i64.sub (get_local 0) (i64.const 1)))
+    )
+  )
+
+  ;; Stack exhaustion
+
+  ;; Implementations are required to have every call consume some abstract
+  ;; resource towards exhausting some abstract finite limit, such that
+  ;; infinitely recursive test cases reliably trap in finite time. This is
+  ;; because otherwise applications could come to depend on it on those
+  ;; implementations and be incompatible with implementations that don't do
+  ;; it (or don't do it under the same circumstances).
+
+  (func "runaway" $runaway (call $runaway))
+
+  (func "mutual-runaway" $mutual-runaway1 (call $mutual-runaway2))
+  (func $mutual-runaway2 (call $mutual-runaway1))
+)
+
+(assert_return (invoke "type-i32") (i32.const 0x132))
+(assert_return (invoke "type-i64") (i64.const 0x164))
+(assert_return (invoke "type-f32") (f32.const 0xf32))
+(assert_return (invoke "type-f64") (f64.const 0xf64))
+
+(assert_return (invoke "type-first-i32") (i32.const 32))
+(assert_return (invoke "type-first-i64") (i64.const 64))
+(assert_return (invoke "type-first-f32") (f32.const 1.32))
+(assert_return (invoke "type-first-f64") (f64.const 1.64))
+
+(assert_return (invoke "type-second-i32") (i32.const 32))
+(assert_return (invoke "type-second-i64") (i64.const 64))
+(assert_return (invoke "type-second-f32") (f32.const 32))
+(assert_return (invoke "type-second-f64") (f64.const 64.1))
+
+(assert_return (invoke "fac" (i64.const 0)) (i64.const 1))
+(assert_return (invoke "fac" (i64.const 1)) (i64.const 1))
+(assert_return (invoke "fac" (i64.const 5)) (i64.const 120))
+(assert_return (invoke "fac" (i64.const 25)) (i64.const 7034535277573963776))
+(assert_return (invoke "fac-acc" (i64.const 0) (i64.const 1)) (i64.const 1))
+(assert_return (invoke "fac-acc" (i64.const 1) (i64.const 1)) (i64.const 1))
+(assert_return (invoke "fac-acc" (i64.const 5) (i64.const 1)) (i64.const 120))
+(assert_return
+  (invoke "fac-acc" (i64.const 25) (i64.const 1))
+  (i64.const 7034535277573963776)
+)
+
+(assert_return (invoke "fib" (i64.const 0)) (i64.const 1))
+(assert_return (invoke "fib" (i64.const 1)) (i64.const 1))
+(assert_return (invoke "fib" (i64.const 2)) (i64.const 2))
+(assert_return (invoke "fib" (i64.const 5)) (i64.const 8))
+(assert_return (invoke "fib" (i64.const 20)) (i64.const 10946))
+
+(assert_return (invoke "even" (i64.const 0)) (i32.const 44))
+(assert_return (invoke "even" (i64.const 1)) (i32.const 99))
+(assert_return (invoke "even" (i64.const 100)) (i32.const 44))
+(assert_return (invoke "even" (i64.const 77)) (i32.const 99))
+(assert_return (invoke "odd" (i64.const 0)) (i32.const 99))
+(assert_return (invoke "odd" (i64.const 1)) (i32.const 44))
+(assert_return (invoke "odd" (i64.const 200)) (i32.const 99))
+(assert_return (invoke "odd" (i64.const 77)) (i32.const 44))
+
+(assert_trap (invoke "runaway") "call stack exhausted")
+(assert_trap (invoke "mutual-runaway") "call stack exhausted")
+
+
+;; Invalid typing
+
+(assert_invalid
+  (module
+    (func $type-void-vs-num (i32.eqz (call 1)))
+    (func)
+  )
+  "type mismatch"
+)
+(assert_invalid
+  (module
+    (func $type-num-vs-num (i32.eqz (call 1)))
+    (func (result i64) (i64.const 1))
+  )
+  "type mismatch"
+)
+
+(assert_invalid
+  (module
+    (func $arity-0-vs-1 (call 1))
+    (func (param i32))
+  )
+  "arity mismatch"
+)
+(assert_invalid
+  (module
+    (func $arity-0-vs-2 (call 1))
+    (func (param f64 i32))
+  )
+  "arity mismatch"
+)
+(assert_invalid
+  (module
+    (func $arity-1-vs-0 (call 1 (i32.const 1)))
+    (func)
+  )
+  "arity mismatch"
+)
+(assert_invalid
+  (module
+    (func $arity-2-vs-0 (call 1 (f64.const 2) (i32.const 1)))
+    (func)
+  )
+  "arity mismatch"
+)
+
+(assert_invalid
+  (module
+    (func $arity-nop-first (call 1 (nop) (i32.const 1) (i32.const 2)))
+    (func (param i32 i32))
+  )
+  "arity mismatch"
+)
+(assert_invalid
+  (module
+    (func $arity-nop-mid (call 1 (i32.const 1) (nop) (i32.const 2)))
+    (func (param i32 i32))
+  )
+  "arity mismatch"
+)
+(assert_invalid
+  (module
+    (func $arity-nop-last (call 1 (i32.const 1) (i32.const 2) (nop)))
+    (func (param i32 i32))
+  )
+  "arity mismatch"
+)
+
+(assert_invalid
+  (module
+    (func $type-first-void-vs-num (call 1 (nop) (i32.const 1)))
+    (func (param i32 i32))
+  )
+  "type mismatch"
+)
+(assert_invalid
+  (module
+    (func $type-second-void-vs-num (call 1 (i32.const 1) (nop)))
+    (func (param i32 i32))
+  )
+  "type mismatch"
+)
+(assert_invalid
+  (module
+    (func $type-first-num-vs-num (call 1 (f64.const 1) (i32.const 1)))
+    (func (param i32 f64))
+  )
+  "type mismatch"
+)
+(assert_invalid
+  (module
+    (func $type-second-num-vs-num (call 1 (i32.const 1) (f64.const 1)))
+    (func (param f64 i32))
+  )
+  "type mismatch"
+)
+
+
+;; Unbound function
+
+(assert_invalid
+  (module (func $unbound-func (call 1)))
+  "unknown function"
+)
+(assert_invalid
+  (module (func $large-func (call 10001232130000)))
+  "unknown function"
+)