Typechecking phase now also prints multiple errors before quitting (could use some more extensive debugging)

README.md

@@ -18,8 +18,6 @@ The Makefile uses [OCamlMakefile(https://bitbucket.org/mmottl/ocaml-makefile/).
 Issues & TODO
 -------------
 
-- Context analysis and typechecking phases should print multiple errors before
-  quitting.
-- Typechecking now gives an error when integers are not in the 32-bit range. Is
+- Typechecking gives an error when integers are not in the 32-bit range. Is
   this correct?
 - Replace VarDec with Var_dec etc? (to adhere to the coding style)

phases/typecheck.ml

@@ -44,14 +44,16 @@ let type2str_error = function
 
 let check_type ?(msg="") expected node =
   let got = typeof node in
-  if (spec got) <> (spec expected) then begin
-    let msg = match msg with
-    | "" -> sprintf "type mismatch: expected type %s, got %s"
-            (type2str_error expected) (type2str_error got)
-    | _ -> msg
-    in
-    raise (node_error (node, msg))
-  end
+  if expected <> Unknown & got <> Unknown & (spec got) <> (spec expected)
+    then begin
+      let msg = match msg with
+      | "" -> sprintf "type mismatch: expected type %s, got %s"
+              (type2str_error expected) (type2str_error got)
+      | _ -> msg
+      in
+      [NodeMsg (node, msg)]
+    end
+    else []
 
 let op_types = function
   | Not | And | Or                      -> [Bool]
@@ -66,28 +68,38 @@ let op_result_type opnd_type = function
 (* Check if the given operator can be applied to the given type *)
 let check_type_op allowed_types desc node =
   let got = typeof node in
-  if not (List.mem got allowed_types) then (
-    let msg = sprintf
-      "%s cannot be applied to type %s, only to %s"
-      desc (type2str got) (types2str allowed_types)
-    in
-    raise (node_error (node, msg))
-  ); ()
+  if got <> Unknown & not (List.mem got allowed_types)
+    then
+      [NodeMsg (node, sprintf
+        "%s cannot be applied to type %s, only to %s"
+        desc (type2str got) (types2str allowed_types))]
+    else
+      []
 
 let check_dims_match dims dec_type errnode =
   match (List.length dims, array_depth dec_type) with
   | (got, expected) when got != expected ->
     let msg = sprintf
-      "dimension mismatch: expected %d indices, got %d" expected got
+      "dimension mismatch: expected %d indices, got %d"
+      expected got
     in
-    raise (node_error (errnode, msg))
-  | _ -> ()
+    [NodeMsg (errnode, msg)]
+  | _ -> []
+
+let err_map f nodes =
+  let (n, e) = List.split (List.map f nodes) in
+  (n, List.concat e)
+
+let default_unknown ctype = function [] -> ctype | _ -> Unknown
 
 let rec typecheck node =
+  let add_error node msg =
+    let (node, err) = traverse_list typecheck node in
+    (annotate (Type Unknown) node, NodeMsg (node, msg) :: err)
+  in
   let check_trav ctype node =
-    let node = typecheck node in
-    check_type ctype node;
-    node
+    let (node, err) = typecheck node in
+    (node, err @ check_type ctype node)
   in
   match node with
   | FunUse ((FunDec (ret_type, name, params, _) as dec), args, ann)
@@ -95,33 +107,36 @@ let rec typecheck node =
     begin
       match (List.length args, List.length params) with
       | (nargs, nparams) when nargs != nparams ->
-        let msg = sprintf
+        add_error node (sprintf
           "function \"%s\" expects %d arguments, got %d"
-          name nparams nargs
-        in
-        raise (node_error (node, msg))
+          name nparams nargs)
       | _ ->
-        let args = List.map typecheck args in
-        let check_arg_type arg param =
-          check_type (typeof param) arg;
-        in
-        List.iter2 check_arg_type args params;
-        FunUse (dec, args, Type ret_type :: ann)
+        let (args, aerr) = err_map typecheck args in
+        let check_arg_type arg param = check_type (typeof param) arg in
+        let err = List.concat (List.map2 check_arg_type args params) in
+        (FunUse (dec, args, Type ret_type :: ann), aerr @ err)
     end
 
   (* Operators match operand types and get a new type based on the operator *)
   | Monop (op, opnd, ann) ->
-    let opnd = typecheck opnd in
+    let (opnd, oerr) = typecheck opnd in
     let desc = sprintf "unary operator \"%s\"" (op2str op) in
-    check_type_op (op_types op) desc opnd;
-    Monop (op, opnd, Type (op_result_type (typeof opnd) op) :: ann)
+    let err = check_type_op (op_types op) desc opnd in
+    let res_type = default_unknown (typeof opnd) err in
+    (Monop (op, opnd, Type (op_result_type res_type op) :: ann),
+     oerr @ err)
 
   | Binop (op, left, right, ann) ->
-    let left = typecheck left in
-    let right = typecheck right in
+    let (left, lerr) = typecheck left in
+    let (right, rerr) = typecheck right in
     let desc = sprintf "binary operator \"%s\"" (op2str op) in
-    check_type_op (op_types op) desc left;
-    check_type (typeof left) right;
+    let err =
+      (* Only compare operand types if left operand has a valid type *)
+      match check_type_op (op_types op) desc left with
+      | []  -> check_type (typeof left) right
+      | err -> err
+    in
+    let res_type = default_unknown (typeof left) err in
 
     (* Check for division by zero *)
     begin
@@ -130,145 +145,149 @@ let rec typecheck node =
       | _ -> ()
     end;
 
-    Binop (op, left, right, Type (op_result_type (typeof left) op) :: ann)
+    (Binop (op, left, right, Type (op_result_type res_type op) :: ann),
+     lerr @ rerr @ err)
 
   (* Conditions must be bool, and right-hand type must match left-hand type *)
   | Cond (cond, texpr, fexpr, ann) ->
-    let cond = check_trav Bool cond in
-    let texpr = typecheck texpr in
-    let fexpr = check_trav (typeof texpr) fexpr in
-    Cond (cond, texpr, fexpr, Type (typeof texpr) :: ann)
+    let (cond, cerr) = check_trav Bool cond in
+    let (texpr, terr) = typecheck texpr in
+    let (fexpr, ferr) = check_trav (typeof texpr) fexpr in
+    (Cond (cond, texpr, fexpr, Type (typeof texpr) :: ann), cerr @ terr @ ferr)
 
   (* Only basic types can be typecasted *)
   | TypeCast (ctype, value, ann) ->
-    let value = typecheck value in
-    check_type_op [Bool; Int; Float] "typecast" value;
-    TypeCast (ctype, value, Type ctype :: ann)
+    let (value, err) = typecheck value in
+    let err = err @ check_type_op [Bool; Int; Float] "typecast" value in
+    (TypeCast (ctype, value, Type ctype :: ann), err)
 
   (* Array allocation dimensions must have type int *)
   | Allocate (dec, dims, ann) ->
-    Allocate (dec, List.map (check_trav Int) dims, ann)
+    let (dims, err) = err_map typecheck dims in
+    let err = err @ List.concat (List.map (check_type Int) dims) in
+    (Allocate (dec, dims, ann), err)
 
   (* Array dimensions are always integers *)
   | Dim (name, ann) ->
-    Dim (name, Type Int :: ann)
-
-  (* Functions and parameters must be traversed to give types to Dim nodes *)
-  (*
-  | FunDec (ret_type, name, params, ann) ->
-    FunDec (ret_type, name, List.map typecheck params, ann)
-
-  | Param (ArrayDims (ctype, dims), name, ann) ->
-    Param (ArrayDims (ctype, List.map typecheck dims), name, ann)
-    *)
+    (Dim (name, Type Int :: ann), [])
 
   (* Void functions may have no return statement, other functions must have a
    * return statement of valid type *)
   | FunDef (export, ret_type, name, params, body, ann) ->
-    let params = List.map typecheck params in
-    let body = typecheck body in
+    let (params, perr) = err_map typecheck params in
+    let (body, berr) = typecheck body in
     let rec find_return = function
       | []                         -> None
       | [Return (value, _) as ret] -> Some (ret, typeof value)
       | hd :: tl                   -> find_return tl
     in
-    begin
+    let err =
       match (ret_type, find_return (block_body body)) with
       | (Void, Some (ret, _)) ->
-        raise (node_error (ret, "void function should not have a return value"))
+        [NodeMsg (ret, "void function should not have a return value")]
 
       | ((Bool | Int | Float), None) ->
-        let msg = sprintf
+        [NodeMsg (node, sprintf
           "expected return value of type %s for function \"%s\""
-          (type2str ret_type) name
-        in
-        raise (node_error (node, msg))
+          (type2str ret_type) name)]
 
       | ((Bool | Int | Float), Some (ret, t)) when t != ret_type ->
-        let msg = sprintf
+        [NodeMsg (ret, sprintf
           "function \"%s\" has return type %s, got %s"
-          name (type2str ret_type) (type2str t)
-        in
-        raise (node_error (ret, msg))
+          name (type2str ret_type) (type2str t))]
 
-      | _ -> FunDef (export, ret_type, name, params, body, ann)
-    end
+      | _ -> []
+    in
+    (FunDef (export, ret_type, name, params, body, ann), perr @ berr @ err)
 
   (* Conditions in must have type bool *)
   | If (cond, body, ann) ->
-    If (check_trav Bool cond, typecheck body, ann)
+    let (cond, cerr) = check_trav Bool cond in
+    let (body, berr) = typecheck body in
+    (If (cond, body, ann), cerr @ berr)
   | IfElse (cond, tbody, fbody, ann) ->
-    IfElse (check_trav Bool cond, typecheck tbody, typecheck fbody, ann)
+    let (cond, cerr) = check_trav Bool cond in
+    let (tbody, terr) = typecheck tbody in
+    let (fbody, ferr) = typecheck fbody in
+    (IfElse (cond, tbody, fbody, ann), cerr @ terr @ ferr)
   | While (cond, body, ann) ->
-    While (check_trav Bool cond, typecheck body, ann)
+    let (cond, cerr) = check_trav Bool cond in
+    let (body, berr) = typecheck body in
+    (While (cond, body, ann), cerr @ berr)
   | DoWhile (cond, body, ann) ->
-    DoWhile (check_trav Bool cond, typecheck body, ann)
+    let (body, berr) = typecheck body in
+    let (cond, cerr) = check_trav Bool cond in
+    (DoWhile (cond, body, ann), berr @ cerr)
 
   (* Constants *)
   | Const (BoolVal value, ann) ->
-    Const (BoolVal value, Type Bool :: ann)
+    (Const (BoolVal value, Type Bool :: ann), [])
   | Const (IntVal value, ann) ->
     (* Do a bound check on integers (use Int32 because default ints in ocaml
      * are 31- or 63-bit *)
     let cmpval = Nativeint.of_int value in
     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 (node_error (node, "integer value out of range (signed 32-bit)"))
-    );
-    Const (IntVal value, Type Int :: ann)
+    if cmpval < min || cmpval > max then
+      add_error node "integer value out of range (signed 32-bit)"
+    else
+      (Const (IntVal value, Type Int :: ann), [])
   | Const (FloatVal value, ann) ->
-    Const (FloatVal value, Type Float :: ann)
+    (Const (FloatVal value, Type Float :: ann), [])
 
   (* Extern arrays variables are transformed to imported functions, so the
    * pointer cannot be passed *)
   | VarUse (GlobalDec (ArrayDims _, _, _), None, _) ->
-    raise (node_error (node, "imported array pointers may only be \
-                             dereferenced, not used directly"))
+    add_error node "imported array pointers may only be dereferenced, not used \
+                    directly"
 
   (* Variables inherit the type of their declaration *)
   | VarUse (dec, None, ann) ->
-    VarUse (dec, None, Type (typeof dec) :: ann)
+    (VarUse (dec, None, Type (typeof dec) :: ann), [])
 
   | VarUse (dec, Some dims, ann) ->
-    let dims = List.map typecheck dims in
-    List.iter (check_type Int) dims;
+    (* Dimensions must have int type *)
+    let (dims, err) = err_map typecheck dims in
+    let err = err @ List.concat (List.map (check_type Int) dims) in
 
-    check_dims_match dims (typeof dec) node;
-    VarUse (dec, Some dims, Type (basetypeof dec) :: ann)
+    (* Number of indices must match number of array dimensions *)
+    let err = err @ check_dims_match dims (typeof dec) node in
+    (VarUse (dec, Some dims, Type (basetypeof dec) :: ann), err)
 
   (* 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 (node_error (node, "cannot assign value to array pointer after \
-                             initialisation"))
+    add_error node "cannot assign value to array pointer after initialisation"
 
   (* Assigned values must match variable declaration *)
   | VarLet (dec, None, value, ann) ->
-    VarLet (dec, None, check_trav (typeof dec) value, ann)
+    let (value, err) = typecheck value in
+    let err = err @ check_type (typeof dec) value in
+    (VarLet (dec, None, value, ann), err)
 
   | VarLet (dec, Some dims, value, ann) ->
-    (* Number of assigned indices must match array definition *)
-    check_dims_match dims (typeof dec) node;
+    (* Number of indices must match number of array dimensions *)
+    let err1 = check_dims_match dims (typeof dec) node in
 
     (* Array indices must be ints *)
-    let dims = List.map typecheck dims in
-    List.iter (check_type Int) dims;
+    let (dims, err2) = err_map typecheck dims in
+    let err2 = err2 @ List.concat (List.map (check_type Int) dims) in
 
     (* Assigned value must match array base type *)
-    let value = typecheck value in
-    check_type (basetypeof dec) value;
+    let (value, err3) = typecheck value in
+    let err3 = err3 @ check_type (basetypeof dec) value in
 
-    VarLet (dec, Some dims, value, ann)
+    (VarLet (dec, Some dims, value, ann), err1 @ err2 @ err3)
 
   (* ArrayConst initialisations are transformed during desugaring, so any
    * occurrences that are left are illegal *)
   | ArrayConst _ ->
-    raise (node_error (node, "array constants can only be used in array \
-                             initialisation"))
+    add_error node "array constants can only be used in array initialisation"
 
-  | _ -> traverse_unit typecheck node
+  | _ -> traverse_list typecheck node
 
 let phase = function
-  | Ast node -> Ast (typecheck node)
+  | Ast node ->
+    let (node, err) = typecheck node in
+    Ast (quit_on_error node err)
   | _ -> raise InvalidInput

stringify.ml

@@ -54,6 +54,7 @@ let rec type2str = function
   | Float -> "float"
   | ArrayDims (t, dims) -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
   | Array t             -> (type2str t) ^ "[]"
+  | Unknown -> "unknown"
 
 and concat sep nodes = String.concat sep (List.map node2str nodes)
 

types.mli

@@ -24,10 +24,12 @@ type const =
 (** Data types supported by CiviC. [ArrayDims] defines an array type with a set
     of dimensions. {!Dimreduce} replaces this multi-dimensional type with the
     [Array] type, which signifies a one-dimensional array of a certain basic
-    type. *)
+    type. [Unknown] is used by {!Typecheck} when the result of an operation is
+    unclear due to a type error. *)
 type ctype =
   | Void | Bool | Int | Float | Array of ctype
   | ArrayDims of ctype * node list
+  | Unknown
 
 (** Annotations for {!node}. Each node has a list of zero or more annotations
     that are gradually added through the compiler phases: