From 13efd4ad65c2516e7d9961c28dbf7056c0d9cb1d Mon Sep 17 00:00:00 2001 From: Mylloon Date: Mon, 18 Dec 2023 19:24:13 +0100 Subject: [PATCH] fmt --- flap/src/fopix/hobixToFopix.ml | 243 +++++++++++++++------------------ 1 file changed, 110 insertions(+), 133 deletions(-) diff --git a/flap/src/fopix/hobixToFopix.ml b/flap/src/fopix/hobixToFopix.ml index 3fe2c8e..d3518dc 100644 --- a/flap/src/fopix/hobixToFopix.ml +++ b/flap/src/fopix/hobixToFopix.ml @@ -105,22 +105,17 @@ let write_block e i v = T.(FunCall (FunId "write_block", [ e; i; v ])) let read_block e i = T.(FunCall (FunId "read_block", [ e; i ])) let lint i = T.(Literal (LInt (Int64.of_int i))) +(* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests *) +let fonction_predef = + [ "print_string"; "equal_string"; "equal_char"; "observe_int"; "print_int" ] +;; - - - -(* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests*) -let fonction_predef = - ["print_string"; - "equal_string"; - "equal_char"; - "observe_int"; - "print_int"] - - (* On regarde si la fonction est prédéfini : soit par des noms, soit par des opérations binaires*) -let is_a_predefined_function (S.Id op) = - FopixInterpreter.is_binary_primitive op || - List.mem op fonction_predef +(* On regarde si la fonction est prédéfini : + - soit par des noms + - soit par des opérations binaires *) +let is_a_predefined_function (S.Id op) = + FopixInterpreter.is_binary_primitive op || List.mem op fonction_predef +;; (** [free_variables e] returns the list of free variables that occur in [e].*) @@ -146,7 +141,7 @@ let free_variables = | S.Define (vd, a) -> let liste_def_valeur = match vd with - | S.SimpleValue (id, expr) -> [(id, expr)] + | S.SimpleValue (id, expr) -> [ id, expr ] | S.RecFunctions list -> list in let id, expr = List.split liste_def_valeur in @@ -221,64 +216,62 @@ let translate (p : S.t) env = | S.RecFunctions fdefs -> let fs, defs = define_recursive_functions env fdefs in fs @ List.map (fun (x, e) -> T.DefineValue (x, e)) defs - - (*Ce qu'il faut faire dans le cadre des fonctions mutuellement récursives : - - On récupère la liste des fonctions - - On créé des clotures pour chaque récursion - - On traduit chaque fonction mutuellement récursive en appel de fonction anonyme - - On finit par combiner chaque liste de définition, celle des la fonction de base, - puis celle des des fonctions traduites. *) + (* Ce qu'il faut faire dans le cadre des fonctions mutuellement récursives : + - On récupère la liste des fonctions + - On créé des clotures pour chaque récursion + - On traduit chaque fonction mutuellement récursive en appel + de fonction anonyme + - On finit par combiner chaque liste de définition, + celle des la fonction de base, puis celle des des fonctions traduites. *) and define_recursive_functions env rdefs = - - (*On récupère d'abord les informations qui nous intéresse : nom, variables libres, - arguments, et le corps de la fonction récursive *) - let rdefs =( - let rname = List.map fst rdefs in - let free_vars f = - - match f with - | S.Fun(id, expr) -> - let new_id = id @ rname in - let lfree_vars = free_variables (S.Fun(new_id, expr)) in - lfree_vars, id, expr - | _ -> failwith "Error recFunctions : This is not a function" - in - List.map (fun (name, expr) -> name, free_vars expr) rdefs) - - in - (* On regarde si la fonction recursive est seule, si c'est le cas, on traite - le cas simple d'une fonction anonyme seul.*) - match rdefs with - | [name, (free_vars, arguments, expr)] -> - let defs, expre = fonction_anonyme env ~name free_vars arguments expr in - defs, [identifier name, expre] - | _ -> (*Sinon, on créé des clotures pour chaque fonction de nos fonctions récursives*) - let rdefs = creation_cloture_rec rdefs in - let fs, rdefs = List.split rdefs in - (* Puis on les traduit toute les fonctions *) - let trad_rdef = trad_rec_definition rdefs in - let fs', exprs = List.split trad_rdef in - fs @ List.concat fs', exprs - - - (*Fonction qui créé des clotures pour chaque récursion *) - and creation_cloture_rec rdefs = - let nb = List.length rdefs -1 in - List.map (fun (name, (free_vars, x, e)) -> - let new_name = make_fresh_variable () in - T.DefineValue (new_name, new_cloture nb free_vars), ((name, new_name), (free_vars, x, e))) rdefs - - (* Fonction qui traduit chaque fonction en appel de fonction anonyme mais également - le nom en identifiant de fonction pour fopix.*) - and trad_rec_definition rdefs = - let rname = List.map fst rdefs in + (* On récupère d'abord les informations qui nous intéresse : + nom, variables libres, arguments, et le corps de la fonction récursive *) + let rdefs = + let rname = List.map fst rdefs in + let free_vars f = + match f with + | S.Fun (id, expr) -> + let new_id = id @ rname in + let lfree_vars = free_variables (S.Fun (new_id, expr)) in + lfree_vars, id, expr + | _ -> failwith "Error recFunctions : This is not a function" + in + List.map (fun (name, expr) -> name, free_vars expr) rdefs + in + (* On regarde si la fonction recursive est seule, si c'est le cas, on traite + le cas simple d'une fonction anonyme seul. *) + match rdefs with + | [ (name, (free_vars, arguments, expr)) ] -> + let defs, expre = fonction_anonyme env ~name free_vars arguments expr in + defs, [ identifier name, expre ] + | _ -> + (* Sinon, on créé des clotures pour chaque fonction de + nos fonctions récursives *) + let rdefs = creation_cloture_rec rdefs in + let fs, rdefs = List.split rdefs in + (* Puis on les traduit toute les fonctions *) + let trad_rdef = trad_rec_definition rdefs in + let fs', exprs = List.split trad_rdef in + fs @ List.concat fs', exprs + (* Fonction qui créé des clotures pour chaque récursion *) + and creation_cloture_rec rdefs = + let nb = List.length rdefs - 1 in List.map - (fun ((name,new_name),(fv,x,e)) -> - let names = List.filter (fun (xi,_) -> xi != name) rname in - let defs, expr = fonction_anonyme ~name ~block:(new_name,names) env fv x e in - defs, (identifier name,expr)) - rdefs - + (fun (name, (free_vars, x, e)) -> + let new_name = make_fresh_variable () in + ( T.DefineValue (new_name, new_cloture nb free_vars) + , ((name, new_name), (free_vars, x, e)) )) + rdefs + (* Fonction qui traduit chaque fonction en appel de fonction anonyme + mais également le nom en identifiant de fonction pour fopix. *) + and trad_rec_definition rdefs = + let rname = List.map fst rdefs in + List.map + (fun ((name, new_name), (fv, x, e)) -> + let names = List.filter (fun (xi, _) -> xi != name) rname in + let defs, expr = fonction_anonyme ~name ~block:(new_name, names) env fv x e in + defs, (identifier name, expr)) + rdefs and expression env = function | S.Literal l -> [], T.Literal (literal l) | S.While (cond, e) -> @@ -299,18 +292,15 @@ let translate (p : S.t) env = let bfs, b = expression env b in afs @ bfs, T.Define (identifier id, a, b) | S.RecFunctions rdefs -> - let fs, defs = define_recursive_functions env rdefs in - afs @ fs, defines defs a - ) - | S.Apply (a, bs) -> - apply env a bs + let fs, defs = define_recursive_functions env rdefs in + afs @ fs, defines defs a) + | S.Apply (a, bs) -> apply env a bs | S.IfThenElse (a, b, c) -> let afs, a = expression env a in let bfs, b = expression env b in let cfs, c = expression env c in afs @ bfs @ cfs, T.IfThenElse (a, b, c) - | S.Fun (x, e) as f -> - fonction_anonyme env (free_variables f) x e + | S.Fun (x, e) as f -> fonction_anonyme env (free_variables f) x e | S.AllocateBlock a -> let afs, a = expression env a in afs, allocate_block a @@ -342,9 +332,6 @@ let translate (p : S.t) env = bs, Some e in afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default) - - - and expressions env = function | [] -> [], [] | e :: es -> @@ -357,58 +344,51 @@ let translate (p : S.t) env = | S.LChar c -> T.LChar c and identifier (S.Id x) = T.Id x and function_identifier (S.Id x) = T.FunId x - - (* Ici, on rajoute notre fonction anonyme dans la liste des définitions de fonctions *) and add_liste_funcdef env fid x expr = let dfs, expr = expression env expr in - let dfs, expr = - ( + let dfs, expr = let aux x (xs, acc) = match x with - | T.DefineValue (id, exp) -> xs, T.Define (id,exp,acc) - | x -> x::xs, acc in - List.fold_right aux dfs ([], expr) - ) in + | T.DefineValue (id, exp) -> xs, T.Define (id, exp, acc) + | x -> x :: xs, acc + in + List.fold_right aux dfs ([], expr) + in dfs @ [ T.DefineFunction (fid, T.Id "oldenvironment" :: x, expr) ] - - (*Traitement des fonctions anonymes*) + (* Traitement des fonctions anonymes *) and fonction_anonyme ?name ?block env f x e = - (*On commence par générer de nouveaux identifiants pour nos fonctions*) + (* On commence par générer de nouveaux identifiants pour nos fonctions *) let fname = make_fresh_function_identifier () in - (*On traduit l'id de chaque argument*) - let arguments_x = List.map identifier x in - (* On créé la cloture pour notre fonction anonyme*) - let cloture, env = creation_cloture env name block fname f in - (*On met à jour la liste des définitions de fonctions*) - let dfs = add_liste_funcdef env fname arguments_x e in - dfs, cloture - - and creation_cloture env name block fname free_vars = - let env = - match name with - | None -> env - | Some name -> bind_var env name (T.Variable(T.Id "oldenvironment")) + (* On traduit l'id de chaque argument *) + let arguments_x = List.map identifier x in + (* On créé la cloture pour notre fonction anonyme *) + let cloture, env = creation_cloture env name block fname f in + (* On met à jour la liste des définitions de fonctions *) + let dfs = add_liste_funcdef env fname arguments_x e in + dfs, cloture + and creation_cloture env name block fname free_vars = + let env = + match name with + | None -> env + | Some name -> bind_var env name (T.Variable (T.Id "oldenvironment")) in match block with - | None -> (*Cas où on a une simple fonction anonyme*) + | None -> + (* Cas où on a une simple fonction anonyme *) let new_clot = new_cloture 0 free_vars in let blocks, env = add_to_cloture env fname (T.Variable (T.Id "environment")) free_vars [] in T.Define (T.Id "environment", new_clot, blocks), env - | Some (block, rdefs) -> (*Cas pour les fonctions mutuellements récursive*) + | Some (block, rdefs) -> + (* Cas pour les fonctions mutuellements récursive *) add_to_cloture env fname (T.Variable block) free_vars rdefs - - - (* Fonction qui initialise une cloture de taille espace + la taille de la liste de variable (le nombre de variable libre) *) and new_cloture espace list_variable = allocate_block (lint (espace + List.length list_variable + 1)) - - (* Fonction qui rajoute à la cloture l'ensemble de variable libres *) and add_to_cloture env fname env_var free_vars rdefs = (* On commence d'abord par écrire dans le premier bloc le nom de @@ -445,35 +425,32 @@ let translate (p : S.t) env = (env, [], 1) free_vars in - (*Dans le cas d'une récursion, on rajoute chaque fonction dans l'env et à la liste - d'instruction*) - let env,vars_fun,_ = - List.fold_left (fun (env, list, k) (id, id_var) -> - let new_env = - bind_var env id (read_block (T.Variable (T.Id "oldenvironment")) (lint k)) - in - let new_instr = write_block env_var (lint k) (T.Variable id_var) in - (new_env, new_instr::list,k+1) - ) - (env,[],k) (*On commence avec k car on a mis k variables libres juste avant*) - rdefs - in + (* Dans le cas d'une récursion, on rajoute chaque fonction dans l'env et + à la liste d'instruction*) + let env, vars_fun, _ = + List.fold_left + (fun (env, list, k) (id, id_var) -> + let new_env = + bind_var env id (read_block (T.Variable (T.Id "oldenvironment")) (lint k)) + in + let new_instr = write_block env_var (lint k) (T.Variable id_var) in + new_env, new_instr :: list, k + 1) + (* On commence avec k car on a mis k variables libres juste avant *) + (env, [], k) + rdefs + in (* On créé une séquence d'instructions contenant le premier bloc et la suite *) - let instrs = List.rev (env_var :: first_block :: vars_free @ vars_fun) in + let instrs = List.rev ((env_var :: first_block :: vars_free) @ vars_fun) in seqs instrs, env - - - - (* Revoir les explications c'est pas clair *) and apply env f arguments = (* D'abord, on traduit chaque arguments *) - let defs_args, trad_arguments = expressions env arguments in (* On créé un FunCall en fonction de f *) match f with - | S.Variable x when Dict.lookup x env.externals <> None || is_a_predefined_function x-> + | S.Variable x when Dict.lookup x env.externals <> None || is_a_predefined_function x + -> (* Si f est une externe fonction, on créé directement un FunCall *) [], T.FunCall (function_identifier x, trad_arguments) | _ ->