[petitcaml] Make it actually work

1 files changed, 48 insertions, 32 deletions

diff --git a/closure.ml b/closure.ml
index 7549c86..07a6662 100644
--- a/closure.ml
+++ b/closure.ml
@@ -1,19 +1,31 @@
+(****************************************
+    closure.ml - gestion des clotures
+ ****************************************)
+
 open Ast
 open Utils
 
-let next_fun_id = ref 0
+module Sset = Set.Make(String)
+
+let next_fun_id = ref 1
+
+(* Gestion des conflits de labels sur les fonctions *)
+let rec new_function_label idents =
+    let label = Printf.sprintf "fun___%d" !next_fun_id
+    in
+        incr next_fun_id;
+        if Sset.mem label idents then
+            new_function_label idents
+        else
+            label
 
-let get_function_name f =
+(* Petit helper, générant un identifiant à la volée si nécessaire *)
+let get_function_name idents f =
     match f.name with
-        | None ->
-            let name = Printf.sprintf "fun____%d" !next_fun_id
-            in
-                incr next_fun_id;
-                name
+        | None -> new_function_label idents
         | Some s -> s
 
-module Sset = Set.Make(String)
-
+(* Calcul des identifiants d'un motif *)
 let rec motif_vars m =
     match m.m with
         | Munderscore -> Sset.empty
@@ -22,6 +34,8 @@ let rec motif_vars m =
                                         Sset.union base (motif_vars motif))
                                      Sset.empty l
 
+(* Détermination des variables libres d'une expression,
+   utilisée lors de la construction des clotures et letfuns *)
 let rec free_vars expr =
     match expr.e with
         | Econst _ -> Sset.empty
@@ -36,7 +50,7 @@ let rec free_vars expr =
         | Eif (e1, e2, e3) ->
             Sset.union (Sset.union (free_vars e1) (free_vars e2))
                        (free_vars e3)
-        | Eletin ({m = Mident id}, {e = Efunc f}, e2) when f.recursive ->
+        | Eletin ({ m = Mident id }, { e = (Efunc f) }, e2) when f.recursive ->
             Sset.diff (Sset.union (free_vars (raw_expr (Efunc f)))
                                   (free_vars e2))
                       (Sset.singleton id)
@@ -53,70 +67,72 @@ let rec free_vars expr =
                            (Sset.diff (free_vars result_expr) motifs_idents)
         | Eclos _ -> failwith "free_vars : Unreachable matching"
 
-let rec replace_funcs expr =
+(* Parcours récursif de l'arbre pour remplacer les fonctions par des
+   clotures et des letfuns, retourne un (expr * (letfun list)) *)
+let rec replace_funcs idents expr =
     match expr.e with
         | Econst _ -> expr, []
         | Eident _ -> expr, []
         | Etuple l ->
             let l, letfuns =
                 List.fold_right (fun e (l, letfuns) ->
-                                    let e2, letfuns2 = replace_funcs e
+                                    let e2, letfuns2 = replace_funcs idents e
                                     in
                                         (e2::l, letfuns2 @ letfuns))
                                 l  ([], [])
             in
                 (raw_expr (Etuple l)), letfuns
         | Ebinop (e1, o, e2) ->
-            let e1, letfuns1 = replace_funcs e1
-            and e2, letfuns2 = replace_funcs e2
+            let e1, letfuns1 = replace_funcs idents e1
+            and e2, letfuns2 = replace_funcs idents e2
             in
                 (raw_expr (Ebinop (e1, o, e2))), letfuns1 @ letfuns2
         | Eunop (o, e) ->
-            let e, letfuns = replace_funcs e
+            let e, letfuns = replace_funcs idents e
             in
                 (raw_expr (Eunop (o, e))), letfuns
         | Eletin (m, val_expr, body_expr) ->
-            let val_expr, letfuns1 = replace_funcs val_expr
-            and body_expr, letfuns2 = replace_funcs body_expr
+            let val_expr, letfuns1 = replace_funcs idents val_expr
+            and body_expr, letfuns2 = replace_funcs idents body_expr
             in
                 (raw_expr (Eletin (m, val_expr, body_expr))),
                 letfuns1 @ letfuns2
         | Efunc f ->
-            let fname = get_function_name f
+            let fname = get_function_name idents f
             in
                 let fvars = Sset.elements (free_vars expr)
                 in
-                    (raw_expr (Eclos (fname, fvars))),
-                    (build_letfun fname f fvars)
+                    (raw_expr (Eclos (f.recursive, fname, fvars))),
+                    (build_letfun idents fname f fvars)
         | Eif (cond_expr, then_expr, else_expr) ->
-            let cond_expr, letfuns1 = replace_funcs cond_expr
-            and then_expr, letfuns2 = replace_funcs then_expr
-            and else_expr, letfuns3 = replace_funcs else_expr
+            let cond_expr, letfuns1 = replace_funcs idents cond_expr
+            and then_expr, letfuns2 = replace_funcs idents then_expr
+            and else_expr, letfuns3 = replace_funcs idents else_expr
             in
                 (raw_expr (Eif (cond_expr, then_expr, else_expr))),
                 letfuns1 @ letfuns2 @ letfuns3
         | Elistcons (head_expr, tail_expr) ->
-            let head_expr, letfuns1 = replace_funcs head_expr
-            and tail_expr, letfuns2 = replace_funcs tail_expr
+            let head_expr, letfuns1 = replace_funcs idents head_expr
+            and tail_expr, letfuns2 = replace_funcs idents tail_expr
             in
                 (raw_expr (Elistcons (head_expr, tail_expr))),
                 letfuns1 @ letfuns2
         | Ecall (func_expr, arg_expr) ->
-            let func_expr, letfuns1 = replace_funcs func_expr
-            and arg_expr, letfuns2 = replace_funcs arg_expr
+            let func_expr, letfuns1 = replace_funcs idents func_expr
+            and arg_expr, letfuns2 = replace_funcs idents arg_expr
             in
                 (raw_expr (Ecall (func_expr, arg_expr))),
                 letfuns1 @ letfuns2
         | Ematch (match_expr, empty_expr, head_m, tail_m, result_expr) ->
-            let match_expr, letfuns1 = replace_funcs match_expr
-            and empty_expr, letfuns2 = replace_funcs empty_expr
-            and result_expr, letfuns3 = replace_funcs result_expr
+            let match_expr, letfuns1 = replace_funcs idents match_expr
+            and empty_expr, letfuns2 = replace_funcs idents empty_expr
+            and result_expr, letfuns3 = replace_funcs idents result_expr
             in
                 (raw_expr (Ematch (match_expr, empty_expr,
                                    head_m, tail_m, result_expr))),
                 letfuns1 @ letfuns2 @ letfuns3
         | Eclos _ -> failwith "replace_funcs : Unreachable matching"
-and build_letfun fname f fvars =
-    let fbody, letfuns = replace_funcs f.body
+and build_letfun idents fname f fvars =
+    let fbody, letfuns = replace_funcs idents f.body
     in
         letfuns @ [(fname, fvars, f.arg, fbody)]