ホーム エクスプローラ ヘルプ
サインイン
taddeus
/
civicaml
1
0
フォーク 0
ファイル 課題 0 プルリクエスト 0 Wiki
ソースを参照

Changed the way nodes are annotated to something more moldable, in the process changing/bugfixing pretty much everything

Taddeus Kroes 12 年 前
親
d9836cd72f
コミット
838389b893
18 ファイル変更、886 行追加、573 行削除
分割表示 差分情報を表示
  1. 2 2
      Makefile
  2. 91 47
      ast.ml
  3. 10 10
      main.ml
  4. 4 4
      parser.mly
  5. 64 2
      phases/assemble.ml
  6. 10 10
      phases/bool_op.ml
  7. 94 82
      phases/constant_propagation.ml
  8. 43 68
      phases/context_analysis.ml
  9. 122 63
      phases/desug.ml
  10. 33 20
      phases/dim_reduce.ml
  11. 6 10
      phases/expand_dims.ml
  12. 38 47
      phases/extern_vars.ml
  13. 89 0
      phases/print.ml
  14. 111 102
      phases/typecheck.ml
  15. 37 23
      stringify.ml
  16. 12 0
      test/old/array_dim.cvc
  17. 100 69
      util.ml
  18. 20 14
      util.mli

+ 2 - 2
Makefile
ファイルの表示 

@@ -1,6 +1,6 @@
 
 RESULT := civicc
 
-PHASES := load parse print desug constant_propagation context_analysis \
 
-	expand_dims typecheck dim_reduce bool_op extern_vars assemble
 
+PHASES := load parse print desug context_analysis expand_dims typecheck \
 
+	dim_reduce bool_op extern_vars constant_propagation
 
 SOURCES := ast.ml stringify.mli stringify.ml util.mli util.ml lexer.mll \
 
 	parser.mly $(patsubst %,phases/%.ml,$(PHASES)) main.ml
 
 PRE_TARGETS := ast.cmi ast.o stringify.cmi stringify.o util.cmi util.o

+ 91 - 47
ast.ml
ファイルの表示 

@@ -1,4 +1,4 @@
 
-type loc = string * int * int * int * int
 
+type location = string * int * int * int * int
 
 let noloc = ("", 0, 0, 0, 0)
 
 
 type operator = Neg | Not
 
@@ -7,55 +7,99 @@ type operator = Neg | Not
 
               | And | Or
 
 type ctype = Void | Bool | Int | Float
 
            | Array of ctype * node list
 
-           | ArrayDepth of ctype * int
 
+           | ArrayDepth of ctype * int  (* TODO: remove? *)
 
+           | FlatArray of ctype
 
+and annotation =
 
+    | Loc of location
 
+    | Depth of int
 
+    | Type of ctype
 
+and ann = annotation list
 
 and node =
 
-    (* global *)
 
-    | Program of node list * loc
 
-    | Param of ctype * string * loc
 
-    | Dim of string * loc
 
-    | FunDec of ctype * string * node list * loc
 
-    | FunDef of bool * ctype * string * node list * node * loc
 
-    | GlobalDec of ctype * string * loc
 
-    | GlobalDef of bool * ctype * string * node option * loc
 
+    (* 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
 
+      (* dimension name in array Param *)
 
 
-    (* statements *)
 
-    | VarDec of ctype * string * node option * loc
 
-    | Assign of string * node list option * node * loc
 
-    | Return of node * loc
 
-    | If of node * node * loc
 
-    | IfElse of node * node * node * loc
 
-    | While of node * node * loc
 
-    | DoWhile of node * node * loc
 
-    | For of string * node * node * node * node * loc
 
-    | Allocate of string * node list * node * loc
 
-    | Expr of node
 
-    | Block 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 string * node list * node * ann
 
+      (* name, dims, decl  # 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 *)
 
-    | BoolConst of bool * loc
 
-    | IntConst of int * loc
 
-    | FloatConst of float * loc
 
-    | ArrayConst of node list * loc
 
-    | Var of string * loc
 
-    | Deref of string * node list * loc
 
-    | Monop of operator * node * loc
 
-    | Binop of operator * node * node * loc
 
-    | TypeCast of ctype * node * loc
 
-    | FunCall of string * node list * loc
 
-    | Arg of node
 
+    (* Expressions *)
 
+    | BoolConst of bool * ann                  (* bool value *)
 
+    | IntConst of int * ann                    (* int value *)
 
+    | FloatConst of float * ann                (* 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 *)
 
-    | ArrayScalar of node
 
-    | ArrayInit of node * ctype
 
-    | Cond of node * node * node * loc
 
-    | VarLet of node * ctype * int
 
-    | VarUse of node * ctype * int
 
-    | FunUse of node * node * int
 
-    | DimDec of node
 
-    | Type of node * ctype
 
-    | DummyNode
 
+    (* 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 * ctype                (* Array(Scalar|Const) * dimensions *)
 
+    | Cond of node * node * node * ann         (* cond, true_expr, false_expr *)
 
+    | DummyNode                                (* null node, pruned by traversals *)
 
 
-(* container for command-line arguments *)
 
+type instr =
 
+    (* # <comment> *)
 
+    | Comment of string
 
+    (* <label>: *)
 
+    | Label of string
 
+
 
+    (* 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> *)
 
+    | Const of node
 
+    (* .global <type> *)
 
+    | Global of ctype
 
+
 
+    (* [ifb]loadg G *)
 
+    | LoadGlob of node
 
+    (* [ifb]loadc C *)
 
+    | LoadConst of ctype * int
 
+    (* [ifb]load_[01tf] <value> *)
 
+    | LoadImm of node
 
+
 
+    (* Instructions *)
 
+    (* i(inc|dec) L C *)
 
+    | Inc of int * int
 
+    (* i(inc|dec)_1 C *)
 
+    | IncOne of int
 
+
 
+(* Container for command-line arguments *)
 
 type args_record = {
 
     mutable infile  : string option;
 
     mutable outfile : string option;
 
@@ -82,10 +126,10 @@ type intermediate =
 
     | Empty
 
     | FileContent of string * string
 
     | Ast of node
 
-    | Assembly of string list list
 
+    | Assembly of instr list
 
 
 (* exceptions *)
 
-exception LocError of loc * string
 
+exception LocError of location * string
 
 exception NodeError of node * string
 
 exception CompileError of string
 
 exception EmptyError

+ 10 - 10
main.ml
ファイルの表示 

@@ -12,25 +12,25 @@ let compile () =
 
     in
 
     run_phases Empty [
 
         Load.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Parse.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Desug.phase;
 
-        (*Print.phase;*)
 
-        Constant_propagation.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Context_analysis.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Typecheck.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Expand_dims.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Bool_op.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Dim_reduce.phase;
 
-        (*Print.phase;*)
 
+        Print.phase;
 
         Extern_vars.phase;
 
         Print.phase;
 
+        Constant_propagation.phase;
 
+        Print.phase;
 
         (*
 
         Assemble.phase;
 
         Print.phase;

+ 4 - 4
parser.mly
ファイルの表示 

@@ -9,7 +9,7 @@
 
     open Lexing
 
     open Ast
 
 
-    let loc = Util.loc_from_lexpos
 
+    let loc start stop = [Loc (Util.loc_from_lexpos start stop)]
 
 
     let rec make_dims dimloc = function
 
         | [] -> []
 
@@ -177,7 +177,7 @@ statement:
 
     | FOR; LPAREN; INT; cnt=ID; ASSIGN; start=expr; COMMA; stop=expr; RPAREN;
 
       body=block
 
     { let loc = loc $startpos(cnt) $endpos(cnt) in
 
-      For (cnt, start, stop, IntConst (1, noloc), Block body, loc) }
 
+        For (cnt, start, stop, IntConst (1, []), Block body, loc) }
 
 
     | FOR; LPAREN; INT; cnt=ID; ASSIGN; start=expr; COMMA; stop=expr; COMMA;
 
       step=expr; RPAREN; body=block
 
@@ -193,7 +193,7 @@ expr:
 
     { FunCall (name, make_args args, loc $startpos $endpos) }
 
 
     | LPAREN; expr; RPAREN              { $2 }
 
-    | ID                                { Var ($1, loc $startpos $endpos) }
 
+    | ID                                { Var ($1, None, loc $startpos $endpos) }
 
     | l=expr; op=binop; r=expr          { Binop (op, l, r, loc $startpos $endpos) }
 
     | SUB; expr                         { Monop (Neg, $2, loc $startpos $endpos) }    %prec NEG
 
     | NOT; expr                         { Monop (Not, $2, loc $startpos $endpos) }
 
@@ -201,7 +201,7 @@ expr:
 
     | FLOAT_CONST                       { FloatConst ($1, loc $startpos $endpos) }
 
     | INT_CONST                         { IntConst ($1, loc $startpos $endpos) }
 
     | BOOL_CONST                        { BoolConst ($1, loc $startpos $endpos) }
 
-    | ID; array_const                   { Deref ($1, $2, loc $startpos $endpos) }
 
+    | ID; array_const                   { Var ($1, Some $2, loc $startpos $endpos) }
 
     | array_const                       { ArrayConst ($1, loc $startpos $endpos) }
 
 
 %inline binop:

+ 64 - 2
phases/assemble.ml
ファイルの表示 

@@ -1,8 +1,70 @@
 
 open Ast
 
 open Util
 
 
-let assemble = function
 
-    | node -> [[""]]
 
+let store ctype = function
 
+    | 0 -> StoreGlob ()
 
+
 
+let assemble program =
 
+    let labcounter = ref 0 in
 
+    let genlabel suffix =
 
+        labcounter := !labcounter + 1;
 
+        string_of_int !labcounter ^ "_" ^ suffix
 
+    in
 
+
 
+    let consts = ref [] in
 
+    let const_index const =
 
+        let rec trav_consts i = function
 
+            | [] -> consts := !consts @ [const]; i
 
+            | hd :: _ when hd = const -> i
 
+            | hd :: tl -> trav_consts (i + 1) tl
 
+        in
 
+        trav_consts 0 !consts
 
+    in
 
+
 
+    let rec trav node =
 
+        let rec trav_all = function
 
+            | [] -> []
 
+            | hd :: tl -> trav hd @ (trav_all tl)
 
+        in
 
+        match node with
 
+        | Program (decls, _) ->
 
+            trav_all decls
 
+
 
+        | FunDec (ret_type, name, params, _) ->
 
+            [Import (name, ret_type, List.map ctypeof params)]
 
+
 
+        | FunDef (export, ret_type, name, params, body, _) ->
 
+            let label = name in
 
+            let param_types = List.map ctypeof params in
 
+            let export = match export with
 
+                | false -> []
 
+                | true -> [Export (name, ret_type, param_types, label)]
 
+            in
 
+            Comment ("function \"" ^ name ^ "\":") ::
 
+            (export @ (Label label :: (trav body)))
 
+
 
+        | VarDec (ctype, name, None, _) ->
 
+            []
 
+
 
+        | VarLet (Assign (name, None, value, _), ctype, depth) ->
 
+            [store ctype depth]
 
+        (*
 
+        | VarLet (Assign (name, Some indices, value, _), ctype, depth) ->
 
+            [store deoth]
 
+        *)
 
+
 
+        | BoolConst _ ->
 
+            [LoadImm node]
 
+
 
+        | IntConst _ | FloatConst _ ->
 
+            [LoadConst (ctypeof node, const_index node)]
 
+
 
+        | _ -> []
 
+        (*| _ -> raise InvalidNode*)
 
+    in
 
+    let instrs = trav program in
 
+    let const_defs = List.map (fun c -> Const c) !consts in
 
+    const_defs @ instrs
 
 
 let rec phase input =
 
     prerr_endline "- Assembly";

+ 10 - 10
phases/bool_op.ml
ファイルの表示 

@@ -19,11 +19,11 @@
 
 open Ast
 
 open Util
 
 
-let cast ctype node = Type (TypeCast (ctype, node, noloc), ctype)
 
+let cast ctype node = TypeCast (ctype, node, [Type ctype])
 
 
-let boolconst  value = Type (BoolConst  (value, noloc), Bool)
 
-let intconst   value = Type (IntConst   (value, noloc), Int)
 
-let floatconst value = Type (FloatConst (value, noloc), Float)
 
+let boolconst  value = BoolConst  (value, [Type Bool])
 
+let intconst   value = IntConst   (value, [Type Int])
 
+let floatconst value = FloatConst (value, [Type Float])
 
 
 let rec trav_binop = function
 
     | ((Eq | Ne) as op, left, right, loc) ->
 
@@ -42,25 +42,25 @@ let rec trav_binop = function
 
         Binop (op, left, right, loc)
 
 
 and bool_op = function
 
-    | Binop (op, (Type (_, Bool) as left), (Type (_, Bool) as right), loc) ->
 
+    | Binop (op, left, right, loc) when typeof left = Bool && typeof right = Bool ->
 
         trav_binop (op, left, right, loc)
 
 
-    | TypeCast (Bool, (Type (_, Int) as value), loc) ->
 
+    | TypeCast (Bool, value, loc) when typeof value = Int ->
 
         Binop (Ne, value, intconst 0, loc)
 
 
-    | TypeCast (Bool, (Type (_, Float) as value), loc) ->
 
+    | TypeCast (Bool, value, loc) when typeof value = Float ->
 
         Binop (Ne, value, floatconst 0.0, loc)
 
 
-    | TypeCast (Int, (Type (_, Bool) as value), loc) ->
 
+    | TypeCast (Int, value, loc) when typeof value = Bool ->
 
         Cond (value, intconst 1, intconst 0, loc)
 
 
-    | TypeCast (Float, (Type (_, Bool) as value), loc) ->
 
+    | TypeCast (Float, value, loc) when typeof value = Bool ->
 
         Cond (value, floatconst 1.0, floatconst 0.0, loc)
 
 
     | node -> transform_children bool_op node
 
 
 let rec phase input =
 
-    prerr_endline "- Convert bool operations";
 
+    log_line 2 "- Convert bool operations";
 
     match input with
 
     | Ast node -> Ast (bool_op node)
 
     | _ -> raise (InvalidInput "bool operations")

+ 94 - 82
phases/constant_propagation.ml
ファイルの表示 

@@ -14,149 +14,161 @@ open Ast
 
 open Util
 
 
 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
 
     | BoolConst _ | IntConst _ | FloatConst _ -> true
 
     | _ -> false
 
 
 let eval_monop = function
 
-    | (Not, BoolConst  (value, _), loc) -> BoolConst  (not value, loc)
 
-    | (Neg, IntConst   (value, _), loc) -> IntConst   (-value, loc)
 
-    | (Neg, FloatConst (value, _), loc) -> FloatConst (-.value, loc)
 
-    | (op, opnd, loc) -> Monop (op, opnd, loc)
 
+    | (Not, BoolConst  (value, _), ann) -> BoolConst  (not value, ann)
 
+    | (Neg, IntConst   (value, _), ann) -> IntConst   (-value, ann)
 
+    | (Neg, FloatConst (value, _), ann) -> FloatConst (-.value, ann)
 
+    | (op, opnd, ann) -> Monop (op, opnd, ann)
 
 
 let eval_binop = function
 
     (* Arithmetic *)
 
-    | (Add, IntConst (left, _), IntConst (right, _), loc) ->
 
-        IntConst (left + right, loc)
 
-    | (Add, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        FloatConst (left +. right, loc)
 
+    | (Add, IntConst (left, _), IntConst (right, _), ann) ->
 
+        IntConst (left + right, ann)
 
+    | (Add, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        FloatConst (left +. right, ann)
 
 
-    | (Sub, IntConst (left, _), IntConst (right, _), loc) ->
 
-        IntConst (left - right, loc)
 
-    | (Sub, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        FloatConst (left -. right, loc)
 
+    | (Sub, IntConst (left, _), IntConst (right, _), ann) ->
 
+        IntConst (left - right, ann)
 
+    | (Sub, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        FloatConst (left -. right, ann)
 
 
-    | (Mul, IntConst (left, _), IntConst (right, _), loc) ->
 
-        IntConst (left * right, loc)
 
-    | (Mul, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        FloatConst (left *. right, loc)
 
+    | (Mul, IntConst (left, _), IntConst (right, _), ann) ->
 
+        IntConst (left * right, ann)
 
+    | (Mul, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        FloatConst (left *. right, ann)
 
 
-    | (Div, IntConst (left, _), IntConst (right, _), loc) ->
 
-        IntConst (left / right, loc)
 
-    | (Div, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        FloatConst (left /. right, loc)
 
+    | (Div, IntConst (left, _), IntConst (right, _), ann) ->
 
+        IntConst (left / right, ann)
 
+    | (Div, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        FloatConst (left /. right, ann)
 
 
-    | (Mod, IntConst (left, _), IntConst (right, _), loc) ->
 
-        IntConst (left mod right, loc)
 
+    | (Mod, IntConst (left, _), IntConst (right, _), ann) ->
 
+        IntConst (left mod right, ann)
 
 
     (* Relational *)
 
-    | (Eq, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left = right, loc)
 
-    | (Eq, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left = right, loc)
 
-
 
-    | (Ne, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left != right, loc)
 
-    | (Ne, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left != right, loc)
 
-
 
-    | (Gt, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left > right, loc)
 
-    | (Gt, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left > right, loc)
 
-
 
-    | (Lt, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left < right, loc)
 
-    | (Lt, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left < right, loc)
 
-
 
-    | (Ge, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left >= right, loc)
 
-    | (Ge, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left >= right, loc)
 
-
 
-    | (Le, IntConst (left, _), IntConst (right, _), loc) ->
 
-        BoolConst (left <= right, loc)
 
-    | (Le, FloatConst (left, _), FloatConst (right, _), loc) ->
 
-        BoolConst (left <= right, loc)
 
+    | (Eq, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left = right, ann)
 
+    | (Eq, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left = right, ann)
 
+
 
+    | (Ne, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left != right, ann)
 
+    | (Ne, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left != right, ann)
 
+
 
+    | (Gt, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left > right, ann)
 
+    | (Gt, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left > right, ann)
 
+
 
+    | (Lt, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left < right, ann)
 
+    | (Lt, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left < right, ann)
 
+
 
+    | (Ge, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left >= right, ann)
 
+    | (Ge, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left >= right, ann)
 
+
 
+    | (Le, IntConst (left, _), IntConst (right, _), ann) ->
 
+        BoolConst (left <= right, ann)
 
+    | (Le, FloatConst (left, _), FloatConst (right, _), ann) ->
 
+        BoolConst (left <= right, ann)
 
 
     (* Logical *)
 
-    | (And, BoolConst (left, _), BoolConst (right, _), loc) ->
 
-        BoolConst (left && right, loc)
 
-    | (Or, BoolConst (left, _), BoolConst (right, _), loc) ->
 
-        BoolConst (left || right, loc)
 
+    | (And, BoolConst (left, _), BoolConst (right, _), ann) ->
 
+        BoolConst (left && right, ann)
 
+    | (Or, BoolConst (left, _), BoolConst (right, _), ann) ->
 
+        BoolConst (left || right, ann)
 
 
-    | (op, left, right, loc) -> Binop (op, left, right, loc)
 
+    | (op, left, right, ann) -> Binop (op, left, right, ann)
 
 
 let rec propagate consts node =
 
     let propagate = propagate consts in
 
     match node with
 
 
     (* Constant assignments are added to constants table *)
 
-    | Assign (name, None, value, loc) when is_const_name name ->
 
+    | 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, loc)
 
+            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, loc) when Hashtbl.mem consts name ->
 
+    | 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, loc) ->
 
+    | Monop (op, opnd, ann) ->
 
         let opnd = propagate opnd in
 
         if is_const opnd
 
-            then eval_monop (op, opnd, loc)
 
-            else Monop (op, opnd, loc)
 
+            then eval_monop (op, opnd, ann)
 
+            else Monop (op, opnd, ann)
 
 
-    | Binop (op, left, right, loc) ->
 
+    | Binop (op, left, right, ann) ->
 
         let left = propagate left in
 
         let right = propagate right in
 
         if is_const left && is_const right
 
-            then eval_binop (op, left, right, loc)
 
-            else Binop (op, left, right, loc)
 
+            then eval_binop (op, left, right, ann)
 
+            else Binop (op, left, right, ann)
 
 
-    | Cond (cond, texp, fexp, loc) ->
 
+    | Cond (cond, texp, fexp, ann) ->
 
         let cond = propagate cond in
 
         let texp = propagate texp in
 
         let fexp = propagate fexp in
 
         (match cond with
 
         | BoolConst (value, _) -> if value then texp else fexp
 
-        | _ -> Cond (cond, texp, fexp, loc)
 
+        | _ -> Cond (cond, texp, fexp, ann)
 
         )
 
 
-    | TypeCast (ctype, value, loc) ->
 
+    | TypeCast (ctype, value, ann) ->
 
         let value = propagate value in
 
         (match (ctype, value) with
 
-        | (Bool,  BoolConst  (value, _)) -> BoolConst (value, loc)
 
-        | (Bool,  IntConst   (value, _)) -> BoolConst (value != 1, loc)
 
-        | (Bool,  FloatConst (value, _)) -> BoolConst (value != 1.0, loc)
 
-        | (Int,   BoolConst  (value, _)) -> IntConst ((if value then 1 else 0), loc)
 
-        | (Int,   IntConst   (value, _)) -> IntConst (value, loc)
 
-        | (Int,   FloatConst (value, _)) -> IntConst (int_of_float value, loc)
 
-        | (Float, BoolConst  (value, _)) -> FloatConst ((if value then 1. else 0.), loc)
 
-        | (Float, IntConst   (value, _)) -> FloatConst (float_of_int value, loc)
 
-        | (Float, FloatConst (value, _)) -> FloatConst (value, loc)
 
-        | _ -> TypeCast (ctype, value, loc)
 
+        | (Bool,  BoolConst  (value, _)) -> BoolConst (value, ann)
 
+        | (Bool,  IntConst   (value, _)) -> BoolConst (value != 1, ann)
 
+        | (Bool,  FloatConst (value, _)) -> BoolConst (value != 1.0, ann)
 
+        | (Int,   BoolConst  (value, _)) -> IntConst ((if value then 1 else 0), ann)
 
+        | (Int,   IntConst   (value, _)) -> IntConst (value, ann)
 
+        | (Int,   FloatConst (value, _)) -> IntConst (int_of_float value, ann)
 
+        | (Float, BoolConst  (value, _)) -> FloatConst ((if value then 1. else 0.), ann)
 
+        | (Float, IntConst   (value, _)) -> FloatConst (float_of_int value, ann)
 
+        | (Float, FloatConst (value, _)) -> FloatConst (value, ann)
 
+        | _ -> TypeCast (ctype, value, ann)
 
         )
 
 
     | _ -> transform_children propagate node
 
 
 let rec prune_vardecs consts = function
 
-    | VarDec (ctype, name, init, loc) when Hashtbl.mem consts name -> DummyNode
 
+    | VarDec (ctype, name, init, ann) when Hashtbl.mem consts name -> DummyNode
 
     | node -> transform_children (prune_vardecs consts) node
 
 
 let rec phase input =
 
-    prerr_endline "- Constant propagation";
 
+    log_line 2 "- Constant propagation";
 
     match input with
 
     | Ast node ->
 
-        let consts = (Hashtbl.create 32) in
 
+        let consts = Hashtbl.create 32 in
 
         let node = propagate consts node in
 
         Ast (prune_vardecs consts node)
 
     | _ -> raise (InvalidInput "constant propagation")

+ 43 - 68
phases/context_analysis.ml
ファイルの表示 

@@ -16,8 +16,8 @@ let check_in_scope name errnode scope =
 
         | Funcname name -> (name, funs, vars, "function")
 
     in
 
     match mapfind name tbl with
 
-    | Some (decl, dec_depth, _) ->
 
-        (decl, dec_depth)
 
+    | 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
 
@@ -27,7 +27,7 @@ let check_in_scope name errnode scope =
 
 
 let rec analyse scope depth args node =
 
     (* add_to_scope uses args, so it needs to be defined here *)
 
-    let add_to_scope name decl depth scope =
 
+    let add_to_scope name dec depth scope =
 
         let (vars, funs) = scope in
 
         let (name, tbl, name_type) = match name with
 
             | Varname name  -> (name, vars, "variable")
 
@@ -38,103 +38,87 @@ let rec analyse scope depth args node =
 
          * the same depth must be unique for consistency *)
 
         | Some (orig, orig_depth, _) when orig_depth >= depth ->
 
             let msg = sprintf "Error: cannot redeclare %s \"%s\"" name_type name in
 
-            prerr_loc_msg (locof decl) msg args.verbose;
 
+            prerr_loc_msg (locof dec) msg args.verbose;
 
             prerr_loc_msg (locof orig) "Previously declared here:" args.verbose;
 
             raise EmptyError
 
         | Some _ ->
 
-            Hashtbl.replace tbl name (decl, depth, name_type)
 
+            Hashtbl.replace tbl name (dec, depth, name_type)
 
         | None ->
 
-            Hashtbl.add tbl name (decl, depth, name_type)
 
+            Hashtbl.add tbl name (dec, depth, name_type)
 
     in
 
 
     let rec collect node = match node with
 
         (* Add node reference for this varname to vars map *)
 
-        | VarDec (ctype, name, init, loc) ->
 
+        | VarDec (ctype, name, init, ann) ->
 
             let node = match init with
 
-                | Some value -> VarDec (ctype, name, Some (collect value), loc)
 
+                | Some value -> VarDec (ctype, name, Some (collect value), ann)
 
                 | None -> node
 
             in
 
             add_to_scope (Varname name) node depth scope;
 
-            node
 
+            VarDec (ctype, name, init, Depth depth :: ann)
 
 
         (* For global vars, only the name and array dimensions *)
 
-        | GlobalDec (Array (ctype, dims), name, loc) ->
 
+        | GlobalDec (Array (ctype, dims), name, ann) ->
 
             add_to_scope (Varname name) node depth scope;
 
-            GlobalDec (Array (ctype, List.map collect dims), name, loc)
 
-        | Dim (name, loc) ->
 
-            add_to_scope (Varname name) (DimDec node) depth scope;
 
-            node
 
-        | GlobalDec (_, name, _)
 
-        | GlobalDef (_, _, name, _, _) ->
 
+            GlobalDec (Array (ctype, List.map collect dims), name, ann)
 
+
 
+        | Dim (name, ann) ->
 
             add_to_scope (Varname name) node depth scope;
 
-            node
 
+            Dim (name, Depth depth :: ann)
 
+
 
+        | GlobalDec (ctype, name, ann) ->
 
+            add_to_scope (Varname name) node depth scope;
 
+            GlobalDec (ctype, name, Depth depth :: ann)
 
+
 
+        | GlobalDef (export, ctype, name, init, ann) ->
 
+            add_to_scope (Varname name) node depth scope;
 
+            GlobalDef (export, ctype, name, init, Depth depth :: ann)
 
 
         (* Functions are traversed later on, for now only add the name *)
 
-        | FunDec (_, name, _, _)
 
-        | FunDef (_, _, name, _, _, _) ->
 
+        | FunDec (ret_type, name, params, ann) ->
 
             add_to_scope (Funcname name) node depth scope;
 
-            node
 
+            FunDec (ret_type, name, params, Depth depth :: ann)
 
+
 
+        | FunDef (export, ret_type, name, params, body, ann) ->
 
+            add_to_scope (Funcname name) node depth scope;
 
+            FunDef (export, ret_type, name, params, body, Depth depth :: ann)
 
 
         (* For a variable or function call, look for its declaration in the
 
          * current scope and save a its type/depth information  *)
 
-        | Var (name, _) ->
 
-            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
 
-            VarUse (node, ctypeof decl, depth - dec_depth)
 
-
 
-        | Deref (name, dims, loc) ->
 
-            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
 
-            let node = Deref (name, List.map collect dims, loc) in
 
-            VarUse (node, ctypeof decl, depth - dec_depth)
 
+        | 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, loc) ->
 
-            let (decl, dec_depth) = check_in_scope (Funcname name) node scope in
 
-            let node = FunCall (name, transform_all collect args, loc) in
 
-            FunUse (node, decl, depth - dec_depth)
 
+        | 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 wrapped in VarLet nodes, which stores the type
 
+        (* Assign statements are replaced with VarLet nodes, which stores the type
 
          * and depth of the assigned variable are *)
 
-        | Assign (name, None, value, loc) ->
 
-            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
 
-            let assign = Assign (name, None, collect value, loc) in
 
-            VarLet (assign, ctypeof decl, depth - dec_depth)
 
-
 
-        | Assign (name, Some dims, value, loc) ->
 
-            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
 
-            let dims = Some (List.map collect dims) in
 
-            let assign = Assign (name, dims, collect value, loc) in
 
-            VarLet (assign, ctypeof decl, depth - dec_depth)
 
+        | 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)
 
 
         | _ -> transform_children collect node
 
     in
 
 
-    (*let print_scope () =
 
-        let (vars, funs) = scope in
 
-        let print_key key value = prerr_string (" " ^ key) in
 
-        prerr_string "vars: ";
 
-        Hashtbl.iter print_key vars;
 
-        prerr_endline "";
 
-        prerr_string "funs: ";
 
-        Hashtbl.iter print_key funs;
 
-        prerr_endline "";
 
-    in*)
 
-
 
     let rec traverse scope depth node =
 
         match node with
 
         (* Increase nesting level when entering function *)
 
-        | FunDef (export, ret_type, name, params, body, loc) ->
 
+        | 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) args body in
 
-            FunDef (export, ret_type, name, params, body, loc)
 
+            FunDef (export, ret_type, name, params, body, ann)
 
 
-        | Param (Array (ctype, dims), name, loc) as node ->
 
+        | Param (Array (ctype, dims), name, ann) as node ->
 
             let _ = List.map (traverse scope depth) dims in
 
             add_to_scope (Varname name) node depth scope;
 
             node
 
 
         | Dim (name, _) as dim ->
 
-            add_to_scope (Varname name) (DimDec dim) depth scope;
 
+            add_to_scope (Varname name) dim depth scope;
 
             node
 
 
         | Param (_, name, _) ->
 
@@ -157,18 +141,9 @@ let rec analyse scope depth args node =
 
      * void foo() { glob = 1; }
 
      * int glob;
 
      *)
 
-    (*prerr_endline "";
 
-    prerr_endline ("node:----\n" ^ Stringify.node2str node);
 
-    prerr_endline "----";*)
 
     let node = collect node in
 
-    (*prerr_endline "collected";
 
-    print_scope ();
 
-    prerr_endline "\ntraversing";*)
 
 
     let node = traverse scope depth node in
 
-    (*prerr_endline "traversed";
 
-    print_scope ();
 
-    prerr_endline "";*)
 
     node
 
 
 let analyse_context args program =
 
@@ -176,7 +151,7 @@ let analyse_context args program =
 
     analyse scope 0 args program
 
 
 let rec phase input =
 
-    prerr_endline "- Context analysis";
 
+    log_line 2 "- Context analysis";
 
     match input with
 
     | Ast node -> Ast (analyse_context args node)
 
     | _ -> raise (InvalidInput "context analysis")

+ 122 - 63
phases/desug.ml
ファイルの表示 

@@ -4,87 +4,87 @@ open Util
 
 
 let rec var_init = function
 
     (* Move global initialisations to __init function *)
 
-    | Program (decls, loc) ->
 
+    | Program (decls, ann) ->
 
         let decls = flatten_blocks (List.map var_init decls) in
 
         let rec trav assigns = function
 
             | [] -> (assigns, [])
 
-            | (Assign _ as h) :: t
 
-            | (Allocate _ as h) :: t -> trav (assigns @ [h]) t
 
-            | h :: t ->
 
-                let (assigns, decls) = trav assigns t in
 
-                (assigns, (h :: decls))
 
+            | (Assign _ as hd) :: tl
 
+            | (Allocate _ as hd) :: tl -> trav (assigns @ [hd]) tl
 
+            | hd :: tl ->
 
+                let (assigns, decls) = trav assigns tl in
 
+                (assigns, (hd :: decls))
 
         in
 
         let (assigns, decls) = trav [] decls in (
 
             match assigns with
 
-            | [] -> Program (decls, loc)
 
+            | [] -> Program (decls, ann)
 
             | assigns ->
 
-                let init_func = FunDef (true, Void, "__init", [], Block assigns, noloc) in
 
-                Program (init_func :: decls, loc)
 
+                let init_func = FunDef (true, Void, "__init", [], Block assigns, []) in
 
+                Program (init_func :: decls, ann)
 
         )
 
 
     (* Global variable initialisation:
 
      * Add an assign statement and the Program node will remove it later on *)
 
-    | GlobalDef (export, ctype, name, Some init, loc) ->
 
-        Block [GlobalDef (export, ctype, name, None, loc);
 
-               Assign (name, None, init, loc)]
 
+    | GlobalDef (export, ctype, name, Some init, ann) ->
 
+        Block [GlobalDef (export, ctype, name, None, ann);
 
+               Assign (name, None, init, ann)]
 
 
     (* Global array definition:
 
      * - Create a new global variable for each dimension and initialise it to
 
      *   the given expression
 
      * - create __allocate statement in __init *)
 
-    | GlobalDef (export, Array (ctype, dims), name, None, loc) as dec ->
 
+    | GlobalDef (export, Array (ctype, dims), name, None, ann) as dec ->
 
         let rec create_dimvars i = function
 
             | [] -> []
 
             | hd :: tl ->
 
                 let dimname = name ^ "$" ^ string_of_int i in
 
-                let var = Var (dimname, loc) in
 
+                let var = Var (dimname, None, ann) in
 
                 var :: (create_dimvars (i + 1) tl)
 
         in
 
         let dimvars = create_dimvars 1 dims in
 
         let create_globaldef dim = function
 
-            | Var (dimname, loc) ->
 
-                var_init (GlobalDef (export, Int, dimname, Some dim, loc))
 
+            | Var (dimname, None, ann) ->
 
+                var_init (GlobalDef (export, Int, dimname, Some dim, ann))
 
             | _ -> raise InvalidNode
 
         in
 
         let vardecs = List.map2 create_globaldef dims dimvars in
 
-        let alloc = [Allocate (name, dimvars, dec, loc)] in
 
+        let alloc = [Allocate (name, dimvars, dec, ann)] in
 
         Block (vardecs @
 
-               [GlobalDef (export, Array (ctype, dimvars), name, None, loc)] @
 
+               [GlobalDef (export, Array (ctype, dimvars), name, None, ann)] @
 
                alloc)
 
 
     (* Split local variable initialisations in declaration and assignment *)
 
-    | FunDef (export, ret_type, name, params, Block body, loc) ->
 
+    | FunDef (export, ret_type, name, params, Block body, ann) ->
 
         let move_inits body =
 
             let rec trav inits node = match node with
 
                 (* Translate scalar array initialisation to ArrayScalar node,
 
                  * for easy replacement later on *)
 
-                | VarDec (Array _ as vtype, name, Some (BoolConst _  as v), loc) :: t
 
-                | VarDec (Array _ as vtype, name, Some (FloatConst _ as v), loc) :: t
 
-                | VarDec (Array _ as vtype, name, Some (IntConst _   as v), loc) :: t ->
 
+                | VarDec (Array _ as vtype, name, Some (BoolConst _  as v), ann) :: tl
 
+                | VarDec (Array _ as vtype, name, Some (FloatConst _ as v), ann) :: tl
 
+                | VarDec (Array _ as vtype, name, Some (IntConst _   as v), ann) :: tl ->
 
                     let init = Some (ArrayInit (ArrayScalar v, vtype)) in
 
-                    trav inits (VarDec (vtype, name, init, loc) :: t)
 
+                    trav inits (VarDec (vtype, name, init, ann) :: tl)
 
 
                 (* Wrap ArrayConst in ArrayInit to pass dimensions *)
 
-                | VarDec (Array _ as vtype, name, Some (ArrayConst _ as v), loc) :: t ->
 
+                | VarDec (Array _ as vtype, name, Some (ArrayConst _ as v), ann) :: tl ->
 
                     let init = Some (ArrayInit (v, vtype)) in
 
-                    trav inits (VarDec (vtype, name, init, loc) :: t)
 
+                    trav inits (VarDec (vtype, name, init, ann) :: tl)
 
 
-                | VarDec (ctype, name, init, loc) as dec :: tl ->
 
+                | VarDec (ctype, name, init, ann) as dec :: tl ->
 
                     (* array definition: create __allocate statement *)
 
                     let alloc = match ctype with
 
-                        | Array (_, dims) -> [Allocate (name, dims, dec, loc)]
 
+                        | Array (_, dims) -> [Allocate (name, dims, dec, ann)]
 
                         | _ -> []
 
                     in
 
                     (* initialisation: create assign statement *)
 
                     let add = match init with
 
-                        | Some value -> alloc @ [Assign (name, None, value, loc)]
 
+                        | Some value -> alloc @ [Assign (name, None, value, ann)]
 
                         | None -> alloc
 
                     in
 
-                    VarDec (ctype, name, None, loc) :: (trav (inits @ add) tl)
 
+                    VarDec (ctype, name, None, ann) :: (trav (inits @ add) tl)
 
 
                 (* initialisations need to be placed after local functions *)
 
-                | (FunDef (_, _, _, _, _, _) as h) :: t ->
 
-                    (var_init h) :: (trav inits t)
 
+                | (FunDef (_, _, _, _, _, _) as h) :: tl ->
 
+                    (var_init h) :: (trav inits tl)
 
 
                 (* rest of function body: recurse *)
 
                 | rest -> inits @ (List.map var_init rest)
 
@@ -92,61 +92,61 @@ let rec var_init = function
 
             flatten_blocks (trav [] body)
 
         in
 
         let params = flatten_blocks (List.map var_init params) in
 
-        FunDef (export, ret_type, name, params, Block (move_inits body), loc)
 
+        FunDef (export, ret_type, name, params, Block (move_inits body), ann)
 
 
     | node -> transform_children var_init node
 
 
 let rec replace_var var replacement node =
 
     let trav = (replace_var var replacement) in
 
     match node with
 
-    | Var (name, loc) when name = var ->
 
-        Var (replacement, loc)
 
-    | For (counter, start, stop, step, body, loc) when counter = var ->
 
-        For (replacement, trav start, trav stop, trav step, trav body, loc)
 
+    | 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
 
 
 let for_to_while node =
 
     let rec traverse new_vars = function
 
-        | FunDef (export, ret_type, name, params, body, loc) ->
 
+        | 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, noloc) 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, loc)
 
+            FunDef (export, ret_type, name, params, Block _body, ann)
 
 
         (* Transform for-loops to while-loops *)
 
-        | For (counter, start, stop, step, body, loc) ->
 
+        | 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, noloc) in
 
-            let vstop = Var (_stop, locof stop) in
 
-            let vstep = Var (_step, locof step) in
 
+            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, IntConst (0, noloc), noloc),
 
-                Binop (Lt, vi, vstop, noloc),
 
-                Binop (Gt, vi, vstop, noloc),
 
-                noloc
 
+                Binop (Gt, vstep, IntConst (0, []), []),
 
+                Binop (Lt, vi, vstop, []),
 
+                Binop (Gt, vi, vstop, []),
 
+                []
 
             ) in
 
             Block [
 
-                Assign (_i, None, start, locof start);
 
-                Assign (_stop, None, stop, locof stop);
 
-                Assign (_step, None, step, locof step);
 
+                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, noloc), noloc)]
 
-                )), loc));
 
+                    [Assign (_i, None, Binop (Add, vi, vstep, []), [])]
 
+                )), ann));
 
             ]
 
 
         (* Transform while-loops to do-while loops in if-statements *)
 
-        | While (cond, body, loc) ->
 
+        | 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, loc)], loc)]
 
+            Block [If (cond, Block [DoWhile (cond, body, ann)], ann)]
 
 
         | node -> transform_children (traverse new_vars) node
 
     in
 
@@ -154,21 +154,21 @@ let for_to_while node =
 
 
 let rec array_init = function
 
     (* Transform scalar assignment into nested for-loops *)
 
-    | Assign (name, None, ArrayInit (ArrayScalar value, Array (_, dims)), loc) ->
 
+    | Assign (name, None, ArrayInit (ArrayScalar value, Array (_, dims)), ann) ->
 
         let rec add_loop indices = function
 
             | [] ->
 
-                Assign (name, Some indices, value, loc)
 
+                Assign (name, Some indices, value, ann)
 
             | dim :: rest ->
 
                 let counter = fresh_var "i" in
 
-                let body = Block [add_loop (indices @ [Var (counter, noloc)]) rest] in
 
-                For (counter, IntConst (0, noloc), dim, IntConst (1, noloc), body, noloc)
 
+                let body = Block [add_loop (indices @ [Var (counter, None, [])]) rest] in
 
+                For (counter, IntConst (0, []), dim, IntConst (1, []), body, [])
 
         in
 
         add_loop [] dims
 
 
     (* 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, Array (_, dims)), loc) ->
 
+    | Assign (name, None, ArrayInit (ArrayConst _ as value, Array (_, dims)), ann) ->
 
         let ndims = list_size dims in
 
         let rec make_assigns depth i indices = function
 
             | [] -> []
 
@@ -179,8 +179,8 @@ let rec array_init = function
 
             | ArrayConst (values, _) ->
 
                 make_assigns (depth + 1) 0 indices values
 
             | value when depth = ndims ->
 
-                let indices = List.map (fun i -> IntConst (i, noloc)) indices in
 
-                [Assign (name, Some (List.rev indices), value, loc)]
 
+                let indices = List.map (fun i -> IntConst (i, [])) indices in
 
+                [Assign (name, Some (List.rev indices), value, ann)]
 
             | node ->
 
                 let msg = sprintf
 
                     "dimension mismatch: expected %d nesting levels, got %d"
 
@@ -192,8 +192,67 @@ let rec array_init = function
 
 
     | node -> transform_children array_init node
 
 
+(* Generate new variables for array dimensions in function bodies, to avoid
 
+ * re-evalutation after array dimension reduction. For example:
 
+ *
 
+ * int dims = 0;
 
+ *
 
+ * int dim() {
 
+ *     dims = dims 1;  // Side effect => dims() should be called once
 
+ *     return 10;
 
+ * }
 
+ *
 
+ * void foo() {
 
+ *    int[10, dim()] arr;
 
+ *    arr[0, 1] = 1;
 
+ * }
 
+ *
 
+ * After dimension reduction, this would become:
 
+ * void foo() {
 
+ *    int[] arr;
 
+ *    arr = allocate(10, dim());
 
+ *    arr[1 * dim() + 0] = 1;
 
+ * }
 
+ *
 
+ * This behaviour is of course incorrect. To avoid dim() from being evaluated
 
+ * twice, the snippet above is transformed into (note the $$ which will help
 
+ * later during constant propagation):
 
+ * void foo() {
 
+ *    int a$dim$$1 = 10;
 
+ *    int a$dim$$2 = dim();
 
+ *    int[a$dim$$1, a$dim$$2] arr;
 
+ *    arr[1, 2] = 1;
 
+ * }
 
+ *
 
+ * ... which then becomes:
 
+ * void foo() {
 
+ *    int a$dim$$1;
 
+ *    int a$dim$$2;
 
+ *    int[a$dim$$1, a$dim$$2] arr;
 
+ *    a$dim$1 = 10;
 
+ *    a$dim$2 = dim();
 
+ *    arr = __allocate(a$dim$1 * a$dim$2);
 
+ *    arr[1 * a$dim$2 * 0] = 1;
 
+ * }
 
+ * *)
 
+let rec array_dims = function
 
+    | VarDec (Array (ctype, dims), name, init, ann) ->
 
+        let make_dimname i _ = name ^ "$dim$$" ^ string_of_int (i + 1) in
 
+        let dimnames = mapi make_dimname dims in
 
+
 
+        let make_dimvar d n = Var (n, None, annof d) in
 
+        let dimvars = List.map2 make_dimvar dims dimnames in
 
+
 
+        let make_dimdec dimname dim = VarDec (Int, dimname, Some dim, []) in
 
+        let dimdecs = List.map2 make_dimdec dimnames dims in
 
+
 
+        Block (dimdecs @ [VarDec (Array (ctype, dimvars), name, init, ann)])
 
+
 
+    | node -> transform_children array_dims node
 
+
 
 let rec phase input =
 
-    prerr_endline "- Desugaring";
 
+    log_line 2 "- Desugaring";
 
     match input with
 
-    | Ast node -> Ast (for_to_while (array_init (var_init node)))
 
+    | Ast node ->
 
+            Ast (for_to_while (array_init (var_init (array_dims node))))
 
     | _ -> raise (InvalidInput "desugar")

+ 33 - 20
phases/dim_reduce.ml
ファイルの表示 

@@ -4,38 +4,51 @@ open Util
 
 let rec multiply = function
 
     | []       -> raise InvalidNode
 
     | [node]   -> node
 
-    | hd :: tl -> Binop (Mul, hd, multiply tl, noloc)
 
+    | hd :: tl -> Binop (Mul, hd, multiply tl, [Type Int])
 
 
-let rec expand dims depth = function
 
+let use_dim depth = function
 
+    | Dim _ as dim -> VarUse (dim, None, [Type Int; Depth depth])
 
+    (*| VarUse (dim, None, ann) -> VarUse ()*)
 
+    | node -> node
 
+
 
+let rec expand depth dims = function
 
     | []       -> raise InvalidNode
 
     | [node]   -> dim_reduce depth node
 
-    | hd :: tl -> let trav = dim_reduce depth in
 
-                  let mul = Binop (Mul, trav hd, trav (List.hd dims), noloc) in
 
-                  Binop (Add, mul, expand (List.tl dims) depth tl, noloc)
 
+    | hd :: tl ->
 
+        let dim = use_dim depth (List.hd dims) in
 
+        let mul = Binop (Mul, dim_reduce depth hd, dim, [Type Int]) in
 
+        Binop (Add, mul, expand depth (List.tl dims) tl, [Type Int])
 
 
 and dim_reduce depth = function
 
-    | Allocate (name, dims, dec, loc) ->
 
-        Allocate (name, [multiply dims], dec, loc)
 
+    | Allocate (name, dims, dec, ann) ->
 
+        Allocate (name, [multiply dims], dec, ann)
 
 
-    | FunDef (export, ret_type, name, params, body, loc) ->
 
+    (* 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, loc)
 
-
 
-    | Dim (name, loc) ->
 
-        VarUse (Var (name, loc), Int, depth)
 
+        FunDef (export, ret_type, name, List.map trav params, trav body, ann)
 
 
-    | VarUse (Type (Deref (name, values, loc), t), (Array (_, dims) as ctype), depth) ->
 
-        let reduced = [expand (List.rev dims) depth values] in
 
-        VarUse (Type (Deref (name, reduced, loc), t), ctype, depth)
 
+    (* Expand indices when dereferencing *)
 
+    | VarUse (VarDec (Array (_, dims), _, _, _) as dec, Some values, ann) ->
 
+        VarUse (dec, Some [expand depth (List.rev dims) values], ann)
 
 
-    | VarLet (Assign (name, Some values, value, loc), (Array (_, dims) as ctype), depth) ->
 
-        let reduced = Some [expand (List.rev dims) depth values] in
 
-        VarLet (Assign (name, reduced, dim_reduce depth value, loc), ctype, depth)
 
+    (* Expand indices when assigning to array index *)
 
+    | VarLet (VarDec (Array (_, dims), _, _, _) as dec, Some values, value, ann) ->
 
+        VarLet (dec, Some [expand depth (List.rev dims) values], value, ann)
 
 
     | node -> transform_children (dim_reduce depth) node
 
 
+let rec simplify_decs = function
 
+    | VarDec (Array (ctype, dims), name, init, ann) ->
 
+        VarDec (FlatArray ctype, name, init, ann)
 
+
 
+    | Param (Array (ctype, dims), name, ann) ->
 
+        Param (FlatArray ctype, name, ann)
 
+
 
+    | node -> transform_children simplify_decs node
 
+
 
 let rec phase input =
 
-    prerr_endline "- Array dimension reduction";
 
+    log_line 2 "- Array dimension reduction";
 
     match input with
 
-    | Ast node -> Ast (dim_reduce 0 node)
 
+    | Ast node -> Ast (simplify_decs (dim_reduce 0 node))
 
     | _ -> raise (InvalidInput "dimension reduction")

+ 6 - 10
phases/expand_dims.ml
ファイルの表示 

@@ -11,11 +11,8 @@ let rec expand_dims = function
 
         let params = flatten_blocks (List.map expand_dims params) in
 
         FunDec (ret_type, name, params, loc)
 
 
-    | FunUse (funcall, fundef, depth) ->
 
-        FunUse (expand_dims funcall, expand_dims fundef, depth)
 
-
 
-    | FunCall (name, args, loc) ->
 
-        FunCall (name, flatten_blocks (List.map expand_dims args), loc)
 
+    | FunUse (dec, params, loc) ->
 
+        FunUse (dec, flatten_blocks (List.map expand_dims params), loc)
 
 
     (* Add additional parameters for array dimensions *)
 
     | Param (Array (_,dims) as ctype, name, loc) ->
 
@@ -29,18 +26,17 @@ let rec expand_dims = function
 
         Block (do_expand dims)
 
 
     (* Add additional function arguments for array dimensions *)
 
-    | Arg (VarUse (var, (Array (_, dims) as ctype), depth)) ->
 
+    | Arg (VarUse (VarDec (Array (_, dims), _, _, _), None, _)) as node ->
 
         let rec do_expand = function
 
-            | []       -> [Arg (VarUse (var, ctype, depth))]
 
-            | hd :: tl -> Arg (VarUse (hd, Int, depth)) :: (do_expand tl)
 
-            | _        -> raise InvalidNode
 
+            | []       -> [node]
 
+            | hd :: tl -> Arg (VarUse (hd, None, [])) :: (do_expand tl)
 
         in
 
         Block (do_expand dims)
 
 
     | node -> transform_children expand_dims node
 
 
 let rec phase input =
 
-    prerr_endline "- Expand array dimensions";
 
+    log_line 2 "- Expand array dimensions";
 
     match input with
 
     | Ast node -> Ast (expand_dims node)
 
     | _ -> raise (InvalidInput "expand dimensions")

+ 38 - 47
phases/extern_vars.ml
ファイルの表示 

@@ -1,54 +1,49 @@
 
 open Ast
 
 open Util
 
 
-(* Remove Type nodes temporarily for easy traversal *)
 
-let rec prune_types = function
 
-    | Type (node, _) -> prune_types node
 
-    | node -> transform_children prune_types node
 
-
 
 let create_param ctype name =
 
-    let param = Param (ctype, name, noloc) in
 
-    let value = VarUse (Var (name, noloc), ctype, 0) in
 
+    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 def ->
 
-        Type (FunUse (FunCall (name, args, noloc), def, depth), ctype)
 
+    | FunDec (ctype, name, _, _) as dec ->
 
+        FunUse (dec, args, [Type ctype; Depth depth])
 
     | _ -> raise InvalidNode
 
 
 let process globals = function
 
-    | GlobalDef (true, Array (ctype, dims), name, None, loc) ->
 
+    | GlobalDef (true, Array (ctype, dims), 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 = Deref (name, [index], noloc) in
 
-        let body = Block [Return (var, noloc)] in
 
-        let getter = FunDef (true, ctype, name ^ "$get", [param], body, noloc) 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 (Assign (name, Some [index], value, noloc), ctype, 1)] in
 
-        let setter = FunDef (true, Void, name ^ "$set", [param1; param2], body, noloc) 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, loc) ->
 
+    | GlobalDef (true, ctype, name, None, ann) as dec ->
 
         (* Getter for basic variable type: return the variable *)
 
-        let var = VarUse (Var (name, noloc), ctype, 1) in
 
-        let body = [Return (var, noloc)] in
 
-        let getter = FunDef (true, ctype, name ^ "$get", [], Block body, noloc) 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 (Assign (name, None, value, noloc), ctype, 1)] in
 
-        let setter = FunDef (true, Void, name ^ "$set", [param], Block body, noloc) in
 
+        let body = [VarLet (dec, None, value, [])] in
 
+        let setter = FunDef (true, Void, name ^ "$set", [param], Block body, []) in
 
 
         [getter; setter]
 
 
-    | GlobalDec (Array (ctype, dims), name, loc) ->
 
+    | GlobalDec (Array (ctype, dims), name, ann) ->
 
         (* Getters for external array variable: create getter for a given index *)
 
         (* Setters for external array variable:
 
          * - define setter for a given index
 
@@ -59,31 +54,31 @@ let process globals = function
 
             | Dim (oldname, _) :: tl ->
 
                 let dimname = name ^ "$" ^ string_of_int i in
 
 
-                let getter = FunDec (Void, dimname ^ "$get", [], noloc) in
 
+                let getter = FunDec (Void, dimname ^ "$get", [], []) in
 
 
                 let (param, _) = create_param ctype "value" in
 
-                let setter = FunDec (Void, dimname ^ "$set", [param], noloc) in
 
+                let setter = FunDec (Void, dimname ^ "$set", [param], []) in
 
 
                 Hashtbl.add globals oldname (call getter, call setter);
 
                 getter :: setter :: (process_dims (i + 1) tl)
 
             | _ -> raise InvalidNode
 
         in
 
 
-        let getter = FunDec (ctype, name ^ "$get", [param], noloc) 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], noloc) in
 
+        let setter = FunDec (Void, name ^ "$set", [param1; param2], []) in
 
 
         Hashtbl.add globals name (call getter, call setter);
 
         getter :: setter :: (process_dims 1 dims)
 
 
     (* Getter for basic variable type: return the variable *)
 
-    | GlobalDec (ctype, name, loc) ->
 
-        let getter = FunDec (ctype, name ^ "$get", [], noloc) in
 
+    | 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], noloc) in
 
+        let setter = FunDec (Void, name ^ "$set", [param], []) in
 
 
         Hashtbl.add globals name (call getter, call setter);
 
         [getter; setter]
 
@@ -91,15 +86,15 @@ let process globals = function
 
     | _ -> raise InvalidNode
 
 
 let rec create_funcs globals = function
 
-    | Program (decls, loc) ->
 
+    | Program (decls, ann) ->
 
         let decls = List.map (create_funcs globals) decls in
 
-        Program (flatten_blocks (List.map (create_funcs globals) decls), loc)
 
+        Program (flatten_blocks (List.map (create_funcs globals) decls), ann)
 
 
-    | GlobalDef (true, ctype, name, None, loc) as node ->
 
-        Block (GlobalDef (false, ctype, name, None, loc) ::
 
+    | GlobalDef (true, ctype, name, None, ann) as node ->
 
+        Block (GlobalDef (false, ctype, name, None, ann) ::
 
                (process globals node))
 
 
-    | GlobalDec (ctype, name, loc) as node ->
 
+    | GlobalDec (ctype, name, ann) as node ->
 
         Block (process globals node)
 
 
     | node -> transform_children (create_funcs globals) node
 
@@ -111,32 +106,28 @@ let rec replace_vars scope depth = function
 
         Hashtbl.remove scope name;
 
         node
 
 
-    | FunDef (export, ret_type, name, params, body, loc) ->
 
+    | 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, loc)
 
+        FunDef (export, ret_type, name, params, trav body, ann)
 
 
-    | VarUse (Var (name, loc), _, _) as node when Hashtbl.mem scope name ->
 
-        let (get, _) = Hashtbl.find scope name in
 
+    | VarUse (dec, None, _) when Hashtbl.mem scope (nameof dec) ->
 
+        let (get, _) = Hashtbl.find scope (nameof dec) in
 
         get [] depth
 
 
-    | VarLet (Assign (name, None, value, _), _, _) when Hashtbl.mem scope name ->
 
-        let (_, set) = Hashtbl.find scope name in
 
-        Expr (set [replace_vars scope depth value] depth)
 
-
 
-    | VarLet (Assign (name, Some dims, value, _), _, _) when Hashtbl.mem scope name ->
 
-        let dims = List.map (replace_vars scope depth) dims in
 
-        let (_, set) = Hashtbl.find scope name in
 
+    | 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
 
 
 let rec phase input =
 
-    prerr_endline "- Create getters and setters for extern variables";
 
+    log_line 2 "- Create getters and setters for extern variables";
 
     match input with
 
     | Ast node ->
 
         let globals = Hashtbl.create 20 in
 
-        let node = create_funcs globals (prune_types node) in
 
+        let node = create_funcs globals node in
 
         Ast (replace_vars globals 0 node)
 
     | _ -> raise (InvalidInput "extern vars")

+ 89 - 0
phases/print.ml
ファイルの表示 

@@ -1,6 +1,81 @@
 
 open Ast
 
+open Util
 
 open Stringify
 
 
+let tab = "    "
 
+
 
+let rec repeat s n = if n < 1 then "" else s ^ (repeat s (n - 1))
 
+let pad width s = s ^ (repeat " " (String.length s - width))
 
+let paddall width = List.map (pad width)
 
+
 
+let ctype2str = Stringify.type2str
 
+let type2str = function
 
+    | Array (t, dims) -> ctype2str t ^ repeat "," (List.length dims - 1)
 
+    | t -> ctype2str t
 
+
 
+let prefix node = match typeof node with
 
+    | Bool _  -> "b"
 
+    | Int _   -> "i"
 
+    | Float _ -> "f"
 
+    | Array _ -> "a"
 
+    | _ -> raise InvalidNode
 
+
 
+let instr2str = function
 
+    (* Global / directives *)
 
+    | Comment comment ->
 
+        "# " ^ comment
 
+    | 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)
 
+    | Const node ->
 
+        ".const  " ^ (node2str node)
 
+    | Global ctype ->
 
+        ".global " ^ (type2str ctype)
 
+
 
+    (* Load constant *)
 
+    | LoadConst (ctype, index) ->
 
+        tab ^ type2str ctype ^ "loadc " ^ string_of_int index
 
+    | LoadImm (BoolConst (b, _)) ->
 
+        tab ^ "bloadc_" ^ (if b then "t" else "f")
 
+    | LoadImm (IntConst (i, _)) when i < 0 ->
 
+        tab ^ "iloadc_m" ^ string_of_int (-i)
 
+    | LoadImm (IntConst (i, _)) ->
 
+        tab ^ "iloadc_" ^ string_of_int i
 
+    | LoadImm (FloatConst (i, _)) ->
 
+        tab ^ "floadc_" ^ string_of_int (int_of_float i)
 
+
 
+    | _ -> tab ^ "<unknown instruction>"
 
+
 
+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
 
+        | [] -> ()
 
+        | hd :: tl ->
 
+            let line = instr2str hd in
 
+            (if String.length line > 0 && line.[0] = '.' then
 
+                endbuf := line :: !endbuf
 
+            else
 
+                output_line line
 
+            );
 
+            trav tl
 
+    in
 
+    trav instrs;
 
+    List.iter output_line (List.rev !endbuf)
 
+    (*
 
+    let hasdot ins = if String.length ins > 0 && ins.[0] = '.' then 1 else 0 in
 
+    let cmp a b = compare (hasdot a) (hasdot b) in
 
+    List.sort cmp (trav instrs)
 
+    *)
 
+
 
 let phase = function
 
     | Ast node as input ->
 
         if args.verbose >= 2 then (
 
@@ -20,6 +95,20 @@ let phase = function
 
         input
 
 
     | Assembly instrs as input ->
 
+        (match args.outfile with
 
+        | Some filename ->
 
+            let oc = open_out filename in
 
+            print_assembly oc instrs;
 
+            close_out oc
 
+        | None ->
 
+            if args.verbose >= 2 then
 
+                prerr_endline "--------------------------------------------------";
 
+
 
+            print_assembly stdout instrs;
 
+
 
+            if args.verbose >= 2 then
 
+                prerr_endline "--------------------------------------------------"
 
+        );
 
         input
 
 
     | _ -> raise (InvalidInput "print")

+ 111 - 102
phases/typecheck.ml
ファイルの表示 

@@ -24,17 +24,16 @@ let spec = function
 
     | Array (ctype, dims) -> ArrayDepth (ctype, list_size dims)
 
     | ctype               -> ctype
 
 
-let check_type ?(msg="") expected = function
 
-    | Type (node, got) when (spec got) <> (spec expected) ->
 
+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))
 
-    | Type _ -> ()
 
-    | _ -> raise InvalidNode
 
+        in raise (NodeError (node, msg))
 
+    ); ()
 
 
 let op_types = function
 
     | Not | And | Or                      -> [Bool]
 
@@ -42,20 +41,20 @@ let op_types = function
 
     | Neg | Sub | Div | Lt | Le | Gt | Ge -> [Int; Float]
 
     | Add | Mul | Eq | Ne                 -> [Bool; Int; Float]
 
 
-let op_result_type operand_type = function
 
+let op_result_type opnd_type = function
 
     | Not | And | Or | Eq | Ne | Lt | Le | Gt | Ge -> Bool
 
-    | Neg | Add | Sub | Mul | Div | Mod            -> operand_type
 
+    | 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 = function
 
-    | Type (node, ctype) when not (List.mem ctype allowed_types) ->
 
+let check_type_op allowed_types desc node =
 
+    let got = typeof node in
 
+    if not (List.mem got allowed_types) then (
 
         let msg = sprintf
 
             "%s cannot be applied to type %s, only to %s"
 
-            desc (type2str ctype) (types2str allowed_types)
 
+            desc (type2str got) (types2str allowed_types)
 
         in
 
         raise (NodeError (node, msg))
 
-    | Type _ -> ()
 
-    | _ -> raise InvalidNode
 
+    ); ()
 
 
 let check_dims_match dims dec_type errnode =
 
     match (list_size dims, array_depth dec_type) with
 
@@ -66,11 +65,15 @@ let check_dims_match dims dec_type errnode =
 
         raise (NodeError (errnode, msg))
 
     | _ -> ()
 
 
-let rec typecheck node = match node with
 
-    | FunUse (FunCall (fname, args, floc),
 
-                (FunDec (ftype, name, params, _) as dec), loc)
 
-    | FunUse (FunCall (fname, args, floc),
 
-                (FunDef (_, ftype, name, params, _, _) as dec), loc) ->
 
+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_size args, list_size params) with
 
         | (nargs, nparams) when nargs != nparams ->
 
             let msg = sprintf
 
@@ -81,128 +84,134 @@ let rec typecheck node = match node with
 
         | _ ->
 
             let args = List.map typecheck args in
 
             let check_arg_type arg param =
 
-                check_type (ctypeof param) arg;
 
+                check_type (typeof param) arg;
 
             in
 
             List.iter2 check_arg_type args params;
 
-            Type (FunUse (FunCall (fname, args, floc), dec, loc), ftype)
 
+            FunUse (dec, args, Type ret_type :: ann)
 
         )
 
 
-    | Arg (Type (_, vtype)) -> Type (node, vtype)
 
-    | Arg value             -> typecheck (Arg (typecheck value))
 
-
 
-    | Monop (op, (Type (_, vtype) as value), _) ->
 
+    (* 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 value;
 
-        Type (node, op_result_type vtype op)
 
-    | Monop (op, value, loc) ->
 
-        typecheck (Monop (op, typecheck value, loc))
 
+        check_type_op (op_types op) desc opnd;
 
+        Monop (op, opnd, Type (op_result_type (typeof opnd) op) :: ann)
 
 
-    | Binop (op, (Type (_, ltype) as left), right, loc) ->
 
+    | 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 ltype right;
 
-        Type (node, op_result_type ltype op)
 
-    | Binop (op, left, right, loc) ->
 
-        typecheck (Binop (op, typecheck left, typecheck right, loc))
 
-
 
-    | Cond (Type (cond, condtype), Type (texpr, ttype), fexpr, loc) ->
 
-        check_type ttype fexpr;
 
-        Type (node, ttype)
 
-    | Cond (cond, texpr, fexpr, loc) ->
 
-        typecheck (Cond (typecheck cond, typecheck texpr, typecheck fexpr, loc))
 
-
 
-    | VarLet (Assign (_, None, (Type _ as value), _), dec_type, depth) ->
 
-        check_type dec_type value;
 
-        node
 
-    | VarLet (Assign (_, Some dims, (Type _ as value), _) as assign, dec_type, depth) ->
 
-        (* Number of assigned indices must match array definition *)
 
-        check_dims_match dims dec_type assign;
 
-
 
-        (* Array indices must be ints *)
 
-        List.iter (check_type Int) dims;
 
-
 
-        (* Assigned value must match array base type *)
 
-        check_type (base_type dec_type) value;
 
-        node
 
-    | VarLet (assign, dec_type, depth) ->
 
-        typecheck (VarLet (typecheck assign, dec_type, depth))
 
-
 
-    | TypeCast (ctype, (Type _ as value), loc) ->
 
+        check_type (typeof left) right;
 
+        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;
 
-        Type (node, ctype)
 
-    | TypeCast (ctype, value, loc) ->
 
-        typecheck (TypeCast (ctype, typecheck value, loc))
 
+        TypeCast (ctype, value, Type (typeof value) :: ann)
 
 
-    | VarUse (Deref (_, dims, _) as deref, dec_type, depth) ->
 
-        let dims = List.map typecheck dims in
 
-        List.iter (check_type Int) dims;
 
-
 
-        check_dims_match dims dec_type deref;
 
+    (* Array allocation dimensions must have type int *)
 
+    | Allocate (name, dims, dec, ann) ->
 
+        Allocate (name, List.map (check_trav Int) dims, dec, ann)
 
 
-        typecheck (VarUse (Type (deref, base_type dec_type), dec_type, depth))
 
-    | VarUse (Type (_, ctype), _, _)
 
-    | VarUse (_, ctype, _) ->
 
-        Type (node, ctype)
 
+    (* Array dimensions are always integers *)
 
+    | Dim (name, ann) ->
 
+        Dim (name, Type Int :: ann)
 
 
-    | Allocate (name, dims, dec, loc) ->
 
-        let dims = List.map typecheck dims in
 
-        List.iter (check_type Int) dims;
 
-        Allocate (name, dims, dec, loc)
 
+    (* 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)
 
 
-    | Return (Type _, _)  -> node
 
-    | Return (value, loc) -> typecheck (Return (typecheck value, loc))
 
+    | Param (Array (ctype, dims), name, ann) ->
 
+        Param (Array (ctype, List.map typecheck dims), name, ann)
 
 
-    | FunDef (export, ret_type, name, params, body, loc) ->
 
-        let params = transform_all typecheck params in
 
+    (* 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 (Type (_, rtype), _) as ret] -> Some (ret, rtype)
 
-            | hd :: tl                             -> find_return tl
 
+            | []                         -> 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, loc)
 
+
 
+            | _ -> FunDef (export, ret_type, name, params, body, ann)
 
         )
 
 
-    (* Conditions in if-statements and loop must be type bool *)
 
-    | If (Type _ as cond, _, _)
 
-    | IfElse (Type _ as cond, _, _, _)
 
-    | While (Type _ as cond, _, _)
 
-    | DoWhile (Type _ as cond, _, _) ->
 
-        check_type Bool cond (*~msg:"condition should have type bool"*);
 
-        node
 
-    | If (cond, body, loc) ->
 
-        typecheck (If (typecheck cond, typecheck body, loc))
 
-    | IfElse (cond, tbody, fbody, loc) ->
 
-        typecheck (IfElse (typecheck cond, typecheck tbody, typecheck fbody, loc))
 
-    | While (cond, body, loc) ->
 
-        typecheck (While (typecheck cond, typecheck body, loc))
 
-    | DoWhile (cond, body, loc) ->
 
-        typecheck (DoWhile (typecheck cond, typecheck body, loc))
 
-
 
-    | BoolConst  (value, _) -> Type (node, Bool)
 
-    | IntConst   (value, _) -> Type (node, Int)
 
-    | FloatConst (value, _) -> Type (node, Float)
 
+    (* 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 *)
 
+    | BoolConst  (value, ann) -> BoolConst  (value, Type Bool  :: ann)
 
+    | IntConst   (value, ann) -> IntConst   (value, Type Int   :: ann)
 
+    | FloatConst (value, ann) -> FloatConst (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)
 
+
 
+    (* 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)
 
 
     | _ -> transform_children typecheck node
 
 
 let rec phase input =
 
-    prerr_endline "- Type checking";
 
+    log_line 2 "- Type checking";
 
     match input with
 
     | Ast node -> Ast (typecheck node)
 
     | _ -> raise (InvalidInput "typecheck")

+ 37 - 23
stringify.ml
ファイルの表示 

@@ -11,6 +11,17 @@ let float2string f = match string_of_float f with
 
     | s when s.[String.length s - 1] = '.' -> s ^ "0"
 
     | s -> s
 
 
+(* 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
 
+
 
 (* operator -> string *)
 
 let op2str = function
 
     | Neg -> "-"
 
@@ -37,6 +48,7 @@ let rec type2str = function
 
     | Float -> "float"
 
     | Array (t, dims)       -> (type2str t) ^ "[" ^ (concat ", " dims) ^ "]"
 
     | ArrayDepth (t, ndims) -> (type2str t) ^ "[" ^ string_of_int ndims ^ "]"
 
+    | FlatArray t           -> (type2str t) ^ "[]"
 
 
 and concat sep nodes = String.concat sep (List.map node2str nodes)
 
 
@@ -104,8 +116,8 @@ and node2str node =
 
     | IntConst (i, _) -> string_of_int i
 
     | FloatConst (f, _) -> float2string f
 
     | ArrayConst (dims, _) -> "[" ^ concat ", " dims ^ "]"
 
-    | Var (v, _) -> v
 
-    | Deref (name, dims, _) -> name ^ (str (ArrayConst (dims, noloc)))
 
+    | 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 ^ ")"
 
@@ -113,32 +125,34 @@ and node2str node =
 
     | FunCall (name, args, _) -> name ^ "(" ^ (concat ", " args) ^ ")"
 
     | Cond (cond, t, f, _) -> (str cond) ^ " ? " ^ str t ^ " : " ^ str f
 
 
-    (* Some intermediate nodes print more information at higher verbosity, for
 
+    (* Annotation nodes print more information at higher verbosity, for
 
      * debugging purposes *)
 
-    | 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 ^ ")"
 
-    | Type (node, ctype)        when args.verbose >= 3 ->
 
-        str node ^ ":" ^ type2str ctype
 
-    | VarUse (value, ctype, _)  when args.verbose >= 3 ->
 
-        "<use:" ^ type2str ctype ^ ">(" ^ str value ^ ")"
 
-    | FunUse (value, _, _)      when args.verbose >= 3 ->
 
-        "<use>(" ^ str value ^ ")"
 
-
 
-    | Dim (name, _)  -> name
 
+    | VarLet (dec, dims, value, _) when args.verbose >= verbosity_debug ->
 
+        "<let:" ^ node2str (Assign (nameof dec, dims, value, [])) ^ ">"
 
+    | VarUse (dec, dims, _)        when args.verbose >= verbosity_debug ->
 
+        "<use:" ^ node2str (Var (nameof dec, dims, [])) ^ ">"
 
+    | FunUse (dec, params, _)      when args.verbose >= verbosity_debug ->
 
+        "<use:" ^ node2str (FunCall (nameof dec, params, [])) ^ ">"
 
+    | Dim (name, _)                when args.verbose >= verbosity_debug ->
 
+        "<dim:" ^ name ^ ">"
 
+    | ArrayScalar value            when args.verbose >= verbosity_debug ->
 
+        "<scalar:" ^ str value ^ ">"
 
+    | Arg node                     when args.verbose >= verbosity_debug ->
 
+        "<arg:" ^ str node ^ ">"
 
+
 
+    | 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
 
-    | Type (node, _)
 
-    | FunUse (node, _, _)
 
-    | VarLet (node, _, _)
 
-    | VarUse (node, _, _) -> str node
 
+    | Arg node -> str node
 
 
-    | _ -> raise InvalidNode
 
+    | DummyNode -> "<dummy>"
 
 
 (* ctype list -> string *)
 
 let rec types2str = function

+ 12 - 0
test/old/array_dim.cvc
ファイルの表示 

@@ -0,0 +1,12 @@
 
+int dims = 0;
 
+
 
+int dim() {
 
+    dims = dims + 1;
 
+    return 10;
 
+}
 
+/*
 
+void foo() {
 
+   int[10, dim()] arr;
 
+   arr[1, 0] = 1;
 
+}
 
+*/

+ 100 - 69
util.ml
ファイルの表示 

@@ -86,6 +86,10 @@ let transform_children trav node =
 
         Assign (name, None, trav value, loc)
 
     | Assign (name, Some dims, value, loc) ->
 
         Assign (name, Some (trav_all dims), trav value, loc)
 
+    | VarLet (dec, None, value, loc) ->
 
+        VarLet (dec, None, trav value, loc)
 
+    | VarLet (dec, Some dims, value, loc) ->
 
+        VarLet (dec, Some (trav_all dims), trav value, loc)
 
     | Return (value, loc) ->
 
         Return (trav value, loc)
 
     | If (cond, body, loc) ->
 
@@ -117,72 +121,90 @@ let transform_children trav node =
 
         FunCall (name, trav_all args, loc)
 
     | Arg value ->
 
         Arg (trav value)
 
-    | Deref (name, dims, loc) ->
 
-        Deref (name, trav_all dims, loc)
 
 
     | ArrayInit (value, dims) ->
 
         ArrayInit (trav value, dims)
 
     | ArrayScalar value ->
 
         ArrayScalar (trav value)
 
-    | Type (value, ctype) ->
 
-        Type (trav value, ctype)
 
-    | VarLet (assign, def, depth) ->
 
-        VarLet (trav assign, def, depth)
 
-    | VarUse (var, def, depth) ->
 
-        VarUse (trav var, def, depth)
 
-    | FunUse (funcall, def, depth) ->
 
-        FunUse (trav funcall, def, depth)
 
-    | DimDec node ->
 
-        DimDec (trav node)
 
+    | 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
 
 
-(* Default tree transformation
 
- * (node -> node) -> node -> node *)
 
-let rec transform_all trav = function
 
-    | [] -> []
 
-    | node :: tail -> trav node :: (transform_all trav tail)
 
-
 
- let rec locof = function
 
-    | Program (_, loc)
 
-    | Param (_, _, loc)
 
-    | Dim (_, loc)
 
-    | FunDec (_, _, _, loc)
 
-    | FunDef (_, _, _, _, _, loc)
 
-    | GlobalDec (_, _, loc)
 
-    | GlobalDef (_, _, _, _, loc)
 
-    | VarDec (_, _, _, loc)
 
-    | Assign (_, _, _, loc)
 
-    | Return (_, loc)
 
-    | If (_, _, loc)
 
-    | IfElse (_, _, _, loc)
 
-    | While (_, _, loc)
 
-    | DoWhile (_, _, loc)
 
-    | For (_, _, _, _, _, loc)
 
-    | Allocate (_, _, _, loc)
 
-    | BoolConst (_, loc)
 
-    | IntConst (_, loc)
 
-    | FloatConst (_, loc)
 
-    | ArrayConst (_, loc)
 
-    | Var (_, loc)
 
-    | Deref (_, _, loc)
 
-    | Monop (_, _, loc)
 
-    | Binop (_, _, _, loc)
 
-    | Cond (_, _, _, loc)
 
-    | TypeCast (_, _, loc)
 
-    | FunCall (_, _, loc) -> loc
 
+ 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)
 
+    | BoolConst (_, ann)
 
+    | IntConst (_, ann)
 
+    | FloatConst (_, 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
 
-    | VarLet (value, _, _)
 
-    | VarUse (value, _, _)
 
-    | FunUse (value, _, _)
 
-    | Arg value
 
-    | Type (value, _)
 
-    | DimDec value -> locof value
 
+    | Arg value -> annof value
 
 
-    | _ -> noloc
 
+    | _ -> raise InvalidNode
 
+
 
+ let locof node =
 
+     let rec trav = function
 
+         | []            -> noloc
 
+         | Loc loc :: tl -> loc
 
+         | _ :: tl       -> trav tl
 
+     in trav (annof node)
 
+
 
+ let rec depthof node =
 
+     let rec trav = function
 
+         | []                -> raise InvalidNode
 
+         | Depth depth :: tl -> depth
 
+         | _ :: 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
 
+
 
+    (* 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 :: tl -> t
 
+            | _ :: tl      -> trav tl
 
+        in trav (annof node)
 
 
 let prerr_loc (fname, ystart, yend, xstart, xend) =
 
     let file = open_in fname in
 
@@ -221,21 +243,6 @@ let prerr_loc_msg loc msg verbose =
 
     if verbose >= 2 then prerr_loc loc;
 
     ()
 
 
-let ctypeof = function
 
-    | VarDec (ctype, _, _, _)
 
-    | Param (ctype, _, _)
 
-    | FunDec (ctype, _, _, _)
 
-    | FunDef (_, ctype, _, _, _, _)
 
-    | GlobalDec (ctype, _, _)
 
-    | GlobalDef (_, ctype, _, _, _)
 
-    | TypeCast (ctype, _, _)
 
-    | Type (_, ctype)
 
-        -> ctype
 
-
 
-    | Dim _ | DimDec _ -> Int
 
-
 
-    | _ -> raise InvalidNode
 
-
 
 let block_body = function
 
     | Block nodes -> nodes
 
     | _ -> raise InvalidNode
 
@@ -244,10 +251,34 @@ let rec list_size = function
 
     | [] -> 0
 
     | hd :: tl -> 1 + (list_size tl)
 
 
-let base_type = function
 
+let basetypeof node = match typeof node with
 
     | Array (ctype, _)
 
     | ctype -> ctype
 
 
 let array_depth = function
 
     | Array (_, dims) -> list_size dims
 
     | _               -> raise InvalidNode
 
+
 
+let nameof = function
 
+    | 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)
 
+
 
+let optmapl f = function
 
+    | 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

+ 20 - 14
util.mli
ファイルの表示 

@@ -12,40 +12,46 @@ val fresh_var : string -> string
 
 (* Generate a fresg constant from a given prefix, e.g. "foo" -> "foo$$1"  *)
 
 val fresh_const : string -> string
 
 
-(* Generate an Ast.loc tuple from Lexing data structures *)
 
-val loc_from_lexpos : Lexing.position -> Lexing.position -> Ast.loc
 
+(* Generate an Ast.location tuple from Lexing data structures *)
 
+val loc_from_lexpos : Lexing.position -> Lexing.position -> Ast.location
 
 
 (* Default transformation traversal for AST nodes *)
 
 val transform_children : (Ast.node -> Ast.node) -> Ast.node -> Ast.node
 
 
-(* Transform all nodes in a list *)
 
-val transform_all : (Ast.node -> Ast.node) -> Ast.node list -> Ast.node list
 
-
 
 (*val visit_children : (Ast.node -> unit) -> Ast.node -> unit*)
 
 
-(* Extract location from node *)
 
-val locof : Ast.node -> Ast.loc
 
+(* Extract annotation from node *)
 
+val annof   : Ast.node -> Ast.annotation list
 
+val locof   : Ast.node -> Ast.location
 
+val depthof : Ast.node -> int
 
+val typeof  : Ast.node -> Ast.ctype
 
 
 (* Print file location to stderr *)
 
-val prerr_loc : Ast.loc -> unit
 
+val prerr_loc : Ast.location -> unit
 
 
 (* Print file location to stderr *)
 
-val prerr_loc_msg : Ast.loc -> string -> int -> unit
 
+val prerr_loc_msg : Ast.location -> string -> int -> unit
 
 
 (* Flatten Block nodes into the given array of nodes *)
 
 val flatten_blocks : Ast.node list -> Ast.node list
 
 
-(* Get function / expression type *)
 
-val ctypeof : Ast.node -> Ast.ctype
 
-
 
 (* Extract the node list from a Block node *)
 
 val block_body : Ast.node -> Ast.node list
 
 
 (* Get the size of a list by traversing it recurcively *)
 
 val list_size : 'a list -> int
 
 
-(* Get the basic type of a ctype, removing array dimensions *)
 
-val base_type : Ast.ctype -> Ast.ctype
 
+(* Get the basic type of a declaration, removing array dimensions *)
 
+val basetypeof : Ast.node -> Ast.ctype
 
 
 (* Get the number of dimensions from an Array type *)
 
 val array_depth : Ast.ctype -> int
 
+
 
+(* Get name from variable or function declaration *)
 
+val nameof : Ast.node -> string
 
+
 
+val optmap : ('a -> 'b) -> 'a list option -> 'b list option
 
+val optmapl : ('a -> 'b) -> 'a list option -> 'b list
 
+
 
+(* List.mapi clone (only available in OCaml version >= 4.00 *)
 
+val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list