Changed the way errors are represented + context analysis now prints multiple errors before exiting

main.ml

@@ -105,30 +105,11 @@ let compile () =
  * Command-line arguments are stored in lobals.args *)
 let main () =
   try
-    try
-      parse_args ();
-      compile ();
-      0
-    with
-    (*| InvalidNode ->
-      raise (CompileError "invalid node")*)
-    | InvalidInput name ->
-      raise (CompileError ("invalid input for phase \"" ^ name ^ "\""))
-    | NodeError (node, msg) ->
-      (* If no location is given, just stringify the node to at least give
-       * some information *)
-      let msg = if locof node = noloc then
-        msg ^ "\nnode: " ^ Stringify.node2str node
-      else msg in
-      raise (LocError (locof node, msg))
-  with
-  | CompileError msg ->
-    eprintf "Error: %s\n" msg;
-    1
-  | LocError (loc, msg) ->
-    prerr_loc_msg loc ("Error: " ^ msg);
-    1
-  | EmptyError ->
+    parse_args ();
+    compile ();
+    0
+  with FatalError err ->
+    print_error err;
     1
 
 let _ = exit (main ())

phases/assemble.ml

@@ -165,14 +165,16 @@ let assemble program =
 
     | TypeCast (ctype, value, _) ->
       let vtype = typeof value in
-      (match (ctype, vtype) with
-      | (Float, Int) | (Int, Float) -> ()
-      | _ ->
-        let msg = sprintf
-          "invalid typecast: %s -> %s"
-          (type2str vtype) (type2str ctype)
-        in raise (NodeError (node, msg))
-      );
+      begin
+        match (ctype, vtype) with
+        | (Float, Int) | (Int, Float) -> ()
+        | _ ->
+          let msg = sprintf
+            "invalid typecast: %s -> %s"
+            (type2str vtype) (type2str ctype)
+          in
+          raise (FatalError (NodeMsg (node, msg)))
+      end;
       trav value @ [Convert (vtype, ctype)]
 
     (* Function calls *)
@@ -267,4 +269,4 @@ let assemble program =
 
 let phase = function
   | Ast node -> Assembly (assemble node)
-  | _ -> raise (InvalidInput "assembly")
+  | _ -> raise InvalidInput

phases/boolop.ml

@@ -64,4 +64,4 @@ and bool_op = function
 
 let phase = function
   | Ast node -> Ast (bool_op node)
-  | _ -> raise (InvalidInput "bool operations")
+  | _ -> raise InvalidInput

phases/constprop.ml

@@ -188,4 +188,4 @@ let propagate_consts node =
 
 let phase = function
   | Ast node -> Ast (propagate_consts node)
-  | _ -> raise (InvalidInput "constant propagation")
+  | _ -> raise InvalidInput

phases/context.ml

@@ -9,7 +9,7 @@ let type2str = function Funcname _ -> "function" | Varname _ -> "variable"
 let mapfind name tbl =
   if Hashtbl.mem tbl name then Some (Hashtbl.find tbl name) else None
 
-let check_in_scope name errnode scope =
+let check_in_scope name errnode scope err =
   let (vars, funs) = scope in
   let (name, tbl, other_map, desired_type) = match name with
   | Varname  name -> (name, vars, funs, "variable")
@@ -23,7 +23,8 @@ let check_in_scope name errnode scope =
     | Some _ -> sprintf "\"%s\" is not a %s" name desired_type
     | None   -> sprintf "undefined %s \"%s\"" desired_type name
     in
-    raise (NodeError (errnode, msg))
+    err := !err @ [NodeMsg (errnode, msg)];
+    (DummyNode, -1)
 
 let add_to_scope name dec depth (vars, funs) =
   let (name, tbl, name_type) = match name with
@@ -43,13 +44,13 @@ let add_to_scope name dec depth (vars, funs) =
       let msg = sprintf "Error: cannot redeclare %s \"%s\"" name_type name in
       prerr_loc_msg (locof dec) msg;
       prerr_loc_msg (locof orig) "Previously declared here:";
-      raise EmptyError
+      raise (FatalError NoMsg)
   | Some _ ->
     Hashtbl.replace tbl name (dec, depth, name_type)
   | None ->
     Hashtbl.add tbl name (dec, depth, name_type)
 
-let rec analyse scope depth node =
+let rec analyse scope depth node err =
   let rec collect node = match node with
     (* For extern array declarations, add the dimension names as well *)
     | GlobalDec (ArrayDims (ctype, dims), name, ann) ->
@@ -86,21 +87,21 @@ let rec analyse scope depth node =
     (* For a variable or function call, look for its declaration in the
      * current scope and save a its type/depth information  *)
     | Var (name, dims, ann) ->
-      let (dec, dec_depth) = check_in_scope (Varname name) node scope in
+      let (dec, dec_depth) = check_in_scope (Varname name) node scope err in
       VarUse (dec, optmap collect dims, Depth depth :: ann)
 
     | FunCall (name, args, ann) ->
-      let (dec, dec_depth) = check_in_scope (Funcname name) node scope in
+      let (dec, dec_depth) = check_in_scope (Funcname name) node scope err in
       FunUse (dec, List.map collect args, Depth depth :: ann)
 
     (* Assign statements are replaced with VarLet nodes, which stores the
      * declaration of the assigned variable *)
     | Assign (name, dims, value, ann) ->
-      let (dec, dec_depth) = check_in_scope (Varname name) node scope in
+      let (dec, dec_depth) = check_in_scope (Varname name) node scope err in
       VarLet (dec, optmap collect dims, collect value, Depth depth :: ann)
 
     | Allocate (dec, dims, ann) ->
-      let (dec, dec_depth) = check_in_scope (Varname (nameof dec)) node scope in
+      let (dec, dec_depth) = check_in_scope (Varname (nameof dec)) node scope err in
       Allocate (dec, List.map collect dims, Depth depth :: ann)
 
     | _ -> traverse_unit collect node
@@ -113,7 +114,7 @@ let rec analyse scope depth node =
       let (vars, funs) = scope in
       let local_scope = (Hashtbl.copy vars, Hashtbl.copy funs) in
       let params = List.map (traverse local_scope (depth + 1)) params in
-      let body = analyse local_scope (depth + 1) body in
+      let body = analyse local_scope (depth + 1) body err in
       FunDef (export, ret_type, name, params, body, ann)
 
     | Param (ArrayDims (ctype, dims), name, ann) ->
@@ -159,8 +160,10 @@ let rec analyse scope depth node =
 
 let analyse_context program =
   let scope = (Hashtbl.create 20, Hashtbl.create 20) in
-  analyse scope 0 program
+  let err = ref [] in
+  let node = analyse scope 0 program err in
+  quit_on_error node !err
 
 let phase = function
   | Ast node -> Ast (analyse_context node)
-  | _ -> raise (InvalidInput "context analysis")
+  | _ -> raise InvalidInput

phases/desug.ml

@@ -269,7 +269,7 @@ let rec array_init = function
           "dimension mismatch: expected %d nesting levels, got %d"
           ndims depth
         in
-        raise (NodeError (node, msg))
+        raise (FatalError (NodeMsg (node, msg)))
     in
     Block (List.rev (traverse 0 [] value))
 
@@ -311,4 +311,4 @@ let phase = function
      * transform all for-loops to while-loops afterwards *)
     Ast (for_to_while (array_init (node)))
 
-  | _ -> raise (InvalidInput "desugar")
+  | _ -> raise InvalidInput

phases/dimreduce.ml

@@ -128,4 +128,4 @@ and dim_reduce depth = function
 
 let phase = function
   | Ast node -> Ast (dim_reduce 0 (expand_dims node))
-  | _ -> raise (InvalidInput "dimension reduction")
+  | _ -> raise InvalidInput

phases/extern.ml

@@ -143,4 +143,4 @@ let phase = function
     let globals = Hashtbl.create 20 in
     let node = create_funcs globals node in
     Ast (replace_vars globals 0 node)
-  | _ -> raise (InvalidInput "extern vars")
+  | _ -> raise InvalidInput

phases/index.ml

@@ -80,4 +80,4 @@ let phase = function
   | Ast node ->
     let tagged = tag_index (strip_context node) in
     Ast (Context.analyse_context tagged)
-  | _ -> raise (InvalidInput "index analysis")
+  | _ -> raise InvalidInput

phases/load.ml

@@ -63,4 +63,4 @@ let phase = function
       in
       FileContent (display_name, content)
 
-  | _ -> raise (InvalidInput "load")
+  | _ -> raise InvalidInput

phases/output.ml

@@ -13,4 +13,4 @@ let phase = function
       Print.print_assembly stdout instrs
     end;
     Empty
-  | _ -> raise (InvalidInput "output")
+  | _ -> raise InvalidInput

phases/parse.ml

@@ -13,9 +13,9 @@ let shift_back lexbuf = shift_loc (get_loc lexbuf) 0 (-1)
 let parse_with_error lexbuf =
   try Some (Parser.program Lexer.token lexbuf) with
   | Lexer.SyntaxError msg ->
-    raise (LocError ((shift_back lexbuf), msg))
+    raise (FatalError (LocMsg (shift_back lexbuf, msg)))
   | Parser.Error ->
-    raise (LocError ((shift_back lexbuf), "syntax error"))
+    raise (FatalError (LocMsg (shift_back lexbuf, "syntax error")))
 
 let phase = function
   | FileContent (display_name, content) ->
@@ -23,7 +23,7 @@ let phase = function
     lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = display_name };
     let ast = parse_with_error lexbuf in
     begin match ast with
-      | None -> raise (CompileError "no syntax tree was constructed")
+      | None -> raise (FatalError (Msg "no syntax tree was constructed"))
       | Some node -> Ast node
     end
-  | _ -> raise (InvalidInput "parse")
+  | _ -> raise InvalidInput

phases/peephole.ml

@@ -92,4 +92,4 @@ let phase = function
       oldcount newcount (oldcount - newcount)
     );
     Assembly instrs
-  | _ -> raise (InvalidInput "peephole")
+  | _ -> raise InvalidInput

phases/print.ml

@@ -21,7 +21,7 @@ let op2str = function
   | Le  -> "le"
   | Gt  -> "gt"
   | Ge  -> "ge"
-  | _ -> raise (CompileError ("operator unsupported by VM"))
+  | _ -> raise (FatalError (Msg "operator unsupported by VM"))
 
 let prefix = function
   | Bool _  -> "b"

phases/typecheck.ml

@@ -19,6 +19,8 @@ open Types
 open Util
 open Stringify
 
+let node_error (node, msg) = FatalError (NodeMsg (node, msg))
+
 (* Stringify a list of types for use in error messages.
  * ctype list -> string *)
 let rec types2str = function
@@ -48,7 +50,7 @@ let check_type ?(msg="") expected node =
             (type2str_error expected) (type2str_error got)
     | _ -> msg
     in
-    raise (NodeError (node, msg))
+    raise (node_error (node, msg))
   end
 
 let op_types = function
@@ -69,7 +71,7 @@ let check_type_op allowed_types desc node =
       "%s cannot be applied to type %s, only to %s"
       desc (type2str got) (types2str allowed_types)
     in
-    raise (NodeError (node, msg))
+    raise (node_error (node, msg))
   ); ()
 
 let check_dims_match dims dec_type errnode =
@@ -78,7 +80,7 @@ let check_dims_match dims dec_type errnode =
     let msg = sprintf
       "dimension mismatch: expected %d indices, got %d" expected got
     in
-    raise (NodeError (errnode, msg))
+    raise (node_error (errnode, msg))
   | _ -> ()
 
 let rec typecheck node =
@@ -97,7 +99,7 @@ let rec typecheck node =
           "function \"%s\" expects %d arguments, got %d"
           name nparams nargs
         in
-        raise (NodeError (node, msg))
+        raise (node_error (node, msg))
       | _ ->
         let args = List.map typecheck args in
         let check_arg_type arg param =
@@ -173,21 +175,21 @@ let rec typecheck node =
     begin
       match (ret_type, find_return (block_body body)) with
       | (Void, Some (ret, _)) ->
-        raise (NodeError (ret, "void function should not have a return value"))
+        raise (node_error (ret, "void function should not have a return value"))
 
       | ((Bool | Int | Float), None) ->
         let msg = sprintf
           "expected return value of type %s for function \"%s\""
           (type2str ret_type) name
         in
-        raise (NodeError (node, msg))
+        raise (node_error (node, msg))
 
       | ((Bool | Int | Float), Some (ret, t)) when t != ret_type ->
         let msg = sprintf
           "function \"%s\" has return type %s, got %s"
           name (type2str ret_type) (type2str t)
         in
-        raise (NodeError (ret, msg))
+        raise (node_error (ret, msg))
 
       | _ -> FunDef (export, ret_type, name, params, body, ann)
     end
@@ -212,7 +214,7 @@ let rec typecheck node =
     let min = Nativeint.of_int32 Int32.min_int in
     let max = Nativeint.of_int32 Int32.max_int in
     if cmpval < min || cmpval > max then (
-      raise (NodeError (node, "integer value out of range (signed 32-bit)"))
+      raise (node_error (node, "integer value out of range (signed 32-bit)"))
     );
     Const (IntVal value, Type Int :: ann)
   | Const (FloatVal value, ann) ->
@@ -221,7 +223,7 @@ let rec typecheck node =
   (* Extern arrays variables are transformed to imported functions, so the
    * pointer cannot be passed *)
   | VarUse (GlobalDec (ArrayDims _, _, _), None, _) ->
-    raise (NodeError (node, "imported array pointers may only be \
+    raise (node_error (node, "imported array pointers may only be \
                              dereferenced, not used directly"))
 
   (* Variables inherit the type of their declaration *)
@@ -238,7 +240,7 @@ let rec typecheck node =
   (* Array pointers cannot be re-assigned, because array dimension reduction
    * makes assumptions about dimensions of an array *)
   | VarLet (dec, None, _, _) when is_array dec ->
-    raise (NodeError (node, "cannot assign value to array pointer after \
+    raise (node_error (node, "cannot assign value to array pointer after \
                              initialisation"))
 
   (* Assigned values must match variable declaration *)
@@ -262,11 +264,11 @@ let rec typecheck node =
   (* ArrayConst initialisations are transformed during desugaring, so any
    * occurrences that are left are illegal *)
   | ArrayConst _ ->
-    raise (NodeError (node, "array constants can only be used in array \
+    raise (node_error (node, "array constants can only be used in array \
                              initialisation"))
 
   | _ -> traverse_unit typecheck node
 
 let phase = function
   | Ast node -> Ast (typecheck node)
-  | _ -> raise (InvalidInput "typecheck")
+  | _ -> raise InvalidInput

phases/unroll.ml

@@ -89,4 +89,4 @@ let phase = function
     let node = unroll counters node in
     let node = prune_vardecs counters node in
     Ast (Constprop.propagate_consts node)
-  | _ -> raise (InvalidInput "loop unrolling")
+  | _ -> raise InvalidInput

types.mli

@@ -229,24 +229,27 @@ type args_record = {
 
 (** {2 Exceptions} *)
 
-(** Error occurred at a certain location in an input file. Used in combination
-    with {!Util.prerr_loc} and {!Util.prerr_loc_msg}. *)
-exception LocError of location * string
+type error_msg =
+  (** General compilation error message (caught by main function). *)
+  | Msg of string
 
-(** Error occurred at a certain AST node, to be transformed to {!LocError} using
-    {!Util.locof}. *)
-exception NodeError of node * string
+  (** Error occurred at a certain location in an input file. Used in combination
+      with {!Util.prerr_loc} and {!Util.prerr_loc_msg}. *)
+  | LocMsg of location * string
 
-(** General compilation error message (caught by main function). *)
-exception CompileError of string
+  (** Error occurred at a certain AST node, use {!Util.locof} to get node
+      location. *)
+  | NodeMsg of node * string
 
-(** Error without message, just makes the compiler fail with non-zero return
-    value. *)
-exception EmptyError
+  (** No error message, just quit *)
+  | NoMsg
+
+(** Raised error message. Makes the compiler print the message and quit with
+    status code 1. *)
+exception FatalError of error_msg
 
 (** Catch-all error for traversals that accept a limit set of node types. *)
 exception InvalidNode
 
 (** Error raised when a phase receives an unsupported {!intermediate} type. *)
-exception InvalidInput of string
-
+exception InvalidInput

util.ml

@@ -520,3 +520,26 @@ let node_error node msg =
 
 let node_warning node msg =
   prerr_loc_msg (locof node) ("Warning: " ^ msg)
+
+let print_error = function
+  | Msg msg ->
+    eprintf "Error: %s\n" msg;
+
+  | LocMsg (loc, msg) ->
+    prerr_loc_msg loc ("Error: " ^ msg)
+
+  | NodeMsg (node, msg) ->
+    (* If no location is given, just stringify the node to at least give
+      * some information *)
+    let msg = if locof node = noloc then
+      msg ^ "\nnode: " ^ Stringify.node2str node
+    else msg in
+    node_error node msg
+
+  | NoMsg -> ()
+
+let quit_on_error node = function
+  | [] -> node
+  | errors ->
+    List.iter print_error errors;
+    raise (FatalError NoMsg)

util.mli

@@ -170,6 +170,13 @@ val node_error : node -> string -> unit
 (** Print a warning message for a node. Calls {!prerr_loc_msg}. *)
 val node_warning : node -> string -> unit
 
+(** Print an error message of type {!Types.error_msg}. *)
+val print_error : error_msg -> unit
+
+(** Raise a {!Types.FatalError} if the given error list is not empty, and
+    print the errors before quitting. *)
+val quit_on_error : node -> error_msg list -> node
+
 (** {2 String utilities} *)
 
 (** [repeat s n] returns a new string of [n] times [s]. *)