ecomp

+src/_build/default/main.exe
\ No newline at end of file

expr_grammar_action.g

@@ -10,6 +10,9 @@ non-terminals ADD_EXPRS ADD_EXPR
 non-terminals MUL_EXPRS MUL_EXPR
 non-terminals CMP_EXPRS CMP_EXPR
 non-terminals EQ_EXPRS EQ_EXPR
+
+non-terminals AFTER_IDENTIFIER LARGS REST_ARGS
+
 axiom S
 {
 
@@ -20,13 +23,94 @@ axiom S
   open Batteries
   open Utils
 
+  type after_id =
+  | Assign of tree
+  | Funcall of tree list
+  | Nothing
+
   (* TODO *)
-  let resolve_associativity term other =
+  let rec resolve_associativity (term : tree) (other : (tag * tree) list) =
        (* TODO *)
-    term
+      match List.rev other with
+      | [] -> term
+      | (high_tag, right_side)::rest -> Node(high_tag, [resolve_associativity term (List.rev rest); right_side])
+}
 
+rules
+S -> FUNDEFS SYM_EOF { Node(Tlistglobdef, $1) }
+FUNDEFS -> FUNDEF FUNDEFS { $1::$2 }
+FUNDEFS -> { [] }
+FUNDEF -> IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS INSTR { Node(Tfundef, [Node(Tfunname, [$1]); Node(Tfunargs, $3); Node(Tfunbody, [$5])]) }
 
+LPARAMS -> IDENTIFIER REST_PARAMS { Node(Targ, [$1])::$2 }
+LPARAMS -> { [] }
+REST_PARAMS -> SYM_COMMA LPARAMS { $2 }
+REST_PARAMS -> { [] }
+
+LARGS -> EXPR REST_ARGS { $1::$2 }
+LARGS -> { [] }
+REST_ARGS -> SYM_COMMA LARGS { $2 }
+REST_ARGS -> { [] }
+
+LINSTRS -> INSTR INSTRS { Node(Tblock, $1::$2) }
+LINSTRS -> { NullLeaf }
+INSTRS -> INSTR INSTRS { $1::$2 }
+INSTRS -> { [] }
+
+INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_LBRACE LINSTRS SYM_RBRACE ELSE { Node(Tif, [$3; $6; $8]) }
+INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS INSTR { Node(Twhile, [$3; $5]) }
+INSTR -> SYM_RETURN EXPR SYM_SEMICOLON { Node(Treturn, [$2]) }
+INSTR -> SYM_PRINT SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS SYM_SEMICOLON { Node(Tprint, [$3]) }
+INSTR -> IDENTIFIER AFTER_IDENTIFIER SYM_SEMICOLON { 
+  match $2 with
+  | Assign exp -> Node(Tassign, [$1; exp]) 
+  | Funcall args -> Node(Tcall, [$1; Node(Targs, args)]) 
+  | _ -> $1 
 }
+INSTR -> SYM_LBRACE LINSTRS SYM_RBRACE { $2 }
 
-rules
-S -> FUNDEFS SYM_EOF {  Node (Tlistglobdef, []) }
+AFTER_IDENTIFIER -> SYM_ASSIGN EXPR { Assign $2 }
+AFTER_IDENTIFIER -> SYM_LPARENTHESIS LARGS SYM_RPARENTHESIS { Funcall $2 }
+AFTER_IDENTIFIER -> { Nothing }
+
+ELSE -> SYM_ELSE SYM_LBRACE LINSTRS SYM_RBRACE { $3 }
+ELSE -> { NullLeaf }
+
+EXPR -> EQ_EXPR EQ_EXPRS { resolve_associativity $1 $2 }
+EQ_EXPR -> CMP_EXPR CMP_EXPRS { resolve_associativity $1 $2 }
+CMP_EXPR -> ADD_EXPR ADD_EXPRS { resolve_associativity $1 $2 }
+ADD_EXPR -> MUL_EXPR MUL_EXPRS { resolve_associativity $1 $2 }
+ADD_EXPR -> SYM_MINUS MUL_EXPR MUL_EXPRS { resolve_associativity (Node(Tneg, [$2])) $3 }
+ADD_EXPR -> SYM_PLUS MUL_EXPR MUL_EXPRS { resolve_associativity $2 $3 }
+MUL_EXPR -> FACTOR { $1 }
+
+EQ_EXPRS -> SYM_EQUALITY EQ_EXPR EQ_EXPRS { (Tceq, $2)::$3 } 
+EQ_EXPRS -> SYM_NOTEQ EQ_EXPR EQ_EXPRS { (Tne, $2)::$3 } 
+EQ_EXPRS -> { [] } 
+
+CMP_EXPRS -> SYM_LT CMP_EXPR CMP_EXPRS { (Tclt, $2)::$3 } 
+CMP_EXPRS -> SYM_LEQ CMP_EXPR CMP_EXPRS { (Tcle, $2)::$3 } 
+CMP_EXPRS -> SYM_GT CMP_EXPR CMP_EXPRS { (Tcgt, $2)::$3 }
+CMP_EXPRS -> SYM_GEQ CMP_EXPR CMP_EXPRS { (Tcge, $2)::$3 } 
+CMP_EXPRS -> { [] } 
+
+ADD_EXPRS -> SYM_PLUS ADD_EXPR ADD_EXPRS { (Tadd, $2)::$3 } 
+ADD_EXPRS -> SYM_MINUS ADD_EXPR ADD_EXPRS { (Tsub, $2)::$3 }
+ADD_EXPRS -> { [] } 
+
+MUL_EXPRS -> SYM_ASTERISK MUL_EXPR MUL_EXPRS { (Tmul, $2)::$3 }
+MUL_EXPRS -> SYM_DIV MUL_EXPR MUL_EXPRS { (Tdiv, $2)::$3 } 
+MUL_EXPRS -> SYM_MOD MUL_EXPR MUL_EXPRS { (Tmod, $2)::$3 } 
+MUL_EXPRS -> { [] }
+
+FACTOR -> INTEGER { $1 }
+FACTOR -> IDENTIFIER AFTER_IDENTIFIER { 
+  match $2 with
+  | Funcall args -> Node(Tcall, [$1; Node(Targs, args)])
+  | Nothing -> $1
+  | _ -> $1
+}
+FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS { $2 }
+
+IDENTIFIER -> SYM_IDENTIFIER {StringLeaf $1}
+INTEGER -> SYM_INTEGER {IntLeaf $1}

src/ast.ml

@@ -28,9 +28,9 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
          | Tclt | Tcgt | Tcle | Tcge | Tceq | Tne
          | Tneg
          | Tlistglobdef
-         | Tfundef | Tfunname | Tfunargs | Tfunbody
+         | Tfundef | Tfunname | Tfunargs | Tfunbody | Tcall
          | Tassignvar
-         | Targ
+         | Targ | Targs
 
 type tree = | Node of tag * tree list
             | StringLeaf of string
@@ -73,7 +73,8 @@ let string_of_tag = function
   | Tfunbody -> "Tfunbody"
   | Tassignvar -> "Tassignvar"
   | Targ -> "Targ"
-
+  | Tcall -> "Tcall"
+  | Targs -> "Targs"
 
 (* Écrit un fichier .dot qui correspond à un AST *)
 let rec draw_ast a next =

src/cfg.ml

@@ -8,6 +8,7 @@ type expr =
   | Eunop of unop * expr
   | Eint of int
   | Evar of string
+  | Ecall of string * expr list
 
 type cfg_node =
   | Cassign of string * expr * int
@@ -15,6 +16,7 @@ type cfg_node =
   | Cprint of expr * int
   | Ccmp of expr * int * int
   | Cnop of int
+  | Ccall of string * expr list * int
 
 type cfg_fun = {
   cfgfunargs: string list;
@@ -35,7 +37,7 @@ let succs cfg n =
   | Some (Creturn _) -> Set.empty
   | Some (Ccmp (_, s1, s2)) -> Set.of_list [s1;s2]
   | Some (Cnop s) -> Set.singleton s
-
+  | Some (Ccall (_, _, s)) -> Set.singleton s
 
 (* [preds cfg n] donne l'ensemble des prédécesseurs d'un nœud [n] dans un CFG [cfg]
    *)
@@ -44,7 +46,8 @@ let preds cfgfunbody n =
       match m' with
       | Cassign (_, _, s)
       | Cprint (_, s)
-      | Cnop s -> if s = n then Set.add m acc else acc
+      | Cnop s 
+      | Ccall (_, _, s) -> if s = n then Set.add m acc else acc
       | Creturn _ -> acc
       | Ccmp (_, s1, s2) -> if s1 = n || s2 = n then Set.add m acc else acc
     ) cfgfunbody Set.empty
@@ -62,6 +65,7 @@ let rec size_expr (e: expr) : int =
   | Eunop (u, e) -> size_unop u (size_expr e)
   | Eint _ -> 1
   | Evar _ -> 1
+  | Ecall (_, args) -> 1 + List.fold_left (fun acc arg -> acc + size_expr arg) 0 args
 
 let size_instr (i: cfg_node) : int =
   match (i : cfg_node) with
@@ -70,6 +74,7 @@ let size_instr (i: cfg_node) : int =
   | Cprint (e, _) -> 1 + (size_expr e)
   | Ccmp (e, _, _) -> 1 + size_expr e
   | Cnop _ -> 1
+  | Ccall (_, args, _) -> 1 + List.fold_left (fun acc arg -> acc + size_expr arg) 0 args
 
 let size_fun f =
   Hashtbl.fold (fun _ v acc -> acc + size_instr v) f 0

src/cfg_dead_assign.ml

@@ -14,22 +14,25 @@ open Options
    nouvelle fonction, et [c] est un booléen qui indique si du progrès a été
    fait. *)
 let dead_assign_elimination_fun ({ cfgfunbody; _ } as f: cfg_fun) =
-  let changed = ref false in
-  let cfgfunbody =
-    Hashtbl.map (fun (n: int) (m: cfg_node) ->
-        match m with
-           (* TODO *)
-        | _ -> m
-      ) cfgfunbody in
-  ({ f with cfgfunbody }, !changed )
+  let changed = ref false 
+    in let lives_in = live_cfg_fun f 
+      in let lives_out n = live_after_node cfgfunbody n lives_in
+        in let cfgfunbody =
+        Hashtbl.map (fun (n: int) (m: cfg_node) ->
+            match m with
+              (* TODO *)
+            | Cassign (s, e, i) -> if (Set.mem s (lives_out n)) then m else (changed := true; Cnop i)
+            | _ -> m
+          ) cfgfunbody
+          in ({ f with cfgfunbody }, !changed )
 
 (* Applique l'élimination de code mort autant de fois que nécessaire. Testez
    notamment sur le fichier de test [basic/useless_assigns.e]. *)
 let rec iter_dead_assign_elimination_fun f =
   let f, c = dead_assign_elimination_fun f in
-   (* TODO *)
-   f
-
+    (* TODO *)
+    if c then iter_dead_assign_elimination_fun f else f
+    
 let dead_assign_elimination_gdef = function
     Gfun f -> Gfun (iter_dead_assign_elimination_fun f)
 

src/cfg_gen.ml

@@ -25,6 +25,9 @@ let rec cfg_expr_of_eexpr (e: Elang.expr) : expr res =
   | Elang.Eint i -> OK (Eint i)
   | Elang.Evar v ->
     OK (Evar v)
+  | Elang.Ecall (f, args) -> 
+    list_map_res cfg_expr_of_eexpr args >>= fun es ->
+    OK (Ecall (f, es))
 
 (* [cfg_node_of_einstr next cfg succ i] builds the CFG node(s) that correspond
    to the E instruction [i].
@@ -70,6 +73,11 @@ let rec cfg_node_of_einstr (next: int) (cfg : (int, cfg_node) Hashtbl.t)
     cfg_expr_of_eexpr e >>= fun e ->
     Hashtbl.replace cfg next (Cprint (e,succ));
     OK (next, next + 1)
+  | Elang.Icall (f, args) ->
+    list_map_res cfg_expr_of_eexpr args >>= fun es ->
+    Hashtbl.replace cfg next (Ccall (f, es, succ));
+    OK (next, next + 1)
+    
 
 (* Some nodes may be unreachable after the CFG is entirely generated. The
    [reachable_nodes n cfg] constructs the set of node identifiers that are
@@ -86,6 +94,7 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
       | Some (Creturn _) -> reach
       | Some (Ccmp (_, s1, s2)) ->
         reachable_aux s1 (reachable_aux s2 reach)
+      | Some (Ccall (_, _, succ)) -> reachable_aux succ reach
   in reachable_aux n Set.empty
 
 (* [cfg_fun_of_efun f] builds the CFG for E function [f]. *)

src/cfg_liveness.ml

 open Batteries
 open Cfg
+open Utils
 
 (* Analyse de vivacité *)
 
 (* [vars_in_expr e] renvoie l'ensemble des variables qui apparaissent dans [e]. *)
 let rec vars_in_expr (e: expr) =
    (* TODO *)
-   Set.empty
+   match e with
+   | Eint i -> Set.empty
+   | Evar s -> Set.singleton s
+   | Ebinop (b, e1, e2) -> Set.union (vars_in_expr e1) (vars_in_expr e2)
+   | Eunop (u, e) -> vars_in_expr e
+   | Ecall (f, args) -> set_concat (List.map vars_in_expr args)
 
 (* [live_after_node cfg n] renvoie l'ensemble des variables vivantes après le
    nœud [n] dans un CFG [cfg]. [lives] est l'état courant de l'analyse,
@@ -14,14 +20,27 @@ let rec vars_in_expr (e: expr) =
    les valeurs sont les ensembles de variables vivantes avant chaque nœud. *)
 let live_after_node cfg n (lives: (int, string Set.t) Hashtbl.t) : string Set.t =
    (* TODO *)
-   Set.empty
-
+   let in_succs_opt = Set.map (fun s -> Hashtbl.find_opt lives s) (succs cfg n)
+      in let in_succs = Set.filter_map (fun s -> s) in_succs_opt
+         in set_concat (Set.to_list in_succs) 
 (* [live_cfg_node node live_after] renvoie l'ensemble des variables vivantes
    avant un nœud [node], étant donné l'ensemble [live_after] des variables
    vivantes après ce nœud. *)
 let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
    (* TODO *)
-   live_after
+   let use node = 
+         match node with
+         | Cassign (s, e, i) -> vars_in_expr e
+         | Creturn e -> vars_in_expr e
+         | Cprint (e, i) -> vars_in_expr e
+         | Ccmp (e, i1, i2) -> vars_in_expr e
+         | Cnop (i) -> Set.empty
+         | Ccall (f, args, i) -> vars_in_expr (Ecall (f, args))
+      in let def node =
+            match node with
+            | Cassign (s, e, i) -> Set.singleton s
+            | _ -> Set.empty
+         in Set.union (use node) (Set.diff live_after (def node))
 
 (* [live_cfg_nodes cfg lives] effectue une itération du calcul de point fixe.
 
@@ -31,12 +50,22 @@ let live_cfg_node (node: cfg_node) (live_after: string Set.t) =
    nœud a changé). *)
 let live_cfg_nodes cfg (lives : (int, string Set.t) Hashtbl.t) =
    (* TODO *)
-   false
+   let changed = ref false in
+      Hashtbl.iter (fun n node -> 
+         let new_alive_vars = live_cfg_node node (live_after_node cfg n lives)
+            in match Hashtbl.find_opt lives n with
+            | None -> changed := true; Hashtbl.replace lives n new_alive_vars
+            | Some alive_vars -> if not (Set.equal alive_vars new_alive_vars) then changed := true; Hashtbl.replace lives n new_alive_vars) cfg; !changed
+
 
 (* [live_cfg_fun f] calcule l'ensemble des variables vivantes avant chaque nœud
    du CFG en itérant [live_cfg_nodes] jusqu'à ce qu'un point fixe soit atteint.
    *)
 let live_cfg_fun (f: cfg_fun) : (int, string Set.t) Hashtbl.t =
-  let lives = Hashtbl.create 17 in
+   let lives = Hashtbl.create 17 in
      (* TODO *)
- lives
+      let cfg = f.cfgfunbody
+         in while live_cfg_nodes cfg lives do 
+            ()
+         done; 
+         lives

src/cfg_nop_elim.ml

@@ -15,7 +15,9 @@ open Options
 *)
 let nop_transitions (cfgfunbody: (int, cfg_node) Hashtbl.t) : (int * int) list =
    (* TODO *)
-   []
+   Hashtbl.fold (fun n node acc -> match node with
+            | Cnop i -> (n, i)::acc
+            | _ -> acc) cfgfunbody []
 
 
 (* [follow n l visited] donne le premier successeur à partir de [n] qui ne soit
@@ -26,9 +28,13 @@ let nop_transitions (cfgfunbody: (int, cfg_node) Hashtbl.t) : (int * int) list =
 
    L'ensemble [visited] est utilisé pour éviter les boucles.
    *)
-let rec follow (n: int) (l: (int * int) list) (visited: int Set.t) : int =
+let rec follow (nop: int) (l: (int * int) list) (visited: int Set.t) : int =
    (* TODO *)
-   n
+   if Set.mem nop visited 
+      then nop 
+      else match List.assoc_opt nop l with
+      | None -> nop
+      | Some m -> follow m l (Set.add nop visited)
 
 (* [nop_transitions_closed] contient la liste [(n,s)] telle que l'instruction au
    nœud [n] est le début d'une chaîne de NOPs qui termine au nœud [s]. Les
@@ -48,13 +54,21 @@ let nop_transitions_closed cfgfunbody =
    liste [nop_succs] (telle que renvoyée par [nop_transitions_closed]). *)
 let replace_succ nop_succs s =
    (* TODO *)
-   s
+   match List.assoc_opt s nop_succs with
+   | None -> s
+   | Some x -> x
 
 (* [replace_succs nop_succs n] remplace le nœud [n] par un nœud équivalent où on
    a remplacé les successeurs, en utilisant la liste [nop_succs]. *)
 let replace_succs nop_succs (n: cfg_node) =
    (* TODO *)
-   n
+   match n with
+   | Cassign (s, e, i) -> Cassign (s, e, replace_succ nop_succs i)
+   | Cprint (e, i) -> Cprint (e, replace_succ nop_succs i)
+   | Ccmp (e, i1, i2) -> Ccmp (e, replace_succ nop_succs i1, replace_succ nop_succs i2)
+   | Cnop i -> Cnop (replace_succ nop_succs i)
+   | Creturn e -> Creturn e
+   | Ccall (f, args, i) -> Ccall (f, args, replace_succ nop_succs i)
 
 (* [nop_elim_fun f] applique la fonction [replace_succs] à chaque nœud du CFG. *)
 let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
@@ -67,13 +81,18 @@ let nop_elim_fun ({ cfgfunargs; cfgfunbody; cfgentry } as f: cfg_fun) =
      (inaccessibles), et appliquer la fonction [replace_succs] aux nœuds qui
      resteront.
   *)
-  let cfgfunbody = Hashtbl.filter_map (fun n node ->
          (* TODO *)
-         Some node
-    ) cfgfunbody in
+   let cfgfunbody_corr_links = Hashtbl.map (fun n node ->
+      replace_succs nop_transf node
+   ) cfgfunbody
+   in let cfgfunbody_wout_inacc = Hashtbl.filter_map (fun n node ->
+      match node with
+      | Cnop i -> None
+      | _ -> if Set.is_empty (preds cfgfunbody_corr_links n) && n!=cfgentry then None else Some node
+   ) cfgfunbody_corr_links in
   (* La fonction renvoyée est composée du nouveau [cfgfunbody] que l'on vient de
      calculer, et le point d'entrée est transformé en conséquence. *)
-  {f with cfgfunbody; cfgentry = replace_succ nop_transf cfgentry }
+  {f with cfgfunbody=cfgfunbody_wout_inacc; cfgentry = replace_succ nop_transf cfgentry }
 
 let nop_elim_gdef gd =
   match gd with

src/cfg_print.ml

@@ -8,6 +8,7 @@ let rec dump_cfgexpr : expr -> string = function
   | Eunop(u, e) -> Format.sprintf "(%s %s)" (dump_unop u) (dump_cfgexpr e)
   | Eint i -> Format.sprintf "%d" i
   | Evar s -> Format.sprintf "%s" s
+  | Ecall (f, args) -> Format.sprintf "%s(%s)" f (String.concat ", " (List.map dump_cfgexpr args))
 
 let dump_list_cfgexpr l =
   l |> List.map dump_cfgexpr |> String.concat ", "
@@ -17,7 +18,8 @@ let dump_arrows oc fname n (node: cfg_node) =
   match node with
   | Cassign (_, _, succ)
   | Cprint (_, succ)
-  | Cnop succ ->
+  | Cnop succ 
+  | Ccall (_, _, succ) ->
     Format.fprintf oc "n_%s_%d -> n_%s_%d\n" fname n fname succ
   | Creturn _ -> ()
   | Ccmp (_, succ1, succ2) ->
@@ -32,7 +34,7 @@ let dump_cfg_node oc (node: cfg_node) =
   | Creturn e -> Format.fprintf oc "return %s" (dump_cfgexpr e)
   | Ccmp (e, _, _) -> Format.fprintf oc "%s" (dump_cfgexpr e)
   | Cnop _ -> Format.fprintf oc "nop"
-
+  | Ccall (f, args, _) -> Format.fprintf oc "%s(%s)" f (String.concat ", " (List.map dump_cfgexpr args))
 
 let dump_liveness_state oc ht state =
   Hashtbl.iter (fun n cn ->

src/cfg_run.ml

@@ -7,52 +7,81 @@ open Cfg
 open Utils
 open Builtins
 
-let rec eval_cfgexpr st (e: expr) : int res =
+let rec eval_cfgexpr oc st cp (e: expr) : (int * int state) res =
   match e with
   | Ebinop(b, e1, e2) ->
-    eval_cfgexpr st e1 >>= fun v1 ->
-    eval_cfgexpr st e2 >>= fun v2 ->
+    eval_cfgexpr oc st cp e1 >>= fun (v1, st') ->
+    eval_cfgexpr oc st' cp e2 >>= fun (v2, st'') ->
     let v = eval_binop b v1 v2 in
-    OK v
+    OK (v, st'')
   | Eunop(u, e) ->
-    eval_cfgexpr st e >>= fun v1 ->
+    eval_cfgexpr oc st cp e >>= fun (v1, st') ->
     let v = (eval_unop u v1) in
-    OK v
-  | Eint i -> OK i
+    OK (v, st')
+  | Eint i -> OK (i, st)
   | Evar s ->
     begin match Hashtbl.find_option st.env s with
-      | Some v -> OK v
+      | Some v -> OK (v, st)
       | None -> Error (Printf.sprintf "Unknown variable %s\n" s)
     end
-
-let rec eval_cfginstr oc st ht (n: int): (int * int state) res =
+  | Ecall (f, args) ->
+      List.fold_left (
+        fun (acc : (int list * int state) res) (arg : expr) -> 
+        match acc with
+        | Error msg -> Error msg
+        | OK (l, st') -> 
+            match eval_cfgexpr oc st' cp arg with
+            | Error msg -> Error msg
+            | OK (i, st'') -> OK ((l@[i]), st'')
+              ) (OK([], st)) args >>= fun (int_args, st') ->
+                find_function cp f >>= fun found_f ->
+                  match eval_cfgfun oc st' cp f found_f int_args with
+                  | Error msg -> Error msg
+                  | OK (None, st'') -> Error (Format.sprintf "CFG: Function %s doesn't have a return value.\n" f)
+                  | OK (Some ret, st'') -> OK (ret, st'')
+  
+and eval_cfginstr oc st cp ht (n: int): (int * int state) res =
   match Hashtbl.find_option ht n with
   | None -> Error (Printf.sprintf "Invalid node identifier\n")
   | Some node ->
     match node with
     | Cnop succ ->
-      eval_cfginstr oc st ht succ
+      eval_cfginstr oc st cp ht succ
     | Cassign(v, e, succ) ->
-      eval_cfgexpr st e >>= fun i ->
-      Hashtbl.replace st.env v i;
-      eval_cfginstr oc st ht succ
+      eval_cfgexpr oc st cp e >>= fun (i, st') ->
+      Hashtbl.replace st'.env v i;
+      eval_cfginstr oc st' cp ht succ
     | Ccmp(cond, i1, i2) ->
-      eval_cfgexpr st cond >>= fun i ->
-      if i = 0 then eval_cfginstr oc st ht i2 else eval_cfginstr oc st ht i1
+      eval_cfgexpr oc st cp cond >>= fun (i, st') ->
+      if i = 0 then eval_cfginstr oc st' cp ht i2 else eval_cfginstr oc st' cp ht i1
     | Creturn(e) ->
-      eval_cfgexpr st e >>= fun e ->
-      OK (e, st)
+      eval_cfgexpr oc st cp e >>= fun (e, st') ->
+      OK (e, st')
     | Cprint(e, succ) ->
-      eval_cfgexpr st e >>= fun e ->
+      eval_cfgexpr oc st cp e >>= fun (e, st') ->
       Format.fprintf oc "%d\n" e;
-      eval_cfginstr oc st ht succ
+      eval_cfginstr oc st' cp ht succ
+    | Ccall (f, args, succ) ->
+      List.fold_left (
+        fun (acc : (int list * int state) res) (arg : expr) -> 
+        match acc with
+        | Error msg -> Error msg
+        | OK (l, st') -> 
+            match eval_cfgexpr oc st' cp arg with
+            | Error msg -> Error msg
+            | OK (i, st'') -> OK ((l@[i]), st'')
+              ) (OK([], st)) args 
+              >>= fun (int_args, st') ->
+              find_function cp f >>= fun found_f ->
+              eval_cfgfun oc st' cp f found_f int_args >>= fun (ret, st'') -> 
+              eval_cfginstr oc st'' cp ht succ
 
-let eval_cfgfun oc st cfgfunname { cfgfunargs;
+and eval_cfgfun oc st cp cfgfunname { cfgfunargs;
                                       cfgfunbody;
                                       cfgentry} vargs =
   let st' = { st with env = Hashtbl.create 17 } in
   match List.iter2 (fun a v -> Hashtbl.replace st'.env a v) cfgfunargs vargs with
-  | () -> eval_cfginstr oc st' cfgfunbody cfgentry >>= fun (v, st') ->
+  | () -> eval_cfginstr oc st' cp cfgfunbody cfgentry >>= fun (v, st') ->
     OK (Some v, {st' with env = st.env})
   | exception Invalid_argument _ ->
     Error (Format.sprintf "CFG: Called function %s with %d arguments, expected %d.\n"
@@ -64,7 +93,7 @@ let eval_cfgprog oc cp memsize params =
   find_function cp "main" >>= fun f ->
   let n = List.length f.cfgfunargs in
   let params = take n params in
-  eval_cfgfun oc st "main" f params >>= fun (v, st) ->
+  eval_cfgfun oc st cp "main" f params >>= fun (v, st) ->
   OK v
 
 

src/e_regexp.ml

@@ -69,35 +69,35 @@ let list_regexp : (regexp * (string -> token option)) list =
     (keyword_regexp "while",    fun _ -> Some (SYM_WHILE));
     (keyword_regexp "int", fun _ -> Some (SYM_INT));
     (* begin TODO *)
-    (Eps,       fun _ -> Some (SYM_VOID));
-    (Eps,       fun _ -> Some (SYM_CHAR));
-    (Eps,       fun _ -> Some (SYM_IF));
-    (Eps,       fun _ -> Some (SYM_ELSE));
-    (Eps,       fun _ -> Some (SYM_RETURN));
-    (Eps,       fun _ -> Some (SYM_PRINT));
-    (Eps,       fun _ -> Some (SYM_STRUCT));
-    (Eps,       fun _ -> Some (SYM_POINT));
-    (Eps,       fun _ -> Some (SYM_PLUS));
-    (Eps,       fun _ -> Some (SYM_MINUS));
-    (Eps,       fun _ -> Some (SYM_ASTERISK));
-    (Eps,       fun _ -> Some (SYM_DIV));
-    (Eps,       fun _ -> Some (SYM_MOD));
-    (Eps,       fun _ -> Some (SYM_LBRACE));
-    (Eps,       fun _ -> Some (SYM_RBRACE));
-    (Eps,       fun _ -> Some (SYM_LBRACKET));
-    (Eps,       fun _ -> Some (SYM_RBRACKET));
-    (Eps,       fun _ -> Some (SYM_LPARENTHESIS));
-    (Eps,       fun _ -> Some (SYM_RPARENTHESIS));
-    (Eps,       fun _ -> Some (SYM_SEMICOLON));
-    (Eps,       fun _ -> Some (SYM_COMMA));
-    (Eps,       fun _ -> Some (SYM_ASSIGN));
-    (Eps,       fun _ -> Some (SYM_EQUALITY));
-    (Eps,       fun _ -> Some (SYM_NOTEQ));
-    (Eps,       fun _ -> Some (SYM_LT));
-    (Eps,       fun _ -> Some (SYM_GT));
-    (Eps,       fun _ -> Some (SYM_LEQ));
-    (Eps,       fun _ -> Some (SYM_GEQ));
-    (Eps,       fun s -> Some (SYM_IDENTIFIER s));
+    (keyword_regexp "void",       fun _ -> Some (SYM_VOID));
+    (keyword_regexp "void",       fun _ -> Some (SYM_CHAR));
+    (keyword_regexp "if",       fun _ -> Some (SYM_IF));
+    (keyword_regexp "else",       fun _ -> Some (SYM_ELSE));
+    (keyword_regexp "return",       fun _ -> Some (SYM_RETURN));
+    (keyword_regexp "print",       fun _ -> Some (SYM_PRINT));
+    (keyword_regexp "struct",       fun _ -> Some (SYM_STRUCT));
+    (char_regexp '.',       fun _ -> Some (SYM_POINT));
+    (char_regexp '+',       fun _ -> Some (SYM_PLUS));
+    (char_regexp '-',       fun _ -> Some (SYM_MINUS));
+    (char_regexp '*',       fun _ -> Some (SYM_ASTERISK));
+    (char_regexp '/',       fun _ -> Some (SYM_DIV));
+    (char_regexp '%',       fun _ -> Some (SYM_MOD));
+    (char_regexp '{',       fun _ -> Some (SYM_LBRACE));
+    (char_regexp '}',       fun _ -> Some (SYM_RBRACE));
+    (char_regexp '[',       fun _ -> Some (SYM_LBRACKET));
+    (char_regexp ']',       fun _ -> Some (SYM_RBRACKET));
+    (char_regexp '(',       fun _ -> Some (SYM_LPARENTHESIS));
+    (char_regexp ')',       fun _ -> Some (SYM_RPARENTHESIS));
+    (char_regexp ';',       fun _ -> Some (SYM_SEMICOLON));
+    (char_regexp ',',       fun _ -> Some (SYM_COMMA));
+    (char_regexp '=',       fun _ -> Some (SYM_ASSIGN));
+    (Cat(char_regexp '=', char_regexp '='),       fun _ -> Some (SYM_EQUALITY));
+    (Cat(char_regexp '!', char_regexp '='),       fun _ -> Some (SYM_NOTEQ));
+    (char_regexp '<',       fun _ -> Some (SYM_LT));
+    (char_regexp '>',       fun _ -> Some (SYM_GT));
+    (Cat(char_regexp '<', char_regexp '='),       fun _ -> Some (SYM_LEQ));
+    (Cat(char_regexp '>', char_regexp '='),       fun _ -> Some (SYM_GEQ));
+    (Cat(Alt(letter_regexp, char_regexp '_'), Star identifier_material),       fun s -> Some (SYM_IDENTIFIER s));
     (* end TODO *)
     (Cat(keyword_regexp "//",
          Cat(Star (char_range (List.filter (fun c -> c <> '\n') alphabet)),

src/elang.ml

@@ -9,6 +9,7 @@ type expr =
   | Eunop of unop * expr
   | Eint of int
   | Evar of string
+  | Ecall of string * expr list
 
 type instr =
   | Iassign of string * expr
@@ -17,6 +18,7 @@ type instr =
   | Iblock of instr list
   | Ireturn of expr
   | Iprint of expr
+  | Icall of string * expr list
 
 type efun = {
   funargs: ( string ) list;

src/elang_gen.ml

@@ -44,10 +44,28 @@ let binop_of_tag =
 let rec make_eexpr_of_ast (a: tree) : expr res =
   let res =
     match a with
+    (* TODO *)
+    | IntLeaf i -> OK (Eint i)
+    | StringLeaf s -> OK (Evar s) 
     | Node(t, [e1; e2]) when tag_is_binop t ->
-         Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
-                        (string_of_ast a))
-    | _ -> Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
+        (let res1 = make_eexpr_of_ast e1
+          in let res2 = make_eexpr_of_ast e2
+            in match res1, res2 with
+            | Error msg, _ -> Error msg
+            | _, Error msg -> Error msg
+            | OK expr1, OK expr2 -> OK (Ebinop (binop_of_tag t, expr1, expr2)))
+    | Node(Tneg, [e]) -> 
+        (let res = make_eexpr_of_ast e
+          in match res with
+          | Error msg -> Error msg
+          | OK expr -> OK (Eunop (Eneg, expr)))
+    | Node(Tcall, [StringLeaf f; Node(Targs, args)]) -> 
+        (let res = list_map_res make_eexpr_of_ast args 
+          in match res with
+          | Error msg -> Error msg
+          | OK exprs -> OK (Ecall (f, exprs)))
+    | _ -> 
+        Error (Printf.sprintf "Unacceptable ast in make_eexpr_of_ast %s"
                     (string_of_ast a))
   in
   match res with
@@ -59,6 +77,48 @@ let rec make_einstr_of_ast (a: tree) : instr res =
   let res =
     match a with
     (* TODO *)
+    | Node(Tassign, [StringLeaf s; e]) -> 
+      (let res_of_e = make_eexpr_of_ast e 
+        in match res_of_e with 
+        | OK exp -> OK (Iassign (s, exp))
+        | Error msg -> Error msg)
+    | Node(Tif, [e; i1; i2]) -> 
+      (let res_of_e = make_eexpr_of_ast e
+        in let res_of_i1 = make_einstr_of_ast i1
+          in let res_of_i2 = make_einstr_of_ast i2
+            in match res_of_e, res_of_i1, res_of_i2 with 
+            | Error msg, _, _ -> Error msg
+            | _, Error msg, _ -> Error msg
+            | _, _, Error msg -> Error msg
+            | OK exp, OK inst1, OK inst2 -> OK (Iif (exp, inst1, inst2)))
+    | Node(Twhile, [e; i]) -> 
+      (let res_of_e = make_eexpr_of_ast e
+        in let res_of_i = make_einstr_of_ast i
+          in match res_of_e, res_of_i with 
+          | Error msg, _ -> Error msg
+          | _, Error msg -> Error msg
+          | OK exp, OK inst-> OK (Iwhile (exp, inst)))
+    | Node(Tblock, i_list) -> 
+      (let res_of_i_list = list_map_res make_einstr_of_ast i_list
+        in match res_of_i_list with
+        | Error msg -> Error msg
+        | OK instr_list -> OK (Iblock instr_list))
+    | Node(Treturn, [e]) -> 
+      (let res_of_e = make_eexpr_of_ast e 
+        in match res_of_e with 
+        | OK exp -> OK (Ireturn exp)
+        | Error msg -> Error msg)
+    | Node(Tprint, [e]) -> 
+      (let res_of_e = make_eexpr_of_ast e 
+        in match res_of_e with 
+        | OK exp -> OK (Iprint exp)
+        | Error msg -> Error msg)
+    | Node(Tcall, [StringLeaf f; Node(Targs, args)]) -> 
+      (let res = list_map_res make_eexpr_of_ast args 
+        in match res with
+        | Error msg -> Error msg
+        | OK exprs -> OK (Icall (f, exprs)))
+    | NullLeaf -> OK (Iblock [])
     | _ -> Error (Printf.sprintf "Unacceptable ast in make_einstr_of_ast %s"
                     (string_of_ast a))
   in
@@ -76,10 +136,11 @@ let make_ident (a: tree) : string res =
 
 let make_fundef_of_ast (a: tree) : (string * efun) res =
   match a with
-  | Node (Tfundef, [StringLeaf fname; Node (Tfunargs, fargs); fbody]) ->
+  | Node (Tfundef, [Node(Tfunname, [StringLeaf fname]); Node (Tfunargs, fargs); Node(Tfunbody, [fbody])]) ->
     list_map_res make_ident fargs >>= fun fargs ->
      (* TODO *)
-     Error "make_fundef_of_ast: Not implemented, yet."
+      make_einstr_of_ast fbody >>= fun fbody ->
+        OK (fname, {funargs = fargs; funbody = fbody})
   | _ ->
     Error (Printf.sprintf "make_fundef_of_ast: Expected a Tfundef, got %s."
              (string_of_ast a))

src/elang_print.ml

@@ -26,6 +26,7 @@ let rec dump_eexpr = function
   | Eunop(u, e) -> Printf.sprintf "(%s %s)" (dump_unop u) (dump_eexpr e)
   | Eint i -> Printf.sprintf "%d" i
   | Evar s -> Printf.sprintf "%s" s
+  | Ecall (f, args) -> Printf.sprintf "%s(%s)" f (String.concat ", " (List.map dump_eexpr args))
 
 let indent_size = 2
 let spaces n =
@@ -58,6 +59,10 @@ let rec dump_einstr_rec indent oc i =
   | Iprint(e) ->
     print_spaces oc indent;
     Format.fprintf oc "print %s;\n" (dump_eexpr e)
+  | Icall(f, args) ->
+    print_spaces oc indent;
+    Format.fprintf oc "%s(%s);\n" f (String.concat ", " (List.map dump_eexpr args))
+
 
 let dump_einstr oc i = dump_einstr_rec 0 oc i
 

src/elang_run.ml

@@ -9,18 +9,70 @@ let binop_bool_to_int f x y = if f x y then 1 else 0
    et [y]. *)
 let eval_binop (b: binop) : int -> int -> int =
   match b with
-   | _ -> fun x y -> 0
+   | Eadd -> fun x y -> x + y
+   | Emul -> fun x y -> x * y
+   | Emod -> fun x y -> x mod y
+   | Exor -> fun x y -> x lxor y
+   | Ediv -> fun x y -> x / y
+   | Esub -> fun x y -> x - y
+   | Eclt -> fun x y -> if x < y then 1 else 0
+   | Ecle -> fun x y -> if x <= y then 1 else 0
+   | Ecgt -> fun x y -> if x > y then 1 else 0
+   | Ecge -> fun x y -> if x >= y then 1 else 0
+   | Eceq -> fun x y -> if x = y then 1 else 0
+   | Ecne -> fun x y -> if x != y then 1 else 0
+
 
 (* [eval_unop u x] évalue l'opération unaire [u] sur l'argument [x]. *)
 let eval_unop (u: unop) : int -> int =
   match u with
-   | _ -> fun x -> 0
+   | Eneg -> fun x -> -x
 
 (* [eval_eexpr st e] évalue l'expression [e] dans l'état [st]. Renvoie une
    erreur si besoin. *)
-let rec eval_eexpr st (e : expr) : int res =
-   Error "eval_eexpr not implemented yet."
-
+let rec eval_eexpr oc st (ep: eprog) (e : expr) : (int * int state) res =
+   match e with
+   | Eint i -> OK (i, st)
+   | Evar s -> 
+      (match Hashtbl.find_option st.env s with
+      | Some i -> OK (i, st)
+      | None -> Error "Variable is not defined")
+   | Ebinop (b, ex, ey) -> 
+      (let res_x = eval_eexpr oc st ep ex
+         in match res_x with
+         | Error msg -> Error msg
+         | OK (x, st') -> 
+            let res_y = eval_eexpr oc st' ep ey
+               in match res_y with
+               | Error msg -> Error msg
+               | OK (y, st'') -> OK (eval_binop b x y, st''))
+   | Eunop (u, ex) ->
+      (let res_x = eval_eexpr oc st ep ex
+         in match res_x with
+         | Error msg -> Error msg
+         | OK (x, st') -> OK (eval_unop u x, st'))
+   | Ecall (f, args) -> 
+      let (res : (int list * int state) res) = List.fold_left (
+            fun (acc : (int list * int state) res) (arg : expr) -> 
+            match acc with
+            | Error msg -> Error msg
+            | OK (l, st') -> 
+               match eval_eexpr oc st' ep arg with
+               | Error msg -> Error msg
+               | OK (i, st'') -> OK ((l@[i]), st'')
+                  ) (OK([], st)) args
+         in match res with
+         | Error msg -> Error msg
+         | OK (int_args, st') -> 
+            match find_function ep f with
+            | Error msg -> Error msg
+            | OK found_f -> 
+               match eval_efun oc st' ep found_f f int_args with
+               | Error msg -> Error msg
+               | OK (None, st'') -> Error (Format.sprintf "E: Function %s doesn't have a return value.\n" f)
+               | OK (Some ret, st'') -> OK (ret, st'')
+         
+         
 (* [eval_einstr oc st ins] évalue l'instrution [ins] en partant de l'état [st].
 
    Le paramètre [oc] est un "output channel", dans lequel la fonction "print"
@@ -33,16 +85,78 @@ let rec eval_eexpr st (e : expr) : int res =
    lieu et que l'exécution doit continuer.
 
    - [st'] est l'état mis à jour. *)
-let rec eval_einstr oc (st: int state) (ins: instr) :
+and eval_einstr oc (st: int state) (ep: eprog) (ins: instr) :
   (int option * int state) res =
-   Error "eval_einstr not implemented yet."
+   match ins with
+   | Iassign (s, e) -> 
+      (match eval_eexpr oc st ep e with
+         | Error msg -> Error msg
+         | OK (v, st') -> 
+            let replace st s v =
+                  let new_env = Hashtbl.copy st.env 
+                     in Hashtbl.replace new_env s v; 
+                        {st with env = new_env}  
+               in OK (None, replace st' s v))
+   | Iif (e, i1, i2) -> 
+      (match eval_eexpr oc st ep e with 
+      | Error msg -> Error msg
+      | OK (v, st') -> if v = 0 then eval_einstr oc st' ep i2 else eval_einstr oc st' ep i1)
+   | Iwhile (e, i) -> 
+      (match eval_eexpr oc st ep e with
+         | Error msg -> Error msg
+         | OK (v, st') ->
+            if v = 1 
+               then (let res_i = eval_einstr oc st' ep i
+                  in match res_i with
+                  | Error msg -> Error msg
+                  | OK (r_opt, next_st) -> match r_opt with 
+                     | None -> eval_einstr oc next_st ep (Iwhile (e, i))
+                     | Some r -> OK (r_opt, next_st)) 
+               else OK(None, st'))
+   | Iblock i_list -> 
+      (match i_list with
+      | [] -> OK (None, st)
+      | i::rest -> 
+         match eval_einstr oc st ep i with
+         | Error msg -> Error msg
+         | OK (Some r, next_st) -> OK (Some r, next_st)
+         | OK (None, next_st) -> eval_einstr oc next_st ep (Iblock rest))
+   | Ireturn e -> 
+      (match eval_eexpr oc st ep e with
+      | Error msg -> Error msg
+      | OK (v, st') -> OK(Some v, st'))  
+   | Iprint e -> 
+      (match eval_eexpr oc st ep e with
+      | Error msg -> Error msg
+      | OK (v, st') -> 
+         Format.fprintf oc "%d\n" v;
+         OK(None, st'))
+   | Icall (f, args) -> 
+      let (res : (int list * int state) res) = List.fold_left (
+            fun (acc : (int list * int state) res) (arg : expr) -> 
+            match acc with
+            | Error msg -> Error msg
+            | OK (l, st') -> 
+               match eval_eexpr oc st' ep arg with
+               | Error msg -> Error msg
+               | OK (i, st'') -> OK ((l@[i]), st'')
+                  ) (OK([], st)) args
+         in match res with
+         | Error msg -> Error msg
+         | OK (int_args, st') -> 
+            match find_function ep f with
+            | Error msg -> Error msg
+            | OK found_f -> 
+               match eval_efun oc st' ep found_f f int_args with
+               | Error msg -> Error msg
+               | OK (_, st'') -> OK (None, st'')
 
 (* [eval_efun oc st f fname vargs] évalue la fonction [f] (dont le nom est
    [fname]) en partant de l'état [st], avec les arguments [vargs].
 
    Cette fonction renvoie un couple (ret, st') avec la même signification que
    pour [eval_einstr]. *)
-let eval_efun oc (st: int state) ({ funargs; funbody}: efun)
+and eval_efun oc (st: int state) ep ({ funargs; funbody}: efun)
     (fname: string) (vargs: int list)
   : (int option * int state) res =
   (* L'environnement d'une fonction (mapping des variables locales vers leurs
@@ -54,7 +168,7 @@ let eval_efun oc (st: int state) ({ funargs; funbody}: efun)
   let env = Hashtbl.create 17 in
   match List.iter2 (fun a v -> Hashtbl.replace env a v) funargs vargs with
   | () ->
-    eval_einstr oc { st with env } funbody >>= fun (v, st') ->
+    eval_einstr oc { st with env } ep funbody >>= fun (v, st') ->
     OK (v, { st' with env = env_save })
   | exception Invalid_argument _ ->
     Error (Format.sprintf
@@ -85,5 +199,5 @@ let eval_eprog oc (ep: eprog) (memsize: int) (params: int list)
   (* ne garde que le nombre nécessaire de paramètres pour la fonction "main". *)
   let n = List.length f.funargs in
   let params = take n params in
-  eval_efun oc st f "main" params >>= fun (v, _) ->
+  eval_efun oc st ep f "main" params >>= fun (v, _) ->
   OK v

src/lexer_generator.ml

@@ -45,41 +45,70 @@ let empty_nfa =
 
 (* Concaténation de NFAs.  *)
 let cat_nfa n1 n2 =
-   (* TODO *)
-   empty_nfa
+  (* TODO *)
+  {
+    nfa_states = n1.nfa_states @ n2.nfa_states;
+    nfa_initial = n1.nfa_initial;
+    nfa_final = n2.nfa_final;
+    nfa_step = fun q -> 
+      if List.mem q (List.map (fun x -> fst(x)) n1.nfa_final) 
+        then n1.nfa_step(q)@List.map (fun x -> (None, x)) n2.nfa_initial 
+        else n1.nfa_step(q)@n2.nfa_step(q)
+  }
 
 (* Alternatives de NFAs *)
 let alt_nfa n1 n2 =
-   (* TODO *)
-   empty_nfa
+  (* TODO *)
+  {
+    nfa_states = n1.nfa_states @ n2.nfa_states;
+    nfa_initial = n1.nfa_initial @ n2.nfa_initial;
+    nfa_final = n1.nfa_final @ n2.nfa_final;
+    nfa_step = fun q -> n1.nfa_step(q) @ n2.nfa_step(q) 
+  }
 
 (* Répétition de NFAs *)
 (* t est de type [string -> token option] *)
 let star_nfa n t =
-   (* TODO *)
-   empty_nfa
-
+  (* TODO *)
+  {
+    nfa_states = n.nfa_states;
+    nfa_initial = n.nfa_initial;
+    nfa_final = (List.map (fun x -> fst x, t) n.nfa_final) @ (List.map (fun x -> x, t) n.nfa_initial);
+    nfa_step = fun q -> 
+      if List.mem q (List.map (fun x -> fst x) n.nfa_final) 
+        then n.nfa_step q @ List.map (fun x -> None, x) n.nfa_initial
+        else n.nfa_step q 
+  }
 
 (* [nfa_of_regexp r freshstate t] construit un NFA qui reconnaît le même langage
    que l'expression régulière [r].
-   [freshstate] correspond à un entier pour lequel il n'y a pas encore d'état dans 
+   [freshstate] correspond à un entier pour leq uel il n'y a pas encore d'état dans 
    le nfa. Il suffit d'incrémenter [freshstate] pour obtenir de nouveaux états non utilisés.
    [t] est une fonction du type [string -> token option] utile pour les états finaux.
 *)
 let rec nfa_of_regexp r freshstate t =
   match r with
   | Eps -> { nfa_states = [freshstate];
-             nfa_initial = [freshstate];
-             nfa_final = [(freshstate,t)];
-             nfa_step = fun q -> []}, freshstate + 1
+              nfa_initial = [freshstate];
+              nfa_final = [(freshstate,t)];
+              nfa_step = fun q -> []}, freshstate + 1
   | Charset c -> { nfa_states = [freshstate; freshstate + 1];
                 nfa_initial = [freshstate];
                 nfa_final = [freshstate + 1, t];
                 nfa_step = fun q -> if q = freshstate then [(Some c, freshstate + 1)] else []
               }, freshstate + 2
-   (* TODO *)
-   | _ -> empty_nfa, freshstate
-
+    (* TODO *)
+  | Cat(r1, r2) -> 
+    let n1, intermediate_freshstate = nfa_of_regexp r1 freshstate t 
+      in let n2, final_freshstate = nfa_of_regexp r2 intermediate_freshstate t 
+        in (cat_nfa n1 n2, final_freshstate);
+  | Alt(r1, r2) -> 
+    let n1, intermediate_freshstate = nfa_of_regexp r1 freshstate t 
+      in let n2, final_freshstate = nfa_of_regexp r2 intermediate_freshstate t 
+        in (alt_nfa n1 n2, final_freshstate);
+  | Star r -> 
+    let n, final_freshstate = nfa_of_regexp r freshstate t 
+      in star_nfa n t, final_freshstate;  
 (* Deterministic Finite Automaton (DFA) *)
 
 (* Les états d'un DFA [dfa_state] sont des ensembles d'entiers.
@@ -119,21 +148,26 @@ let epsilon_closure (n: nfa) (s: nfa_state) : nfa_state set =
   (* La fonction [traversal visited s] effectue un parcours de l'automate en
      partant de l'état [s], et en suivant uniquement les epsilon-transitions. *)
   let rec traversal (visited: nfa_state set) (s: nfa_state) : nfa_state set =
-         (* TODO *)
-         visited
-  in
-  traversal Set.empty s
+    (* TODO *)
+      let direct_epsilon_closure = List.map (fun x -> snd x) (List.filter (fun x -> fst x == None) (n.nfa_step s)) 
+        in let not_visited_direct_epsilon_closure = List.filter (fun x -> not(Set.mem x visited)) direct_epsilon_closure
+          in let visited_with_s = Set.add s visited
+            in if Set.mem s visited 
+              then visited
+              else List.fold_left (fun acc x -> Set.union (traversal visited_with_s x) acc) visited_with_s not_visited_direct_epsilon_closure
+    in traversal Set.empty s 
 
 (* [epsilon_closure_set n ls] calcule l'union des epsilon-fermeture de chacun
    des états du NFA [n] dans l'ensemble [ls]. *)
 let epsilon_closure_set (n: nfa) (ls: nfa_state set) : nfa_state set =
-   (* TODO *)
-   ls
+  (* TODO *)
+  let set_of_epsilon_closures = (Set.map (fun x -> epsilon_closure n x) ls)
+    in Set.fold (fun acc x -> Set.union x acc) set_of_epsilon_closures Set.empty 
 
 (* [dfa_initial_state n] calcule l'état initial de l'automate déterminisé. *)
 let dfa_initial_state (n: nfa) : dfa_state =
-   (* TODO *)
-   Set.empty
+  (* TODO *)
+  epsilon_closure_set n (Set.of_list n.nfa_initial)
 
 (* Construction de la table de transitions de l'automate DFA. *)
 
@@ -180,19 +214,17 @@ let assoc_merge_vals (l : ('a * 'b) list) : ('a * 'b set) list =
       | Some vl -> (k, Set.add v vl)::List.remove_assoc k acc
     ) [] l
 
-let rec build_dfa_table (table: (dfa_state, (char * dfa_state) list) Hashtbl.t)
-    (n: nfa)
-    (ds: dfa_state) : unit =
+let rec build_dfa_table (table: (dfa_state, (char * dfa_state) list) Hashtbl.t) (n: nfa) (ds: dfa_state) : unit =
   match Hashtbl.find_option table ds with
   | Some _ -> ()
   | None ->
     (* [transitions] contient les transitions du DFA construites
-     * à partir des transitions du NFA comme décrit auparavant *)
+      * à partir des transitions du NFA comme décrit auparavant *)
     let transitions : (char * dfa_state) list =
-         (* TODO *)
-         []
-      in
-    Hashtbl.replace table ds transitions;
+          (* TODO *)
+        let t = Set.fold (fun x acc -> acc @ n.nfa_step x) ds []
+          in List.map (fun x -> fst x, epsilon_closure_set n (snd x)) (assoc_merge_vals (assoc_distribute_key (assoc_throw_none t)))
+      in Hashtbl.replace table ds transitions;
     List.iter (build_dfa_table table n) (List.map snd transitions)
 
 (* Calcul des états finaux de l'automate DFA *)
@@ -223,17 +255,31 @@ let priority t =
   | _ -> 0
 
 (* [min_priority l] renvoie le token de [l] qui a la plus petite priorité, ou
-   [None] si la liste [l] est vide. *)
+  [None] si la liste [l] est vide. *)
 let min_priority (l: token list) : token option =
-   (* TODO *)
-   None
+  (* TODO *)
+  match l with
+  | [] -> None
+  | _ -> Some(List.fold_left (fun x acc -> if priority x < priority acc then x else acc) SYM_EOF l)
 
 (* [dfa_final_states n dfa_states] renvoie la liste des états finaux du DFA,
    accompagnés du token qu'ils reconnaissent. *)
 let dfa_final_states (n: nfa) (dfa_states: dfa_state list) :
   (dfa_state * (string -> token option)) list  =
-   (* TODO *)
-   []
+  (* TODO *)
+  let dfa_final_states_list : nfa_state set list= 
+      let is_final q = List.mem q (List.map (fun x -> fst(x)) n.nfa_final) 
+        in List.filter (fun ds -> Set.exists is_final ds) dfa_states 
+    in let function_of_nfa_state ns = 
+      assoc_opt ns n.nfa_final
+      in let functions_of_dfa_state (ds : dfa_state) = 
+         (List.filter_map function_of_nfa_state (Set.to_list ds)) (* use List.filter_map instead of Set.filter_map to avoid the error*)
+        in let constructed_function ds = 
+            fun s -> 
+              let images_of_s : token list
+              = List.filter_map (fun (t) -> t s) (functions_of_dfa_state ds)
+                in min_priority images_of_s
+          in List.map (fun (ds : dfa_state ) -> ds, constructed_function ds) dfa_final_states_list
 
 (* Construction de la relation de transition du DFA. *)
 
@@ -241,8 +287,13 @@ let dfa_final_states (n: nfa) (dfa_states: dfa_state list) :
    est la table générée par [build_dfa_table], définie ci-dessus. *)
 let make_dfa_step (table: (dfa_state, (char * dfa_state) list) Hashtbl.t) =
   fun (q: dfa_state) (a: char) ->
-   (* TODO *)
-   None
+    (* TODO *)
+    match Hashtbl.find_option table q with
+    | None -> None
+    | Some l -> 
+      match List.filter (fun x -> fst x = a) l with
+      | [] -> None
+      | (c, ds)::rest -> Some ds
 
 (* Finalement, on assemble tous ces morceaux pour construire l'automate. La
    fonction [dfa_of_nfa n] vous est grâcieusement offerte. *)
@@ -306,13 +357,29 @@ type lexer_result =
 *)
 
 let tokenize_one (d : dfa) (w: char list) : lexer_result * char list =
-  let rec recognize (q: dfa_state) (w: char list)
-      (current_token: char list) (last_accepted: lexer_result * char list)
-    : lexer_result * char list =
-         (* TODO *)
-         last_accepted
-  in
-  recognize d.dfa_initial w [] (LRerror, w)
+  let rec recognize (q: dfa_state) (w: char list) (current_word: char list) (last_accepted: lexer_result * char list) : lexer_result * char list =
+      (* TODO *)
+      let token_function ds = 
+          assoc_opt ds d.dfa_final 
+        in let new_accepted =
+            match token_function q with
+            | None -> last_accepted
+            | Some t -> 
+                match (t (string_of_char_list current_word)) with
+                | None -> LRskip, w
+                | Some tok -> LRtoken tok, w
+          in if List.is_empty w 
+            then new_accepted 
+            else let next_state_option = d.dfa_step q (hd w)
+              in match next_state_option with
+              | None -> new_accepted
+              | Some next_state -> recognize next_state (tl w) (current_word@[hd w]) new_accepted
+          
+    in recognize d.dfa_initial w [] (LRerror, w)
+
+(*
+  recognize 3 "iler" "wh" (SYM_(w), "hile") -> (SYM_WHILE, "r") 
+*)
 
 (* La fonction [tokenize_all d w] répète l'application de [tokenize_one] tant qu'on
    n'est pas arrivé à la fin du fichier (token [SYM_EOF]). Encore une fois,
@@ -326,6 +393,7 @@ let rec tokenize_all (d: dfa) (w: char list) : (token list * char list) =
       if token = SYM_EOF
       then ([], w)
       else tokenize_all d w in
+      (*print_endline (string_of_symbol token);*)
     (token :: tokens, w)
 
 

src/linear_gen.ml

@@ -8,6 +8,8 @@ open Linear_print
 open Options
 open Linear_liveness
 
+type 'a set = 'a Set.t
+
 let succs_of_rtl_instr (i: rtl_instr) =
   match i with
   | Rtl.Rbranch (_, _, _, s1) -> [s1]
@@ -19,23 +21,39 @@ let rec succs_of_rtl_instrs il : int list =
 
 (* effectue un tri topologique des blocs.  *)
 let sort_blocks (nodes: (int, rtl_instr list) Hashtbl.t) entry =
-  let rec add_block order n =
-   (* TODO *)
-   List.of_enum (Hashtbl.keys nodes)
+  let rec add_block order visited n : reg list * reg set =
+    (* TODO *)
+    (*List.of_enum (Hashtbl.keys nodes)*)
+    if Set.mem n visited 
+      then order, visited
+      else let succs = succs_of_rtl_instrs (Hashtbl.find nodes n) 
+        in List.fold_left (fun (ord, vis) s -> add_block ord vis s) (order@[n], Set.add n visited) succs
   in
-  add_block [] entry
+  fst (add_block [] Set.empty entry)
 
 
 (* Supprime les jumps inutiles (Jmp à un label défini juste en dessous). *)
 let rec remove_useless_jumps (l: rtl_instr list) =
-   (* TODO *)
-   l
+  (* TODO *)
+  match l with
+  | [] -> []
+  | Rjmp l1::Rlabel l2::rest -> 
+      if l1=l2 
+        then Rlabel l2::remove_useless_jumps rest 
+        else Rjmp l1::Rlabel l2::remove_useless_jumps rest
+  | i::rest -> i::remove_useless_jumps rest
 
 
 (* Remove labels that are never jumped to. *)
 let remove_useless_labels (l: rtl_instr list) =
-   (* TODO *)
-   l
+  (* TODO *)
+  List.filter (function 
+    Rlabel i -> List.exists (
+      function 
+      Rbranch(_, _, _, j) -> j = i 
+      | Rjmp j -> j = i
+      | _ -> false) l
+    | _ -> true) l
 
 let linear_of_rtl_fun
     ({ rtlfunargs; rtlfunbody; rtlfunentry; rtlfuninfo }: rtl_fun) =

src/linear_liveness.ml

@@ -16,18 +16,21 @@ let gen_live (i: rtl_instr) =
   | Rmov (_, rs) -> Set.singleton rs
   | Rret r -> Set.singleton r
   | Rlabel _ -> Set.empty
+  | Rcall (_, _, args) -> Set.of_list args
 
 let kill_live (i: rtl_instr) =
   match i with
   | Rbinop (_, rd, _, _)
   | Runop (_, rd,_)
   | Rconst (rd, _)
-  | Rmov (rd,_) -> Set.singleton rd
+  | Rmov (rd,_)
+  | Rcall (Some rd, _, _) -> Set.singleton rd
   | Rbranch (_, _, _, _)
   | Rprint _
   | Rret _
   | Rjmp _
-  | Rlabel _ -> Set.empty
+  | Rlabel _ 
+  | Rcall (None, _, _) -> Set.empty
 
 let linear_succs (ins: rtl_instr) i labels =
   match ins with

src/linear_run.ml

@@ -60,6 +60,25 @@ let rec exec_linear_instr oc lp fname f st (i: rtl_instr) =
       | _ -> Error (Printf.sprintf "Ret on undefined register (%s)" (print_reg r))
     end
   | Rlabel n -> OK (None, st)
+  | Rcall (rd_opt, g, args) -> 
+    begin 
+    let vs_opt = List.fold_left (fun acc arg -> 
+        match acc with
+        | None -> None
+        | Some vs -> 
+          (match Hashtbl.find_option st.regs arg with
+          | None -> None
+          | Some v -> Some (vs@[v]))) 
+          (Some []) args 
+      in match vs_opt with
+      | Some params -> find_function lp g >>= fun found_g ->
+        (match rd_opt, exec_linear_fun oc lp st g found_g params with
+        | _, Error msg -> Error msg
+        | Some rd, OK (Some ret, st') -> exec_linear_instr oc lp fname f st' (Rconst (rd, ret))
+        | Some rd, OK (None, st') -> Error (Printf.sprintf "Function %s doesn't have a return value" g)
+        | None, OK (_, st') -> OK(None, st'))
+      | _ -> Error (Printf.sprintf "Function %s applied on undefined register" g)
+    end
 
 and exec_linear_instr_at oc lp fname ({  linearfunbody;  } as f) st i =
   let l = List.drop_while (fun x -> x <> Rlabel i) linearfunbody in

src/ltl_gen.ml

@@ -51,7 +51,7 @@ let make_loc_mov src dst =
     [LMov(rdst,rsrc)]
 
 (* load_loc tmp allocation r = (l, r'). Loads the equivalent of RTL register r
-   in a LTL register r'. tmpis used if necessary. *)
+   in a LTL register r'. tmp is used if necessary. *)
 let load_loc tmp allocation r =
   match Hashtbl.find_option allocation r with
   | None ->
@@ -215,26 +215,27 @@ let written_rtl_regs_instr (i: rtl_instr) =
   | Rbinop (_, rd, _, _)
   | Runop (_, rd, _)
   | Rconst (rd, _)
-  | Rmov (rd, _) -> Set.singleton rd
+  | Rmov (rd, _) 
+  | Rcall (Some rd, _, _)-> Set.singleton rd
   | Rprint _
   | Rret _
   | Rlabel _
   | Rbranch (_, _, _, _)
-  | Rjmp _ -> Set.empty
+  | Rjmp _ 
+  | Rcall (None, _, _) -> Set.empty
 
 let read_rtl_regs_instr (i: rtl_instr) =
   match i with
   | Rbinop (_, _, rs1, rs2)
   | Rbranch (_, rs1, rs2, _) -> Set.of_list [rs1; rs2]
-
   | Rprint rs
   | Runop (_, _, rs)
   | Rmov (_, rs)
   | Rret rs -> Set.singleton rs
-
   | Rlabel _
   | Rconst (_, _)
   | Rjmp _ -> Set.empty
+  | Rcall (_, _, args) -> Set.of_list args
 
 let read_rtl_regs (l: rtl_instr list) =
   List.fold_left (fun acc i -> Set.union acc (read_rtl_regs_instr i))
@@ -323,6 +324,30 @@ let ltl_instrs_of_linear_instr fname live_out allocation
     load_loc reg_tmp1 allocation r >>= fun (l,r) ->
     OK (l @ [LMov (reg_ret, r) ; LJmp epilogue_label])
   | Rlabel l -> OK [LLabel (Format.sprintf "%s_%d" fname l)]
+
+  | Rcall (rd_opt, f, rargs) -> 
+    caller_save live_out allocation rargs >>= fun to_save ->
+    let save_regs_instrs, arg_saved, ofs = save_caller_save (Set.to_list to_save) (-(numspilled + 1))
+    in let move_sp_instr1 = LSubi(reg_sp, reg_s0, (Archi.wordsize ()) * -(ofs + 1))
+    in pass_parameters rargs allocation arg_saved >>= fun (parameter_passing_instrs, npush) ->
+    let call_instr = LCall f
+    in let move_sp_instr2 = LAddi(reg_sp, reg_sp, (Archi.wordsize ()) * npush)
+    in let return_instrs_and_reg = match rd_opt with
+    | None -> OK ([], None)
+    | Some rd -> 
+      match Hashtbl.find_option allocation rd with
+      | None -> Error (Format.sprintf "Could not find allocation for register %d\n" rd)
+      | Some (Stk o) -> OK (make_loc_mov (Reg reg_ret) (Stk o) , None)
+      | Some (Reg r_phy) -> OK (make_loc_mov (Reg reg_ret) (Reg r_phy), Some r_phy)
+    in return_instrs_and_reg >>= fun (return_instrs, r_ret_opt) ->
+    let arg_saved_wout_rd = List.filter (fun (reg, stk_loc) -> match r_ret_opt with | None -> true | Some r_ret -> reg != r_ret) arg_saved
+    in let restore_caller_save_instrs = restore_caller_save arg_saved_wout_rd
+    in let move_sp_instr3 = LAddi(reg_sp, reg_sp, (Archi.wordsize ()) * -(ofs + 1))
+    in OK (save_regs_instrs 
+    @ move_sp_instr1 :: parameter_passing_instrs 
+    @ call_instr :: move_sp_instr2 :: return_instrs
+    @ restore_caller_save_instrs
+    @ [move_sp_instr3])
   in
   res >>= fun l ->
   OK (LComment (Format.asprintf "#<span style=\"background: pink;\"><b>Linear instr</b>: %a #</span>" (Rtl_print.dump_rtl_instr fname (None, None) ~endl:"") ins)::l)