Mostly finished desugaring and context analysis, added some utils, general bugfixes, started on array dimension reduction

Makefile

@@ -2,9 +2,9 @@ RESULT := civicc
 SOURCES := ast.ml util.mli util.ml lexer.mll parser.mly stringify.mli \
 	stringify.ml \
 	phases/load.ml phases/parse.ml phases/print.ml phases/desug.ml \
-	phases/context_analysis.ml \
+	phases/context_analysis.ml phases/dim_reduce.ml \
 	main.ml
-PRE_TARGETS := ast.cmi util.cmi
+PRE_TARGETS := ast.cmi util.cmi util.o
 LIBS := str unix
 
 OCAMLFLAGS := -g

ast.ml

@@ -6,12 +6,13 @@ type binop = Add | Sub | Mul | Div | Mod
            | Eq | Ne | Lt | Le | Gt | Ge
            | And | Or
 type ctype = Void | Bool | Int | Float
-           | ArrayDec of ctype * string list
+           | ArrayDec of ctype * node list
            | ArrayDef of ctype * node list
 and node =
     (* global *)
     | Program of node list * loc
     | Param of ctype * string * loc
+    | Dim of string * loc
     | FunDec of ctype * string * node list * loc
     | FunDef of bool * ctype * string * node list * node * loc
     | GlobalDec of ctype * string * loc
@@ -37,7 +38,6 @@ and node =
     | ArrayConst of node list * loc
     | ArrayScalar of node * loc
     | Var of string * loc
-    | VarUse of node * node ref * int
     | Deref of string * node list * loc
     | Monop of monop * node * loc
     | Binop of binop * node * node * loc
@@ -45,7 +45,12 @@ and node =
     | TypeCast of ctype * node * loc
     | FunCall of string * node list * loc
 
+    (* additional types for convenience in traversals *)
+    | VarUse of node * ctype * int
+    | FunUse of node * ctype * int
     | Type of ctype
+    | DimDec of node
+    | Arg of node
 
 (* container for command-line arguments *)
 type args = {

main.ml

@@ -12,19 +12,22 @@ let compile args =
     in
     run_phases (Args args) [
         Load.phase;
-        Print.phase;
+        (*Print.phase;*)
         Parse.phase;
         Print.phase;
         Desug.phase;
         Print.phase;
         Context_analysis.phase;
         (*
-        Print.phase;
         Typecheck.phase;
         Extern_vars.phase;
         Dim_reduce.phase;
+        Print.phase;
+        Print.phase;
         Bool_op.phase;
+        Print.phase;
         Assemble.phase;
+        Print.phase;
         Peephole.phase;
         Print.phase;
         *)
@@ -55,8 +58,8 @@ let main () =
             compile args;
             0
         with
-        | InvalidNode ->
-            raise (CompileError "invalid node")
+        (*| InvalidNode ->
+            raise (CompileError "invalid node")*)
         | InvalidInput name ->
             raise (CompileError ("invalid input for phase \"" ^ name ^ "\""))
         | NodeError (node, msg) ->

parser.mly

@@ -10,6 +10,10 @@
     open Ast
 
     let loc = Util.loc_from_lexpos
+
+    let rec make_dims dimloc = function
+        | [] -> []
+        | dim :: tail -> Dim (dim, dimloc) :: (make_dims dimloc tail)
 %}
 
 (* Tokens *)
@@ -71,8 +75,9 @@ decl:
     | EXTERN; ctype=basic_type;
       LBRACK; dims=separated_list(COMMA, ID); RBRACK;
       name=ID; SEMICOL
-    { let loc = loc $startpos(name) $endpos(name) in
-      GlobalDec (ArrayDec (ctype, dims), name, loc) }
+    { let dimloc = loc $startpos(dims) $endpos(dims) in
+      let loc = loc $startpos(name) $endpos(name) in
+      GlobalDec (ArrayDec (ctype, make_dims dimloc dims), name, loc) }
 
     | export=boption(EXPORT); ctype=basic_type; name=ID; SEMICOL
     { let loc = loc $startpos(name) $endpos(name) in
@@ -108,7 +113,9 @@ param:
     { Param (ctype, name, loc $startpos(name) $endpos(name)) }
 
     | ctype=basic_type; LBRACK; dims=separated_list(COMMA, ID); RBRACK; name=ID
-    { Param (ArrayDec (ctype, dims), name, loc $startpos(name) $endpos(name)) }
+    { let dimloc = loc $startpos(dims) $endpos(dims) in
+      let loc = loc $startpos(name) $endpos(name) in
+      Param (ArrayDec (ctype, make_dims dimloc dims), name, loc) }
 
 fun_body:
     | var_dec* local_fun_dec* statement* loption(return_statement)
@@ -148,8 +155,9 @@ statement:
     | name=ID; ASSIGN; value=expr; SEMICOL
     { Assign (name, value, loc $startpos(name) $endpos(name)) }
 
-    | name=ID; LPAREN; params=separated_list(COMMA, expr); RPAREN; SEMICOL
-    { Expr (FunCall (name, params, loc $startpos $endpos)) }
+    | name=ID; LPAREN; args=separated_list(COMMA, expr); RPAREN; SEMICOL
+    { let rec make_args = function [] -> [] | h::t -> Arg h :: (make_args t) in
+      Expr (FunCall (name, make_args args, loc $startpos(name) $endpos(name))) }
 
     (* if-statements and (do-)while-loops: use location of condition *)
     | IF; LPAREN; cond=expr; RPAREN; body=block

phases/context_analysis.ml

@@ -2,63 +2,158 @@ open Printf
 open Ast
 open Util
 
-module StrMap = Map.Make (String)
+type nametype = Varname of string | Funcname of string
 
-let analyse_context args node =
-    let scope = ref StrMap.empty in
-    let add_to_scope name decl depth desc =
-        if StrMap.mem name !scope then (
-            let msg = sprintf "Error: cannot redeclare %s \"%s\"" desc name in
-            prerr_loc_msg (locof !decl) msg args.verbose;
+let type2str = function Funcname _ -> "function" | Varname _ -> "variable"
 
-            let (orig, _) = StrMap.find name !scope in
-            prerr_loc_msg (locof !orig) "Previously declared here:" args.verbose;
+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 (vars, funs) = scope in
+    let (name, tbl, other_map, desired_type) = match name with
+        | Varname  name -> (name, vars, funs, "variable")
+        | Funcname name -> (name, funs, vars, "function")
+    in
+    match mapfind name tbl with
+    | Some (decl, decl_depth, _) ->
+        (decl, decl_depth)
+    | None ->
+        let msg = match mapfind name other_map with
+            | Some _ -> sprintf "\"%s\" is not a %s" name desired_type
+            | None   -> sprintf "undefined %s \"%s\"" desired_type name
+        in
+        raise (NodeError (errnode, msg))
+
+let rec analyse scope depth args node =
+    (* add_to_scope uses args, so it needs to be defined here *)
+    let add_to_scope name decl depth scope =
+        let (vars, funs) = scope in
+        let (name, tbl, name_type) = match name with
+            | Varname name  -> (name, vars, "variable")
+            | Funcname name -> (name, funs, "function")
+        in
+        match mapfind name tbl with
+        (* Identifiers of lower depth may be overwritten, but idenetifiers at
+         * the same depth must be unique for consistency *)
+        | Some (orig, orig_depth, _) when orig_depth >= depth ->
+            let msg = sprintf "Error: cannot redeclare %s \"%s\"" name_type name in
+            prerr_loc_msg (locof decl) msg args.verbose;
+            prerr_loc_msg (locof orig) "Previously declared here:" args.verbose;
             raise EmptyError
-        ) else
-            scope := StrMap.add name (decl, depth) !scope
+        | Some _ ->
+            Hashtbl.replace tbl name (decl, depth, name_type)
+        | None ->
+            Hashtbl.add tbl name (decl, depth, name_type)
     in
-    let rec analyse depth node = match node with
+
+    let rec collect node = match node with
         (* Add node reference for this varname to vars map *)
         | VarDec (ctype, name, init, loc) ->
             let node = match init with
-                | Some value ->
-                    let value = analyse depth value in
-                    VarDec (ctype, name, Some value, loc)
+                | Some value -> VarDec (ctype, name, Some (collect value), loc)
                 | None -> node
             in
-            add_to_scope name (ref node) depth "variable";
+            add_to_scope (Varname name) node depth scope;
+            node
+
+        (* For global vars, only add the name *)
+        | GlobalDec (_, name, _)
+        | GlobalDef (_, _, name, _, _) ->
+            add_to_scope (Varname name) node depth scope;
             node
 
-        (* For a variable, look for its declaration in the current scope and
-         * save a reference with the relative nesting depth *)
+        (* Functions are traversed later on, for now only add the name *)
+        | FunDec (_, name, _, _)
+        | FunDef (_, _, name, _, _, _) ->
+            add_to_scope (Funcname name) node depth scope;
+            node
+
+        (* For a variable or function call, look for its declaration in the
+         * current scope and save a its type/depth information  *)
         | Var (name, _) ->
-            if StrMap.mem name !scope then
-                let (decl, decl_depth) = StrMap.find name !scope in
-                VarUse (node, decl, depth - decl_depth)
-            else
-                raise (NodeError (node, (sprintf "undefined variable \"%s\"" name)))
+            let (decl, decl_depth) = check_in_scope (Varname name) node scope in
+            VarUse (node, ctypeof decl, depth - decl_depth)
 
+        | FunCall (name, args, loc) ->
+            let (decl, decl_depth) = check_in_scope (Funcname name) node scope in
+            let node = FunCall (name, transform_all collect args, loc) in
+            FunUse (node, ctypeof decl, depth - decl_depth)
+
+        | _ -> transform_children collect node
+    in
+
+    (*let print_scope () =
+        let (vars, funs) = scope in
+        let print_key key value = prerr_string (" " ^ key) in
+        prerr_string "vars: ";
+        Hashtbl.iter print_key vars;
+        prerr_endline "";
+        prerr_string "funs: ";
+        Hashtbl.iter print_key funs;
+        prerr_endline "";
+    in*)
+
+    let rec traverse scope depth node =
+        match node with
         (* Increase nesting level when entering function *)
         | FunDef (export, ret_type, name, params, body, loc) ->
-            add_to_scope name (ref node) depth "function";
-            let params = List.map (analyse (depth + 1)) params in
-            let body = analyse (depth + 1) body in
+            let params = List.map (traverse scope depth) params in
+            let body = analyse scope depth args body in
             FunDef (export, ret_type, name, params, body, loc)
 
         | Param (ArrayDec (_, dims) as atype, name, _) as node ->
-            let add dim = add_to_scope dim (ref (Type atype)) depth "variable" in
-            List.iter add dims;
-            add_to_scope name (ref node) depth "variable";
+            let rec add_dims = function
+                | [] -> ()
+                | Dim (name, _) as dim :: tail ->
+                    add_to_scope (Varname name) (DimDec dim) depth scope;
+                    add_dims tail
+                | _ -> raise InvalidNode
+            in
+            add_dims dims;
+            add_to_scope (Varname name) node depth scope;
             node
 
         | Param (_, name, _) ->
-            add_to_scope name (ref node) depth "variable";
+            add_to_scope (Varname name) node depth scope;
             node
 
-        | node -> transform_children (analyse depth) node
+        (* Do not traverse into external function declarations, since their
+         * parameters must not be added to the namespace *)
+        | FunDec _ -> node
+
+        | _ -> transform_children (traverse scope depth) node
     in
-    analyse 0 node
+
+    (*
+     * First collect all definitions at the current depth. Then, traverse into
+     * functions with a copy of the current scope. This is needed because
+     * functions can access all identifiers in their surrounding scope.
+     * E.g., the following is allowed:
+     *
+     * void foo() { glob = 1; }
+     * int glob;
+     *)
+    (*prerr_endline "";
+    prerr_endline ("node:----\n" ^ Stringify.node2str node);
+    prerr_endline "----";*)
+    let node = collect node in
+    (*prerr_endline "collected";
+    print_scope ();
+    prerr_endline "\ntraversing";*)
+
+    let (vars, funs) = scope in
+    let local_scope = (Hashtbl.copy vars, Hashtbl.copy funs) in
+
+    let node = traverse local_scope (depth + 1) node in
+    (*prerr_endline "traversed";
+    print_scope ();
+    prerr_endline "";*)
+    node
+
+let analyse_context args program =
+    let scope = (Hashtbl.create 20, Hashtbl.create 20) in
+    analyse scope 0 args program
 
 let rec phase input =
     prerr_endline "- Context analysis";

phases/desug.ml

@@ -5,11 +5,6 @@ let block_body = function
     | Block nodes -> nodes
     | _ -> raise InvalidNode
 
-let rec flatten_blocks = function
-    | [] -> []
-    | Block nodes :: t -> (flatten_blocks nodes) @ (flatten_blocks t)
-    | h :: t -> h :: (flatten_blocks t)
-
 let rec replace_var var replacement = function
     | Var (name, loc) when name = var -> Var (replacement, loc)
     | node -> transform_children (replace_var var replacement) node
@@ -112,6 +107,7 @@ let rec var_init = function
             in
             flatten_blocks (trav [] body)
         in
+        let params = flatten_blocks (List.map var_init params) in
         let (body, new_vars) = for_to_while (Block (move_inits body)) in
         let create_vardec name = VarDec (Int, name, None, noloc) in
         let new_vardecs = List.map create_vardec !new_vars in

phases/dim_reduce.ml

@@ -0,0 +1,63 @@
+open Ast
+open Util
+
+let rec expand_dims = function
+    (* Flatten Block nodes returned by transformations below*)
+    | FunDef (export, ret_type, name, params, body, loc) as node ->
+        let params = flatten_blocks (List.map expand_dims params) in
+        FunDef (export, ret_type, name, params, expand_dims body, loc)
+
+    | FunDec (ret_type, name, params, loc) ->
+        let params = flatten_blocks (List.map expand_dims params) in
+        FunDec (ret_type, name, params, loc)
+
+    | FunCall (name, args, loc) as node ->
+        FunCall (name, flatten_blocks (List.map expand_dims args), loc)
+
+    (* Add additional parameters for array dimensions *)
+    | Param (ArrayDec (_, dims), name, _) as node ->
+        let rec do_expand = function
+            | [] -> [node]
+            | Dim (name, loc) :: tail ->
+                Param (Int, name, loc) :: (do_expand tail)
+            | _ -> raise InvalidNode
+        in
+        Block (do_expand dims)
+
+    (* Add additional function arguments for array dimensions *)
+    | Arg (VarUse (_, ArrayDec (_, dims), _)) as node ->
+        let rec do_expand = function
+            | [] -> [node]
+            | Dim (name, _) :: tail ->
+                Var (name, noloc) :: (do_expand tail)
+            | _ -> raise InvalidNode
+        in
+        Block (do_expand dims)
+
+    | node -> transform_children expand_dims node
+
+(*
+let rec array_init = function
+    (* transform scalar assignment into nested for loops *)
+    | Assign (name, ArrayScalar (value)) ->
+        let rec add_loop indices = function
+            | [] ->
+                Assign (Deref (name, indices), value)
+            | dim :: rest ->
+                let counter = fresh_var "counter" in
+                let ind = (indices @ [Var counter]) in
+                For (counter, IntConst 0, dim, IntConst 1, add_loop ind rest)
+        in
+        add_loop [] dims
+
+    | Assign (name, ArrayConst (dims)) -> Block []
+
+    | node -> transform array_init node
+*)
+
+let rec phase input =
+    prerr_endline "- Array dimension reduction";
+    match input with
+    | Ast (node, args) ->
+        Ast (expand_dims node, args)
+    | _ -> raise (InvalidInput "desugar")

stringify.ml

@@ -32,14 +32,14 @@ let rec type2str = function
     | Bool -> "bool"
     | Int -> "int"
     | Float -> "float"
-    | ArrayDec (t, dims) -> (type2str t) ^ "[" ^ (String.concat ", " dims) ^ "]"
-    | ArrayDef (t, dims) -> (type2str t) ^ "[" ^ (String.concat ", " (List.map node2str dims)) ^ "]"
+    | ArrayDec (t, dims)
+    | ArrayDef (t, dims) -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
+
+and concat sep nodes = String.concat sep (List.map node2str nodes)
 
 (* node -> string *)
 and node2str node =
     let str = node2str in
-    let all_str = List.map str in
-    let concat sep nodes = String.concat sep (all_str nodes) in
     match node with
 
     (* Global *)
@@ -47,12 +47,13 @@ and node2str node =
         concat "\n\n" decls
     | Param (param_type, name, _) ->
         (type2str param_type) ^ " " ^ name
+    | Dim (name, _) -> name
     | FunDec (ret_type, name, params, _) ->
         let params = concat ", " params in
         "extern " ^ type2str ret_type ^ " " ^ name ^ "(" ^ params ^ ");"
     | FunDef (export, ret_type, name, params, body, _) ->
         let export = if export then "export " else "" in
-        let params = "(" ^ (concat "," params) ^ ")" in
+        let params = "(" ^ (concat ", " params) ^ ")" in
         export ^ type2str ret_type ^ " " ^ name ^ params ^ " " ^ str body
     | GlobalDec (var_type, name, _) ->
         "extern " ^ type2str var_type ^ " " ^ name ^ ";"
@@ -101,14 +102,15 @@ and node2str node =
     | ArrayConst (dims, _) -> "[" ^ concat ", " dims ^ "]"
     | ArrayScalar (value, _) -> str value
     | Var (v, _) -> v
-    | VarUse (var, _, _) -> str var
     | Deref (name, dims, _) -> name ^ (str (ArrayConst (dims, noloc)))
     | Monop (op, opnd, _) -> monop2str op ^ str opnd
-    | Binop (op, left, right, _) ->
-        "(" ^ str left ^ binop2str op ^ str right ^ ")"
-    | Cond (cond, t, f, _) ->
-        (str cond) ^ " ? " ^ str t ^ " : " ^ str f
-    | TypeCast (ctype, value, _) ->
-        "(" ^ type2str ctype ^ ")" ^ str value
-    | FunCall (name, args, _) ->
-        name ^ "(" ^ (concat ", " args) ^ ")"
+    | Binop (op, left, right, _) -> "(" ^ str left ^ binop2str op ^ str right ^ ")"
+    | Cond (cond, t, f, _) -> (str cond) ^ " ? " ^ str t ^ " : " ^ str f
+    | TypeCast (ctype, value, _) -> "(" ^ type2str ctype ^ ")" ^ str value
+    | FunCall (name, args, _) -> name ^ "(" ^ (concat ", " args) ^ ")"
+
+    | Arg node
+    | VarUse (node, _, _)
+    | FunUse (node, _, _) -> str node
+
+    | _ -> raise InvalidNode

test/array_scope.cvc

@@ -0,0 +1,6 @@
+extern void printInt(int val);
+
+void foo(int[n] arr) {
+    printInt(n);
+    foo(arr);
+}

test/scope.cvc

@@ -1,3 +1,21 @@
-int foobar() {
-    int foobar;
+int get_glob() {
+    int local;
+
+    void inc_local() {
+        add_local(1);
+    }
+
+    void add_local(int i) {
+        local = local + i;
+    }
+
+    return glob;
+}
+
+int glob = 1;
+
+int foo(int param) {
+    int foo = foo();
+    int glob;
+    return foo;
 }

util.ml

@@ -55,6 +55,8 @@ let transform_children trav node =
         For (counter, trav start, trav stop, trav step, trav body, loc)
     | Expr value ->
         Expr (trav value)
+    | Block (body) ->
+        Block (trav_all body)
 
     | Monop (op, value, loc) ->
         Monop (op, trav value, loc)
@@ -66,18 +68,28 @@ let transform_children trav node =
         TypeCast (ctype, trav value, loc)
     | FunCall (name, args, loc) ->
         FunCall (name, trav_all args, loc)
-
-    | Block (body) ->
-        Block (trav_all body)
+    | Arg value ->
+        Arg (trav value)
 
     | VarUse (var, def, depth) ->
         VarUse (trav var, def, depth)
+    | FunUse (funcall, def, depth) ->
+        FunUse (trav funcall, def, depth)
+    | DimDec node ->
+        DimDec (trav node)
 
     | _ -> node
 
+(* Default tree transformation
+ * (node -> node) -> node -> node *)
+let rec transform_all trav = function
+    | [] -> []
+    | node :: tail -> trav node :: (transform_all trav tail)
+
  let rec locof = function
     | Program (_, loc)
     | Param (_, _, loc)
+    | Dim (_, loc)
     | FunDec (_, _, _, loc)
     | FunDef (_, _, _, _, _, loc)
     | GlobalDec (_, _, loc)
@@ -104,9 +116,13 @@ let transform_children trav node =
     | TypeCast (_, _, loc)
     | FunCall (_, _, loc) -> loc
 
-    | Expr value | VarUse (value, _, _) -> locof value
+    | Expr value
+    | VarUse (value, _, _)
+    | FunUse (value, _, _)
+    | Arg value
+    | DimDec value -> locof value
 
-    | Block _ | Type _ -> noloc
+    | _ -> noloc
 
 let prerr_loc (fname, ystart, yend, xstart, xend) =
     let file = open_in fname in
@@ -144,3 +160,23 @@ let prerr_loc_msg loc msg verbose =
 
     if verbose >= 2 then prerr_loc loc;
     ()
+
+let rec flatten_blocks = function
+    | [] -> []
+    | Block nodes :: t -> (flatten_blocks nodes) @ (flatten_blocks t)
+    | h :: t -> h :: (flatten_blocks t)
+
+let ctypeof = function
+    | VarDec (ctype, _, _, _)
+    | Param (ctype, _, _)
+    | FunDec (ctype, _, _, _)
+    | FunDef (_, ctype, _, _, _, _)
+    | GlobalDec (ctype, _, _)
+    | GlobalDef (_, ctype, _, _, _)
+    | TypeCast (ctype, _, _)
+    | Type ctype
+        -> ctype
+
+    | DimDec _ -> Int
+
+    | _ -> raise InvalidNode

util.mli

@@ -7,6 +7,9 @@ val loc_from_lexpos : Lexing.position -> Lexing.position -> Ast.loc
 (* Default transformation traversal for AST nodes *)
 val transform_children : (Ast.node -> Ast.node) -> Ast.node -> Ast.node
 
+(* Transform all nodes in a list *)
+val transform_all : (Ast.node -> Ast.node) -> Ast.node list -> Ast.node list
+
 (*val visit_children : (Ast.node -> unit) -> Ast.node -> unit*)
 
 (* Extract location from node *)
@@ -17,3 +20,9 @@ val prerr_loc : Ast.loc -> unit
 
 (* Print file location to stderr *)
 val prerr_loc_msg : Ast.loc -> string -> int -> unit
+
+(* Flatten Block nodes into the given array of nodes *)
+val flatten_blocks : Ast.node list -> Ast.node list
+
+(* Get function / expression type *)
+val ctypeof : Ast.node -> Ast.ctype