Distinguish different categories of errors

ml-proto/host/builtins.ml

@@ -2,6 +2,9 @@ open Source
 open Types
 open Ast
 
+module Unknown = Error.Make ()
+exception Unknown = Unknown.Error  (* indicates unknown import name *)
+
 let print vs =
   List.iter Print.print_value (List.map (fun v -> Some v) vs);
   None
@@ -10,14 +13,14 @@ let match_import m i =
   let {module_name; func_name; itype} = i.it in
   let {ins; out} = List.nth m.it.types itype.it in
   if module_name <> "stdio" then
-    Error.error i.at ("no builtin module \"" ^ module_name ^ "\"");
+    Unknown.error i.at ("no module \"" ^ module_name ^ "\"");
   match func_name with
   | "print" ->
     if out <> None then
-      Error.error i.at "stdio.print has no result";
+      Unknown.error i.at "stdio.print has no result";
     print
   | _ ->
-    Error.error i.at ("no \"stdio." ^ func_name ^ "\"")
+    Unknown.error i.at ("no function \"stdio." ^ func_name ^ "\"")
 
 let match_imports m =
   List.map (match_import m) m.it.imports

ml-proto/host/builtins.mli

@@ -1 +1,3 @@
-val match_imports : Ast.module_ -> Eval.import list
+exception Unknown of Source.region * string
+
+val match_imports : Ast.module_ -> Eval.import list (* raises Unknown *)

ml-proto/host/lexer.mll

@@ -17,10 +17,10 @@ let region lexbuf =
   let right = convert_pos (Lexing.lexeme_end_p lexbuf) in 
   {Source.left = left; Source.right = right}
 
-let error lexbuf m = Error.error (region lexbuf) m
-let error_nest start lexbuf m =
+let error lexbuf msg = raise (Script.Syntax (region lexbuf, msg))
+let error_nest start lexbuf msg =
   lexbuf.Lexing.lex_start_p <- start;
-  error lexbuf m
+  error lexbuf msg
 
 let convert_text s =
   let b = Buffer.create (String.length s) in

ml-proto/host/main.ml

@@ -22,11 +22,16 @@ let parse name source =
   let lexbuf = Lexing.from_string source in
   lexbuf.Lexing.lex_curr_p <-
     {lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = name};
-  try Parser.script Lexer.token lexbuf with Error.Error (region, s) ->
+  try Parser.script Lexer.token lexbuf with Script.Syntax (region, s) ->
     let region' = if region <> Source.no_region then region else
       {Source.left = Lexer.convert_pos lexbuf.Lexing.lex_start_p;
        Source.right = Lexer.convert_pos lexbuf.Lexing.lex_curr_p} in
-    raise (Error.Error (region', s))
+    raise (Script.Syntax (region', s))
+
+let error at category msg =
+  Script.trace ("Error (" ^ category ^ "): ");
+  prerr_endline (Source.string_of_region at ^ ": " ^ msg);
+  false
 
 let process file source =
   try
@@ -35,10 +40,13 @@ let process file source =
     Script.trace "Running...";
     Script.run script;
     true
-  with Error.Error (at, s) ->
-    Script.trace "Error:";
-    prerr_endline (Source.string_of_region at ^ ": " ^ s);
-    false
+  with
+  | Script.Syntax (at, msg) -> error at "syntax error" msg
+  | Script.AssertFailure (at, msg) -> error at "assertion failure" msg
+  | Check.Invalid (at, msg) -> error at "invalid module" msg
+  | Eval.Trap (at, msg) -> error at "runtime trap" msg
+  | Eval.Crash (at, msg) -> error at "runtime crash" msg
+  | Builtins.Unknown (at, msg) -> error at "unknown built-in" msg
 
 let process_file file =
   Script.trace ("Loading (" ^ file ^ ")...");

ml-proto/host/parser.mly

@@ -10,6 +10,13 @@ open Types
 open Script
 
 
+(* Error handling *)
+
+let error at msg = raise (Script.Syntax (at, msg))
+
+let parse_error msg = error Source.no_region msg
+
+
 (* Position handling *)
 
 let position_to_pos position =
@@ -28,8 +35,6 @@ let at () =
 let ati i =
   positions_to_region (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i)
 
-let parse_error s = Error.error Source.no_region s
-
 
 (* Literals *)
 
@@ -41,8 +46,8 @@ let literal s t =
     | Float32Type -> Values.Float32 (F32.of_string s.it) @@ s.at
     | Float64Type -> Values.Float64 (F64.of_string s.it) @@ s.at
   with
-    | Failure reason -> Error.error s.at ("constant out of range: " ^ reason)
-    | _ -> Error.error s.at "constant out of range"
+    | Failure msg -> error s.at ("constant out of range: " ^ msg)
+    | _ -> error s.at "constant out of range"
 
 
 (* Memory operands *)
@@ -87,28 +92,28 @@ let enter_func c =
 
 let type_ c x =
   try VarMap.find x.it c.types.tmap
-  with Not_found -> Error.error x.at ("unknown type " ^ x.it)
+  with Not_found -> error x.at ("unknown type " ^ x.it)
 
 let lookup category space x =
   try VarMap.find x.it space.map
-  with Not_found -> Error.error x.at ("unknown " ^ category ^ " " ^ x.it)
+  with Not_found -> error x.at ("unknown " ^ category ^ " " ^ x.it)
 
 let func c x = lookup "function" c.funcs x
 let import c x = lookup "import" c.imports x
 let local c x = lookup "local" c.locals x
 let label c x =
   try VarMap.find x.it c.labels
-  with Not_found -> Error.error x.at ("unknown label " ^ x.it)
+  with Not_found -> error x.at ("unknown label " ^ x.it)
 
 let bind_type c x ty =
   if VarMap.mem x.it c.types.tmap then
-    Error.error x.at ("duplicate type " ^ x.it);
+    error x.at ("duplicate type " ^ x.it);
   c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap;
   c.types.tlist <- c.types.tlist @ [ty]
 
 let bind category space x =
   if VarMap.mem x.it space.map then
-    Error.error x.at ("duplicate " ^ category ^ " " ^ x.it);
+    error x.at ("duplicate " ^ category ^ " " ^ x.it);
   space.map <- VarMap.add x.it space.count space.map;
   space.count <- space.count + 1
 
@@ -132,10 +137,12 @@ let empty_type = {ins = []; out = None}
 
 let explicit_decl c name t at =
   let x = name c type_ in
-  if x.it < List.length c.types.tlist &&
-     t <> empty_type &&
-     t <> List.nth c.types.tlist x.it then
-    Error.error at "signature mismatch";
+  if
+    x.it < List.length c.types.tlist &&
+    t <> empty_type &&
+    t <> List.nth c.types.tlist x.it
+  then
+    error at "signature mismatch";
   x
 
 let implicit_decl c t at =
@@ -323,8 +330,7 @@ func_fields :
     { {(fst $6) with ins = $4 :: (fst $6).ins},
       fun c -> bind_local c $3; (snd $6) c }
   | LPAR RESULT VALUE_TYPE RPAR func_fields
-    { if (fst $5).out <> None then
-        Error.error (at ()) "more than one return type";
+    { if (fst $5).out <> None then error (at ()) "multiple return types";
       {(fst $5) with out = Some $3},
       fun c -> (snd $5) c }
   | LPAR LOCAL value_type_list RPAR func_fields
@@ -437,7 +443,7 @@ module_fields :
   | memory module_fields
     { fun c -> let m = $2 c in
       match m.memory with
-      | Some _ -> Error.error $1.at "more than one memory section"
+      | Some _ -> error $1.at "multiple memory sections"
       | None -> {m with memory = Some $1} }
 ;
 module_ :

ml-proto/host/script.ml

@@ -21,35 +21,20 @@ type script = command list
 
 (* Execution *)
 
+module Syntax = Error.Make ()
+module AssertFailure = Error.Make ()
+
+exception Syntax = Syntax.Error
+exception AssertFailure = AssertFailure.Error  (* assert command failure *)
+
 let trace name = if !Flags.trace then print_endline ("-- " ^ name)
 
 let current_module : Eval.instance option ref = ref None
 
 let get_module at = match !current_module with
   | Some m -> m
-  | None -> Error.error at "no module defined to invoke"
-
-let show_value label v = begin
-  print_string (label ^ ": ");
-  Print.print_value v
-end
-
-let show_result got_v = begin
-  show_value "Result" got_v
-end
-
-let show_result_expect got_v expect_v = begin
-  show_result got_v;
-  show_value "Expect" expect_v
-end
-
-let assert_error f err re at =
-  match f () with
-  | exception Error.Error (_, s) ->
-    if not (Str.string_match (Str.regexp re) s 0) then
-      Error.error at ("failure \"" ^ s ^ "\" does not match: \"" ^ re ^ "\"")
-  | _ ->
-    Error.error at ("expected " ^ err)
+  | None -> raise (Eval.Crash (at, "no module defined to invoke"))
+
 
 let run_command cmd =
   match cmd.it with
@@ -76,73 +61,56 @@ let run_command cmd =
 
   | AssertInvalid (m, re) ->
     trace "Asserting invalid...";
-    assert_error (fun () -> Check.check_module m) "invalid module" re cmd.at
+    (match Check.check_module m with
+    | exception Check.Invalid (_, msg) ->
+      if not (Str.string_match (Str.regexp re) msg 0) then begin
+        print_endline ("Result: \"" ^ msg ^ "\"");
+        print_endline ("Expect: \"" ^ re ^ "\"");
+        AssertFailure.error cmd.at "wrong validation error"
+      end
+    | _ ->
+      AssertFailure.error cmd.at "expected validation error"
+    )
 
   | AssertReturn (name, es, expect_e) ->
-    let open Values in
     trace "Asserting return...";
     let m = get_module cmd.at in
     let got_v = Eval.invoke m name (List.map it es) in
     let expect_v = Lib.Option.map it expect_e in
-    (match got_v, expect_v with
-    | None, None -> ()
-    | Some (Int32 got_i32), Some (Int32 expect_i32) ->
-      if got_i32 <> expect_i32 then begin
-        show_result_expect got_v expect_v;
-        Error.error cmd.at "assert_return i32 operands are not equal"
-      end
-    | Some (Int64 got_i64), Some (Int64 expect_i64) ->
-      if got_i64 <> expect_i64 then begin
-        show_result_expect got_v expect_v;
-        Error.error cmd.at "assert_return i64 operands are not equal"
-      end
-    | Some (Float32 got_f32), Some (Float32 expect_f32) ->
-      if (F32.to_bits got_f32) <> (F32.to_bits expect_f32) then begin
-        show_result_expect got_v expect_v;
-        Error.error cmd.at
-          "assert_return f32 operands have different bit patterns"
-      end
-    | Some (Float64 got_f64), Some (Float64 expect_f64) ->
-      if (F64.to_bits got_f64) <> (F64.to_bits expect_f64) then begin
-        show_result_expect got_v expect_v;
-        Error.error cmd.at
-          "assert_return f64 operands have different bit patterns"
-      end
-    | _, _ ->
-      begin
-        show_result_expect got_v expect_v;
-        Error.error cmd.at "assert_return operands must be the same type"
-      end
-    )
+    if got_v <> expect_v then begin
+      print_string "Result: "; Print.print_value got_v;
+      print_string "Expect: "; Print.print_value expect_v;
+      AssertFailure.error cmd.at "wrong return value"
+    end
 
   | AssertReturnNaN (name, es) ->
-    let open Values in
     trace "Asserting return...";
     let m = get_module cmd.at in
     let got_v = Eval.invoke m name (List.map it es) in
-    (match got_v with
-    | Some (Float32 got_f32) ->
-      if (F32.eq got_f32 got_f32) then begin
-        show_result got_v;
-        Error.error cmd.at "assert_return_nan f32 operand is not a NaN"
-      end
-    | Some (Float64 got_f64) ->
-      if (F64.eq got_f64 got_f64) then begin
-        show_result got_v;
-        Error.error cmd.at "assert_return_nan f64 operand is not a NaN"
-      end
-    | _ ->
-      begin
-        show_result got_v;
-        Error.error cmd.at "assert_return_nan operand must be f32 or f64"
-      end
-    )
+    if
+      match got_v with
+      | Some (Values.Float32 got_f32) -> F32.eq got_f32 got_f32
+      | Some (Values.Float64 got_f64) -> F64.eq got_f64 got_f64
+      | _ -> true
+    then begin
+      print_string "Result: "; Print.print_value got_v;
+      print_string "Expect: "; print_endline "nan";
+      AssertFailure.error cmd.at "wrong return value"
+    end
 
   | AssertTrap (name, es, re) ->
     trace "Asserting trap...";
     let m = get_module cmd.at in
-    assert_error (fun () -> Eval.invoke m name (List.map it es))
-      "trap" re cmd.at
+    (match Eval.invoke m name (List.map it es) with
+    | exception Eval.Trap (_, msg) ->
+      if not (Str.string_match (Str.regexp re) msg 0) then begin
+        print_endline ("Result: \"" ^ msg ^ "\"");
+        print_endline ("Expect: \"" ^ re ^ "\"");
+        AssertFailure.error cmd.at "wrong runtime trap"
+      end
+    | _ ->
+      AssertFailure.error cmd.at "expected runtime trap"
+    )
 
 let dry_command cmd =
   match cmd.it with

ml-proto/host/script.mli

@@ -13,5 +13,10 @@ and command' =
 
 type script = command list
 
-val run : script -> unit (* raises Error.Error *)
+exception Syntax of Source.region * string
+exception AssertFailure of Source.region * string
+
+val run : script -> unit
+  (* raises Check.Invalid, Eval.Trap, Eval.Crash, Failure *)
+
 val trace : string -> unit

ml-proto/spec/check.ml

@@ -9,7 +9,10 @@ open Types
 
 (* Errors *)
 
-let error = Error.error
+module Invalid = Error.Make ()
+exception Invalid = Invalid.Error
+
+let error = Invalid.error
 let require b at s = if not b then error at s
 
 

ml-proto/spec/check.mli

@@ -2,4 +2,6 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-val check_module : Ast.module_ -> unit (* raise Error *)
+exception Invalid of Source.region * string
+
+val check_module : Ast.module_ -> unit (* raise Invalid *)

ml-proto/spec/error.ml

@@ -2,7 +2,11 @@
  * (c) 2015 Andreas Rossberg
  *)
 
-exception Error of Source.region * string
+module Make () =
+struct
+  exception Error of Source.region * string
+
+  let warn at m = prerr_endline (Source.string_of_region at ^ ": warning: " ^ m)
+  let error at m = raise (Error (at, m))
+end
 
-let warn at m = prerr_endline (Source.string_of_region at ^ ": warning: " ^ m)
-let error at m = raise (Error (at, m))