fmt
This commit is contained in:
parent
e4b7a7bc0c
commit
13efd4ad65
1 changed files with 110 additions and 133 deletions
|
@ -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 *)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests*)
|
|
||||||
let fonction_predef =
|
let fonction_predef =
|
||||||
["print_string";
|
[ "print_string"; "equal_string"; "equal_char"; "observe_int"; "print_int" ]
|
||||||
"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*)
|
(* 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) =
|
let is_a_predefined_function (S.Id op) =
|
||||||
FopixInterpreter.is_binary_primitive op ||
|
FopixInterpreter.is_binary_primitive op || List.mem op fonction_predef
|
||||||
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 *)
|
||||||
|
|
||||||
|
|
||||||
(*Fonction qui créé des clotures pour chaque récursion *)
|
|
||||||
and creation_cloture_rec rdefs =
|
and creation_cloture_rec rdefs =
|
||||||
let nb = List.length rdefs -1 in
|
let nb = List.length rdefs - 1 in
|
||||||
List.map (fun (name, (free_vars, x, e)) ->
|
List.map
|
||||||
let new_name = make_fresh_variable () in
|
(fun (name, (free_vars, x, e)) ->
|
||||||
T.DefineValue (new_name, new_cloture nb free_vars), ((name, new_name), (free_vars, x, e))) rdefs
|
let new_name = make_fresh_variable () in
|
||||||
|
( T.DefineValue (new_name, new_cloture nb free_vars)
|
||||||
(* Fonction qui traduit chaque fonction en appel de fonction anonyme mais également
|
, ((name, new_name), (free_vars, x, e)) ))
|
||||||
le nom en identifiant de fonction pour fopix.*)
|
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 =
|
and trad_rec_definition rdefs =
|
||||||
let rname = List.map fst rdefs in
|
let rname = List.map fst rdefs in
|
||||||
List.map
|
List.map
|
||||||
(fun ((name,new_name),(fv,x,e)) ->
|
(fun ((name, new_name), (fv, x, e)) ->
|
||||||
let names = List.filter (fun (xi,_) -> xi != name) rname in
|
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
|
let defs, expr = fonction_anonyme ~name ~block:(new_name, names) env fv x e in
|
||||||
defs, (identifier name,expr))
|
defs, (identifier name, expr))
|
||||||
rdefs
|
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)
|
||||||
| _ ->
|
| _ ->
|
||||||
|
|
Reference in a new issue