Paris7/compilation
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Activity

fmt

Browse source
This commit is contained in:
Mylloon 2023-12-18 19:24:13 +01:00
parent e4b7a7bc0c
commit 13efd4ad65
Signed by: Anri
GPG key ID: A82D63DFF8D1317F
1 changed files with 110 additions and 133 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

243
flap/src/fopix/hobixToFopix.ml
View file

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