Formatted all source code to 2 spaces as tab, and some more prettifications

globals.ml

@@ -4,10 +4,10 @@ open Types
  * (yes, it is a bit dirty, but I don't know how to do this without passing
  * [args] to every function). *)
 let args = {
-    infile   = None;
-    outfile  = None;
-    verbose  = 1;
-    cpp      = true;
-    optimize = true;
-    endphase = "";
+  infile   = None;
+  outfile  = None;
+  verbose  = 1;
+  cpp      = true;
+  optimize = true;
+  endphase = "";
 }

main.ml

@@ -8,117 +8,120 @@ let always _ = true
 let when_optimize _ = args.optimize
 
 let phases = [
-    ("load", Load.phase, always,
-     "Load input file");
-    ("parse", Parse.phase, always,
-     "Parse input");
-    ("desug", Desug.phase, always,
-     "Desugaring");
-    ("context", Context.phase, always,
-     "Context analysis");
-    ("typecheck", Typecheck.phase, always,
-     "Type checking");
-    ("dimreduce", Dimreduce.phase, always,
-     "Array dimension reduction");
-    ("boolop", Boolop.phase, always,
-     "Convert bool operations");
-    ("extern", Extern.phase, always,
-     "Create getters and setters for extern variables");
-    ("constprop", Constprop.phase, when_optimize,
-     "Constant propagation");
-    ("index", Index.phase, always,
-     "Index analysis");
-    ("assemble", Assemble.phase, always,
-     "Assembly");
-    ("peephole", Peephole.phase, when_optimize,
-     "Peephole optimization");
-    ("output", Output.phase, always,
-     "Output assembly");
+  ("load", Load.phase, always,
+   "Load input file");
+  ("parse", Parse.phase, always,
+   "Parse input");
+  ("desug", Desug.phase, always,
+   "Desugaring");
+  ("context", Context.phase, always,
+   "Context analysis");
+  ("typecheck", Typecheck.phase, always,
+   "Type checking");
+  ("dimreduce", Dimreduce.phase, always,
+   "Array dimension reduction");
+  ("boolop", Boolop.phase, always,
+   "Convert bool operations");
+  ("extern", Extern.phase, always,
+   "Create getters and setters for extern variables");
+  ("constprop", Constprop.phase, when_optimize,
+   "Constant propagation");
+  ("index", Index.phase, always,
+   "Index analysis");
+  ("assemble", Assemble.phase, always,
+   "Assembly");
+  ("peephole", Peephole.phase, when_optimize,
+   "Peephole optimization");
+  ("output", Output.phase, always,
+   "Output assembly");
 ]
 
 (* Compile CVC file to assembly code
  * in_channel -> int -> repr *)
 let compile () =
-    let rec run_phases input = function
-        | [] -> ()
-        | (id, phase, cond, msg) :: tl ->
-            let output = if cond () then (
-                log_plain_line 2 (expand 13 ("- " ^ id ^ ":") ^ msg);
-                let output = phase input in
-                if id = args.endphase || args.verbose >= 2 then (
-                    let _ = Print.phase output in ()
-                );
-                output
-            ) else input in
-            if id = args.endphase then () else run_phases output tl
-    in
-    run_phases Empty phases
+  let rec run_phases input = function
+    | [] -> ()
+    | (id, phase, cond, msg) :: tl ->
+      let output =
+        if cond () then begin
+          log_plain_line 2 (expand 13 ("- " ^ id ^ ":") ^ msg);
+          let output = phase input in
+          if id = args.endphase || args.verbose >= 2 then begin
+            ignore (Print.phase output)
+          end;
+          output
+        end else
+          input
+      in
+      if id = args.endphase then () else run_phases output tl
+  in
+  run_phases Empty phases
 
 (* Main function, returns exit status
  * Command-line arguments are stored in Util.args
  * () -> int *)
 let main () =
-    let rec upto_usage = function
-        | [] -> ""
-        | (id, _, _, msg) :: tl ->
-            "\n" ^ repeat " " 12 ^ expand 10 id ^ ": " ^ msg ^ (upto_usage tl)
-    in
-    let args_spec = [
-        ("<file>", Arg.Rest (fun s -> ()),
-                 "   Optional input file (default is to read from stdin)");
+  let rec upto_usage = function
+    | [] -> ""
+    | (id, _, _, msg) :: tl ->
+      "\n" ^ repeat " " 12 ^ expand 10 id ^ ": " ^ msg ^ (upto_usage tl)
+  in
+  let args_spec = [
+    ("<file>", Arg.Rest (fun s -> ()),
+             "   Optional input file (default is to read from stdin)");
 
-        ("-o", Arg.String (fun s -> args.outfile <- Some s),
-             "<file> Output file (defaults to foo.s for foo.cvc)");
+    ("-o", Arg.String (fun s -> args.outfile <- Some s),
+         "<file> Output file (defaults to foo.s for foo.cvc)");
 
-        ("-v", Arg.Int (fun i -> args.verbose <- i),
-             "<num>  Set verbosity (0: nothing, 1: errors, 2: intermediate, 3: debug)");
+    ("-v", Arg.Int (fun i -> args.verbose <- i),
+         "<num>  Set verbosity (0: nothing, 1: errors, 2: intermediate, 3: debug)");
 
-        ("-nocpp", Arg.Unit (fun _ -> args.cpp <- false),
-                 "   Disable C preprocessor");
-        ("-cpp", Arg.Unit (fun _ -> args.cpp <- true),
-               "     Enable C preprocessor (overwrite earlier -nocpp)");
+    ("-nocpp", Arg.Unit (fun _ -> args.cpp <- false),
+             "   Disable C preprocessor");
+    ("-cpp", Arg.Unit (fun _ -> args.cpp <- true),
+           "     Enable C preprocessor (overwrite earlier -nocpp)");
 
-        ("-noopt", Arg.Unit (fun _ -> args.optimize <- false),
-                 "   Disable optimization");
-        ("-opt", Arg.Unit (fun _ -> args.optimize <- true),
-               "     Enable optimization (overwrite earlier -nocpp)");
+    ("-noopt", Arg.Unit (fun _ -> args.optimize <- false),
+             "   Disable optimization");
+    ("-opt", Arg.Unit (fun _ -> args.optimize <- true),
+           "     Enable optimization (overwrite earlier -nocpp)");
 
-        ("-upto", Arg.String (fun s -> args.endphase <- s),
-                "<phase> Stop after the specified phase, and print the intermediate " ^
-                "representation to stderr.\n        " ^
-                "    Possible options are (in order of execution):" ^ upto_usage phases);
-    ] in
+    ("-upto", Arg.String (fun s -> args.endphase <- s),
+            "<phase> Stop after the specified phase, and print the intermediate \
+             representation to stderr.\n        \
+             Possible options are (in order of execution):" ^ upto_usage phases);
+  ] in
 
-    let usage =
-        "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] " ^
-        " [-v <verbosity>] [-upto <phase>] [<file>]"
-    in
+  let usage =
+    "Usage: " ^ Sys.argv.(0) ^ " [-o <file>] [-nocpp] [-noopt] \
+     [-v <verbosity>] [-upto <phase>] [<file>]"
+  in
 
+  try
     try
-        try
-            Arg.parse args_spec (fun s -> args.infile <- Some s) usage;
-            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))
+      Arg.parse args_spec (fun s -> args.infile <- Some s) usage;
+      compile ();
+      0
     with
-    | CompileError msg ->
-        eprintf "Error: %s\n" msg;
-        1
-    | LocError (loc, msg) ->
-        prerr_loc_msg loc ("Error: " ^ msg);
-        1
-    | EmptyError ->
-        1
+    (*| 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 ->
+    1
 
 let _ = exit (main ())

phases/assemble.ml

@@ -7,256 +7,254 @@ open Globals
 let comline comment = InlineComment (EmptyLine, comment)
 
 let assemble program =
-    let labcounter = ref 0 in
-    let genlabel suffix =
-        labcounter := !labcounter + 1;
-        string_of_int !labcounter ^ "_" ^ suffix
+  let labcounter = ref 0 in
+  let genlabel suffix =
+  labcounter := !labcounter + 1;
+  string_of_int !labcounter ^ "_" ^ suffix
+  in
+
+  let consts = Hashtbl.create 20 in
+
+  let rec trav node =
+  let rec trav_all = function
+    | [] -> []
+    | hd :: tl -> trav hd @ (trav_all tl)
+  in
+  let rec traverse_localfuns = function
+    | LocalFuns body -> List.concat (List.map trav body)
+    | Block body -> List.concat (List.map traverse_localfuns body)
+    | _ -> []
+  in
+  match node with
+  (* Global *)
+  | Program (decls, _) ->
+    trav_all decls
+
+  | GlobalDef (_, ctype, name, _, _) ->
+    [Comment (sprintf "global var \"%s\" at index %d" name (indexof node));
+     Global ctype]
+
+  | FunDec (ret_type, name, params, _) ->
+    [Comment (sprintf "extern fun \"%s\" at index %d" name (indexof node));
+     Import (name, ret_type, List.map typeof params)]
+
+  | FunDef (export, ret_type, name, params, body, _) ->
+    let label = labelof node in
+    (if export then
+        let param_types = List.map typeof params in
+        [Export (name, ret_type, param_types, label)]
+    else []) @
+    [Comment (sprintf "fun \"%s\" with %d local vars" label (indexof node));
+     Label label;
+     RtnEnter (indexof node)] @
+    (trav body) @
+    (match ret_type with Void -> [Ret Void] | _ -> []) @
+    [EmptyLine] @
+    (traverse_localfuns body)
+
+  | VarDec (_, name, _, _) ->
+    [comline (sprintf "local var \"%s\" at index %d" name (indexof node))]
+
+  | LocalFuns _ -> []
+
+  | Block body | VarDecs body -> trav_all body
+
+  (* Statements *)
+  | VarLet (dec, None, value, _) ->
+    let store = match (depthof dec, depthof node) with
+    | (0, _)            -> Store (typeof dec, Glob,        indexof dec)
+    | (a, b) when a = b -> Store (typeof dec, Current,     indexof dec)
+    | (a, b)            -> Store (typeof dec, Rel (b - a), indexof dec)
     in
-
-    let consts = Hashtbl.create 20 in
-
-    let rec trav node =
-        let rec trav_all = function
-            | [] -> []
-            | hd :: tl -> trav hd @ (trav_all tl)
-        in
-        let rec traverse_localfuns = function
-            | LocalFuns body -> List.concat (List.map trav body)
-            | Block body -> List.concat (List.map traverse_localfuns body)
-            | _ -> []
-        in
-        match node with
-        (* Global *)
-        | Program (decls, _) ->
-            trav_all decls
-
-        | GlobalDef (_, ctype, name, _, _) ->
-            [Comment (sprintf "global var \"%s\" at index %d" name (indexof node));
-             Global ctype]
-
-        | FunDec (ret_type, name, params, _) ->
-            [Comment (sprintf "extern fun \"%s\" at index %d" name (indexof node));
-             Import (name, ret_type, List.map typeof params)]
-
-        | FunDef (export, ret_type, name, params, body, _) ->
-            let label = labelof node in
-            (if export then
-                let param_types = List.map typeof params in
-                [Export (name, ret_type, param_types, label)]
-            else []) @
-            [
-                Comment (sprintf "fun \"%s\" with %d local vars" label (indexof node));
-                Label label;
-                RtnEnter (indexof node);
-            ] @
-            (trav body) @
-            (match ret_type with Void -> [Ret Void] | _ -> []) @
-            [EmptyLine] @
-            (traverse_localfuns body)
-
-        | VarDec (_, name, _, _) ->
-            [comline (sprintf "local var \"%s\" at index %d" name (indexof node))]
-
-        | LocalFuns _ -> []
-
-        | Block body | VarDecs body -> trav_all body
-
-        (* Statements *)
-        | VarLet (dec, None, value, _) ->
-            let store = match (depthof dec, depthof node) with
-                | (0, _)            -> Store (typeof dec, Glob,        indexof dec)
-                | (a, b) when a = b -> Store (typeof dec, Current,     indexof dec)
-                | (a, b)            -> Store (typeof dec, Rel (b - a), indexof dec)
-            in
-            trav value @ [InlineComment (store, node2str node)]
-
-        | Return (value, _) ->
-            trav value @ [InlineComment (Ret (typeof value), node2str node)]
-
-        | If (cond, body, _) ->
-            let endlabel = genlabel "end" in
-            (trav cond) @
-            [Branch (false, endlabel);
-             comline ("if (" ^ (node2str cond) ^ ") {")] @
-            (trav body) @
-            [comline "}";
-             Label endlabel]
-
-        | IfElse (cond, true_body, false_body, _) ->
-            let elselabel = genlabel "else" in
-            let endlabel = genlabel "end" in
-            (trav cond) @
-            [Branch (false, elselabel);
-             comline ("if (" ^ (node2str cond) ^ ") {")] @
-            (trav true_body) @
-            [Jump endlabel;
-             comline "} else {";
-             Label elselabel] @
-            (trav false_body) @
-            [comline "}";
-             Label endlabel]
-
-        | While (cond, body, _) ->
-            let startlabel = genlabel "while" in
-            let endlabel = genlabel "end" in
-            let com = ("while (" ^ (node2str cond) ^ ") {") in
-            [Label startlabel] @
-            (trav cond) @
-            [InlineComment (Branch (false, endlabel), com)] @
-            (trav body) @
-            [Jump startlabel;
-             Label endlabel;
-             comline "}"]
-
-        | DoWhile (cond, body, _) ->
-            let startlabel = genlabel "dowhile" in
-            let com = ("} while (" ^ (node2str cond) ^ ");") in
-            [comline "do {";
-             Label startlabel] @
-            (trav body) @
-            (trav cond) @
-            [InlineComment (Branch (true, startlabel), com)]
-
-        (* Expression statement pops the disregarded expression value from the
-         * stack, if any *)
-        | Expr value ->
-            let pop = match typeof value with
-                | Void -> [comline (node2str node)]
-                | ctype -> [InlineComment (Pop ctype, node2str node)]
-            in
-            (trav value) @ pop
-
-        (* Expressions *)
-        (* Immediate values are handled here, and not in the peephole optimizer,
-         * for convenience: the indices in the constant table would be altered,
-         * so entries cannot be removed. By this early detection (also during
-         * index analysis), they are not added in the first place *)
-        | Const (value, _) when is_immediate_const value ->
-            [InlineComment (LoadImm value, node2str node)]
-
-        | Const (value, _) ->
-            Hashtbl.replace consts value (indexof node);
-            let load = LoadConst (typeof node, indexof node) in
-            [InlineComment (load, node2str node)]
-
-        | VarUse (dec, None, _) ->
-            let load = match (depthof dec, depthof node) with
-                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
-                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
-                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
-            in
-            [InlineComment (load, node2str node)]
-
-        | Monop (op, value, _) ->
-            (trav value) @
-            [InlineComment (Op (op, typeof value), op2str op)]
-
-        | Binop (op, left, right, _) ->
-            (trav left) @
-            (trav right) @
-            [InlineComment (Op (op, typeof left), op2str op)]
-
-        | 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))
-            );
-            trav value @ [Convert (vtype, ctype)]
-
-        (* Function calls *)
-        | FunUse (dec, args, _) ->
-            let init = match (depthof dec, depthof node) with
-                | (0, _)                -> RtnInit Glob
-                | (a, b) when a = b - 1 -> RtnInit Current
-                | (a, b) when a = b     -> RtnInit Local
-                | (a, b)                -> RtnInit (Rel (b - a - 1))
-            in
-            let jmp = match dec with
-                | FunDec _ -> RtnJmp (ExternFun (indexof dec))
-                | FunDef _ -> RtnJmp (LocalFun (List.length args, labelof dec))
-                | _ -> raise InvalidNode
-            in
-            init :: (trav_all args) @ [jmp]
-
-        | Arg value -> trav value
-
-        (* Conditional expression (short-circuit evaluation) *)
-        (*     <cond>
-         *     branch_f else
-         *     <true_expr>
-         *     jump end
-         * else:
-         *     <false_expr>
-         * end:
-         *)
-        | Cond (cond, texp, fexp, _) ->
-            let elselabel = genlabel "false_expr" in
-            let endlabel = genlabel "end" in
-            (trav cond) @
-            [Branch (false, elselabel)] @
-            (trav texp) @
-            [Jump (endlabel);
-             Label (elselabel)] @
-            (trav fexp) @
-            [InlineComment (Label (endlabel), node2str node)]
-
-        (* Arrays *)
-        | Allocate (dec, dims, _) ->
-            let store = match (depthof dec, depthof node) with
-                | (0, _)            -> Store (typeof dec, Glob,    indexof dec)
-                | (a, b) when a = b -> Store (typeof dec, Current, indexof dec)
-                | _                 -> raise InvalidNode
-            in
-            trav_all dims @
-            [NewArray (basetypeof dec, List.length dims);
-             InlineComment (store, node2str node)]
-
-        | VarUse (dec, Some dims, _) ->
-            let load = match (depthof dec, depthof node) with
-                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
-                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
-                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
-            in
-            (trav_all (List.rev dims)) @          (* push dimensions *)
-            [InlineComment (load, nameof dec)] @  (* push array reference *)
-            [InlineComment (LoadArray (basetypeof dec), node2str node)]
-
-        | VarLet (dec, Some dims, value, _) ->
-            let load = match (depthof dec, depthof node) with
-                | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
-                | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
-                | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
-            in
-            (trav value) @                        (* push value *)
-            (trav_all dims) @                     (* push dimensions *)
-            [InlineComment (load, nameof dec)] @  (* push array reference *)
-            [InlineComment (StoreArray (basetypeof dec), node2str node)]
-
-        | _ -> [Comment ("FIXME: " ^ Stringify.node2str node)]
-        (*| _ -> raise InvalidNode*)
+    trav value @ [InlineComment (store, node2str node)]
+
+  | Return (value, _) ->
+    trav value @ [InlineComment (Ret (typeof value), node2str node)]
+
+  | If (cond, body, _) ->
+    let endlabel = genlabel "end" in
+    (trav cond) @
+    [Branch (false, endlabel);
+     comline ("if (" ^ (node2str cond) ^ ") {")] @
+    (trav body) @
+    [comline "}";
+     Label endlabel]
+
+  | IfElse (cond, true_body, false_body, _) ->
+    let elselabel = genlabel "else" in
+    let endlabel = genlabel "end" in
+    (trav cond) @
+    [Branch (false, elselabel);
+     comline ("if (" ^ (node2str cond) ^ ") {")] @
+    (trav true_body) @
+    [Jump endlabel;
+     comline "} else {";
+     Label elselabel] @
+    (trav false_body) @
+    [comline "}";
+     Label endlabel]
+
+  | While (cond, body, _) ->
+    let startlabel = genlabel "while" in
+    let endlabel = genlabel "end" in
+    let com = ("while (" ^ (node2str cond) ^ ") {") in
+    [Label startlabel] @
+    (trav cond) @
+    [InlineComment (Branch (false, endlabel), com)] @
+    (trav body) @
+    [Jump startlabel;
+     Label endlabel;
+     comline "}"]
+
+  | DoWhile (cond, body, _) ->
+    let startlabel = genlabel "dowhile" in
+    let com = ("} while (" ^ (node2str cond) ^ ");") in
+    [comline "do {";
+     Label startlabel] @
+    (trav body) @
+    (trav cond) @
+    [InlineComment (Branch (true, startlabel), com)]
+
+  (* Expression statement pops the disregarded expression value from the
+   * stack, if any *)
+  | Expr value ->
+    let pop = match typeof value with
+        | Void -> [comline (node2str node)]
+        | ctype -> [InlineComment (Pop ctype, node2str node)]
     in
-    let instrs = trav program in
-
-    (* Sort aggregated constants and add definitions
-     * If possible, this should be rewritten in the future because it's a little
-     * cumbersome right now... *)
-    let pairs = ref [] in
-    let add_pair value index =
-        let com = sprintf "index %d" index in
-        pairs := (InlineComment (ConstDef value, com), index) :: !pairs;
+    (trav value) @ pop
+
+  (* Expressions *)
+  (* Immediate values are handled here, and not in the peephole optimizer,
+   * for convenience: the indices in the constant table would be altered,
+   * so entries cannot be removed. By this early detection (also during
+   * index analysis), they are not added in the first place *)
+  | Const (value, _) when is_immediate_const value ->
+    [InlineComment (LoadImm value, node2str node)]
+
+  | Const (value, _) ->
+    Hashtbl.replace consts value (indexof node);
+    let load = LoadConst (typeof node, indexof node) in
+    [InlineComment (load, node2str node)]
+
+  | VarUse (dec, None, _) ->
+    let load = match (depthof dec, depthof node) with
+    | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+    | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+    | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
     in
-    Hashtbl.iter add_pair consts;
-    let cmp (_, i) (_, j) = compare i j in
-    let sorted_pairs = List.sort cmp !pairs in
-    let const_defs = List.map (fun (d, _) -> d) sorted_pairs in
-
-    instrs @ const_defs
+    [InlineComment (load, node2str node)]
+
+  | Monop (op, value, _) ->
+    (trav value) @
+    [InlineComment (Op (op, typeof value), op2str op)]
+
+  | Binop (op, left, right, _) ->
+    (trav left) @
+    (trav right) @
+    [InlineComment (Op (op, typeof left), op2str op)]
+
+  | 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))
+    );
+    trav value @ [Convert (vtype, ctype)]
+
+  (* Function calls *)
+  | FunUse (dec, args, _) ->
+    let init = match (depthof dec, depthof node) with
+    | (0, _)                -> RtnInit Glob
+    | (a, b) when a = b - 1 -> RtnInit Current
+    | (a, b) when a = b     -> RtnInit Local
+    | (a, b)                -> RtnInit (Rel (b - a - 1))
+    in
+    let jmp = match dec with
+    | FunDec _ -> RtnJmp (ExternFun (indexof dec))
+    | FunDef _ -> RtnJmp (LocalFun (List.length args, labelof dec))
+    | _ -> raise InvalidNode
+    in
+    init :: (trav_all args) @ [jmp]
+
+  | Arg value -> trav value
+
+  (* Conditional expression (short-circuit evaluation) *)
+  (*     <cond>
+   *     branch_f else
+   *     <true_expr>
+   *     jump end
+   * else:
+   *     <false_expr>
+   * end:
+   *)
+  | Cond (cond, texp, fexp, _) ->
+    let elselabel = genlabel "false_expr" in
+    let endlabel = genlabel "end" in
+    (trav cond) @
+    [Branch (false, elselabel)] @
+    (trav texp) @
+    [Jump (endlabel);
+     Label (elselabel)] @
+    (trav fexp) @
+    [InlineComment (Label (endlabel), node2str node)]
+
+  (* Arrays *)
+  | Allocate (dec, dims, _) ->
+    let store = match (depthof dec, depthof node) with
+    | (0, _)            -> Store (typeof dec, Glob,    indexof dec)
+    | (a, b) when a = b -> Store (typeof dec, Current, indexof dec)
+    | _                 -> raise InvalidNode
+    in
+    trav_all dims @
+    [NewArray (basetypeof dec, List.length dims);
+     InlineComment (store, node2str node)]
+
+  | VarUse (dec, Some dims, _) ->
+    let load = match (depthof dec, depthof node) with
+    | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+    | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+    | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
+    in
+    (trav_all (List.rev dims)) @          (* push dimensions *)
+    [InlineComment (load, nameof dec)] @  (* push array reference *)
+    [InlineComment (LoadArray (basetypeof dec), node2str node)]
+
+  | VarLet (dec, Some dims, value, _) ->
+    let load = match (depthof dec, depthof node) with
+    | (0, _)            -> Load (typeof dec, Glob,        indexof dec)
+    | (a, b) when a = b -> Load (typeof dec, Current,     indexof dec)
+    | (a, b)            -> Load (typeof dec, Rel (b - a), indexof dec)
+    in
+    (trav value) @                        (* push value *)
+    (trav_all dims) @                     (* push dimensions *)
+    [InlineComment (load, nameof dec)] @  (* push array reference *)
+    [InlineComment (StoreArray (basetypeof dec), node2str node)]
+
+  | _ -> [Comment ("FIXME: " ^ Stringify.node2str node)]
+  (*| _ -> raise InvalidNode*)
+  in
+  let instrs = trav program in
+
+  (* Sort aggregated constants and add definitions
+   * If possible, this should be rewritten in the future because it's a little
+   * cumbersome right now... *)
+  let pairs = ref [] in
+  let add_pair value index =
+  let com = sprintf "index %d" index in
+  pairs := (InlineComment (ConstDef value, com), index) :: !pairs;
+  in
+  Hashtbl.iter add_pair consts;
+  let cmp (_, i) (_, j) = compare i j in
+  let sorted_pairs = List.sort cmp !pairs in
+  let const_defs = List.map (fun (d, _) -> d) sorted_pairs in
+
+  instrs @ const_defs
 
 let phase = function
-    | Ast node -> Assembly (assemble node)
-    | _ -> raise (InvalidInput "assembly")
+  | Ast node -> Assembly (assemble node)
+  | _ -> raise (InvalidInput "assembly")

phases/boolop.ml

@@ -9,11 +9,11 @@
  * > b1 != b2   ==>   (int)b1 != (int)b2
  * > b1 && b2   ==>   b1 ? b2 : false
  * > b1 || b2   ==>   b1 ? true : b2
- * > b1 + b2    ==>   (bool)((int)b1 + (int)b2)
- * > b1 * b2    ==>   (bool)((int)b1 * (int)b2)
- * > (bool)i    ==>   i != 0
- * > (bool)f    ==>   f != 0.0
- * > (int)b1    ==>   b1 ? 1 : 0
+ * > b1 + b2  ==>   (bool)((int)b1 + (int)b2)
+ * > b1 * b2  ==>   (bool)((int)b1 * (int)b2)
+ * > (bool)i  ==>   i != 0
+ * > (bool)f  ==>   f != 0.0
+ * > (int)b1  ==>   b1 ? 1 : 0
  * > (float)b1  ==>   b1 ? 1.0 : 0.0
  *)
 open Types
@@ -27,42 +27,42 @@ let intconst   value = Const (IntVal   value, [Type Int])
 let floatconst value = Const (FloatVal value, [Type Float])
 
 let rec trav_binop = function
-    | ((Eq | Ne) as op, left, right, ann) ->
-        bool_op (Binop (op, cast Int left, cast Int right, ann))
+  | ((Eq | Ne) as op, left, right, ann) ->
+    bool_op (Binop (op, cast Int left, cast Int right, ann))
 
-    | (And, left, right, ann) ->
-        bool_op (Cond (left, right, boolconst false, ann))
+  | (And, left, right, ann) ->
+    bool_op (Cond (left, right, boolconst false, ann))
 
-    | (Or, left, right, ann) ->
-        bool_op (Cond (left, boolconst true, right, ann))
+  | (Or, left, right, ann) ->
+    bool_op (Cond (left, boolconst true, right, ann))
 
-    | ((Add | Mul) as op, left, right, ann) ->
-        bool_op (cast Bool (Binop (op, cast Int left, cast Int right, Type Int :: ann)))
+  | ((Add | Mul) as op, left, right, ann) ->
+    bool_op (cast Bool (Binop (op, cast Int left, cast Int right, Type Int :: ann)))
 
-    | (op, left, right, ann) ->
-        Binop (op, left, right, ann)
+  | (op, left, right, ann) ->
+    Binop (op, left, right, ann)
 
 and bool_op = function
-    | Binop (op, left, right, ann) when typeof left = Bool && typeof right = Bool ->
-        trav_binop (op, bool_op left, bool_op right, ann)
+  | Binop (op, left, right, ann) when typeof left = Bool && typeof right = Bool ->
+    trav_binop (op, bool_op left, bool_op right, ann)
 
-    | TypeCast (Bool, value, ann) when typeof value = Int ->
-        Binop (Ne, bool_op value, intconst 0, ann)
+  | TypeCast (Bool, value, ann) when typeof value = Int ->
+    Binop (Ne, bool_op value, intconst 0, ann)
 
-    | TypeCast (Bool, value, ann) when typeof value = Float ->
-        Binop (Ne, bool_op value, floatconst 0.0, ann)
+  | TypeCast (Bool, value, ann) when typeof value = Float ->
+    Binop (Ne, bool_op value, floatconst 0.0, ann)
 
-    | TypeCast (Int, value, ann) when typeof value = Bool ->
-        Cond (bool_op value, intconst 1, intconst 0, ann)
+  | TypeCast (Int, value, ann) when typeof value = Bool ->
+    Cond (bool_op value, intconst 1, intconst 0, ann)
 
-    | TypeCast (Float, value, ann) when typeof value = Bool ->
-        Cond (bool_op value, floatconst 1.0, floatconst 0.0, ann)
+  | TypeCast (Float, value, ann) when typeof value = Bool ->
+    Cond (bool_op value, floatconst 1.0, floatconst 0.0, ann)
 
-    | TypeCast (ctype, value, ann) when typeof value = ctype ->
-        bool_op value
+  | TypeCast (ctype, value, ann) when typeof value = ctype ->
+    bool_op value
 
-    | node -> transform_children bool_op node
+  | node -> transform_children bool_op node
 
 let phase = function
-    | Ast node -> Ast (bool_op node)
-    | _ -> raise (InvalidInput "bool operations")
+  | Ast node -> Ast (bool_op node)
+  | _ -> raise (InvalidInput "bool operations")

phases/constprop.ml

@@ -20,7 +20,7 @@ open Util
 open Globals
 
 let is_const_name name =
-    Str.string_match (Str.regexp "^.+\\$\\$[0-9]+$") name 0
+  Str.string_match (Str.regexp "^.+\\$\\$[0-9]+$") name 0
 
 let is_const = function Const _ -> true | _ -> false
 
@@ -29,162 +29,162 @@ let is_const = function Const _ -> true | _ -> false
  * particular targeting array indices that can be simplified after array
  * dimension reduction). *)
 let no_side_effect = function
-    | VarUse _ | Const _ | Var _ -> true
-    | _ -> false
+  | VarUse _ | Const _ | Var _ -> true
+  | _ -> false
 
 (* Constand folding *)
 let eval = function
-    (* Binop - arithmetic *)
-    | Binop (Add, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (IntVal (left + right), ann)
-    | Binop (Add, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (FloatVal (left +. right), ann)
-
-    | Binop (Sub, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (IntVal (left - right), ann)
-    | Binop (Sub, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (FloatVal (left -. right), ann)
-
-    | Binop (Mul, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (IntVal (left * right), ann)
-    | Binop (Mul, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (FloatVal (left *. right), ann)
-
-    | Binop (Div, Const (IntVal left, _), Const (IntVal right, _), ann) when right != 0 ->
-        Const (IntVal (left / right), ann)
-    | Binop (Div, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (FloatVal (left /. right), ann)
-
-    | Binop (Mod, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (IntVal (left mod right), ann)
-
-    (* Binop - relational *)
-    | Binop (Eq, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left = right), ann)
-    | Binop (Eq, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left = right), ann)
-
-    | Binop (Ne, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left <> right), ann)
-    | Binop (Ne, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left <> right), ann)
-
-    | Binop (Gt, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left > right), ann)
-    | Binop (Gt, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left > right), ann)
-
-    | Binop (Lt, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left < right), ann)
-    | Binop (Lt, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left < right), ann)
-
-    | Binop (Ge, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left >= right), ann)
-    | Binop (Ge, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left >= right), ann)
-
-    | Binop (Le, Const (IntVal left, _), Const (IntVal right, _), ann) ->
-        Const (BoolVal (left <= right), ann)
-    | Binop (Le, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
-        Const (BoolVal (left <= right), ann)
-
-    (* Binop - logical *)
-    | Binop (And, Const (BoolVal left, _), Const (BoolVal right, _), ann) ->
-        Const (BoolVal (left && right), ann)
-    | Binop (Or, Const (BoolVal left, _), Const (BoolVal right, _), ann) ->
-        Const (BoolVal (left || right), ann)
-
-    (* Monary operations *)
-    | Monop (Not, Const (BoolVal  value, _), ann) -> Const (BoolVal  (not value), ann)
-    | Monop (Neg, Const (IntVal   value, _), ann) -> Const (IntVal   (-value), ann)
-    | Monop (Neg, Const (FloatVal value, _), ann) -> Const (FloatVal (-.value), ann)
-
-    (* 0 * a --> 0 *)
-    | Binop (Mul, Const (IntVal 0, _), other, ann)
-    | Binop (Mul, other, Const (IntVal 0, _), ann) when no_side_effect other ->
-        Const (IntVal 0, ann)
-
-    (* 0 + a --> a *)
-    | Binop (Add, Const (IntVal 0, _), other, _)
-    | Binop (Add, other, Const (IntVal 0, _), _) ->
-        other
-
-    (* 1 * a --> a *)
-    | Binop (Mul, Const (IntVal 1, _), other, _)
-    | Binop (Mul, other, Const (IntVal 1, _), _) ->
-        other
-
-    (* true|false ? texp : fexp --> texp|fexp*)
-    | Cond (Const (BoolVal value, _), texp, fexp, _) ->
-        if value then texp else fexp
-
-    | node -> node
+  (* Binop - arithmetic *)
+  | Binop (Add, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (IntVal (left + right), ann)
+  | Binop (Add, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (FloatVal (left +. right), ann)
+
+  | Binop (Sub, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (IntVal (left - right), ann)
+  | Binop (Sub, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (FloatVal (left -. right), ann)
+
+  | Binop (Mul, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (IntVal (left * right), ann)
+  | Binop (Mul, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (FloatVal (left *. right), ann)
+
+  | Binop (Div, Const (IntVal left, _), Const (IntVal right, _), ann) when right != 0 ->
+    Const (IntVal (left / right), ann)
+  | Binop (Div, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (FloatVal (left /. right), ann)
+
+  | Binop (Mod, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (IntVal (left mod right), ann)
+
+  (* Binop - relational *)
+  | Binop (Eq, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left = right), ann)
+  | Binop (Eq, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left = right), ann)
+
+  | Binop (Ne, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left <> right), ann)
+  | Binop (Ne, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left <> right), ann)
+
+  | Binop (Gt, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left > right), ann)
+  | Binop (Gt, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left > right), ann)
+
+  | Binop (Lt, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left < right), ann)
+  | Binop (Lt, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left < right), ann)
+
+  | Binop (Ge, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left >= right), ann)
+  | Binop (Ge, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left >= right), ann)
+
+  | Binop (Le, Const (IntVal left, _), Const (IntVal right, _), ann) ->
+    Const (BoolVal (left <= right), ann)
+  | Binop (Le, Const (FloatVal left, _), Const (FloatVal right, _), ann) ->
+    Const (BoolVal (left <= right), ann)
+
+  (* Binop - logical *)
+  | Binop (And, Const (BoolVal left, _), Const (BoolVal right, _), ann) ->
+    Const (BoolVal (left && right), ann)
+  | Binop (Or, Const (BoolVal left, _), Const (BoolVal right, _), ann) ->
+    Const (BoolVal (left || right), ann)
+
+  (* Monary operations *)
+  | Monop (Not, Const (BoolVal  value, _), ann) -> Const (BoolVal  (not value), ann)
+  | Monop (Neg, Const (IntVal   value, _), ann) -> Const (IntVal   (-value), ann)
+  | Monop (Neg, Const (FloatVal value, _), ann) -> Const (FloatVal (-.value), ann)
+
+  (* 0 * a --> 0 *)
+  | Binop (Mul, Const (IntVal 0, _), other, ann)
+  | Binop (Mul, other, Const (IntVal 0, _), ann) when no_side_effect other ->
+    Const (IntVal 0, ann)
+
+  (* 0 + a --> a *)
+  | Binop (Add, Const (IntVal 0, _), other, _)
+  | Binop (Add, other, Const (IntVal 0, _), _) ->
+    other
+
+  (* 1 * a --> a *)
+  | Binop (Mul, Const (IntVal 1, _), other, _)
+  | Binop (Mul, other, Const (IntVal 1, _), _) ->
+    other
+
+  (* true|false ? texp : fexp --> texp|fexp*)
+  | Cond (Const (BoolVal value, _), texp, fexp, _) ->
+    if value then texp else fexp
+
+  | node -> node
 
 let rec propagate consts node =
-    let propagate = propagate consts in
-    match node with
-
-    (* Constant assignments are added to constants table *)
-    | Assign (name, None, value, ann) when is_const_name name ->
-        let value = propagate value in
-        if is_const value then (
-            Hashtbl.add consts name value;
-            DummyNode
-        ) else
-            Assign (name, None, value, ann)
-
-    | VarLet (dec, None, value, ann) when is_const_name (nameof dec) ->
-        let value = propagate value in
-        if is_const value then (
-            Hashtbl.add consts (nameof dec) value;
-            DummyNode
-        ) else
-            VarLet (dec, None, value, ann)
-
-    (* Variables that are in the constant table are replaced with their constant
-     * value *)
-    | Var (name, None, ann) when Hashtbl.mem consts name ->
-        Hashtbl.find consts name
-    | VarUse (dec, None, ann) when Hashtbl.mem consts (nameof dec) ->
-        Hashtbl.find consts (nameof dec)
-    | Dim (name, ann) when Hashtbl.mem consts name ->
-        Hashtbl.find consts name
-
-    (* Apply arithmetic simplification to constant operands *)
-    | Monop (op, opnd, ann) ->
-        eval (Monop (op, propagate opnd, ann))
-
-    | Binop (op, left, right, ann) ->
-        eval (Binop (op, propagate left, propagate right, ann))
-
-    | Cond (cond, texp, fexp, ann) ->
-        eval (Cond (propagate cond, propagate texp, propagate fexp, ann))
-
-    | TypeCast (ctype, value, ann) ->
-        let value = propagate value in
-        (match (ctype, value) with
-        | (Bool,  Const (BoolVal  value, _)) -> Const (BoolVal value, ann)
-        | (Bool,  Const (IntVal   value, _)) -> Const (BoolVal (value != 1), ann)
-        | (Bool,  Const (FloatVal value, _)) -> Const (BoolVal (value != 1.0), ann)
-        | (Int,   Const (BoolVal  value, _)) -> Const (IntVal (if value then 1 else 0), ann)
-        | (Int,   Const (IntVal   value, _)) -> Const (IntVal value, ann)
-        | (Int,   Const (FloatVal value, _)) -> Const (IntVal (int_of_float value), ann)
-        | (Float, Const (BoolVal  value, _)) -> Const (FloatVal (if value then 1. else 0.), ann)
-        | (Float, Const (IntVal   value, _)) -> Const (FloatVal (float_of_int value), ann)
-        | (Float, Const (FloatVal value, _)) -> Const (FloatVal value, ann)
-        | _ -> TypeCast (ctype, value, ann)
-        )
-
-    | _ -> transform_children propagate node
+  let propagate = propagate consts in
+  match node with
+
+  (* Constant assignments are added to constants table *)
+  | Assign (name, None, value, ann) when is_const_name name ->
+    let value = propagate value in
+    if is_const value then begin
+      Hashtbl.add consts name value;
+      DummyNode
+    end else
+      Assign (name, None, value, ann)
+
+  | VarLet (dec, None, value, ann) when is_const_name (nameof dec) ->
+    let value = propagate value in
+    if is_const value then begin
+      Hashtbl.add consts (nameof dec) value;
+      DummyNode
+    end else
+      VarLet (dec, None, value, ann)
+
+  (* Variables that are in the constant table are replaced with their constant
+   * value *)
+  | Var (name, None, ann) when Hashtbl.mem consts name ->
+    Hashtbl.find consts name
+  | VarUse (dec, None, ann) when Hashtbl.mem consts (nameof dec) ->
+    Hashtbl.find consts (nameof dec)
+  | Dim (name, ann) when Hashtbl.mem consts name ->
+    Hashtbl.find consts name
+
+  (* Apply arithmetic simplification to constant operands *)
+  | Monop (op, opnd, ann) ->
+    eval (Monop (op, propagate opnd, ann))
+
+  | Binop (op, left, right, ann) ->
+    eval (Binop (op, propagate left, propagate right, ann))
+
+  | Cond (cond, texp, fexp, ann) ->
+    eval (Cond (propagate cond, propagate texp, propagate fexp, ann))
+
+  | TypeCast (ctype, value, ann) ->
+    let value = propagate value in
+    begin match (ctype, value) with
+    | (Bool,  Const (BoolVal  value, _)) -> Const (BoolVal value, ann)
+    | (Bool,  Const (IntVal   value, _)) -> Const (BoolVal (value != 1), ann)
+    | (Bool,  Const (FloatVal value, _)) -> Const (BoolVal (value != 1.0), ann)
+    | (Int,   Const (BoolVal  value, _)) -> Const (IntVal (if value then 1 else 0), ann)
+    | (Int,   Const (IntVal   value, _)) -> Const (IntVal value, ann)
+    | (Int,   Const (FloatVal value, _)) -> Const (IntVal (int_of_float value), ann)
+    | (Float, Const (BoolVal  value, _)) -> Const (FloatVal (if value then 1. else 0.), ann)
+    | (Float, Const (IntVal   value, _)) -> Const (FloatVal (float_of_int value), ann)
+    | (Float, Const (FloatVal value, _)) -> Const (FloatVal value, ann)
+    | _ -> TypeCast (ctype, value, ann)
+    end
+
+  | _ -> transform_children propagate node
 
 let rec prune_vardecs consts = function
-    | VarDec (_, name, _, _) when Hashtbl.mem consts name -> DummyNode
-    | node -> transform_children (prune_vardecs consts) node
+  | VarDec (_, name, _, _) when Hashtbl.mem consts name -> DummyNode
+  | node -> transform_children (prune_vardecs consts) node
 
 let phase = function
-    | Ast node ->
-        let consts = Hashtbl.create 32 in
-        let node = propagate consts node in
-        Ast (prune_vardecs consts node)
-    | _ -> raise (InvalidInput "constant propagation")
+  | Ast node ->
+    let consts = Hashtbl.create 32 in
+    let node = propagate consts node in
+    Ast (prune_vardecs consts node)
+  | _ -> raise (InvalidInput "constant propagation")

phases/context.ml

@@ -8,139 +8,139 @@ type nametype = Varname of string | Funcname of string
 let type2str = function Funcname _ -> "function" | Varname _ -> "variable"
 
 let mapfind name tbl =
-    if Hashtbl.mem tbl name then Some (Hashtbl.find tbl name) else None
+  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")
+  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 (dec, dec_depth, _) ->
+    (dec, dec_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
-    match mapfind name tbl with
-    | Some (dec, dec_depth, _) ->
-        (dec, dec_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))
+    raise (NodeError (errnode, msg))
 
 let add_to_scope name dec depth (vars, funs) =
-    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 dec) msg;
-        prerr_loc_msg (locof orig) "Previously declared here:";
-        raise EmptyError
-    | Some _ ->
-        Hashtbl.replace tbl name (dec, depth, name_type)
-    | None ->
-        Hashtbl.add tbl name (dec, depth, name_type)
+  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 dec) msg;
+    prerr_loc_msg (locof orig) "Previously declared here:";
+    raise EmptyError
+  | 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 collect node = match node with
-        (* For variables, add the name (array dimensions are added
-         * implicitly, since they have separate VarDec nodes which were added
-         * during the desugaring phase *)
-        | VarDec (_, name, _, _)
-        | GlobalDec (_, name, _)
-        | GlobalDef (_, _, name, _, _) ->
-            let node = annotate (Depth depth) node in
-            add_to_scope (Varname name) node depth scope;
-            node
-
-        (* Functions are traversed later on, for now only add the name *)
-        | FunDec (_, name, _, _)
-        | FunDef (_, _, name, _, _, _) ->
-            let node = annotate (Depth depth) node in
-            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, dims, ann) ->
-            let (dec, dec_depth) = check_in_scope (Varname name) node scope 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
-            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
-            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
-            Allocate (dec, List.map collect dims, Depth depth :: ann)
-
-        | _ -> transform_children collect node
-    in
-
-    let rec traverse scope depth node =
-        match node with
-        (* Increase nesting level when entering function *)
-        | FunDef (export, ret_type, name, params, body, ann) ->
-            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
-            FunDef (export, ret_type, name, params, body, ann)
-
-        | Param (ArrayDims (ctype, dims), name, ann) ->
-            let rec add_dims = function
-                | [] -> []
-                | Dim (name, ann) :: tl ->
-                    let dim = Dim (name, Depth depth :: ann) in
-                    add_to_scope (Varname name) dim depth scope;
-                    dim :: (add_dims tl)
-                | _ -> raise InvalidNode
-            in
-            let node = Param (ArrayDims (ctype, add_dims dims), name, ann) in
-            add_to_scope (Varname name) node depth scope;
-            node
-
-        | VarDec _ -> node
-
-        | Param (_, name, _) ->
-            let node = annotate (Depth depth) node in
-            add_to_scope (Varname name) node depth scope;
-            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
-
-    (*
-     * 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;
-     *)
-    let node = collect node in
-
-    let node = traverse scope depth node in
-    node
+  let rec collect node = match node with
+    (* For variables, add the name (array dimensions are added
+     * implicitly, since they have separate VarDec nodes which were added
+     * during the desugaring phase *)
+    | VarDec (_, name, _, _)
+    | GlobalDec (_, name, _)
+    | GlobalDef (_, _, name, _, _) ->
+      let node = annotate (Depth depth) node in
+      add_to_scope (Varname name) node depth scope;
+      node
+
+    (* Functions are traversed later on, for now only add the name *)
+    | FunDec (_, name, _, _)
+    | FunDef (_, _, name, _, _, _) ->
+      let node = annotate (Depth depth) node in
+      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, dims, ann) ->
+      let (dec, dec_depth) = check_in_scope (Varname name) node scope 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
+      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
+      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
+      Allocate (dec, List.map collect dims, Depth depth :: ann)
+
+    | _ -> transform_children collect node
+  in
+
+  let rec traverse scope depth node =
+    match node with
+    (* Increase nesting level when entering function *)
+    | FunDef (export, ret_type, name, params, body, ann) ->
+      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
+      FunDef (export, ret_type, name, params, body, ann)
+
+    | Param (ArrayDims (ctype, dims), name, ann) ->
+      let rec add_dims = function
+        | [] -> []
+        | Dim (name, ann) :: tl ->
+          let dim = Dim (name, Depth depth :: ann) in
+          add_to_scope (Varname name) dim depth scope;
+          dim :: (add_dims tl)
+        | _ -> raise InvalidNode
+      in
+      let node = Param (ArrayDims (ctype, add_dims dims), name, ann) in
+      add_to_scope (Varname name) node depth scope;
+      node
+
+    | VarDec _ -> node
+
+    | Param (_, name, _) ->
+      let node = annotate (Depth depth) node in
+      add_to_scope (Varname name) node depth scope;
+      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
+
+  (*
+   * 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;
+   *)
+  let node = collect node in
+
+  let node = traverse scope depth node in
+  node
 
 let analyse_context program =
-    let scope = (Hashtbl.create 20, Hashtbl.create 20) in
-    analyse scope 0 program
+  let scope = (Hashtbl.create 20, Hashtbl.create 20) in
+  analyse scope 0 program
 
 let phase = function
-    | Ast node -> Ast (analyse_context node)
-    | _ -> raise (InvalidInput "context analysis")
+  | Ast node -> Ast (analyse_context node)
+  | _ -> raise (InvalidInput "context analysis")

phases/desug.ml

@@ -6,282 +6,282 @@ open Globals
 (* Create new constant variables for all assigned array values so that they are
  * only evaluated once *)
 let rec consts_to_vars node =
-    let rec create_vars new_vars values = function
-        | [] -> (new_vars, values)
-        | hd :: tl ->
-            let (new_vars, value) = match hd with
-                | ArrayConst (values, ann) ->
-                    let (new_vars, values) = create_vars new_vars [] values in
-                    (new_vars, ArrayConst (values, ann))
-                | value ->
-                    let index = fresh_const "const" in
-                    (new_vars @ [(index, value)], Var (index, None, annof value))
-            in
-            create_vars new_vars (values @ [value]) tl
+  let rec create_vars new_vars values = function
+    | [] -> (new_vars, values)
+    | hd :: tl ->
+      let (new_vars, value) = match hd with
+        | ArrayConst (values, ann) ->
+          let (new_vars, values) = create_vars new_vars [] values in
+          (new_vars, ArrayConst (values, ann))
+        | value ->
+          let index = fresh_const "const" in
+          (new_vars @ [(index, value)], Var (index, None, annof value))
+      in
+      create_vars new_vars (values @ [value]) tl
+  in
+  match node with
+  (* Add vardecs for values in arrayconst *)
+  | VarDec (ArrayDims _ as ctype, name, Some (ArrayConst (values, vann)), ann) ->
+    let (new_vars, values) = create_vars [] [] values in
+    let value = ArrayConst (values, vann) in
+    let create_vardec (name, value) =
+      VarDec (basetypeof node, name, Some value, annof value)
     in
-    match node with
-    (* Add vardecs for values in arrayconst *)
-    | VarDec (ArrayDims _ as ctype, name, Some (ArrayConst (values, vann)), ann) ->
-        let (new_vars, values) = create_vars [] [] values in
-        let value = ArrayConst (values, vann) in
-        let create_vardec (name, value) =
-            VarDec (basetypeof node, name, Some value, annof value)
-        in
-        let new_vardecs = List.map create_vardec new_vars in
-        Block (new_vardecs @ [VarDec (ctype, name, Some value, ann)])
+    let new_vardecs = List.map create_vardec new_vars in
+    Block (new_vardecs @ [VarDec (ctype, name, Some value, ann)])
 
-    (* Add vardec for scalar value *)
-    | VarDec (ArrayDims _ as ctype, name, Some value, ann) as node ->
-        let scalar_name = fresh_const "scalar" in
-        Block [
-            VarDec (basetypeof node, scalar_name, Some value, ann);
-            VarDec (ctype, name, Some (Var (scalar_name, None, annof value)), ann);
-        ]
+  (* Add vardec for scalar value *)
+  | VarDec (ArrayDims _ as ctype, name, Some value, ann) as node ->
+    let scalar_name = fresh_const "scalar" in
+    Block [
+      VarDec (basetypeof node, scalar_name, Some value, ann);
+      VarDec (ctype, name, Some (Var (scalar_name, None, annof value)), ann);
+    ]
 
-    | node -> transform_children consts_to_vars node
+  | node -> transform_children consts_to_vars node
 
 (* Generate new variables for array dimensions, to avoid re-evalutation when
  * array dimensions are used (e.g., after array dimension reduction). *)
 let rec array_dims node =
-    let make_dims basename values make_dec =
-        let make_name i _ = fresh_const (basename ^ "$dim$" ^ string_of_int (i + 1)) in
-        let names = mapi make_name values in
-
-        let decs = List.map2 make_dec values names in
-
-        let make_dim value name = Dim (name, annof value) in
-        let dims = List.map2 make_dim values names in
-
-        (decs, dims)
+  let make_dims basename values make_dec =
+    let make_name i _ = fresh_const (basename ^ "$dim$" ^ string_of_int (i + 1)) in
+    let names = mapi make_name values in
+
+    let decs = List.map2 make_dec values names in
+
+    let make_dim value name = Dim (name, annof value) in
+    let dims = List.map2 make_dim values names in
+
+    (decs, dims)
+  in
+  match node with
+  | VarDec (ArrayDims (ctype, values), name, init, ann) ->
+    let make_dec value name = VarDec (Int, name, Some value, []) in
+    let (decs, dims) = make_dims name values make_dec in
+    Block (decs @ [VarDec (ArrayDims (ctype, dims), name, init, ann)])
+
+  | GlobalDef (export, ArrayDims (ctype, values), name, None, ann) ->
+    let make_dec value name = GlobalDef (export, Int, name, Some value, []) in
+    let (decs, dims) = make_dims name values make_dec in
+    Block (decs @ [GlobalDef (export, ArrayDims (ctype, dims), name, None, ann)])
+
+  | GlobalDec (ArrayDims (ctype, dims), name, ann) ->
+    let rec make_decs = function
+      | [] -> []
+      | Dim (name, ann) :: tl -> GlobalDec (Int, name, ann) :: (make_decs tl)
+      | _ -> raise InvalidNode
     in
-    match node with
-    | VarDec (ArrayDims (ctype, values), name, init, ann) ->
-        let make_dec value name = VarDec (Int, name, Some value, []) in
-        let (decs, dims) = make_dims name values make_dec in
-        Block (decs @ [VarDec (ArrayDims (ctype, dims), name, init, ann)])
-
-    | GlobalDef (export, ArrayDims (ctype, values), name, None, ann) ->
-        let make_dec value name = GlobalDef (export, Int, name, Some value, []) in
-        let (decs, dims) = make_dims name values make_dec in
-        Block (decs @ [GlobalDef (export, ArrayDims (ctype, dims), name, None, ann)])
-
-    | GlobalDec (ArrayDims (ctype, dims), name, ann) ->
-        let rec make_decs = function
-            | [] -> []
-            | Dim (name, ann) :: tl -> GlobalDec (Int, name, ann) :: (make_decs tl)
-            | _ -> raise InvalidNode
-        in
-        let decs = make_decs dims in
-        Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
+    let decs = make_decs dims in
+    Block (decs @ [GlobalDec (ArrayDims (ctype, dims), name, ann)])
 
-    | node -> transform_children array_dims node
+  | node -> transform_children array_dims node
 
 (* Split variable initialisation into declaration and assignment *)
 let rec split_inits = function
-    (* Wrap array initialisation in ArrayInit to pass dimensions *)
-    | VarDec (ArrayDims (_, dims) as ctype, name, Some value, ann) ->
-        Block [
-            VarDec (ctype, name, None, ann);
-            Assign (name, None, ArrayInit (value, dims), ann);
-        ]
-
-    | VarDec (ctype, name, Some init, ann) ->
-        Block [
-            VarDec (ctype, name, None, ann);
-            Assign (name, None, init, ann);
-        ]
-
-    | GlobalDef (export, ctype, name, Some init, ann) ->
-        Block [
-            GlobalDef (export, ctype, name, None, ann);
-            Assign (name, None, init, ann);
-        ]
-
-    | node -> transform_children split_inits node
+  (* Wrap array initialisation in ArrayInit to pass dimensions *)
+  | VarDec (ArrayDims (_, dims) as ctype, name, Some value, ann) ->
+    Block [
+      VarDec (ctype, name, None, ann);
+      Assign (name, None, ArrayInit (value, dims), ann);
+    ]
+
+  | VarDec (ctype, name, Some init, ann) ->
+    Block [
+      VarDec (ctype, name, None, ann);
+      Assign (name, None, init, ann);
+    ]
+
+  | GlobalDef (export, ctype, name, Some init, ann) ->
+    Block [
+      GlobalDef (export, ctype, name, None, ann);
+      Assign (name, None, init, ann);
+    ]
+
+  | node -> transform_children split_inits node
 
 (* Add <allocate> statements after array declarations *)
 let rec add_allocs node =
-    let create_dimvar = function
-        | Dim (name, _) -> Var (name, None, [])
-        | _ -> raise InvalidNode
-    in
-    match node with
-    | VarDec (ArrayDims (_, dims), _, _, ann) ->
-        Block [node; Allocate (node, List.map create_dimvar dims, ann)]
+  let create_dimvar = function
+    | Dim (name, _) -> Var (name, None, [])
+    | _ -> raise InvalidNode
+  in
+  match node with
+  | VarDec (ArrayDims (_, dims), _, _, ann) ->
+    Block [node; Allocate (node, List.map create_dimvar dims, ann)]
 
-    | GlobalDef (_, ArrayDims (_, dims), _, _, ann) ->
-        Block [node; Allocate (node, List.map create_dimvar dims, ann)]
+  | GlobalDef (_, ArrayDims (_, dims), _, _, ann) ->
+    Block [node; Allocate (node, List.map create_dimvar dims, ann)]
 
-    | node -> transform_children add_allocs node
+  | node -> transform_children add_allocs node
 
 let extract_inits lst =
-    let rec trav inits = function
-        | [] ->
-            (List.rev inits, [])
-        | (Assign _ as hd) :: tl
-        | (Allocate _ as hd) :: tl ->
-            trav (hd :: inits) tl
-        | hd :: tl ->
-            let (inits, tl) = trav inits tl in
-            (inits, (hd :: tl))
-    in trav [] lst
+  let rec trav inits = function
+    | [] ->
+      (List.rev inits, [])
+    | (Assign _ as hd) :: tl
+    | (Allocate _ as hd) :: tl ->
+      trav (hd :: inits) tl
+    | hd :: tl ->
+      let (inits, tl) = trav inits tl in
+      (inits, (hd :: tl))
+  in trav [] lst
 
 let rec move_inits = function
-    (* Move global initialisations to __init function *)
-    | Program (decls, ann) ->
-        let decls = List.map move_inits decls in
-        (match extract_inits decls with
-        | ([], _) -> Program (decls, ann)
-        | (inits, decls) ->
-            let init_func = FunDef (true, Void, "__init", [], Block inits, []) in
-            Program (init_func :: decls, ann)
-        )
-
-    (* Split local variable initialisations in declaration and assignment *)
-    | FunDef (export, ret_type, name, params, Block body, ann) ->
-        let rec place_inits inits = function
-            | VarDecs lst :: tl ->
-                let (inits, decs) = extract_inits lst in
-                VarDecs decs :: (place_inits inits tl)
-            | LocalFuns _ as hd :: tl ->
-                hd :: inits @ tl
-            | _ -> raise InvalidNode
-        in
-        let body = Block (place_inits [] body) in
-        FunDef (export, ret_type, name, params, body, ann)
+  (* Move global initialisations to __init function *)
+  | Program (decls, ann) ->
+    let decls = List.map move_inits decls in
+    begin match extract_inits decls with
+    | ([], _) -> Program (decls, ann)
+    | (inits, decls) ->
+      let init_func = FunDef (true, Void, "__init", [], Block inits, []) in
+      Program (init_func :: decls, ann)
+    end
+
+  (* Split local variable initialisations in declaration and assignment *)
+  | FunDef (export, ret_type, name, params, Block body, ann) ->
+    let rec place_inits inits = function
+      | VarDecs lst :: tl ->
+        let (inits, decs) = extract_inits lst in
+        VarDecs decs :: (place_inits inits tl)
+      | LocalFuns _ as hd :: tl ->
+        hd :: inits @ tl
+      | _ -> raise InvalidNode
+    in
+    let body = Block (place_inits [] body) in
+    FunDef (export, ret_type, name, params, body, ann)
 
-    | node -> transform_children move_inits node
+  | node -> transform_children move_inits node
 
 let for_to_while node =
-    let rec replace_var var replacement node =
-        let trav = (replace_var var replacement) in
-        match node with
-        | Var (name, None, ann) when name = var ->
-            Var (replacement, None, ann)
-        | For (counter, start, stop, step, body, ann) when counter = var ->
-            For (replacement, trav start, trav stop, trav step, trav body, ann)
-        | node ->
-            transform_children trav node
-    in
-    let rec traverse new_vars = function
-        | FunDef (export, ret_type, name, params, body, ann) ->
-            let new_vars = ref [] in
-            let body = traverse new_vars body in
-            let create_vardec name = VarDec (Int, name, None, []) in
-            let new_vardecs = List.map create_vardec !new_vars in
-            let _body = new_vardecs @ (flatten_blocks (block_body body)) in
-            FunDef (export, ret_type, name, params, Block _body, ann)
-
-        (* Transform for-loops to while-loops *)
-        | For (counter, start, stop, step, body, ann) ->
-            let _i = fresh_var counter in
-            let _stop = fresh_const "stop" in
-            let _step = fresh_const "step" in
-            new_vars := !new_vars @ [_i; _stop; _step];
-
-            let vi = Var (_i, None, []) in
-            let vstop = Var (_stop, None, annof stop) in
-            let vstep = Var (_step, None, annof step) in
-            let cond = Cond (
-                Binop (Gt, vstep, Const (IntVal 0, []), []),
-                Binop (Lt, vi, vstop, []),
-                Binop (Gt, vi, vstop, []),
-                []
-            ) in
-            Block [
-                Assign (_i, None, start, annof start);
-                Assign (_stop, None, stop, annof stop);
-                Assign (_step, None, step, annof step);
-                traverse new_vars (While (cond, (Block (
-                    block_body (replace_var counter _i body) @
-                    [Assign (_i, None, Binop (Add, vi, vstep, []), [])]
-                )), ann));
-            ]
-
-        (* DISABLED, while-loops are explicitly supported by the assembly phase
-        (* Transform while-loops to do-while loops in if-statements *)
-        | While (cond, body, ann) ->
-            let cond = traverse new_vars cond in
-            let body = traverse new_vars body in
-            Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
-        *)
-
-        | node -> transform_children (traverse new_vars) node
-    in
-    traverse (ref []) node
+  let rec replace_var var replacement node =
+    let trav = (replace_var var replacement) in
+    match node with
+    | Var (name, None, ann) when name = var ->
+      Var (replacement, None, ann)
+    | For (counter, start, stop, step, body, ann) when counter = var ->
+      For (replacement, trav start, trav stop, trav step, trav body, ann)
+    | node ->
+      transform_children trav node
+  in
+  let rec traverse new_vars = function
+    | FunDef (export, ret_type, name, params, body, ann) ->
+      let new_vars = ref [] in
+      let body = traverse new_vars body in
+      let create_vardec name = VarDec (Int, name, None, []) in
+      let new_vardecs = List.map create_vardec !new_vars in
+      let _body = new_vardecs @ (flatten_blocks (block_body body)) in
+      FunDef (export, ret_type, name, params, Block _body, ann)
+
+    (* Transform for-loops to while-loops *)
+    | For (counter, start, stop, step, body, ann) ->
+      let _i = fresh_var counter in
+      let _stop = fresh_const "stop" in
+      let _step = fresh_const "step" in
+      new_vars := !new_vars @ [_i; _stop; _step];
+
+      let vi = Var (_i, None, []) in
+      let vstop = Var (_stop, None, annof stop) in
+      let vstep = Var (_step, None, annof step) in
+      let cond = Cond (
+        Binop (Gt, vstep, Const (IntVal 0, []), []),
+        Binop (Lt, vi, vstop, []),
+        Binop (Gt, vi, vstop, []),
+        []
+      ) in
+      Block [
+        Assign (_i, None, start, annof start);
+        Assign (_stop, None, stop, annof stop);
+        Assign (_step, None, step, annof step);
+        traverse new_vars (While (cond, (Block (
+          block_body (replace_var counter _i body) @
+          [Assign (_i, None, Binop (Add, vi, vstep, []), [])]
+        )), ann));
+      ]
+
+    (* DISABLED, while-loops are explicitly supported by the assembly phase
+    (* Transform while-loops to do-while loops in if-statements *)
+    | While (cond, body, ann) ->
+      let cond = traverse new_vars cond in
+      let body = traverse new_vars body in
+      Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
+    *)
+
+    | node -> transform_children (traverse new_vars) node
+  in
+  traverse (ref []) node
 
 let rec sublist n = function
-    | [] when n > 0  -> raise (Invalid_argument "n")
-    | []             -> []
-    | lst when n = 0 -> lst
-    | _ :: tl        -> sublist (n - 1) tl
+  | [] when n > 0  -> raise (Invalid_argument "n")
+  | []       -> []
+  | lst when n = 0 -> lst
+  | _ :: tl    -> sublist (n - 1) tl
 
 let rec array_init = function
-    (* Transform array constant inisialisation into separate assign statements
-     * for all entries in the constant array *)
-    (* TODO: only allow when array dimensions are constant? *)
-    | Assign (name, None, ArrayInit (ArrayConst _ as value, dims), ann) ->
-        let ndims = List.length dims in
-        let rec make_assigns depth i indices = function
-            | [] -> []
-            | hd :: tl ->
-                let assigns = traverse depth (i :: indices) hd in
-                make_assigns depth (i + 1) indices tl @ assigns
-        and traverse depth indices = function
-            | ArrayConst (values, _) ->
-                make_assigns (depth + 1) 0 indices values
-            | value when depth = ndims ->
-                let indices = List.map (fun i -> Const (IntVal i, [])) indices in
-                [Assign (name, Some (List.rev indices), value, ann)]
-            | value when depth < ndims ->
-                (* Use the for-loops constructed for scalar assignment *)
-                let value = ArrayInit (value, dims) in
-                let indices = List.map (fun i -> Const (IntVal i, [])) indices in
-                [array_init (Assign (name, Some (List.rev indices), value, ann))]
-            | node ->
-                let msg = sprintf
-                    "dimension mismatch: expected %d nesting levels, got %d"
-                    ndims depth
-                in
-                raise (NodeError (node, msg))
+  (* Transform array constant inisialisation into separate assign statements
+   * for all entries in the constant array *)
+  (* TODO: only allow when array dimensions are constant? *)
+  | Assign (name, None, ArrayInit (ArrayConst _ as value, dims), ann) ->
+    let ndims = List.length dims in
+    let rec make_assigns depth i indices = function
+      | [] -> []
+      | hd :: tl ->
+        let assigns = traverse depth (i :: indices) hd in
+        make_assigns depth (i + 1) indices tl @ assigns
+    and traverse depth indices = function
+      | ArrayConst (values, _) ->
+        make_assigns (depth + 1) 0 indices values
+      | value when depth = ndims ->
+        let indices = List.map (fun i -> Const (IntVal i, [])) indices in
+        [Assign (name, Some (List.rev indices), value, ann)]
+      | value when depth < ndims ->
+        (* Use the for-loops constructed for scalar assignment *)
+        let value = ArrayInit (value, dims) in
+        let indices = List.map (fun i -> Const (IntVal i, [])) indices in
+        [array_init (Assign (name, Some (List.rev indices), value, ann))]
+      | node ->
+        let msg = sprintf
+          "dimension mismatch: expected %d nesting levels, got %d"
+          ndims depth
         in
-        Block (List.rev (traverse 0 [] value))
-
-    (* Replace no indices with empty indices to have a list below *)
-    | Assign (name, None, (ArrayInit _ as value), ann) ->
-        array_init (Assign (name, Some [], value, ann))
-
-    | Assign (name, Some indices, ArrayInit (value, dims), ann) as node ->
-        let rec add_loop indices = function
-            | [] ->
-                array_init (Assign (name, Some indices, value, ann))
-            | dim :: rest ->
-                let counter = fresh_var "i" in
-                let start = Const (IntVal 0, []) in
-                let step = Const (IntVal 1, []) in
-                let body = Block [add_loop (indices @ [Var (counter, None, [])]) rest] in
-                let stop = match dim with
-                    | Dim (name, ann) -> Var (name, None, ann)
-                    | _ -> dim
-                in
-                For (counter, start, stop, step, body, [])
+        raise (NodeError (node, msg))
+    in
+    Block (List.rev (traverse 0 [] value))
+
+  (* Replace no indices with empty indices to have a list below *)
+  | Assign (name, None, (ArrayInit _ as value), ann) ->
+    array_init (Assign (name, Some [], value, ann))
+
+  | Assign (name, Some indices, ArrayInit (value, dims), ann) as node ->
+    let rec add_loop indices = function
+      | [] ->
+        array_init (Assign (name, Some indices, value, ann))
+      | dim :: rest ->
+        let counter = fresh_var "i" in
+        let start = Const (IntVal 0, []) in
+        let step = Const (IntVal 1, []) in
+        let body = Block [add_loop (indices @ [Var (counter, None, [])]) rest] in
+        let stop = match dim with
+        | Dim (name, ann) -> Var (name, None, ann)
+        | _ -> dim
         in
-        let dims_left = sublist (List.length indices) dims in
-        add_loop indices dims_left
+        For (counter, start, stop, step, body, [])
+    in
+    let dims_left = sublist (List.length indices) dims in
+    add_loop indices dims_left
 
-    | node -> transform_children array_init node
+  | node -> transform_children array_init node
 
 let phase = function
-    | Ast node ->
-        (* Generate variable declarations for expressions that must be evaluated
-         * once and used multiple times *)
-        let node = consts_to_vars (array_dims node) in
-
-        (* Split variable initialisations into declarations and assignments, and
-         * move the assignments to the function body *)
-        let node = move_inits (add_allocs (split_inits node)) in
-
-        (* Transform ArrayConst assignment to assignments in for-loops, and
-         * transform all for-loops to while-loops afterwards *)
-        Ast (for_to_while (array_init (node)))
-    | _ -> raise (InvalidInput "desugar")
+  | Ast node ->
+    (* Generate variable declarations for expressions that must be evaluated
+     * once and used multiple times *)
+    let node = consts_to_vars (array_dims node) in
+
+    (* Split variable initialisations into declarations and assignments, and
+     * move the assignments to the function body *)
+    let node = move_inits (add_allocs (split_inits node)) in
+
+    (* Transform ArrayConst assignment to assignments in for-loops, and
+     * transform all for-loops to while-loops afterwards *)
+    Ast (for_to_while (array_init (node)))
+  | _ -> raise (InvalidInput "desugar")

phases/dimreduce.ml

@@ -3,102 +3,102 @@ open Util
 open Globals
 
 let rec expand_dims = function
-    (* Flatten Block nodes returned by transformations below *)
-    | FunDef (export, ret_type, name, params, body, ann) ->
-        let params = flatten_blocks (List.map expand_dims params) in
-        FunDef (export, ret_type, name, params, expand_dims body, ann)
-
-    | FunDec (ret_type, name, params, ann) ->
-        let params = flatten_blocks (List.map expand_dims params) in
-        FunDec (ret_type, name, params, ann)
-
-    | FunUse (dec, params, ann) ->
-        FunUse (dec, flatten_blocks (List.map expand_dims params), ann)
-
-    (* Add additional parameters for array dimensions *)
-    | Param (ArrayDims (ctype, dims), name, ann) ->
-        let rec do_expand = function
-            | [] -> [Param (Array ctype, name, ann)]
-            | Dim (name, ann) :: tail ->
-                Param (Int, name, ann) :: (do_expand tail)
-            | _ -> raise InvalidNode
-        in
-        Block (do_expand dims)
-
-    (* Add additional function arguments for array dimensions *)
-    | Arg (VarUse (VarDec (ArrayDims (ctype, dims), name, None, decann), None, ann)) ->
-        let rec do_expand = function
-            | [] ->
-                (* Remove the (now obsolete dimensions fromt the type) *)
-                let dec = VarDec (Array ctype, name, None, decann) in
-                [VarUse (dec, None, ann)]
-            | hd :: tl ->
-                (* A VarDec node has been added for each dimension during
-                 * desugaring, so we can safely reconstruct it here (we need no
-                 * refrence because the type is immutable, yay!) *)
-                let dimdec = VarDec (Int, nameof hd, None, annof hd) in
-                Arg (VarUse (dimdec, None, [])) :: (do_expand tl)
-        in
-        Block (do_expand dims)
-
-    (* Simplify array types in declarations *)
-    | VarDec (ArrayDims (ctype, _), name, None, ann) ->
-        VarDec (Array ctype, name, None, ann)
-
-    | node -> transform_children expand_dims node
+  (* Flatten Block nodes returned by transformations below *)
+  | FunDef (export, ret_type, name, params, body, ann) ->
+    let params = flatten_blocks (List.map expand_dims params) in
+    FunDef (export, ret_type, name, params, expand_dims body, ann)
+
+  | FunDec (ret_type, name, params, ann) ->
+    let params = flatten_blocks (List.map expand_dims params) in
+    FunDec (ret_type, name, params, ann)
+
+  | FunUse (dec, params, ann) ->
+    FunUse (dec, flatten_blocks (List.map expand_dims params), ann)
+
+  (* Add additional parameters for array dimensions *)
+  | Param (ArrayDims (ctype, dims), name, ann) ->
+    let rec do_expand = function
+      | [] -> [Param (Array ctype, name, ann)]
+      | Dim (name, ann) :: tail ->
+        Param (Int, name, ann) :: (do_expand tail)
+      | _ -> raise InvalidNode
+    in
+    Block (do_expand dims)
+
+  (* Add additional function arguments for array dimensions *)
+  | Arg (VarUse (VarDec (ArrayDims (ctype, dims), name, None, decann), None, ann)) ->
+    let rec do_expand = function
+      | [] ->
+        (* Remove the (now obsolete dimensions fromt the type) *)
+        let dec = VarDec (Array ctype, name, None, decann) in
+        [VarUse (dec, None, ann)]
+      | hd :: tl ->
+        (* A VarDec node has been added for each dimension during
+         * desugaring, so we can safely reconstruct it here (we need no
+         * refrence because the type is immutable, yay!) *)
+        let dimdec = VarDec (Int, nameof hd, None, annof hd) in
+        Arg (VarUse (dimdec, None, [])) :: (do_expand tl)
+    in
+    Block (do_expand dims)
+
+  (* Simplify array types in declarations *)
+  | VarDec (ArrayDims (ctype, _), name, None, ann) ->
+    VarDec (Array ctype, name, None, ann)
+
+  | node -> transform_children expand_dims node
 
 let rec multiply = function
-    | []       -> raise InvalidNode
-    | [node]   -> node
-    | hd :: tl -> Binop (Mul, hd, multiply tl, [Type Int])
+  | []       -> raise InvalidNode
+  | [node]   -> node
+  | hd :: tl -> Binop (Mul, hd, multiply tl, [Type Int])
 
 let rec multiply_all = function
-    | []       -> raise InvalidNode
-    | [node]   -> node
-    | hd :: tl -> Binop (Mul, hd, multiply_all tl, [])
+  | []       -> raise InvalidNode
+  | [node]   -> node
+  | hd :: tl -> Binop (Mul, hd, multiply_all tl, [])
 
 let rec expand depth dims =
-    let rec do_expand dims = function
-        | []       -> raise InvalidNode
-        | [node]   -> dim_reduce depth node
-        | i :: j :: tl ->
-            let parent_width = List.hd dims in
-            let mul = Binop (Mul, dim_reduce depth i, parent_width, [Type Int]) in
-            do_expand (List.tl dims) (Binop (Add, mul, j, [Type Int]) :: tl)
-    in
-    let use_dim = function
-        | Dim _ as dim -> VarUse (dim, None, [Type Int; Depth depth])
-        | node -> node
-    in
-    do_expand (List.map use_dim (List.tl dims))
+  let rec do_expand dims = function
+    | []       -> raise InvalidNode
+    | [node]   -> dim_reduce depth node
+    | i :: j :: tl ->
+      let parent_width = List.hd dims in
+      let mul = Binop (Mul, dim_reduce depth i, parent_width, [Type Int]) in
+      do_expand (List.tl dims) (Binop (Add, mul, j, [Type Int]) :: tl)
+  in
+  let use_dim = function
+    | Dim _ as dim -> VarUse (dim, None, [Type Int; Depth depth])
+    | node -> node
+  in
+  do_expand (List.map use_dim (List.tl dims))
 
 and dim_reduce depth = function
-    | Allocate (dec, dims, ann) ->
-        Allocate (dec, [multiply dims], ann)
-
-    (* Increase nesting depth when goiing into function *)
-    | FunDef (export, ret_type, name, params, body, ann) ->
-        let trav = dim_reduce (depth + 1) in
-        FunDef (export, ret_type, name, List.map trav params, trav body, ann)
-
-    (* Expand indices when dereferencing *)
-    | VarUse (dec, Some values, ann) as node ->
-        (match typeof dec with
-        | ArrayDims (_, dims) ->
-            VarUse (dec, Some [expand depth dims values], ann)
-        | _ -> node
-        )
-
-    (* Expand indices when assigning to array index *)
-    | VarLet (dec, Some values, value, ann) as node ->
-        (match typeof dec with
-        | ArrayDims (_, dims) ->
-            VarLet (dec, Some [expand depth dims values], value, ann)
-        | _ -> node
-        )
-
-    | node -> transform_children (dim_reduce depth) node
+  | Allocate (dec, dims, ann) ->
+    Allocate (dec, [multiply dims], ann)
+
+  (* Increase nesting depth when goiing into function *)
+  | FunDef (export, ret_type, name, params, body, ann) ->
+    let trav = dim_reduce (depth + 1) in
+    FunDef (export, ret_type, name, List.map trav params, trav body, ann)
+
+  (* Expand indices when dereferencing *)
+  | VarUse (dec, Some values, ann) as node ->
+    begin match typeof dec with
+    | ArrayDims (_, dims) ->
+      VarUse (dec, Some [expand depth dims values], ann)
+    | _ -> node
+    end
+
+  (* Expand indices when assigning to array index *)
+  | VarLet (dec, Some values, value, ann) as node ->
+    begin match typeof dec with
+    | ArrayDims (_, dims) ->
+      VarLet (dec, Some [expand depth dims values], value, ann)
+    | _ -> node
+    end
+
+  | node -> transform_children (dim_reduce depth) node
 
 let phase = function
-    | Ast node -> Ast (dim_reduce 0 (expand_dims node))
-    | _ -> raise (InvalidInput "dimension reduction")
+  | Ast node -> Ast (dim_reduce 0 (expand_dims node))
+  | _ -> raise (InvalidInput "dimension reduction")

phases/extern.ml

@@ -3,113 +3,112 @@ open Util
 open Globals
 
 let create_param ctype name =
-    let param = Param (ctype, name, [Depth 1]) in
-    let value = VarUse (param, None, [Type ctype; Depth 1]) in
-    (param, value)
+  let param = Param (ctype, name, [Depth 1]) in
+  let value = VarUse (param, None, [Type ctype; Depth 1]) in
+  (param, value)
 
-let call node args depth = match node with
-    | FunDec (ctype, name, _, _) as dec ->
-        FunUse (dec, args, [Type ctype; Depth depth])
-    | _ -> raise InvalidNode
+let call node args depth =
+  match node with
+  | FunDec (ctype, name, _, _) as dec ->
+    FunUse (dec, args, [Type ctype; Depth depth])
+  | _ -> raise InvalidNode
 
 let process globals = function
-    | GlobalDef (true, Array ctype, name, None, ann) as dec ->
-        (* Getters for array variable: crate getter for given index Note that
-         * getters and setters for dimensions are automatically generated,
-         * because they have been put into new global variables during the
-         * desugarin phase *)
-        let (param, index) = create_param Int (fresh_var "index") in
-        let var = VarUse (dec, Some [index], [Type ctype; Depth 1]) in
-        let body = Block [Return (var, [])] in
-        let getter = FunDef (true, ctype, name ^ "$get", [param], body, []) in
-
-        (* Setters for array variable: create setter for given index *)
-        let (param1, index) = create_param Int (fresh_var "index") in
-        let (param2, value) = create_param ctype (fresh_var "value") in
-        let body = Block [VarLet (dec, Some [index], value, [])] in
-        let setter = FunDef (true, Void, name ^ "$set", [param1; param2], body, []) in
-
-        [getter; setter]
-
-    | GlobalDef (true, ctype, name, None, ann) as dec ->
-        (* Getter for basic variable type: return the variable *)
-        let var = VarUse (dec, None, [Type ctype; Depth 1]) in
-        let body = [Return (var, [])] in
-        let getter = FunDef (true, ctype, name ^ "$get", [], Block body, []) in
-
-        (* Setter for basic variable type: assign the variable *)
-        let (param, value) = create_param ctype (fresh_var "value") in
-        let body = [VarLet (dec, None, value, [])] in
-        let setter = FunDef (true, Void, name ^ "$set", [param], Block body, []) in
-
-        [getter; setter]
-
-    | GlobalDec (Array ctype, name, ann) ->
-        (* Getters for external array variable: create getter and setter for a
-         * given index *)
-        let (param, _) = create_param Int "index" in
-        let getter = FunDec (ctype, name ^ "$get", [param], []) in
-
-        let (param1, index) = create_param Int "index" in
-        let (param2, value) = create_param ctype "value" in
-        let setter = FunDec (Void, name ^ "$set", [param1; param2], []) in
-
-        Hashtbl.add globals name (call getter, call setter);
-        [getter; setter]
-
+  | GlobalDef (true, Array ctype, name, None, ann) as dec ->
+    (* Getters for array variable: crate getter for given index Note that
+     * getters and setters for dimensions are automatically generated,
+     * because they have been put into new global variables during the
+     * desugarin phase *)
+    let (param, index) = create_param Int (fresh_var "index") in
+    let var = VarUse (dec, Some [index], [Type ctype; Depth 1]) in
+    let body = Block [Return (var, [])] in
+    let getter = FunDef (true, ctype, name ^ "$get", [param], body, []) in
+
+    (* Setters for array variable: create setter for given index *)
+    let (param1, index) = create_param Int (fresh_var "index") in
+    let (param2, value) = create_param ctype (fresh_var "value") in
+    let body = Block [VarLet (dec, Some [index], value, [])] in
+    let setter = FunDef (true, Void, name ^ "$set", [param1; param2], body, []) in
+
+    [getter; setter]
+
+  | GlobalDef (true, ctype, name, None, ann) as dec ->
     (* Getter for basic variable type: return the variable *)
-    | GlobalDec (ctype, name, ann) ->
-        let getter = FunDec (ctype, name ^ "$get", [], []) in
+    let var = VarUse (dec, None, [Type ctype; Depth 1]) in
+    let body = [Return (var, [])] in
+    let getter = FunDef (true, ctype, name ^ "$get", [], Block body, []) in
+
+    (* Setter for basic variable type: assign the variable *)
+    let (param, value) = create_param ctype (fresh_var "value") in
+    let body = [VarLet (dec, None, value, [])] in
+    let setter = FunDef (true, Void, name ^ "$set", [param], Block body, []) in
+
+    [getter; setter]
+
+  | GlobalDec (Array ctype, name, ann) ->
+    (* Getters for external array variable: create getter and setter for a
+     * given index *)
+    let (param, _) = create_param Int "index" in
+    let getter = FunDec (ctype, name ^ "$get", [param], []) in
+
+    let (param1, index) = create_param Int "index" in
+    let (param2, value) = create_param ctype "value" in
+    let setter = FunDec (Void, name ^ "$set", [param1; param2], []) in
+
+    Hashtbl.add globals name (call getter, call setter);
+    [getter; setter]
+
+  (* Getter for basic variable type: return the variable *)
+  | GlobalDec (ctype, name, ann) ->
+    let getter = FunDec (ctype, name ^ "$get", [], []) in
 
-        let (param, _) = create_param ctype "value" in
-        let setter = FunDec (Void, name ^ "$set", [param], []) in
+    let (param, _) = create_param ctype "value" in
+    let setter = FunDec (Void, name ^ "$set", [param], []) in
 
-        Hashtbl.add globals name (call getter, call setter);
-        [getter; setter]
+    Hashtbl.add globals name (call getter, call setter);
+    [getter; setter]
 
-    | _ -> raise InvalidNode
+  | _ -> raise InvalidNode
 
 let rec create_funcs globals = function
-    | Program (decls, ann) ->
-        let decls = List.map (create_funcs globals) decls in
-        Program (flatten_blocks (List.map (create_funcs globals) decls), ann)
+  | Program (decls, ann) ->
+    let decls = List.map (create_funcs globals) decls in
+    Program (flatten_blocks (List.map (create_funcs globals) decls), ann)
 
-    | GlobalDef (true, ctype, name, None, ann) as node ->
-        Block (GlobalDef (false, ctype, name, None, ann) ::
-               (process globals node))
+  | GlobalDef (true, ctype, name, None, ann) as node ->
+    Block (GlobalDef (false, ctype, name, None, ann) :: (process globals node))
 
-    | GlobalDec (ctype, name, ann) as node ->
-        Block (process globals node)
+  | GlobalDec (ctype, name, ann) as node ->
+    Block (process globals node)
 
-    | node -> transform_children (create_funcs globals) node
+  | node -> transform_children (create_funcs globals) node
 
 let rec replace_vars scope depth = function
-    | (VarDec (_, name, _, _) as node)
-    | (Param (_, name, _) as node)
-            when Hashtbl.mem scope name ->
-        Hashtbl.remove scope name;
-        node
+  | (VarDec (_, name, _, _) as node)
+  | (Param (_, name, _) as node) when Hashtbl.mem scope name ->
+    Hashtbl.remove scope name;
+    node
 
-    | FunDef (export, ret_type, name, params, body, ann) ->
-        let local_scope = Hashtbl.copy scope in
-        let trav = replace_vars local_scope (depth + 1) in
-        let params = List.map trav params in
-        FunDef (export, ret_type, name, params, trav body, ann)
+  | FunDef (export, ret_type, name, params, body, ann) ->
+    let local_scope = Hashtbl.copy scope in
+    let trav = replace_vars local_scope (depth + 1) in
+    let params = List.map trav params in
+    FunDef (export, ret_type, name, params, trav body, ann)
 
-    | VarUse (dec, None, _) when Hashtbl.mem scope (nameof dec) ->
-        let (get, _) = Hashtbl.find scope (nameof dec) in
-        get [] depth
+  | VarUse (dec, None, _) when Hashtbl.mem scope (nameof dec) ->
+    let (get, _) = Hashtbl.find scope (nameof dec) in
+    get [] depth
 
-    | VarLet (dec, dims, value, _) when Hashtbl.mem scope (nameof dec) ->
-        let dims = optmapl (replace_vars scope depth) dims in
-        let (_, set) = Hashtbl.find scope (nameof dec) in
-        Expr (set (dims @ [replace_vars scope depth value]) depth)
+  | VarLet (dec, dims, value, _) when Hashtbl.mem scope (nameof dec) ->
+    let dims = optmapl (replace_vars scope depth) dims in
+    let (_, set) = Hashtbl.find scope (nameof dec) in
+    Expr (set (dims @ [replace_vars scope depth value]) depth)
 
-    | node -> transform_children (replace_vars scope depth) node
+  | node -> transform_children (replace_vars scope depth) node
 
 let phase = function
-    | Ast node ->
-        let globals = Hashtbl.create 20 in
-        let node = create_funcs globals node in
-        Ast (replace_vars globals 0 node)
-    | _ -> raise (InvalidInput "extern vars")
+  | Ast node ->
+    let globals = Hashtbl.create 20 in
+    let node = create_funcs globals node in
+    Ast (replace_vars globals 0 node)
+  | _ -> raise (InvalidInput "extern vars")

phases/index.ml

@@ -3,78 +3,79 @@ open Util
 open Globals
 
 let tag_index program =
-    let nglobs = ref 0 in
-    let nimport = ref 0 in
-    let consts = Hashtbl.create 32 in
-    let rec trav_localfuns trav = function
-        | LocalFuns body -> LocalFuns (List.map trav body)
-        | node -> transform_children (trav_localfuns trav) node
-    in
-    let rec tag stacklen callstack node =
-        let trav = tag stacklen callstack in
-        match node with
-        | GlobalDef _ ->
-            let index = !nglobs in
-            nglobs := !nglobs + 1;
-            annotate (Index index) (transform_children trav node)
-
-        | FunDef (export, rtype, name, params, body, ann) ->
-            (* label name for local function is "<parent_label>$<name>" *)
-            let callstack = name :: callstack in
-            let label = String.concat "$" (List.rev callstack) in
-
-            let stacklen = ref 0 in
-            let trav = tag stacklen callstack in
-
-            (* Traverse own function body first *)
-            let params = List.map trav params in
-            let body = trav body in
-            let ann = Index (!stacklen - List.length params) :: ann in
-
-            (* Traverse local functions after the function body *)
-            let body = trav_localfuns trav body in
-
-            FunDef (export, rtype, name, params, body, LabelName label :: ann)
-
-        | LocalFuns _ -> node
-
-        | VarDec _ | Param _ | Dim _ ->
-            let index = !stacklen in
-            stacklen := !stacklen + 1;
-            annotate (Index index) (transform_children trav node)
-
-        | FunDec (_, name, _, _) ->
-            let index = !nimport in
-            nimport := !nimport + 1;
-            annotate (LabelName name) (annotate (Index index) node)
-
-        | Const (value, _) when not (is_immediate_const value) ->
-            let index = if Hashtbl.mem consts value then (
-                Hashtbl.find consts value
-            ) else (
-                let index = Hashtbl.length consts in
-                Hashtbl.add consts value index;
-                index
-            ) in
-            annotate (Index index) node
-
-        | _ -> transform_children trav node
-    in tag (ref 0) [] program
+  let nglobs = ref 0 in
+  let nimport = ref 0 in
+  let consts = Hashtbl.create 32 in
+  let rec trav_localfuns trav = function
+    | LocalFuns body -> LocalFuns (List.map trav body)
+    | node -> transform_children (trav_localfuns trav) node
+  in
+  let rec tag stacklen callstack node =
+    let trav = tag stacklen callstack in
+    match node with
+    | GlobalDef _ ->
+      let index = !nglobs in
+      nglobs := !nglobs + 1;
+      annotate (Index index) (transform_children trav node)
+
+    | FunDef (export, rtype, name, params, body, ann) ->
+      (* label name for local function is "<parent_label>$<name>" *)
+      let callstack = name :: callstack in
+      let label = String.concat "$" (List.rev callstack) in
+
+      let stacklen = ref 0 in
+      let trav = tag stacklen callstack in
+
+      (* Traverse own function body first *)
+      let params = List.map trav params in
+      let body = trav body in
+      let ann = Index (!stacklen - List.length params) :: ann in
+
+      (* Traverse local functions after the function body *)
+      let body = trav_localfuns trav body in
+
+      FunDef (export, rtype, name, params, body, LabelName label :: ann)
+
+    | LocalFuns _ -> node
+
+    | VarDec _ | Param _ | Dim _ ->
+      let index = !stacklen in
+      stacklen := !stacklen + 1;
+      annotate (Index index) (transform_children trav node)
+
+    | FunDec (_, name, _, _) ->
+      let index = !nimport in
+      nimport := !nimport + 1;
+      annotate (LabelName name) (annotate (Index index) node)
+
+    | Const (value, _) when not (is_immediate_const value) ->
+      let index =
+        if Hashtbl.mem consts value then
+          Hashtbl.find consts value
+        else
+          let index = Hashtbl.length consts in
+          Hashtbl.add consts value index;
+          index
+      in
+      annotate (Index index) node
+
+    | _ -> transform_children trav node
+  in tag (ref 0) [] program
 
 let rec strip_context = function
-    | VarUse (dec, dims, ann) ->
-        Var (nameof dec, optmap strip_context dims, ann)
+  | VarUse (dec, dims, ann) ->
+    Var (nameof dec, optmap strip_context dims, ann)
 
-    | VarLet (dec, dims, value, ann) ->
-        Assign (nameof dec, optmap strip_context dims, strip_context value, ann)
+  | VarLet (dec, dims, value, ann) ->
+    Assign (nameof dec, optmap strip_context dims, strip_context value, ann)
 
-    | FunUse (dec, args, ann) ->
-        FunCall (nameof dec, List.map strip_context args, ann)
+  | FunUse (dec, args, ann) ->
+    FunCall (nameof dec, List.map strip_context args, ann)
 
-    | node -> transform_children strip_context node
+  | node -> transform_children strip_context node
 
 let phase = function
-    | Ast node ->
-        let tagged = tag_index (strip_context node) in
-        Ast (Context.analyse_context tagged)
-    | _ -> raise (InvalidInput "index analysis")
+  | Ast node ->
+    let tagged = tag_index (strip_context node) in
+    Ast (Context.analyse_context tagged)
+  | _ -> raise (InvalidInput "index analysis")

phases/load.ml

@@ -31,32 +31,37 @@ let input_buffered ic chunksize =
 
 let phase = function
   | Empty ->
-    let display_name = match args.infile with
-    | Some filename -> filename
-    | None -> "<stdin>"
+    let display_name =
+      match args.infile with
+      | Some filename -> filename
+      | None -> "<stdin>"
     in
     let bufsize = 512 in
 
     if args.cpp then
-      let cpp_out = match args.infile with
-      | Some filename ->
-        Unix.open_process_in (cpp_cmd ^ " " ^ filename)
-      | None ->
-        let content = input_buffered stdin bufsize in
-        let (cpp_out, cpp_in) = Unix.open_process cpp_cmd in
-        output_string cpp_in content;
-        close_out cpp_in;
-        cpp_out
+      let cpp_out =
+        match args.infile with
+        | Some filename ->
+          Unix.open_process_in (cpp_cmd ^ " " ^ filename)
+        | None ->
+          let content = input_buffered stdin bufsize in
+          let (cpp_out, cpp_in) = Unix.open_process cpp_cmd in
+          output_string cpp_in content;
+          close_out cpp_in;
+          cpp_out
       in
       log_line 2 "Run C preprocessor";
 
       (* Read preprocessed code from cpp's stdout *)
       let preprocessed = input_buffered cpp_out bufsize in
       FileContent (display_name, preprocessed)
+
     else
-      let content = match args.infile with
-      | Some filename -> input_all (open_in filename)
-      | None -> input_buffered stdin bufsize
+      let content =
+        match args.infile with
+        | Some filename -> input_all (open_in filename)
+        | None -> input_buffered stdin bufsize
       in
       FileContent (display_name, content)
+
   | _ -> raise (InvalidInput "load")

phases/output.ml

@@ -3,15 +3,15 @@ open Util
 open Globals
 
 let phase = function
-    | Assembly instrs ->
-        (match args.outfile with
-        | Some filename ->
-            let oc = open_out filename in
-            Print.print_assembly oc instrs;
-            close_out oc
-        | None ->
-            if args.verbose >= 1 then (prerr_endline hline);
-            Print.print_assembly stdout instrs
-        );
-        Empty
-    | _ -> raise (InvalidInput "output")
+  | Assembly instrs ->
+    begin match args.outfile with
+    | Some filename ->
+      let oc = open_out filename in
+      Print.print_assembly oc instrs;
+      close_out oc
+    | None ->
+      if args.verbose >= 1 then prerr_endline hline;
+      Print.print_assembly stdout instrs
+    end;
+    Empty
+  | _ -> raise (InvalidInput "output")

phases/parse.ml

@@ -4,26 +4,27 @@ open Util
 open Globals
 
 let get_loc lexbuf =
-    Util.loc_from_lexpos lexbuf.lex_curr_p lexbuf.lex_curr_p
+  Util.loc_from_lexpos lexbuf.lex_curr_p lexbuf.lex_curr_p
 
 let shift_loc (fname, ystart, yend, xstart, xend) yshift xshift =
-    (fname, ystart + yshift, yend + yshift, xstart + xshift, xend + xshift)
+  (fname, ystart + yshift, yend + yshift, xstart + xshift, xend + xshift)
 
 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))
-    | Parser.Error ->
-        raise (LocError ((shift_back lexbuf), "syntax error"))
+  try Some (Parser.program Lexer.token lexbuf) with
+  | Lexer.SyntaxError msg ->
+    raise (LocError ((shift_back lexbuf), msg))
+  | Parser.Error ->
+    raise (LocError ((shift_back lexbuf), "syntax error"))
 
 let phase = function
-    | FileContent (display_name, content) ->
-        let lexbuf = Lexing.from_string content in
-        lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = display_name };
-        let ast = parse_with_error lexbuf in
-        (match ast with
-            | None -> raise (CompileError "no syntax tree was constructed")
-            | Some node -> Ast node)
-    | _ -> raise (InvalidInput "parse")
+  | FileContent (display_name, content) ->
+    let lexbuf = Lexing.from_string content in
+    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")
+      | Some node -> Ast node
+    end
+  | _ -> raise (InvalidInput "parse")

phases/peephole.ml

@@ -4,75 +4,93 @@ open Util
 open Globals
 
 let rec strip_comments = function
-    | Comment _ :: tl -> strip_comments tl
-    | InlineComment (EmptyLine, _) :: tl -> strip_comments tl
-    | InlineComment (instr, _) :: tl -> strip_comments (instr :: tl)
-    | hd :: tl -> hd :: (strip_comments tl)
-    | [] -> []
+  | Comment _ :: tl -> strip_comments tl
+  | InlineComment (EmptyLine, _) :: tl -> strip_comments tl
+  | InlineComment (instr, _) :: tl -> strip_comments (instr :: tl)
+  | hd :: tl -> hd :: (strip_comments tl)
+  | [] -> []
 
 let rec peephole = function
-    (* Constant load before branch becomes a jump when the branch condition
-     * matches the loaded value ... *)
-    | LoadImm (BoolVal b) :: Branch (cond, tgt) :: tl when cond = b ->
-        InlineComment (Jump tgt, "branch -> jump") :: (peephole tl)
+  (* Constant load before branch becomes a jump when the branch condition
+   * matches the loaded value ... *)
+  | LoadImm (BoolVal b) :: Branch (cond, tgt) :: tl when cond = b ->
+    InlineComment (Jump tgt, "branch -> jump") :: (peephole tl)
 
-    (* ... otherwise, both instructions can be removed *)
-    | LoadImm (BoolVal _) :: Branch (_, tgt) :: tl ->
-        InlineComment (EmptyLine, "load + branch removed") :: peephole tl
+  (* ... otherwise, both instructions can be removed *)
+  | LoadImm (BoolVal _) :: Branch (_, tgt) :: tl ->
+    InlineComment (EmptyLine, "load + branch removed") :: peephole tl
 
-    (* Transform addition/subtraction by constant to increment/decrement:
-     * iload L          |   iload L
-     * iloadc[_ ]C      |   iloadc_1
-     * i{add,sub}       |   i{add,sub}
-     * istore L         |   istore L
-     *     |                  |
-     *     v                  v
-     * i{inc,dec} L C   |   i{inc,dec}_1 L
-     *)
-    | (Load (Int, Current, index) :: LoadConst (_, i) :: Op (Add, Int) ::
-            Store (Int, Current, store) :: tl
-    |  LoadConst (_, i) :: Load (Int, Current, index) :: Op (Add, Int) ::
-            Store (Int, Current, store) :: tl) when store = index ->
-        InlineComment (Inc (index, i), "add -> inc") :: (peephole tl)
+  (* Transform addition/subtraction by constant to increment/decrement:
+   * iload L          |   iload L
+   * iloadc[_ ]C      |   iloadc_1
+   * i{add,sub}       |   i{add,sub}
+   * istore L         |   istore L
+   *     |                    |
+   *     v                    v
+   * i{inc,dec} L C   |   i{inc,dec}_1 L
+   *)
+  | Load (Int, Current, index) ::
+    LoadConst (_, i) ::
+    Op (Add, Int) ::
+    Store (Int, Current, store) :: tl
+  | LoadConst (_, i) ::
+    Load (Int, Current, index) ::
+    Op (Add, Int) ::
+    Store (Int, Current, store) :: tl
+    when store = index ->
+      InlineComment (Inc (index, i), "add -> inc") :: (peephole tl)
 
-    | (Load (Int, Current, index) :: LoadConst (_, i) :: Op (Sub, Int) ::
-            Store (Int, Current, store) :: tl
-    |  LoadConst (_, i) :: Load (Int, Current, index) :: Op (Sub, Int) ::
-            Store (Int, Current, store) :: tl) when store = index ->
-        InlineComment (Dec (index, i), "sub -> dec") :: (peephole tl)
+  | Load (Int, Current, index) ::
+    LoadConst (_, i) ::
+    Op (Sub, Int) ::
+    Store (Int, Current, store) :: tl
+  | LoadConst (_, i) ::
+    Load (Int, Current, index) ::
+    Op (Sub, Int) ::
+    Store (Int, Current, store) :: tl
+    when store = index ->
+      InlineComment (Dec (index, i), "sub -> dec") :: (peephole tl)
 
-    | (Load (Int, Current, index) :: LoadImm (IntVal 1) :: Op (Add, Int) ::
-            Store (Int, Current, store) :: tl
-    |  LoadImm (IntVal 1) :: Load (Int, Current, index) :: Op (Add, Int) ::
-            Store (Int, Current, store) :: tl) when store = index ->
-        InlineComment (IncOne index, "add -> inc") :: (peephole tl)
+  | Load (Int, Current, index) ::
+    LoadImm (IntVal 1) ::
+    Op (Add, Int) ::
+    Store (Int, Current, store) :: tl
+  | LoadImm (IntVal 1) ::
+    Load (Int, Current, index) ::
+    Op (Add, Int) ::
+    Store (Int, Current, store) :: tl
+    when store = index ->
+      InlineComment (IncOne index, "add -> inc") :: (peephole tl)
 
-    | (Load (Int, Current, index) :: LoadImm (IntVal 1) :: Op (Sub, Int) ::
-            Store (Int, Current, store) :: tl
-    |  LoadImm (IntVal 1) :: Load (Int, Current, index) :: Op (Sub, Int) ::
-            Store (Int, Current, store) :: tl) when store = index ->
-        InlineComment (DecOne index, "sub -> dec") :: (peephole tl)
+  | Load (Int, Current, index) :: LoadImm (IntVal 1) :: Op (Sub, Int) ::
+    Store (Int, Current, store) :: tl
+  | LoadImm (IntVal 1) ::
+    Load (Int, Current, index) ::
+    Op (Sub, Int) ::
+    Store (Int, Current, store) :: tl
+    when store = index ->
+      InlineComment (DecOne index, "sub -> dec") :: (peephole tl)
 
-    | hd :: tl -> hd :: (peephole tl)
-    | [] -> []
+  | hd :: tl -> hd :: (peephole tl)
+  | [] -> []
 
 (* Count actual instructions, ignoring comments and labels *)
 let count_instrs instrs =
-    let rec trav n = function
-    | [] -> n
-    | (Comment _ | Label _ | EmptyLine) :: tl -> trav n tl
-    | InlineComment (hd, _) :: tl -> trav (trav n [hd]) tl
-    | hd :: tl -> trav (n + 1) tl
-    in trav 0 instrs
+  let rec trav n = function
+  | [] -> n
+  | (Comment _ | Label _ | EmptyLine) :: tl -> trav n tl
+  | InlineComment (hd, _) :: tl -> trav (trav n [hd]) tl
+  | hd :: tl -> trav (n + 1) tl
+  in trav 0 instrs
 
 let phase = function
-    | Assembly instrs as input ->
-        let oldcount = count_instrs instrs in
-        let instrs = peephole (strip_comments instrs) in
-        let newcount = count_instrs instrs in
-        log_line 2 (sprintf
-            "Optimized %d to %d instructions (%d fewer)"
-            oldcount newcount (oldcount - newcount)
-        );
-        Assembly instrs
-    | _ -> raise (InvalidInput "peephole")
+  | Assembly instrs as input ->
+    let oldcount = count_instrs instrs in
+    let instrs = peephole (strip_comments instrs) in
+    let newcount = count_instrs instrs in
+    log_line 2 (sprintf
+      "Optimized %d to %d instructions (%d fewer)"
+      oldcount newcount (oldcount - newcount)
+    );
+    Assembly instrs
+  | _ -> raise (InvalidInput "peephole")

phases/print.ml

@@ -3,179 +3,180 @@ open Util
 open Globals
 open Stringify
 
-let tab = "    "
+let tab = "  "
 let max_instr_width = 26
 
 let si = string_of_int
 
 let ctype2str = Stringify.type2str
 let type2str = function
-    | ArrayDims (t, dims) -> ctype2str t ^ repeat "," (List.length dims - 1)
-    | t -> ctype2str t
+  | ArrayDims (t, dims) -> ctype2str t ^ repeat "," (List.length dims - 1)
+  | t -> ctype2str t
 
 let op2str = function
-    | Neg -> "neg"
-    | Not -> "not"
-    | Add -> "add"
-    | Sub -> "sub"
-    | Mul -> "mul"
-    | Div -> "div"
-    | Mod -> "rem"
-    | Eq  -> "eq"
-    | Ne  -> "ne"
-    | Lt  -> "lt"
-    | Le  -> "le"
-    | Gt  -> "gt"
-    | Ge  -> "ge"
-    | _ -> raise (CompileError ("operator unsupported by VM"))
+  | Neg -> "neg"
+  | Not -> "not"
+  | Add -> "add"
+  | Sub -> "sub"
+  | Mul -> "mul"
+  | Div -> "div"
+  | Mod -> "rem"
+  | Eq  -> "eq"
+  | Ne  -> "ne"
+  | Lt  -> "lt"
+  | Le  -> "le"
+  | Gt  -> "gt"
+  | Ge  -> "ge"
+  | _ -> raise (CompileError ("operator unsupported by VM"))
 
 let prefix = function
-    | Bool _  -> "b"
-    | Int _   -> "i"
-    | Float _ -> "f"
-    | Void    -> ""
-    | _       -> "a"
+  | Bool _  -> "b"
+  | Int _   -> "i"
+  | Float _ -> "f"
+  | Void  -> ""
+  | _     -> "a"
 
 let suffix = function
-    | Glob        -> "g"
-    | Current     -> ""
-    | Local       -> "l"
-    | Rel nesting -> "n " ^ si nesting
+  | Glob    -> "g"
+  | Current   -> ""
+  | Local     -> "l"
+  | Rel nesting -> "n " ^ si nesting
 
 let rtn_suffix = function
-    | ExternFun index        -> "e " ^ si index
-    | LocalFun (size, label) -> " " ^ si size ^ " " ^ label
+  | ExternFun index    -> "e " ^ si index
+  | LocalFun (size, label) -> " " ^ si size ^ " " ^ label
 
 let rec instr2str = function
-    (* Global / directives *)
-    | Comment comment ->
-        if args.verbose >= 2 then "; " ^ comment else ""
-    | InlineComment (instr, comment) ->
-        if args.verbose >= 2 then
-            expand max_instr_width (instr2str instr) ^ " ; " ^ comment
-        else
-            instr2str instr
-    | Label name ->
-        name ^ ":"
-    | Export (name, ret_type, arg_types, label) ->
-        let types = List.map type2str (ret_type :: arg_types) in
-        ".export \"" ^ name ^ "\" " ^ (String.concat " " types) ^ " " ^ label
-    | Import (name, ret_type, arg_types) ->
-        let types = List.map type2str (ret_type :: arg_types) in
-        ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
-    | Global ctype ->
-        ".global " ^ (type2str ctype)
-    | ConstDef value ->
-        ".const " ^ type2str (const_type value) ^ " " ^ const2str value
-
-    (* Store *)
-    | Store (ctype, scope, index) ->
-        tab ^ prefix ctype ^ "store" ^ suffix scope ^ " " ^ si index
-
-    (* Load *)
-    | Load (ctype, Current, index) when index >= 0 & index <= 3 ->
-        tab ^ prefix ctype ^ "load_" ^ si index
-    | Load (ctype, scope, index) ->
-        tab ^ prefix ctype ^ "load" ^ suffix scope ^ " " ^ si index
-    | LoadConst (ctype, index) ->
-        tab ^ prefix ctype ^ "loadc " ^ si index
-    | LoadImm (BoolVal b) ->
-        tab ^ "bloadc_" ^ (if b then "t" else "f")
-    | LoadImm (IntVal i) when i < 0 ->
-        tab ^ "iloadc_m" ^ si (-i)
-    | LoadImm (IntVal i) ->
-        tab ^ "iloadc_" ^ si i
-    | LoadImm (FloatVal i) ->
-        tab ^ "floadc_" ^ si (int_of_float i)
-
-    (* Operators *)
-    | Op (op, ctype) ->
-        tab ^ prefix ctype ^ op2str op
-    | Convert (src, tgt) ->
-        tab ^ prefix src ^ "2" ^ prefix tgt
-    | Inc (index, const) ->
-        tab ^ "iinc " ^ si index ^ " " ^ si const
-    | Dec (index, const) ->
-        tab ^ "idec " ^ si index ^ " " ^ si const
-    | IncOne index ->
-        tab ^ "iinc_1 " ^ si index
-    | DecOne index ->
-        tab ^ "idec_1 " ^ si index
-
-    (* Control flow *)
-    | RtnInit scope ->
-        tab ^ "isr" ^ suffix scope
-    | RtnJmp scope ->
-        tab ^ "jsr" ^ rtn_suffix scope
-    | RtnEnter stack_len ->
-        tab ^ "esr " ^ si stack_len
-    | Ret ctype ->
-        tab ^ prefix ctype ^ "return"
-    | Branch (true, target) ->
-        tab ^ "branch_t " ^ target
-    | Branch (false, target) ->
-        tab ^ "branch_f " ^ target
-    | Jump target ->
-        tab ^ "jump " ^ target
-
-    (* Stack management *)
-    | Pop ctype ->
-        tab ^ prefix ctype ^ "pop"
-
-    (* Arrays *)
-    | NewArray (basetype, ndims) ->
-        tab ^ prefix basetype ^ "newa " ^ si ndims
-    | LoadArray basetype ->
-        tab ^ prefix basetype ^ "loada"
-    | StoreArray basetype ->
-        tab ^ prefix basetype ^ "storea"
-
-    | EmptyLine -> ""
-    | DummyInstr -> tab ^ "<dummy>"
+  (* Global / directives *)
+  | Comment comment ->
+    if args.verbose >= 2 then "; " ^ comment else ""
+  | InlineComment (instr, comment) ->
+    if args.verbose >= 2 then
+      expand max_instr_width (instr2str instr) ^ " ; " ^ comment
+    else
+      instr2str instr
+  | Label name ->
+    name ^ ":"
+  | Export (name, ret_type, arg_types, label) ->
+    let types = List.map type2str (ret_type :: arg_types) in
+    ".export \"" ^ name ^ "\" " ^ (String.concat " " types) ^ " " ^ label
+  | Import (name, ret_type, arg_types) ->
+    let types = List.map type2str (ret_type :: arg_types) in
+    ".import \"" ^ name ^ "\" " ^ (String.concat " " types)
+  | Global ctype ->
+    ".global " ^ (type2str ctype)
+  | ConstDef value ->
+    ".const " ^ type2str (const_type value) ^ " " ^ const2str value
+
+  (* Store *)
+  | Store (ctype, scope, index) ->
+    tab ^ prefix ctype ^ "store" ^ suffix scope ^ " " ^ si index
+
+  (* Load *)
+  | Load (ctype, Current, index) when index >= 0 & index <= 3 ->
+    tab ^ prefix ctype ^ "load_" ^ si index
+  | Load (ctype, scope, index) ->
+    tab ^ prefix ctype ^ "load" ^ suffix scope ^ " " ^ si index
+  | LoadConst (ctype, index) ->
+    tab ^ prefix ctype ^ "loadc " ^ si index
+  | LoadImm (BoolVal b) ->
+    tab ^ "bloadc_" ^ (if b then "t" else "f")
+  | LoadImm (IntVal i) when i < 0 ->
+    tab ^ "iloadc_m" ^ si (-i)
+  | LoadImm (IntVal i) ->
+    tab ^ "iloadc_" ^ si i
+  | LoadImm (FloatVal i) ->
+    tab ^ "floadc_" ^ si (int_of_float i)
+
+  (* Operators *)
+  | Op (op, ctype) ->
+    tab ^ prefix ctype ^ op2str op
+  | Convert (src, tgt) ->
+    tab ^ prefix src ^ "2" ^ prefix tgt
+  | Inc (index, const) ->
+    tab ^ "iinc " ^ si index ^ " " ^ si const
+  | Dec (index, const) ->
+    tab ^ "idec " ^ si index ^ " " ^ si const
+  | IncOne index ->
+    tab ^ "iinc_1 " ^ si index
+  | DecOne index ->
+    tab ^ "idec_1 " ^ si index
+
+  (* Control flow *)
+  | RtnInit scope ->
+    tab ^ "isr" ^ suffix scope
+  | RtnJmp scope ->
+    tab ^ "jsr" ^ rtn_suffix scope
+  | RtnEnter stack_len ->
+    tab ^ "esr " ^ si stack_len
+  | Ret ctype ->
+    tab ^ prefix ctype ^ "return"
+  | Branch (true, target) ->
+    tab ^ "branch_t " ^ target
+  | Branch (false, target) ->
+    tab ^ "branch_f " ^ target
+  | Jump target ->
+    tab ^ "jump " ^ target
+
+  (* Stack management *)
+  | Pop ctype ->
+    tab ^ prefix ctype ^ "pop"
+
+  (* Arrays *)
+  | NewArray (basetype, ndims) ->
+    tab ^ prefix basetype ^ "newa " ^ si ndims
+  | LoadArray basetype ->
+    tab ^ prefix basetype ^ "loada"
+  | StoreArray basetype ->
+    tab ^ prefix basetype ^ "storea"
+
+  | EmptyLine -> ""
+  | DummyInstr -> tab ^ "<dummy>"
 
 let rec print_assembly oc instrs =
-    let output_line line =
-        output_string oc line;
-        output_char oc '\n';
-    in
-    let endbuf = ref [] in
-    let rec trav = function
-        | [] -> ()
-        | EmptyLine :: tl -> output_line ""; trav tl
-        | hd :: tl ->
-            let line = instr2str hd in
-            (if String.length line > 0 && line.[0] = '.' then
-                endbuf := line :: !endbuf
-            else (if String.length line > 0 then
-                output_line line
-            ));
-            trav tl
-    in
-    trav instrs;
-    if List.length !endbuf > 1 then (
-        output_line (instr2str (Comment ("globals:")));
-        let cmp a b = compare (String.sub b 0 7) (String.sub a 0 7) in
-        List.iter output_line (List.sort cmp (List.rev !endbuf))
-    ); ()
+  let output_line line =
+    output_string oc line;
+    output_char oc '\n';
+  in
+  let endbuf = ref [] in
+  let rec trav = function
+    | [] -> ()
+    | EmptyLine :: tl -> output_line ""; trav tl
+    | hd :: tl ->
+      let line = instr2str hd in
+      begin
+        if String.length line > 0 && line.[0] = '.' then
+          endbuf := line :: !endbuf
+        else if String.length line > 0 then
+          output_line line
+      end;
+      trav tl
+  in
+  trav instrs;
+  if List.length !endbuf > 1 then begin
+    output_line (instr2str (Comment ("globals:")));
+    let cmp a b = compare (String.sub b 0 7) (String.sub a 0 7) in
+    List.iter output_line (List.sort cmp (List.rev !endbuf))
+  end
 
 let phase = function
-    | Ast node as input ->
-        prerr_endline hline;
-        prerr_endline (node2str node);
-        prerr_endline hline;
-        input
-
-    | FileContent (display_name, content) as input ->
-        prerr_endline hline;
-        prerr_endline (display_name ^ ":\n");
-        prerr_endline content;
-        prerr_endline hline;
-        input
-
-    | Assembly instrs as input ->
-        prerr_endline hline;
-        print_assembly stderr instrs;
-        prerr_endline hline;
-        input
-
-    | Empty -> Empty
+  | Ast node as input ->
+    prerr_endline hline;
+    prerr_endline (node2str node);
+    prerr_endline hline;
+    input
+
+  | FileContent (display_name, content) as input ->
+    prerr_endline hline;
+    prerr_endline (display_name ^ ":\n");
+    prerr_endline content;
+    prerr_endline hline;
+    input
+
+  | Assembly instrs as input ->
+    prerr_endline hline;
+    print_assembly stderr instrs;
+    prerr_endline hline;
+    input
+
+  | Empty -> Empty

phases/typecheck.ml

@@ -21,229 +21,234 @@ open Globals
 open Stringify
 
 let array_depth = function
-    | ArrayDims (_, dims) -> List.length dims
-    | _                   -> raise InvalidNode
+  | ArrayDims (_, dims) -> List.length dims
+  | _                   -> raise InvalidNode
 
 let spec = function
-    | ArrayDims (ctype, dims) -> (ctype, List.length dims)
-    | ctype                   -> (ctype, 0)
+  | ArrayDims (ctype, dims) -> (ctype, List.length dims)
+  | ctype                   -> (ctype, 0)
 
 let check_type ?(msg="") expected node =
-    let got = typeof node in
-    if (spec got) <> (spec expected) then (
-        let msg = match msg with
-            | "" -> sprintf "type mismatch: expected type %s, got %s"
-                            (type2str expected) (type2str got)
-                            (*(type2str (spec expected)) (type2str (spec got))*)
-            | _ -> msg
-        in raise (NodeError (node, msg))
-    ); ()
+  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 expected) (type2str got)
+              (*(type2str (spec expected)) (type2str (spec got))*)
+      | _ -> msg
+    in raise (NodeError (node, msg))
+  end
 
 let op_types = function
-    | Not | And | Or                      -> [Bool]
-    | Mod                                 -> [Int]
-    | Neg | Sub | Div | Lt | Le | Gt | Ge -> [Int; Float]
-    | Add | Mul | Eq | Ne                 -> [Bool; Int; Float]
+  | Not | And | Or                      -> [Bool]
+  | Mod                                 -> [Int]
+  | Neg | Sub | Div | Lt | Le | Gt | Ge -> [Int; Float]
+  | Add | Mul | Eq | Ne                 -> [Bool; Int; Float]
 
 let op_result_type opnd_type = function
-    | Not | And | Or | Eq | Ne | Lt | Le | Gt | Ge -> Bool
-    | Neg | Add | Sub | Mul | Div | Mod            -> opnd_type
+  | Not | And | Or | Eq | Ne | Lt | Le | Gt | Ge -> Bool
+  | Neg | Add | Sub | Mul | Div | Mod      -> opnd_type
 
 (* 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 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 (NodeError (node, msg))
+  ); ()
+
+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
+    in
+    raise (NodeError (errnode, msg))
+  | _ -> ()
+
+let rec typecheck node =
+  let check_trav ctype node =
+    let node = typecheck node in
+    check_type ctype node;
+    node
+  in
+  match node with
+  | FunUse ((FunDec (ret_type, name, params, _) as dec), args, ann)
+  | FunUse ((FunDef (_, ret_type, name, params, _, _) as dec), args, ann) ->
+    begin
+      match (List.length args, List.length params) with
+      | (nargs, nparams) when nargs != nparams ->
         let msg = sprintf
-            "%s cannot be applied to type %s, only to %s"
-            desc (type2str got) (types2str allowed_types)
+          "function \"%s\" expects %d arguments, got %d"
+          name nparams nargs
         in
         raise (NodeError (node, msg))
-    ); ()
+      | _ ->
+        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)
+    end
+
+  (* Operators match operand types and get a new type based on the operator *)
+  | Monop (op, opnd, ann) ->
+    let opnd = 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)
+
+  | Binop (op, left, right, ann) ->
+    let left = typecheck left in
+    let right = 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;
+
+    (* Check for division by zero *)
+    begin
+      match (op, right) with
+      | (Div, Const (IntVal 0, _)) -> node_warning right "division by zero"
+      | _ -> ()
+    end;
+
+    Binop (op, left, right, Type (op_result_type (typeof left) op) :: ann)
+
+  (* 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)
+
+  (* 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)
+
+  (* Array allocation dimensions must have type int *)
+  | Allocate (dec, dims, ann) ->
+    Allocate (dec, List.map (check_trav Int) dims, ann)
+
+  (* 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)
+    *)
+
+  (* 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 rec find_return = function
+      | []                         -> None
+      | [Return (value, _) as ret] -> Some (ret, typeof value)
+      | hd :: tl                   -> find_return tl
+    in
+    begin
+      match (ret_type, find_return (block_body body)) with
+      | (Void, Some (ret, _)) ->
+        raise (NodeError (ret, "void function should not have a return value"))
 
-let check_dims_match dims dec_type errnode =
-    match (List.length dims, array_depth dec_type) with
-    | (got, expected) when got != expected ->
+      | ((Bool | Int | Float), None) ->
         let msg = sprintf
-            "dimension mismatch: expected %d indices, got %d" expected got
+          "expected return value of type %s for function \"%s\""
+          (type2str ret_type) name
         in
-        raise (NodeError (errnode, msg))
-    | _ -> ()
+        raise (NodeError (node, msg))
 
-let rec typecheck node =
-    let check_trav ctype node =
-        let node = typecheck node in
-        check_type ctype node;
-        node
-    in
-    match node with
-    | FunUse ((FunDec (ret_type, name, params, _) as dec), args, ann)
-    | FunUse ((FunDef (_, ret_type, name, params, _, _) as dec), args, ann) ->
-        (match (List.length args, List.length params) with
-        | (nargs, nparams) when nargs != nparams ->
-            let msg = sprintf
-                "function \"%s\" expects %d arguments, got %d"
-                name nparams nargs
-            in
-            raise (NodeError (node, msg))
-        | _ ->
-            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)
-        )
-
-    (* Operators match operand types and get a new type based on the operator *)
-    | Monop (op, opnd, ann) ->
-        let opnd = 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)
-
-    | Binop (op, left, right, ann) ->
-        let left = typecheck left in
-        let right = 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 _ = match (op, right) with
-            | (Div, Const (IntVal 0, _)) -> node_warning right "division by zero"
-            | _ -> ()
+      | ((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
-        Binop (op, left, right, Type (op_result_type (typeof left) op) :: ann)
-
-    (* 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)
-
-    (* 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)
-
-    (* Array allocation dimensions must have type int *)
-    | Allocate (dec, dims, ann) ->
-        Allocate (dec, List.map (check_trav Int) dims, ann)
-
-    (* 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)
-        *)
-
-    (* 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 rec find_return = function
-            | []                         -> None
-            | [Return (value, _) as ret] -> Some (ret, typeof value)
-            | hd :: tl                   -> find_return tl
-        in (
-        match (ret_type, find_return (block_body body)) with
-            | (Void, Some (ret, _)) ->
-                raise (NodeError (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))
-
-            | ((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))
-
-            | _ -> FunDef (export, ret_type, name, params, body, ann)
-        )
-
-    (* Conditions in must have type bool *)
-    | If (cond, body, ann) ->
-        If (check_trav Bool cond, typecheck body, ann)
-    | IfElse (cond, tbody, fbody, ann) ->
-        IfElse (check_trav Bool cond, typecheck tbody, typecheck fbody, ann)
-    | While (cond, body, ann) ->
-        While (check_trav Bool cond, typecheck body, ann)
-    | DoWhile (cond, body, ann) ->
-        DoWhile (check_trav Bool cond, typecheck body, ann)
-
-    (* Constants *)
-    | Const (BoolVal value, 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 (NodeError (node, "integer value out of range (signed 32-bit)"))
-        );
-        Const (IntVal value, Type Int :: ann)
-    | Const (FloatVal value, ann) ->
-        Const (FloatVal value, Type Float :: ann)
-
-    (* Variables inherit the type of their declaration *)
-    | VarUse (dec, None, 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;
-
-        check_dims_match dims (typeof dec) node;
-        VarUse (dec, Some dims, Type (basetypeof dec) :: ann)
-
-    (* 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 initialisation"))
-
-    (* Assigned values must match variable declaration *)
-    | VarLet (dec, None, value, ann) ->
-        VarLet (dec, None, check_trav (typeof dec) value, ann)
-
-    | VarLet (dec, Some dims, value, ann) ->
-        (* Number of assigned indices must match array definition *)
-        check_dims_match dims (typeof dec) node;
-
-        (* Array indices must be ints *)
-        let dims = List.map typecheck dims in
-        List.iter (check_type Int) dims;
-
-        (* Assigned value must match array base type *)
-        let value = typecheck value in
-        check_type (basetypeof dec) value;
-
-        VarLet (dec, Some dims, value, ann)
-
-    (* 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 " ^
-                                "initialisation"))
-
-    | _ -> transform_children typecheck node
+        raise (NodeError (ret, msg))
+
+      | _ -> FunDef (export, ret_type, name, params, body, ann)
+    end
+
+  (* Conditions in must have type bool *)
+  | If (cond, body, ann) ->
+    If (check_trav Bool cond, typecheck body, ann)
+  | IfElse (cond, tbody, fbody, ann) ->
+    IfElse (check_trav Bool cond, typecheck tbody, typecheck fbody, ann)
+  | While (cond, body, ann) ->
+    While (check_trav Bool cond, typecheck body, ann)
+  | DoWhile (cond, body, ann) ->
+    DoWhile (check_trav Bool cond, typecheck body, ann)
+
+  (* Constants *)
+  | Const (BoolVal value, 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 (NodeError (node, "integer value out of range (signed 32-bit)"))
+    );
+    Const (IntVal value, Type Int :: ann)
+  | Const (FloatVal value, ann) ->
+    Const (FloatVal value, Type Float :: ann)
+
+  (* Variables inherit the type of their declaration *)
+  | VarUse (dec, None, 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;
+
+    check_dims_match dims (typeof dec) node;
+    VarUse (dec, Some dims, Type (basetypeof dec) :: ann)
+
+  (* 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 \
+                             initialisation"))
+
+  (* Assigned values must match variable declaration *)
+  | VarLet (dec, None, value, ann) ->
+    VarLet (dec, None, check_trav (typeof dec) value, ann)
+
+  | VarLet (dec, Some dims, value, ann) ->
+    (* Number of assigned indices must match array definition *)
+    check_dims_match dims (typeof dec) node;
+
+    (* Array indices must be ints *)
+    let dims = List.map typecheck dims in
+    List.iter (check_type Int) dims;
+
+    (* Assigned value must match array base type *)
+    let value = typecheck value in
+    check_type (basetypeof dec) value;
+
+    VarLet (dec, Some dims, value, ann)
+
+  (* 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 \
+                             initialisation"))
+
+  | _ -> transform_children typecheck node
 
 let phase = function
-    | Ast node -> Ast (typecheck node)
-    | _ -> raise (InvalidInput "typecheck")
+  | Ast node -> Ast (typecheck node)
+  | _ -> raise (InvalidInput "typecheck")

stringify.ml

@@ -8,170 +8,171 @@ let indent = Str.global_replace (Str.regexp "^\\(.\\)") (tab ^ "\\1")
 
 (* const -> string *)
 let const2str = function
-    | BoolVal  b -> string_of_bool b
-    | IntVal   i -> string_of_int i
-    | FloatVal f ->
-        (* Add a trailing zero to a float stringification *)
-        (match string_of_float f with
-        | s when s.[String.length s - 1] = '.' -> s ^ "0"
-        | s -> s
-        )
+  | BoolVal  b -> string_of_bool b
+  | IntVal   i -> string_of_int i
+  | FloatVal f ->
+    (* Add a trailing zero to a float stringification *)
+    begin
+      match string_of_float f with
+      | s when s.[String.length s - 1] = '.' -> s ^ "0"
+      | s -> s
+    end
 
 (* Copied from util.ml to avoid circular dependency *)
 let nameof = function
-    | GlobalDec (_, name, _)
-    | GlobalDef (_, _, name, _, _)
-    | FunDec (_, name, _, _)
-    | FunDef (_, _, name, _, _, _)
-    | VarDec (_, name, _, _)
-    | Param (_, name, _)
-    | Dim (name, _) -> name
-    | _ -> raise InvalidNode
+  | GlobalDec (_, name, _)
+  | GlobalDef (_, _, name, _, _)
+  | FunDec (_, name, _, _)
+  | FunDef (_, _, name, _, _, _)
+  | VarDec (_, name, _, _)
+  | Param (_, name, _)
+  | Dim (name, _) -> name
+  | _ -> raise InvalidNode
 
 (* operator -> string *)
 let op2str = function
-    | Neg -> "-"
-    | Not -> "!"
-    | Add -> "+"
-    | Sub -> "-"
-    | Mul -> "*"
-    | Div -> "/"
-    | Mod -> "%"
-    | Eq  -> "=="
-    | Ne  -> "!="
-    | Lt  -> "<"
-    | Le  -> "<="
-    | Gt  -> ">"
-    | Ge  -> ">="
-    | And -> "&&"
-    | Or  -> "||"
+  | Neg -> "-"
+  | Not -> "!"
+  | Add -> "+"
+  | Sub -> "-"
+  | Mul -> "*"
+  | Div -> "/"
+  | Mod -> "%"
+  | Eq  -> "=="
+  | Ne  -> "!="
+  | Lt  -> "<"
+  | Le  -> "<="
+  | Gt  -> ">"
+  | Ge  -> ">="
+  | And -> "&&"
+  | Or  -> "||"
 
 (* ctype -> string *)
 let rec type2str = function
-    | Void  -> "void"
-    | Bool  -> "bool"
-    | Int   -> "int"
-    | Float -> "float"
-    | ArrayDims (t, dims) -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
-    | Array t             -> (type2str t) ^ "[]"
+  | Void  -> "void"
+  | Bool  -> "bool"
+  | Int   -> "int"
+  | Float -> "float"
+  | ArrayDims (t, dims) -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
+  | Array t             -> (type2str t) ^ "[]"
 
 and concat sep nodes = String.concat sep (List.map node2str nodes)
 
 (* node -> string *)
 and node2str node =
-    let str = node2str in
-    match node with
-
-    (* Global *)
-    | Program (decls, _) ->
-        concat "\n\n" decls
-    | Param (param_type, name, _) ->
-        (type2str param_type) ^ " " ^ 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
-        export ^ type2str ret_type ^ " " ^ name ^ params ^ " " ^ str body
-    | GlobalDec (var_type, name, _) ->
-        "extern " ^ type2str var_type ^ " " ^ name ^ ";"
-    | GlobalDef (export, ret_type, name, init, _) ->
-        let export = if export then "export " else "" in
-        let init = match init with
-            | Some value -> " = " ^ str value
-            | None -> ""
-        in
-        export ^ (type2str ret_type) ^ " " ^ name ^ init ^ ";"
-
-    (* Statements *)
-    | VarDec (var_type, name, None, _) ->
-        (type2str var_type) ^ " " ^ name ^ ";"
-    | VarDec (var_type, name, Some init, _) ->
-        (type2str var_type) ^ " " ^ name ^ " = " ^ str init ^ ";"
-    | Assign (name, None, value, _) ->
-        name ^ " = " ^ (str value) ^ ";"
-    | Assign (name, Some dims, value, _) ->
-        name ^ "[" ^ (concat ", " dims) ^ "] = " ^ (str value) ^ ";"
-    | Expr expr ->
-        str expr ^ ";"
-    | Return (value, _) ->
-        "return " ^ (str value) ^ ";"
-    | If (cond, body, _) ->
-        "if (" ^ str cond ^ ") " ^ str body
-    | IfElse (cond, true_body, false_body, _) ->
-        "if (" ^ str cond ^ ") " ^ str true_body ^ " else " ^ str false_body
-    | While (cond, body, _) ->
-        "while (" ^ str cond ^ ") " ^ str body
-    | DoWhile (cond, body, _) ->
-        "do " ^ str body ^ " while (" ^ str cond ^ ");"
-    | For (counter, start, stop, step, body, _) ->
-        let step = match step with
-            | Const (IntVal 1, _) -> ""
-            | value -> ", " ^ str value
-        in
-        let range = str start ^ ", " ^ str stop ^ step in
-        "for (int " ^ counter ^ " = " ^ range ^ ") " ^ str body
-    | Allocate (dec, dims, _) ->
-        nameof dec ^ " := <allocate>(" ^ concat ", " dims ^ ");"
-    | Block body ->
-        let rec append = function
-            | [] -> ""
-            | [last] -> last
-            | "" :: tl -> append tl
-            | hd :: tl -> hd ^ "\n" ^ append tl
-        in
-        "{\n" ^ indent (append (List.map str body)) ^ "\n}"
-
-    (* Expressions *)
-    | Const (c, _) -> const2str c
-    | ArrayConst (dims, _) -> "[" ^ concat ", " dims ^ "]"
-    | Var (v, None, _) -> v
-    | Var (name, Some dims, _) -> name ^ (str (ArrayConst (dims, [])))
-    | Monop (op, opnd, _) -> op2str op ^ str opnd
-    | Binop (op, left, right, _) ->
-        "(" ^ str left ^ " " ^ op2str op ^ " " ^ str right ^ ")"
-    | TypeCast (ctype, value, _) -> "(" ^ type2str ctype ^ ")" ^ str value
-    | FunCall (name, args, _) -> name ^ "(" ^ (concat ", " args) ^ ")"
-    | Cond (cond, t, f, _) -> "(" ^ (str cond) ^ " ? " ^ str t ^ " : " ^ str f ^ ")"
-
-    (* Annotation nodes print more information at higher verbosity, for
-     * debugging purposes *)
-    | VarLet (dec, dims, value, _) when args.verbose >= 3 ->
-        "<let:" ^ node2str (Assign (nameof dec, dims, value, [])) ^ ">"
-    | VarUse (dec, dims, _)        when args.verbose >= 3 ->
-        "<use:" ^ node2str (Var (nameof dec, dims, [])) ^ ">"
-    | FunUse (dec, params, _)      when args.verbose >= 3 ->
-        "<use:" ^ node2str (FunCall (nameof dec, params, [])) ^ ">"
-    | Dim (name, _)                when args.verbose >= 3 ->
-        "<dim:" ^ name ^ ">"
-    | ArrayScalar value            when args.verbose >= 3 ->
-        "<scalar:" ^ str value ^ ">"
-    | Arg node                     when args.verbose >= 3 ->
-        "<arg:" ^ str node ^ ">"
-    | VarDecs nodes                when args.verbose >= 3 ->
-        String.concat "\n" ("// vardecs" :: List.map str nodes)
-    | LocalFuns nodes              when args.verbose >= 3 ->
-        String.concat "\n" ("// localfuns" :: List.map str nodes)
-
-    | VarLet (dec, dims, value, _) ->
-        node2str (Assign (nameof dec, dims, value, []))
-    | VarUse (dec, dims, _) ->
-        node2str (Var (nameof dec, dims, []))
-    | FunUse (dec, args, _) ->
-        node2str (FunCall (nameof dec, args, []))
-    | Dim (name, _) -> name
-    | ArrayScalar node
-    | ArrayInit (node, _)
-    | Arg node -> str node
-
-    | VarDecs nodes
-    | LocalFuns nodes -> concat "\n" nodes
-
-    | DummyNode -> "<dummy>"
+  let str = node2str in
+  match node with
+
+  (* Global *)
+  | Program (decls, _) ->
+    concat "\n\n" decls
+  | Param (param_type, name, _) ->
+    (type2str param_type) ^ " " ^ 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
+    export ^ type2str ret_type ^ " " ^ name ^ params ^ " " ^ str body
+  | GlobalDec (var_type, name, _) ->
+    "extern " ^ type2str var_type ^ " " ^ name ^ ";"
+  | GlobalDef (export, ret_type, name, init, _) ->
+    let export = if export then "export " else "" in
+    let init = match init with
+      | Some value -> " = " ^ str value
+      | None -> ""
+    in
+    export ^ (type2str ret_type) ^ " " ^ name ^ init ^ ";"
+
+  (* Statements *)
+  | VarDec (var_type, name, None, _) ->
+    (type2str var_type) ^ " " ^ name ^ ";"
+  | VarDec (var_type, name, Some init, _) ->
+    (type2str var_type) ^ " " ^ name ^ " = " ^ str init ^ ";"
+  | Assign (name, None, value, _) ->
+    name ^ " = " ^ (str value) ^ ";"
+  | Assign (name, Some dims, value, _) ->
+    name ^ "[" ^ (concat ", " dims) ^ "] = " ^ (str value) ^ ";"
+  | Expr expr ->
+    str expr ^ ";"
+  | Return (value, _) ->
+    "return " ^ (str value) ^ ";"
+  | If (cond, body, _) ->
+    "if (" ^ str cond ^ ") " ^ str body
+  | IfElse (cond, true_body, false_body, _) ->
+    "if (" ^ str cond ^ ") " ^ str true_body ^ " else " ^ str false_body
+  | While (cond, body, _) ->
+    "while (" ^ str cond ^ ") " ^ str body
+  | DoWhile (cond, body, _) ->
+    "do " ^ str body ^ " while (" ^ str cond ^ ");"
+  | For (counter, start, stop, step, body, _) ->
+    let step = match step with
+      | Const (IntVal 1, _) -> ""
+      | value -> ", " ^ str value
+    in
+    let range = str start ^ ", " ^ str stop ^ step in
+    "for (int " ^ counter ^ " = " ^ range ^ ") " ^ str body
+  | Allocate (dec, dims, _) ->
+    nameof dec ^ " := <allocate>(" ^ concat ", " dims ^ ");"
+  | Block body ->
+    let rec append = function
+      | [] -> ""
+      | [last] -> last
+      | "" :: tl -> append tl
+      | hd :: tl -> hd ^ "\n" ^ append tl
+    in
+    "{\n" ^ indent (append (List.map str body)) ^ "\n}"
+
+  (* Expressions *)
+  | Const (c, _) -> const2str c
+  | ArrayConst (dims, _) -> "[" ^ concat ", " dims ^ "]"
+  | Var (v, None, _) -> v
+  | Var (name, Some dims, _) -> name ^ (str (ArrayConst (dims, [])))
+  | Monop (op, opnd, _) -> op2str op ^ str opnd
+  | Binop (op, left, right, _) ->
+    "(" ^ str left ^ " " ^ op2str op ^ " " ^ str right ^ ")"
+  | TypeCast (ctype, value, _) -> "(" ^ type2str ctype ^ ")" ^ str value
+  | FunCall (name, args, _) -> name ^ "(" ^ (concat ", " args) ^ ")"
+  | Cond (cond, t, f, _) -> "(" ^ (str cond) ^ " ? " ^ str t ^ " : " ^ str f ^ ")"
+
+  (* Annotation nodes print more information at higher verbosity, for
+   * debugging purposes *)
+  | VarLet (dec, dims, value, _) when args.verbose >= 3 ->
+    "<let:" ^ node2str (Assign (nameof dec, dims, value, [])) ^ ">"
+  | VarUse (dec, dims, _)        when args.verbose >= 3 ->
+    "<use:" ^ node2str (Var (nameof dec, dims, [])) ^ ">"
+  | FunUse (dec, params, _)      when args.verbose >= 3 ->
+    "<use:" ^ node2str (FunCall (nameof dec, params, [])) ^ ">"
+  | Dim (name, _)                when args.verbose >= 3 ->
+    "<dim:" ^ name ^ ">"
+  | ArrayScalar value            when args.verbose >= 3 ->
+    "<scalar:" ^ str value ^ ">"
+  | Arg node                     when args.verbose >= 3 ->
+    "<arg:" ^ str node ^ ">"
+  | VarDecs nodes                when args.verbose >= 3 ->
+    String.concat "\n" ("// vardecs" :: List.map str nodes)
+  | LocalFuns nodes              when args.verbose >= 3 ->
+    String.concat "\n" ("// localfuns" :: List.map str nodes)
+
+  | VarLet (dec, dims, value, _) ->
+    node2str (Assign (nameof dec, dims, value, []))
+  | VarUse (dec, dims, _) ->
+    node2str (Var (nameof dec, dims, []))
+  | FunUse (dec, args, _) ->
+    node2str (FunCall (nameof dec, args, []))
+  | Dim (name, _) -> name
+  | ArrayScalar node
+  | ArrayInit (node, _)
+  | Arg node -> str node
+
+  | VarDecs nodes
+  | LocalFuns nodes -> concat "\n" nodes
+
+  | DummyNode -> "<dummy>"
 
 (* ctype list -> string *)
 let rec types2str = function
-    | [] -> ""
-    | [ctype] -> type2str ctype
-    | ctype :: tail -> type2str ctype ^ " or " ^ (types2str tail)
+  | [] -> ""
+  | [ctype] -> type2str ctype
+  | ctype :: tail -> type2str ctype ^ " or " ^ (types2str tail)

types.mli

@@ -5,157 +5,157 @@ type location = string * int * int * int * int
 
 (**  *)
 type operator =
-    | Neg | Not
-    | Add | Sub | Mul | Div | Mod
-    | Eq | Ne | Lt | Le | Gt | Ge
-    | And | Or
+  | Neg | Not
+  | Add | Sub | Mul | Div | Mod
+  | Eq | Ne | Lt | Le | Gt | Ge
+  | And | Or
 
 (**  *)
 type const =
-    | BoolVal of bool
-    | IntVal of int
-    | FloatVal of float
+  | BoolVal of bool
+  | IntVal of int
+  | FloatVal of float
 
 (**  *)
 type ctype =
-    | Void | Bool | Int | Float | Array of ctype
-    | ArrayDims of ctype * node list
+  | Void | Bool | Int | Float | Array of ctype
+  | ArrayDims of ctype * node list
 
 (**  *)
 and annotation =
-    | Loc of location
-    | Depth of int
-    | Index of int
-    | Type of ctype
-    | LabelName of string
+  | Loc of location
+  | Depth of int
+  | Index of int
+  | Type of ctype
+  | LabelName of string
 
 (** Shorthand for annotation list, only to be used by {! Types.node} definitions
-    below. *)
+  below. *)
 and ann = annotation list
 
 (**  *)
 and node =
-    (* Global *)
-    | Program of node list * ann
-      (* list of declarations *)
-    | FunDec of ctype * string * node list * ann
-      (* ret_type, name, params *)
-    | FunDef of bool * ctype * string * node list * node * ann
-      (* export, ret_type, name, params, body *)
-    | GlobalDec of ctype * string * ann
-      (* type, name *)
-    | GlobalDef of bool * ctype * string * node option * ann
-      (* export, type, name, initialisation? *)
-    | Param of ctype * string * ann
-      (* type, name *)
-    | Dim of string * ann
-      (* name *)
-
-    | VarDecs of node list
-    | LocalFuns of node list
-
-    (* Statements *)
-    | VarDec of ctype * string * node option * ann
-      (* type, name, initialisation? *)
-    | Assign of string * node list option * node * ann
-      (* name, indices?, value *)
-    | For of string * node * node * node * node * ann
-      (* counter, start, stop, step, body *)
-    | Allocate of node * node list * ann
-      (* dec, dims  # name = __allocate(dims) *)
-    | Return of node * ann                   (* return <value>; *)
-    | Expr of node                           (* <expr>; *)
-    | Block of node list                     (* { <body> } *)
-    | If of node * node * ann                (* cond, body *)
-    | IfElse of node * node * node * ann     (* cond, true_body, false_body *)
-    | While of node * node * ann             (* cond, body *)
-    | DoWhile of node * node * ann           (* cond, body *)
-
-    (* Expressions *)
-    | Const of const * ann                     (* bool|int|float value *)
-    | ArrayConst of node list * ann            (* [<exprs>] *)
-    | Var of string * node list option * ann   (* <name> [<indices>]? *)
-    | Monop of operator * node * ann           (* op, operand *)
-    | Binop of operator * node * node * ann    (* op, left, right *)
-    | TypeCast of ctype * node * ann           (* (type) operand *)
-    | FunCall of string * node list * ann      (* name(args) *)
-    | Arg of node                              (* function argument *)
-
-    (* Additional types for convenience in traversals
-     * Mostly used to annotate existing nodes with information from declarations *)
-    | VarUse of node * node list option * ann  (* Same as Var, but with decl. *)
-    | FunUse of node * node list * ann         (* Same as FunCall, but with decl. *)
-    | VarLet of node * node list option * node * ann (* replacement for Assign *)
-    | ArrayScalar of node                      (* (Bool|Int|Float)Const *)
-    | ArrayInit of node * node list            (* Array(Scalar|Const), dimensions *)
-    | Cond of node * node * node * ann         (* cond, true_expr, false_expr *)
-    | DummyNode                                (* null node, pruned by traversals *)
+  (* Global *)
+  | Program of node list * ann
+    (* list of declarations *)
+  | FunDec of ctype * string * node list * ann
+    (* ret_type, name, params *)
+  | FunDef of bool * ctype * string * node list * node * ann
+    (* export, ret_type, name, params, body *)
+  | GlobalDec of ctype * string * ann
+    (* type, name *)
+  | GlobalDef of bool * ctype * string * node option * ann
+    (* export, type, name, initialisation? *)
+  | Param of ctype * string * ann
+    (* type, name *)
+  | Dim of string * ann
+    (* name *)
+
+  | VarDecs of node list
+  | LocalFuns of node list
+
+  (* Statements *)
+  | VarDec of ctype * string * node option * ann
+    (* type, name, initialisation? *)
+  | Assign of string * node list option * node * ann
+    (* name, indices?, value *)
+  | For of string * node * node * node * node * ann
+    (* counter, start, stop, step, body *)
+  | Allocate of node * node list * ann
+    (* dec, dims  # name = __allocate(dims) *)
+  | Return of node * ann                   (* return <value>; *)
+  | Expr of node                           (* <expr>; *)
+  | Block of node list                     (* { <body> } *)
+  | If of node * node * ann                (* cond, body *)
+  | IfElse of node * node * node * ann     (* cond, true_body, false_body *)
+  | While of node * node * ann             (* cond, body *)
+  | DoWhile of node * node * ann           (* cond, body *)
+
+  (* Expressions *)
+  | Const of const * ann                     (* bool|int|float value *)
+  | ArrayConst of node list * ann            (* [<exprs>] *)
+  | Var of string * node list option * ann   (* <name> [<indices>]? *)
+  | Monop of operator * node * ann           (* op, operand *)
+  | Binop of operator * node * node * ann    (* op, left, right *)
+  | TypeCast of ctype * node * ann           (* (type) operand *)
+  | FunCall of string * node list * ann      (* name(args) *)
+  | Arg of node                              (* function argument *)
+
+  (* Additional types for convenience in traversals
+   * Mostly used to annotate existing nodes with information from declarations *)
+  | VarUse of node * node list option * ann  (* Same as Var, but with decl. *)
+  | FunUse of node * node list * ann         (* Same as FunCall, but with decl. *)
+  | VarLet of node * node list option * node * ann (* replacement for Assign *)
+  | ArrayScalar of node                      (* (Bool|Int|Float)Const *)
+  | ArrayInit of node * node list            (* Array(Scalar|Const), dimensions *)
+  | Cond of node * node * node * ann         (* cond, true_expr, false_expr *)
+  | DummyNode                                (* null node, pruned by traversals *)
 
 type stack_scope = Glob | Local | Rel of int | Current
 type rtn_scope = ExternFun of int | LocalFun of int * string
 type instr =
-    | Comment of string                 (* # <comment> *)
-    | InlineComment of instr * string   (* <instr>  # <comment> *)
-    | Label of string                   (* <label>: *)
-
-    (* Directives *)
-    (* .export "<name>" <ret_type> [ <arg_type>; ... ] <label> *)
-    | Export of string * ctype * ctype list * string
-    (* .import "<name>" <ret_type> [ <arg_type>; ... ] *)
-    | Import of string * ctype * ctype list
-    (* .const <value> *)
-    | ConstDef of const
-    (* .global <type> *)
-    | Global of ctype
-
-    | Store of ctype * stack_scope * int (* [ifba]store[ gn] *)
-
-    | Load of ctype * stack_scope * int  (* [ifb]load[ gn] G *)
-    | LoadConst of ctype * int           (* [ifb]loadc C *)
-    | LoadImm of const                   (* [ifb]load_[01tf] <value> *)
-
-    (* Operators *)
-    | Op of operator * ctype             (* [ifb]() *)
-    | Convert of ctype * ctype           (* i2f|f2i *)
-    | Inc of int * int                   (* iinc L C *)
-    | Dec of int * int                   (* idec L C *)
-    | IncOne of int                      (* iinc_1 L *)
-    | DecOne of int                      (* idec_1 L *)
-
-    (* Control flow *)
-    | RtnInit of stack_scope
-    | RtnJmp of rtn_scope
-    | RtnEnter of int
-    | Ret of ctype
-    | Branch of bool * string
-    | Jump of string
-
-    (* Stack management *)
-    | Pop of ctype                       (* [ifb]pop *)
-
-    (* Arrays *)
-    | NewArray of ctype * int
-    | LoadArray of ctype
-    | StoreArray of ctype
-
-    | EmptyLine
-    | DummyInstr
+  | Comment of string                 (* # <comment> *)
+  | InlineComment of instr * string   (* <instr>  # <comment> *)
+  | Label of string                   (* <label>: *)
+
+  (* Directives *)
+  (* .export "<name>" <ret_type> [ <arg_type>; ... ] <label> *)
+  | Export of string * ctype * ctype list * string
+  (* .import "<name>" <ret_type> [ <arg_type>; ... ] *)
+  | Import of string * ctype * ctype list
+  (* .const <value> *)
+  | ConstDef of const
+  (* .global <type> *)
+  | Global of ctype
+
+  | Store of ctype * stack_scope * int (* [ifba]store[ gn] *)
+
+  | Load of ctype * stack_scope * int  (* [ifb]load[ gn] G *)
+  | LoadConst of ctype * int           (* [ifb]loadc C *)
+  | LoadImm of const                   (* [ifb]load_[01tf] <value> *)
+
+  (* Operators *)
+  | Op of operator * ctype             (* [ifb]() *)
+  | Convert of ctype * ctype           (* i2f|f2i *)
+  | Inc of int * int                   (* iinc L C *)
+  | Dec of int * int                   (* idec L C *)
+  | IncOne of int                      (* iinc_1 L *)
+  | DecOne of int                      (* idec_1 L *)
+
+  (* Control flow *)
+  | RtnInit of stack_scope
+  | RtnJmp of rtn_scope
+  | RtnEnter of int
+  | Ret of ctype
+  | Branch of bool * string
+  | Jump of string
+
+  (* Stack management *)
+  | Pop of ctype                       (* [ifb]pop *)
+
+  (* Arrays *)
+  | NewArray of ctype * int
+  | LoadArray of ctype
+  | StoreArray of ctype
+
+  | EmptyLine
+  | DummyInstr
 
 (* Intermediate representations between phases *)
 type intermediate =
-    | Empty
-    | FileContent of string * string
-    | Ast of node
-    | Assembly of instr list
+  | Empty
+  | FileContent of string * string
+  | Ast of node
+  | Assembly of instr list
 
 (** Container for command-line arguments. *)
 type args_record = {
-    mutable infile   : string option;
-    mutable outfile  : string option;
-    mutable verbose  : int;
-    mutable cpp      : bool;
-    mutable optimize : bool;
-    mutable endphase : string;
+  mutable infile   : string option;
+  mutable outfile  : string option;
+  mutable verbose  : int;
+  mutable cpp      : bool;
+  mutable optimize : bool;
+  mutable endphase : string;
 }
 
 (* Exceptions *)

util.ml

@@ -19,333 +19,333 @@ let prt_line = prerr_endline
 let prt_node node = prt_line (Stringify.node2str node)
 
 let log_plain_line verbosity line =
-    if args.verbose >= verbosity then prt_line line
+  if args.verbose >= verbosity then prt_line line
 
 let log_line verbosity line =
-    log_plain_line verbosity (repeat " " 13 ^ line)
+  log_plain_line verbosity (repeat " " 13 ^ line)
 
 let log_node verbosity node =
-    if args.verbose >= verbosity then prt_node node
+  if args.verbose >= verbosity then prt_node node
 
 (* Variable generation *)
 let var_counter = ref 0
 let fresh_var prefix =
-    var_counter := !var_counter + 1;
-    prefix ^ "$" ^ string_of_int !var_counter
+  var_counter := !var_counter + 1;
+  prefix ^ "$" ^ string_of_int !var_counter
 
 (* Constants are marked by a double $$ for recognition during constant
  * propagation *)
 let fresh_const prefix = fresh_var (prefix ^ "$")
 
 let loc_from_lexpos pstart pend =
-    let (fname, ystart, yend, xstart, xend) = (
-        pstart.pos_fname,
-        pstart.pos_lnum,
-        pend.pos_lnum,
-        (pstart.pos_cnum - pstart.pos_bol + 1),
-        (pend.pos_cnum - pend.pos_bol)
-    ) in
-    if ystart = yend && xend < xstart then
-        (fname, ystart, yend, xstart, xstart)
-    else
-        (fname, ystart, yend, xstart, xend)
+  let (fname, ystart, yend, xstart, xend) = begin
+    pstart.pos_fname,
+    pstart.pos_lnum,
+    pend.pos_lnum,
+    (pstart.pos_cnum - pstart.pos_bol + 1),
+    (pend.pos_cnum - pend.pos_bol)
+  end in
+  if ystart = yend && xend < xstart then
+    (fname, ystart, yend, xstart, xstart)
+  else
+    (fname, ystart, yend, xstart, xend)
 
 let rec flatten_blocks lst =
-    let flatten = flatten_blocks in
-    let rec trav = function
-        | Block body ->
-            Block (flatten body)
-        | FunDef (export, ret_type, name, params, body, ann) ->
-            FunDef (export, ret_type, name, flatten params, trav body, ann)
-        | If (cond, body, ann) ->
-            If (cond, trav body, ann)
-        | IfElse (cond, tbody, fbody, ann) ->
-            IfElse (cond, trav tbody, trav fbody, ann)
-        | While (cond, body, ann) ->
-            While (cond, trav body, ann)
-        | DoWhile (cond, body, ann) ->
-            DoWhile (cond, trav body, ann)
-        | For (counter, start, stop, step, body, ann) ->
-            For (counter, start, stop, step, trav body, ann)
-        | VarDecs decs ->
-            VarDecs (flatten decs)
-        | LocalFuns decs ->
-            LocalFuns (flatten decs)
-        | node -> node
-    in
-    match lst with
-    | []                -> []
-    | Block nodes :: tl -> flatten nodes @ (flatten tl)
-    | DummyNode :: tl   -> flatten tl
-    | hd :: tl          -> trav hd :: (flatten tl)
-
-(* Default tree transformation
- * (node -> node) -> node -> node *)
-let transform_children trav node =
-    let trav_all nodes = List.map trav nodes in
-    match node with
-    | Program (decls, ann) ->
-        Program (flatten_blocks (trav_all decls), ann)
-    | FunDec (ret_type, name, params, ann) ->
-        FunDec (ret_type, name, trav_all params, ann)
+  let flatten = flatten_blocks in
+  let rec trav = function
+    | Block body ->
+      Block (flatten body)
     | FunDef (export, ret_type, name, params, body, ann) ->
-        FunDef (export, ret_type, name, trav_all params, trav body, ann)
-    | GlobalDec (ctype, name, ann) ->
-        GlobalDec (ctype, name, ann)
-    | GlobalDef (export, ctype, name, Some init, ann) ->
-        GlobalDef (export, ctype, name, Some (trav init), ann)
-
-    | VarDecs decs ->
-        VarDecs (trav_all decs)
-    | LocalFuns funs ->
-        LocalFuns (trav_all funs)
-
-    | VarDec (ctype, name, Some init, ann) ->
-        VarDec (ctype, name, Some (trav init), ann)
-    | Assign (name, None, value, ann) ->
-        Assign (name, None, trav value, ann)
-    | Assign (name, Some dims, value, ann) ->
-        Assign (name, Some (trav_all dims), trav value, ann)
-    | VarLet (dec, None, value, ann) ->
-        VarLet (dec, None, trav value, ann)
-    | VarLet (dec, Some dims, value, ann) ->
-        VarLet (dec, Some (trav_all dims), trav value, ann)
-    | Return (value, ann) ->
-        Return (trav value, ann)
+      FunDef (export, ret_type, name, flatten params, trav body, ann)
     | If (cond, body, ann) ->
-        If (trav cond, trav body, ann)
-    | IfElse (cond, true_body, false_body, ann) ->
-        IfElse (trav cond, trav true_body, trav false_body, ann)
+      If (cond, trav body, ann)
+    | IfElse (cond, tbody, fbody, ann) ->
+      IfElse (cond, trav tbody, trav fbody, ann)
     | While (cond, body, ann) ->
-        While (trav cond, trav body, ann)
+      While (cond, trav body, ann)
     | DoWhile (cond, body, ann) ->
-        DoWhile (trav cond, trav body, ann)
+      DoWhile (cond, trav body, ann)
     | For (counter, start, stop, step, body, ann) ->
-        For (counter, trav start, trav stop, trav step, trav body, ann)
-    | Allocate (dec, dims, ann) ->
-        Allocate (dec, trav_all dims, ann)
-    | Expr value ->
-        Expr (trav value)
-    | Block (body) ->
-        Block (trav_all body)
-
-    | Monop (op, value, ann) ->
-        Monop (op, trav value, ann)
-    | Binop (op, left, right, ann) ->
-        Binop (op, trav left, trav right, ann)
-    | Cond (cond, true_expr, false_expr, ann) ->
-        Cond (trav cond, trav true_expr, trav false_expr, ann)
-    | TypeCast (ctype, value, ann) ->
-        TypeCast (ctype, trav value, ann)
-    | FunCall (name, args, ann) ->
-        FunCall (name, trav_all args, ann)
-    | Arg value ->
-        Arg (trav value)
-
-    | ArrayInit (value, dims) ->
-        ArrayInit (trav value, dims)
-    | ArrayScalar value ->
-        ArrayScalar (trav value)
-    | Var (dec, Some dims, ann) ->
-        Var (dec, Some (trav_all dims), ann)
-    | VarUse (dec, Some dims, ann) ->
-        VarUse (dec, Some (trav_all dims), ann)
-    | FunUse (dec, params, ann) ->
-        FunUse (dec, trav_all params, ann)
-
-    | _ -> node
+      For (counter, start, stop, step, trav body, ann)
+    | VarDecs decs ->
+      VarDecs (flatten decs)
+    | LocalFuns decs ->
+      LocalFuns (flatten decs)
+    | node -> node
+  in
+  match lst with
+  | []                -> []
+  | Block nodes :: tl -> flatten nodes @ (flatten tl)
+  | DummyNode :: tl   -> flatten tl
+  | hd :: tl          -> trav hd :: (flatten tl)
+
+(* Default tree transformation
+ * (node -> node) -> node -> node *)
+let transform_children trav node =
+  let trav_all nodes = List.map trav nodes in
+  match node with
+  | Program (decls, ann) ->
+    Program (flatten_blocks (trav_all decls), ann)
+  | FunDec (ret_type, name, params, ann) ->
+    FunDec (ret_type, name, trav_all params, ann)
+  | FunDef (export, ret_type, name, params, body, ann) ->
+    FunDef (export, ret_type, name, trav_all params, trav body, ann)
+  | GlobalDec (ctype, name, ann) ->
+    GlobalDec (ctype, name, ann)
+  | GlobalDef (export, ctype, name, Some init, ann) ->
+    GlobalDef (export, ctype, name, Some (trav init), ann)
+
+  | VarDecs decs ->
+    VarDecs (trav_all decs)
+  | LocalFuns funs ->
+    LocalFuns (trav_all funs)
+
+  | VarDec (ctype, name, Some init, ann) ->
+    VarDec (ctype, name, Some (trav init), ann)
+  | Assign (name, None, value, ann) ->
+    Assign (name, None, trav value, ann)
+  | Assign (name, Some dims, value, ann) ->
+    Assign (name, Some (trav_all dims), trav value, ann)
+  | VarLet (dec, None, value, ann) ->
+    VarLet (dec, None, trav value, ann)
+  | VarLet (dec, Some dims, value, ann) ->
+    VarLet (dec, Some (trav_all dims), trav value, ann)
+  | Return (value, ann) ->
+    Return (trav value, ann)
+  | If (cond, body, ann) ->
+    If (trav cond, trav body, ann)
+  | IfElse (cond, true_body, false_body, ann) ->
+    IfElse (trav cond, trav true_body, trav false_body, ann)
+  | While (cond, body, ann) ->
+    While (trav cond, trav body, ann)
+  | DoWhile (cond, body, ann) ->
+    DoWhile (trav cond, trav body, ann)
+  | For (counter, start, stop, step, body, ann) ->
+    For (counter, trav start, trav stop, trav step, trav body, ann)
+  | Allocate (dec, dims, ann) ->
+    Allocate (dec, trav_all dims, ann)
+  | Expr value ->
+    Expr (trav value)
+  | Block (body) ->
+    Block (trav_all body)
+
+  | Monop (op, value, ann) ->
+    Monop (op, trav value, ann)
+  | Binop (op, left, right, ann) ->
+    Binop (op, trav left, trav right, ann)
+  | Cond (cond, true_expr, false_expr, ann) ->
+    Cond (trav cond, trav true_expr, trav false_expr, ann)
+  | TypeCast (ctype, value, ann) ->
+    TypeCast (ctype, trav value, ann)
+  | FunCall (name, args, ann) ->
+    FunCall (name, trav_all args, ann)
+  | Arg value ->
+    Arg (trav value)
+
+  | ArrayInit (value, dims) ->
+    ArrayInit (trav value, dims)
+  | ArrayScalar value ->
+    ArrayScalar (trav value)
+  | Var (dec, Some dims, ann) ->
+    Var (dec, Some (trav_all dims), ann)
+  | VarUse (dec, Some dims, ann) ->
+    VarUse (dec, Some (trav_all dims), ann)
+  | FunUse (dec, params, ann) ->
+    FunUse (dec, trav_all params, ann)
+
+  | _ -> node
 
 let annotate a = function
-    | Program (decls, ann) ->
-        Program (decls, a :: ann)
-    | FunDec (ret_type, name, params, ann) ->
-        FunDec (ret_type, name, params, a :: ann)
-    | FunDef (export, ret_type, name, params, body, ann) ->
-        FunDef (export, ret_type, name, params, body, a :: ann)
-    | GlobalDec (ctype, name, ann) ->
-        GlobalDec (ctype, name, a :: ann)
-    | GlobalDef (export, ctype, name, init, ann) ->
-        GlobalDef (export, ctype, name, init, a :: ann)
-    | VarDec (ctype, name, init, ann) ->
-        VarDec (ctype, name, init, a :: ann)
-    | Assign (name, dims, value, ann) ->
-        Assign (name, dims, value, a :: ann)
-    | VarLet (dec, dims, value, ann) ->
-        VarLet (dec, dims, value, a :: ann)
-    | Return (value, ann) ->
-        Return (value, a :: ann)
-    | If (cond, body, ann) ->
-        If (cond, body, a :: ann)
-    | IfElse (cond, true_body, false_body, ann) ->
-        IfElse (cond, true_body, false_body, a :: ann)
-    | While (cond, body, ann) ->
-        While (cond, body, a :: ann)
-    | DoWhile (cond, body, ann) ->
-        DoWhile (cond, body, a :: ann)
-    | For (counter, start, stop, step, body, ann) ->
-        For (counter, start, stop, step, body, a :: ann)
-    | Allocate (dec, dims, ann) ->
-        Allocate (dec, dims, a :: ann)
-    | Monop (op, value, ann) ->
-        Monop (op, value, a :: ann)
-    | Binop (op, left, right, ann) ->
-        Binop (op, left, right, a :: ann)
-    | Cond (cond, true_expr, false_expr, ann) ->
-        Cond (cond, true_expr, false_expr, a :: ann)
-    | TypeCast (ctype, value, ann) ->
-        TypeCast (ctype, value, a :: ann)
-    | FunCall (name, args, ann) ->
-        FunCall (name, args, a :: ann)
-    | Arg value ->
-        Arg (value)
-    | Var (dec, dims, ann) ->
-        Var (dec, dims, a :: ann)
-    | VarUse (dec, dims, ann) ->
-        VarUse (dec, dims, a :: ann)
-    | FunUse (dec, params, ann) ->
-        FunUse (dec, params, a :: ann)
-    | Const (BoolVal value, ann) ->
-        Const (BoolVal value, a :: ann)
-    | Const (IntVal value, ann) ->
-        Const (IntVal value, a :: ann)
-    | Const (FloatVal value, ann) ->
-        Const (FloatVal value, a :: ann)
-    | ArrayConst (value, ann) ->
-        ArrayConst (value, a :: ann)
-    | Param (ctype, name, ann) ->
-        Param (ctype, name, a :: ann)
-    | Dim (name, ann) ->
-        Dim (name, a :: ann)
-
-    | _ -> raise InvalidNode
+  | Program (decls, ann) ->
+    Program (decls, a :: ann)
+  | FunDec (ret_type, name, params, ann) ->
+    FunDec (ret_type, name, params, a :: ann)
+  | FunDef (export, ret_type, name, params, body, ann) ->
+    FunDef (export, ret_type, name, params, body, a :: ann)
+  | GlobalDec (ctype, name, ann) ->
+    GlobalDec (ctype, name, a :: ann)
+  | GlobalDef (export, ctype, name, init, ann) ->
+    GlobalDef (export, ctype, name, init, a :: ann)
+  | VarDec (ctype, name, init, ann) ->
+    VarDec (ctype, name, init, a :: ann)
+  | Assign (name, dims, value, ann) ->
+    Assign (name, dims, value, a :: ann)
+  | VarLet (dec, dims, value, ann) ->
+    VarLet (dec, dims, value, a :: ann)
+  | Return (value, ann) ->
+    Return (value, a :: ann)
+  | If (cond, body, ann) ->
+    If (cond, body, a :: ann)
+  | IfElse (cond, true_body, false_body, ann) ->
+    IfElse (cond, true_body, false_body, a :: ann)
+  | While (cond, body, ann) ->
+    While (cond, body, a :: ann)
+  | DoWhile (cond, body, ann) ->
+    DoWhile (cond, body, a :: ann)
+  | For (counter, start, stop, step, body, ann) ->
+    For (counter, start, stop, step, body, a :: ann)
+  | Allocate (dec, dims, ann) ->
+    Allocate (dec, dims, a :: ann)
+  | Monop (op, value, ann) ->
+    Monop (op, value, a :: ann)
+  | Binop (op, left, right, ann) ->
+    Binop (op, left, right, a :: ann)
+  | Cond (cond, true_expr, false_expr, ann) ->
+    Cond (cond, true_expr, false_expr, a :: ann)
+  | TypeCast (ctype, value, ann) ->
+    TypeCast (ctype, value, a :: ann)
+  | FunCall (name, args, ann) ->
+    FunCall (name, args, a :: ann)
+  | Arg value ->
+    Arg (value)
+  | Var (dec, dims, ann) ->
+    Var (dec, dims, a :: ann)
+  | VarUse (dec, dims, ann) ->
+    VarUse (dec, dims, a :: ann)
+  | FunUse (dec, params, ann) ->
+    FunUse (dec, params, a :: ann)
+  | Const (BoolVal value, ann) ->
+    Const (BoolVal value, a :: ann)
+  | Const (IntVal value, ann) ->
+    Const (IntVal value, a :: ann)
+  | Const (FloatVal value, ann) ->
+    Const (FloatVal value, a :: ann)
+  | ArrayConst (value, ann) ->
+    ArrayConst (value, a :: ann)
+  | Param (ctype, name, ann) ->
+    Param (ctype, name, a :: ann)
+  | Dim (name, ann) ->
+    Dim (name, a :: ann)
+
+  | _ -> raise InvalidNode
 
 let rec annof = function
-    | Program (_, ann)
-    | Param (_, _, ann)
-    | Dim (_, ann)
-    | FunDec (_, _, _, ann)
-    | FunDef (_, _, _, _, _, ann)
-    | GlobalDec (_, _, ann)
-    | GlobalDef (_, _, _, _, ann)
-    | VarDec (_, _, _, ann)
-    | Assign (_, _, _, ann)
-    | VarLet (_, _, _, ann)
-    | Return (_, ann)
-    | If (_, _, ann)
-    | IfElse (_, _, _, ann)
-    | While (_, _, ann)
-    | DoWhile (_, _, ann)
-    | For (_, _, _, _, _, ann)
-    | Allocate (_, _, ann)
-    | Const (BoolVal _, ann)
-    | Const (IntVal _, ann)
-    | Const (FloatVal _, ann)
-    | ArrayConst (_, ann)
-    | Var (_, _, ann)
-    | Monop (_, _, ann)
-    | Binop (_, _, _, ann)
-    | Cond (_, _, _, ann)
-    | TypeCast (_, _, ann)
-    | VarUse (_, _, ann)
-    | FunUse (_, _, ann)
-    | FunCall (_, _, ann) -> ann
-
-    | ArrayInit (value, _)
-    | ArrayScalar value
-    | Expr value
-    | Arg value -> annof value
-
-    | _ -> raise InvalidNode
+  | Program (_, ann)
+  | Param (_, _, ann)
+  | Dim (_, ann)
+  | FunDec (_, _, _, ann)
+  | FunDef (_, _, _, _, _, ann)
+  | GlobalDec (_, _, ann)
+  | GlobalDef (_, _, _, _, ann)
+  | VarDec (_, _, _, ann)
+  | Assign (_, _, _, ann)
+  | VarLet (_, _, _, ann)
+  | Return (_, ann)
+  | If (_, _, ann)
+  | IfElse (_, _, _, ann)
+  | While (_, _, ann)
+  | DoWhile (_, _, ann)
+  | For (_, _, _, _, _, ann)
+  | Allocate (_, _, ann)
+  | Const (BoolVal _, ann)
+  | Const (IntVal _, ann)
+  | Const (FloatVal _, ann)
+  | ArrayConst (_, ann)
+  | Var (_, _, ann)
+  | Monop (_, _, ann)
+  | Binop (_, _, _, ann)
+  | Cond (_, _, _, ann)
+  | TypeCast (_, _, ann)
+  | VarUse (_, _, ann)
+  | FunUse (_, _, ann)
+  | FunCall (_, _, ann) -> ann
+
+  | ArrayInit (value, _)
+  | ArrayScalar value
+  | Expr value
+  | Arg value -> annof value
+
+  | _ -> raise InvalidNode
 
 let locof node =
-     let rec trav = function
-         | []           -> noloc
-         | Loc loc :: _ -> loc
-         | _ :: tl      -> trav tl
-     in trav (annof node)
+  let rec trav = function
+    | []           -> noloc
+    | Loc loc :: _ -> loc
+    | _ :: tl      -> trav tl
+  in trav (annof node)
 
 let depthof node =
-     let rec trav = function
-         | [] ->
-            prerr_string "cannot get depth for: ";
-            prt_node node;
-            raise InvalidNode
-         | Depth depth :: _ -> depth
-         | _ :: tl          -> trav tl
-     in trav (annof node)
+  let rec trav = function
+    | [] ->
+      prerr_string "cannot get depth for: ";
+      prt_node node;
+      raise InvalidNode
+    | Depth depth :: _ -> depth
+    | _ :: tl          -> trav tl
+  in trav (annof node)
 
 let indexof node =
-     let rec trav = function
-         | [] ->
-            prerr_string "cannot get index for: ";
-            prt_node node;
-            raise InvalidNode
-         | Index index :: _ -> index
-         | _ :: tl          -> trav tl
-     in trav (annof node)
+  let rec trav = function
+    | [] ->
+      prerr_string "cannot get index for: ";
+      prt_node node;
+      raise InvalidNode
+    | Index index :: _ -> index
+    | _ :: tl          -> trav tl
+  in trav (annof node)
 
 let typeof = function
-    (* Some nodes have their type as property *)
-    | VarDec (ctype, _, _, _)
-    | Param (ctype, _, _)
-    | FunDec (ctype, _, _, _)
-    | FunDef (_, ctype, _, _, _, _)
-    | GlobalDec (ctype, _, _)
-    | GlobalDef (_, ctype, _, _, _)
-    | TypeCast (ctype, _, _)
-        -> ctype
-
-    (* Dim nodes are always type Int, and are copied by context analysis before
-     * they are annotated with Type Int, so this match is necessary *)
-    | Dim _ -> Int
-
-    (* Other nodes must be annotated during typechecking *)
-    | node ->
-        let rec trav = function
-         | [] ->
-            prerr_string "cannot get type for: ";
-            prt_node node;
-            raise InvalidNode
-            | Type t :: _ -> t
-            | _ :: tl     -> trav tl
-        in trav (annof node)
+  (* Some nodes have their type as property *)
+  | VarDec (ctype, _, _, _)
+  | Param (ctype, _, _)
+  | FunDec (ctype, _, _, _)
+  | FunDef (_, ctype, _, _, _, _)
+  | GlobalDec (ctype, _, _)
+  | GlobalDef (_, ctype, _, _, _)
+  | TypeCast (ctype, _, _)
+    -> ctype
+
+  (* Dim nodes are always type Int, and are copied by context analysis before
+   * they are annotated with Type Int, so this match is necessary *)
+  | Dim _ -> Int
+
+  (* Other nodes must be annotated during typechecking *)
+  | node ->
+    let rec trav = function
+      | [] ->
+        prerr_string "cannot get type for: ";
+        prt_node node;
+        raise InvalidNode
+      | Type t :: _ -> t
+      | _ :: tl     -> trav tl
+    in trav (annof node)
 
 let labelof node =
-     let rec trav = function
-         | [] ->
-            prerr_string "cannot get label for: ";
-            prt_node node;
-            raise InvalidNode
-         | LabelName label :: _ -> label
-         | _ :: tl              -> trav tl
-     in trav (annof node)
+  let rec trav = function
+    | [] ->
+      prerr_string "cannot get label for: ";
+      prt_node node;
+      raise InvalidNode
+    | LabelName label :: _ -> label
+    | _ :: tl              -> trav tl
+  in trav (annof node)
 
 let const_type = function
-    | BoolVal _  -> Bool
-    | IntVal _   -> Int
-    | FloatVal _ -> Float
+  | BoolVal _  -> Bool
+  | IntVal _   -> Int
+  | FloatVal _ -> Float
 
 (*
 let get_line str n =
-    let rec find_start from = function
-        | n when n < 1 -> raise (Invalid_argument "n")
-        | 1 -> from
-        | n -> find_start ((String.index_from str from '\n') + 1) (n - 1)
-    in
-    let linestart = find_start 0 n in
-    let len = String.length str in
-    let lineend =
-        try String.index_from str linestart '\n'
-        with Not_found -> len
-    in
-    String.sub str linestart (lineend - linestart)
+  let rec find_start from = function
+    | n when n < 1 -> raise (Invalid_argument "n")
+    | 1 -> from
+    | n -> find_start ((String.index_from str from '\n') + 1) (n - 1)
+  in
+  let linestart = find_start 0 n in
+  let len = String.length str in
+  let lineend =
+    try String.index_from str linestart '\n'
+    with Not_found -> len
+  in
+  String.sub str linestart (lineend - linestart)
 *)
 
 let count_tabs str upto =
-    let rec count n = function
-        | 0 -> n
-        | i -> count (if String.get str (i - 1) = '\t' then n + 1 else n) (i - 1)
-    in count 0 upto
+  let rec count n = function
+    | 0 -> n
+    | i -> count (if String.get str (i - 1) = '\t' then n + 1 else n) (i - 1)
+  in count 0 upto
 
 let tabwidth = 4
 
@@ -354,99 +354,99 @@ let retab str = global_replace (regexp "\t") (repeat " " tabwidth) str
 let indent n = repeat (repeat " " (tabwidth - 1)) n
 
 let prerr_loc (fname, ystart, yend, xstart, xend) =
-    let file = open_in fname in
-
-    (* skip lines until the first matched line *)
-    for i = 1 to ystart - 1 do let _ = input_line file in () done;
-
-    (* for each line in `loc`, print the source line with an underline *)
-    for l = ystart to yend do
-        let line = input_line file in
-        let linewidth = String.length line in
-        let left = if l = ystart then xstart else 1 in
-        let right = if l = yend then xend else linewidth in
-        if linewidth > 0 then (
-            prerr_endline (retab line);
-            prerr_string (indent (count_tabs line right));
-            for i = 1 to left - 1 do prerr_char ' ' done;
-            for i = left to right do prerr_char '^' done;
-            prerr_endline "";
-        )
-    done;
-    ()
+  let file = open_in fname in
+
+  (* skip lines until the first matched line *)
+  for i = 1 to ystart - 1 do let _ = input_line file in () done;
+
+  (* for each line in `loc`, print the source line with an underline *)
+  for l = ystart to yend do
+    let line = input_line file in
+    let linewidth = String.length line in
+    let left = if l = ystart then xstart else 1 in
+    let right = if l = yend then xend else linewidth in
+    if linewidth > 0 then begin
+      prerr_endline (retab line);
+      prerr_string (indent (count_tabs line right));
+      for i = 1 to left - 1 do prerr_char ' ' done;
+      for i = left to right do prerr_char '^' done;
+      prerr_endline "";
+    end
+  done;
+  ()
 
 let prerr_loc_msg loc msg =
-    if args.verbose >= 1 then (
-        let (fname, ystart, yend, xstart, xend) = loc in
-        if loc != noloc then (
-            let line_s = if yend != ystart
-                then sprintf "lines %d-%d" ystart yend
-                else sprintf "line %d" ystart
-            in
-            let char_s = if xend != xstart || yend != ystart
-                then sprintf "characters %d-%d" xstart xend
-                else sprintf "character %d" xstart
-            in
-            eprintf "File \"%s\", %s, %s:\n" fname line_s char_s;
-        );
-        eprintf "%s\n" msg;
-
-        if args.verbose >= 1 && loc != noloc then
-            try prerr_loc loc
-            with Sys_error _ -> ()
-    );
-    ()
+  if args.verbose >= 1 then begin
+    let (fname, ystart, yend, xstart, xend) = loc in
+    if loc != noloc then begin
+      let line_s = if yend != ystart
+        then sprintf "lines %d-%d" ystart yend
+        else sprintf "line %d" ystart
+      in
+      let char_s = if xend != xstart || yend != ystart
+        then sprintf "characters %d-%d" xstart xend
+        else sprintf "character %d" xstart
+      in
+      eprintf "File \"%s\", %s, %s:\n" fname line_s char_s;
+    end;
+    eprintf "%s\n" msg;
+
+    if args.verbose >= 1 && loc != noloc then
+        try prerr_loc loc
+        with Sys_error _ -> ()
+  end;
+  ()
 
 let block_body = function
-    | Block nodes -> nodes
-    | _ -> raise InvalidNode
+  | Block nodes -> nodes
+  | _ -> raise InvalidNode
 
 let basetypeof node = match typeof node with
-    | ArrayDims (ctype, _)
-    | Array ctype
-    | ctype -> ctype
+  | ArrayDims (ctype, _)
+  | Array ctype
+  | ctype -> ctype
 
 let nameof = function
-    | GlobalDec (_, name, _)
-    | GlobalDef (_, _, name, _, _)
-    | FunDec (_, name, _, _)
-    | FunDef (_, _, name, _, _, _)
-    | VarDec (_, name, _, _)
-    | Param (_, name, _)
-    | Dim (name, _) -> name
-    | _ -> raise InvalidNode
+  | GlobalDec (_, name, _)
+  | GlobalDef (_, _, name, _, _)
+  | FunDec (_, name, _, _)
+  | FunDef (_, _, name, _, _, _)
+  | VarDec (_, name, _, _)
+  | Param (_, name, _)
+  | Dim (name, _) -> name
+  | _ -> raise InvalidNode
 
 let optmap f = function
-    | None -> None
-    | Some lst -> Some (List.map f lst)
+  | None -> None
+  | Some lst -> Some (List.map f lst)
 
 let optmapl f = function
-    | None -> []
-    | Some lst -> List.map f lst
+  | None -> []
+  | Some lst -> List.map f lst
 
 let mapi f lst =
-    let rec trav i = function
-        | [] -> []
-        | hd :: tl -> f i hd :: (trav (i + 1) tl)
-    in trav 0 lst
+  let rec trav i = function
+    | [] -> []
+    | hd :: tl -> f i hd :: (trav (i + 1) tl)
+  in trav 0 lst
 
 (** Constants that are *)
 let immediate_consts = [
-    BoolVal true;
-    BoolVal false;
-    IntVal (-1);
-    IntVal 0;
-    IntVal 1;
-    FloatVal 0.0;
-    FloatVal 1.0;
+  BoolVal true;
+  BoolVal false;
+  IntVal (-1);
+  IntVal 0;
+  IntVal 1;
+  FloatVal 0.0;
+  FloatVal 1.0;
 ]
 
 let is_immediate_const const =
-    if args.optimize then List.mem const immediate_consts else false
+  if args.optimize then List.mem const immediate_consts else false
 
 let is_array node = match typeof node with
-    | ArrayDims _ | Array _ -> true
-    | _ -> false
+  | ArrayDims _ | Array _ -> true
+  | _ -> false
 
 let node_warning node msg =
-    prerr_loc_msg (locof node) ("Warning: " ^ msg)
+  prerr_loc_msg (locof node) ("Warning: " ^ msg)