Merge branch 'jalon4'
This commit is contained in:
commit
38ab723583
1 changed files with 349 additions and 168 deletions
|
@ -8,9 +8,7 @@ module S = Source.AST
|
||||||
module Target = Fopix
|
module Target = Fopix
|
||||||
module T = Target.AST
|
module T = Target.AST
|
||||||
|
|
||||||
(**
|
(** The translation from Hobix to Fopix turns anonymous
|
||||||
|
|
||||||
The translation from Hobix to Fopix turns anonymous
|
|
||||||
lambda-abstractions into toplevel functions and applications into
|
lambda-abstractions into toplevel functions and applications into
|
||||||
function calls. In other words, it translates a high-level language
|
function calls. In other words, it translates a high-level language
|
||||||
(like OCaml) into a first order language (like C).
|
(like OCaml) into a first order language (like C).
|
||||||
|
@ -63,97 +61,108 @@ module T = Target.AST
|
||||||
|
|
||||||
(Remark: Did you notice that this form of "auto-application" is
|
(Remark: Did you notice that this form of "auto-application" is
|
||||||
very similar to the way "this" is defined in object-oriented
|
very similar to the way "this" is defined in object-oriented
|
||||||
programming languages?)
|
programming languages?) *)
|
||||||
|
|
||||||
*)
|
(** Helpers functions. *)
|
||||||
|
|
||||||
(**
|
let error pos msg = Error.error "compilation" pos msg
|
||||||
Helpers functions.
|
|
||||||
*)
|
|
||||||
|
|
||||||
let error pos msg =
|
|
||||||
Error.error "compilation" pos msg
|
|
||||||
|
|
||||||
let make_fresh_variable =
|
let make_fresh_variable =
|
||||||
let r = ref 0 in
|
let r = ref 0 in
|
||||||
fun () -> incr r; T.Id (Printf.sprintf "_%d" !r)
|
fun () ->
|
||||||
|
incr r;
|
||||||
|
T.Id (Printf.sprintf "_%d" !r)
|
||||||
|
;;
|
||||||
|
|
||||||
let make_fresh_function_identifier =
|
let make_fresh_function_identifier =
|
||||||
let r = ref 0 in
|
let r = ref 0 in
|
||||||
fun () -> incr r; T.FunId (Printf.sprintf "_%d" !r)
|
fun () ->
|
||||||
|
incr r;
|
||||||
|
T.FunId (Printf.sprintf "_%d" !r)
|
||||||
|
;;
|
||||||
|
|
||||||
let define e f =
|
let define e f =
|
||||||
let x = make_fresh_variable () in
|
let x = make_fresh_variable () in
|
||||||
T.Define (x, e, f x)
|
T.Define (x, e, f x)
|
||||||
|
;;
|
||||||
|
|
||||||
let rec defines ds e =
|
let rec defines ds e =
|
||||||
match ds with
|
match ds with
|
||||||
| [] ->
|
| [] -> e
|
||||||
e
|
| (x, d) :: ds -> T.Define (x, d, defines ds e)
|
||||||
| (x, d) :: ds ->
|
;;
|
||||||
T.Define (x, d, defines ds e)
|
|
||||||
|
|
||||||
let seq a b =
|
let seq a b = define a (fun _ -> b)
|
||||||
define a (fun _ -> b)
|
|
||||||
|
|
||||||
let rec seqs = function
|
let rec seqs = function
|
||||||
| [] -> assert false
|
| [] -> assert false
|
||||||
| [x] -> x
|
| [ x ] -> x
|
||||||
| x :: xs -> seq x (seqs xs)
|
| x :: xs -> seq x (seqs xs)
|
||||||
|
;;
|
||||||
|
|
||||||
let allocate_block e =
|
let allocate_block e = T.(FunCall (FunId "allocate_block", [ e ]))
|
||||||
T.(FunCall (FunId "allocate_block", [e]))
|
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)))
|
||||||
|
|
||||||
let write_block e i v =
|
(* Liste de fonction prédéfini par le code, que l'on retrouve dans les tests *)
|
||||||
T.(FunCall (FunId "write_block", [e; i; v]))
|
let fonction_predef =
|
||||||
|
[ "print_string"; "equal_string"; "equal_char"; "observe_int"; "print_int" ]
|
||||||
let read_block e i =
|
;;
|
||||||
T.(FunCall (FunId "read_block", [e; i]))
|
|
||||||
|
|
||||||
let lint i =
|
|
||||||
T.(Literal (LInt (Int64.of_int i)))
|
|
||||||
|
|
||||||
|
(* 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].*)
|
||||||
let free_variables =
|
let free_variables =
|
||||||
let module M =
|
let module M =
|
||||||
Set.Make (struct type t = S.identifier let compare = compare end)
|
Set.Make (struct
|
||||||
|
type t = S.identifier
|
||||||
|
|
||||||
|
let compare = compare
|
||||||
|
end)
|
||||||
in
|
in
|
||||||
let rec unions f = function
|
let rec unions f = function
|
||||||
| [] -> M.empty
|
| [] -> M.empty
|
||||||
| [s] -> f s
|
| [ s ] -> f s
|
||||||
| s :: xs -> M.union (f s) (unions f xs)
|
| s :: xs -> M.union (f s) (unions f xs)
|
||||||
in
|
in
|
||||||
|
(* Une variable libre est une variable qui peut être substitué *)
|
||||||
let rec fvs = function
|
let rec fvs = function
|
||||||
| S.Literal _ ->
|
| S.Literal _ -> M.empty
|
||||||
M.empty
|
(* Si la fonction est prédéfini, alors ce n'est pas une variable libre. *)
|
||||||
| S.Variable x ->
|
| S.Variable x -> if is_a_predefined_function x then M.empty else M.singleton x
|
||||||
M.singleton x
|
| S.While (cond, e) -> unions fvs [ cond; e ]
|
||||||
| S.While (cond, e) ->
|
|
||||||
failwith "Students! This is your job!"
|
|
||||||
| S.Define (vd, a) ->
|
| S.Define (vd, a) ->
|
||||||
failwith "Students! This is your job!"
|
let liste_def_valeur =
|
||||||
| S.ReadBlock (a, b) ->
|
match vd with
|
||||||
unions fvs [a; b]
|
| S.SimpleValue (id, expr) -> [ id, expr ]
|
||||||
| S.Apply (a, b) ->
|
| S.RecFunctions list -> list
|
||||||
unions fvs (a :: b)
|
in
|
||||||
| S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) ->
|
let id, expr = List.split liste_def_valeur in
|
||||||
unions fvs [a; b; c]
|
M.diff (unions fvs (a :: expr)) (M.of_list id)
|
||||||
| S.AllocateBlock a ->
|
| S.ReadBlock (a, b) -> unions fvs [ a; b ]
|
||||||
fvs a
|
| S.Apply (a, b) -> unions fvs (a :: b)
|
||||||
| S.Fun (xs, e) ->
|
| S.WriteBlock (a, b, c) | S.IfThenElse (a, b, c) -> unions fvs [ a; b; c ]
|
||||||
failwith "Students! This is your job!"
|
| S.AllocateBlock a -> fvs a
|
||||||
|
| S.Fun (xs, e) -> M.diff (fvs e) (M.of_list xs)
|
||||||
| S.Switch (a, b, c) ->
|
| S.Switch (a, b, c) ->
|
||||||
let c = match c with None -> [] | Some c -> [c] in
|
let c =
|
||||||
unions fvs (a :: ExtStd.Array.present_to_list b @ c)
|
match c with
|
||||||
|
| None -> []
|
||||||
|
| Some c -> [ c ]
|
||||||
|
in
|
||||||
|
unions fvs ((a :: ExtStd.Array.present_to_list b) @ c)
|
||||||
in
|
in
|
||||||
fun e -> M.elements (fvs e)
|
fun e -> M.elements (fvs e)
|
||||||
|
;;
|
||||||
|
|
||||||
(**
|
(** A closure compilation environment relates an identifier to the way
|
||||||
|
|
||||||
A closure compilation environment relates an identifier to the way
|
|
||||||
it is accessed in the compiled version of the function's
|
it is accessed in the compiled version of the function's
|
||||||
body.
|
body.
|
||||||
|
|
||||||
|
@ -170,58 +179,101 @@ let free_variables =
|
||||||
Indeed, "x" is a local variable that can be accessed directly in
|
Indeed, "x" is a local variable that can be accessed directly in
|
||||||
the compiled version of this function's body whereas "y" is a free
|
the compiled version of this function's body whereas "y" is a free
|
||||||
variable whose value must be retrieved from the closure's
|
variable whose value must be retrieved from the closure's
|
||||||
environment.
|
environment. *)
|
||||||
|
type environment =
|
||||||
|
{ vars : (HobixAST.identifier, FopixAST.expression) Dict.t
|
||||||
|
; externals : (HobixAST.identifier, int) Dict.t
|
||||||
|
}
|
||||||
|
|
||||||
*)
|
let initial_environment () = { vars = Dict.empty; externals = Dict.empty }
|
||||||
type environment = {
|
let bind_external id n env = { env with externals = Dict.insert id n env.externals }
|
||||||
vars : (HobixAST.identifier, FopixAST.expression) Dict.t;
|
let is_external id env = Dict.lookup id env.externals <> None
|
||||||
externals : (HobixAST.identifier, int) Dict.t;
|
let reset_vars env = { env with vars = Dict.empty }
|
||||||
}
|
let bind_var env id expr = { env with vars = Dict.insert id expr env.vars }
|
||||||
|
|
||||||
let initial_environment () =
|
|
||||||
{ vars = Dict.empty; externals = Dict.empty }
|
|
||||||
|
|
||||||
let bind_external id n env =
|
|
||||||
{ env with externals = Dict.insert id n env.externals }
|
|
||||||
|
|
||||||
let is_external id env =
|
|
||||||
Dict.lookup id env.externals <> None
|
|
||||||
|
|
||||||
let reset_vars env =
|
|
||||||
{ env with vars = Dict.empty }
|
|
||||||
|
|
||||||
(** Precondition: [is_external id env = true]. *)
|
(** Precondition: [is_external id env = true]. *)
|
||||||
let arity_of_external id env =
|
let arity_of_external id env =
|
||||||
match Dict.lookup id env.externals with
|
match Dict.lookup id env.externals with
|
||||||
| Some n -> n
|
| Some n -> n
|
||||||
| None -> assert false (* By is_external. *)
|
| None -> assert false (* By is_external. *)
|
||||||
|
;;
|
||||||
|
|
||||||
(** [translate p env] turns an Hobix program [p] into a Fopix program
|
(** [translate p env] turns an Hobix program [p] into a Fopix program
|
||||||
using [env] to retrieve contextual information. *)
|
using [env] to retrieve contextual information. *)
|
||||||
let translate (p : S.t) env =
|
let translate (p : S.t) env =
|
||||||
let rec program env defs =
|
let rec program env defs =
|
||||||
let env, defs = ExtStd.List.foldmap definition env defs in
|
let env, defs = ExtStd.List.foldmap definition env defs in
|
||||||
(List.flatten defs, env)
|
List.flatten defs, env
|
||||||
and definition env = function
|
and definition env = function
|
||||||
| S.DeclareExtern (id, n) ->
|
| S.DeclareExtern (id, n) ->
|
||||||
let env = bind_external id n env in
|
let env = bind_external id n env in
|
||||||
(env, [T.ExternalFunction (function_identifier id, n)])
|
env, [ T.ExternalFunction (function_identifier id, n) ]
|
||||||
| S.DefineValue vd ->
|
| S.DefineValue vd -> env, value_definition env vd
|
||||||
(env, value_definition env vd)
|
|
||||||
and value_definition env = function
|
and value_definition env = function
|
||||||
| S.SimpleValue (x, e) ->
|
| S.SimpleValue (x, e) ->
|
||||||
let fs, e = expression (reset_vars env) e in
|
let fs, e = expression (reset_vars env) e in
|
||||||
fs @ [T.DefineValue (identifier x, e)]
|
fs @ [ T.DefineValue (identifier x, e) ]
|
||||||
| S.RecFunctions fdefs ->
|
| S.RecFunctions fdefs ->
|
||||||
let fs, defs = define_recursive_functions 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 :
|
||||||
and define_recursive_functions rdefs =
|
- On récupère la liste des fonctions
|
||||||
failwith "Students! This is your job!"
|
- 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
|
||||||
|
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 ->
|
| S.Literal l -> [], T.Literal (literal l)
|
||||||
[], T.Literal (literal l)
|
|
||||||
| S.While (cond, e) ->
|
| S.While (cond, e) ->
|
||||||
let cfs, cond = expression env cond in
|
let cfs, cond = expression env cond in
|
||||||
let efs, e = expression env e in
|
let efs, e = expression env e in
|
||||||
|
@ -232,66 +284,195 @@ let translate (p : S.t) env =
|
||||||
| None -> T.Variable (identifier x)
|
| None -> T.Variable (identifier x)
|
||||||
| Some e -> e
|
| Some e -> e
|
||||||
in
|
in
|
||||||
([], xc)
|
[], xc
|
||||||
| S.Define (vdef, a) ->
|
| S.Define (vdef, a) ->
|
||||||
failwith "Students! This is your job!"
|
let afs, a = expression env a in
|
||||||
| S.Apply (a, bs) ->
|
(match vdef with
|
||||||
failwith "Students! This is your job!"
|
| S.SimpleValue (id, b) ->
|
||||||
|
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
|
||||||
| 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 -> fonction_anonyme env (free_variables f) x e
|
||||||
| S.Fun (x, e) ->
|
|
||||||
failwith "Students! This is your job!"
|
|
||||||
| 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
|
||||||
| S.WriteBlock (a, b, c) ->
|
| S.WriteBlock (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,
|
afs @ bfs @ cfs, T.FunCall (T.FunId "write_block", [ a; b; c ])
|
||||||
T.FunCall (T.FunId "write_block", [a; b; c])
|
|
||||||
| S.ReadBlock (a, b) ->
|
| S.ReadBlock (a, b) ->
|
||||||
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
|
||||||
afs @ bfs,
|
afs @ bfs, T.FunCall (T.FunId "read_block", [ a; b ])
|
||||||
T.FunCall (T.FunId "read_block", [a; b])
|
|
||||||
| S.Switch (a, bs, default) ->
|
| S.Switch (a, bs, default) ->
|
||||||
let afs, a = expression env a in
|
let afs, a = expression env a in
|
||||||
let bsfs, bs =
|
let bsfs, bs =
|
||||||
ExtStd.List.foldmap (fun bs t ->
|
ExtStd.List.foldmap
|
||||||
|
(fun bs t ->
|
||||||
match ExtStd.Option.map (expression env) t with
|
match ExtStd.Option.map (expression env) t with
|
||||||
| None -> (bs, None)
|
| None -> bs, None
|
||||||
| Some (bs', t') -> (bs @ bs', Some t')
|
| Some (bs', t') -> bs @ bs', Some t')
|
||||||
) [] (Array.to_list bs)
|
[]
|
||||||
|
(Array.to_list bs)
|
||||||
in
|
in
|
||||||
let dfs, default = match default with
|
let dfs, default =
|
||||||
|
match default with
|
||||||
| None -> [], None
|
| None -> [], None
|
||||||
| Some e -> let bs, e = expression env e in bs, Some e
|
| Some e ->
|
||||||
|
let bs, e = expression env e in
|
||||||
|
bs, Some e
|
||||||
in
|
in
|
||||||
afs @ bsfs @ dfs,
|
afs @ bsfs @ dfs, T.Switch (a, Array.of_list bs, default)
|
||||||
T.Switch (a, Array.of_list bs, default)
|
|
||||||
|
|
||||||
|
|
||||||
and expressions env = function
|
and expressions env = function
|
||||||
| [] ->
|
| [] -> [], []
|
||||||
[], []
|
|
||||||
| e :: es ->
|
| e :: es ->
|
||||||
let efs, es = expressions env es in
|
let efs, es = expressions env es in
|
||||||
let fs, e = expression env e in
|
let fs, e = expression env e in
|
||||||
fs @ efs, e :: es
|
fs @ efs, e :: es
|
||||||
|
|
||||||
and literal = function
|
and literal = function
|
||||||
| S.LInt x -> T.LInt x
|
| S.LInt x -> T.LInt x
|
||||||
| S.LString s -> T.LString s
|
| S.LString s -> T.LString s
|
||||||
| 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
|
||||||
|
and old_env = make_fresh_variable ()
|
||||||
|
and curr_env = make_fresh_variable ()
|
||||||
|
(* 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 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
|
||||||
|
dfs @ [ T.DefineFunction (fid, old_env :: x, expr) ]
|
||||||
|
(* 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 *)
|
||||||
|
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 old_env)
|
||||||
|
in
|
||||||
|
match block with
|
||||||
|
| 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 curr_env) free_vars [] in
|
||||||
|
T.Define (curr_env, new_clot, blocks), env
|
||||||
|
| 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
|
||||||
|
la fonction fopix *)
|
||||||
|
let first_block = write_block env_var (lint 0) (T.Literal (T.LFun fname)) in
|
||||||
|
(* Ensuite, on s'occupe d'écrire dans chaque bloc de notre cloture
|
||||||
|
les variables libres *)
|
||||||
|
let env, vars_free, k =
|
||||||
|
List.fold_left
|
||||||
|
(fun (env, list, k) id ->
|
||||||
|
(* Pour chaque élément de la liste ...
|
||||||
|
On commence par lié la variable dans le nouvelle environnement
|
||||||
|
qui se trouve dans l'ancien environnement *)
|
||||||
|
let curr_env = bind_var env id (read_block (T.Variable old_env) (lint k)) in
|
||||||
|
(* On cherche la valeur de la variable dans
|
||||||
|
le dictionnaire du programme *)
|
||||||
|
let new_valeur =
|
||||||
|
match Dict.lookup id env.vars with
|
||||||
|
| None -> T.Variable (identifier id)
|
||||||
|
| Some v -> v
|
||||||
|
in
|
||||||
|
(* Enfin, on écrit dans notre cloture la valeur de la variable libre
|
||||||
|
à la position k *)
|
||||||
|
let new_instr = write_block env_var (lint k) new_valeur in
|
||||||
|
(* On rappelle notre fonction avec le nouvelle environnement,
|
||||||
|
en rajoutant notre instruction à la liste d'instruction,
|
||||||
|
et en incrémentant l'index *)
|
||||||
|
curr_env, new_instr :: list, k + 1)
|
||||||
|
(* On commence notre fonction avec l'env de base,
|
||||||
|
la liste d'instruction vide et l'indice à 1
|
||||||
|
(0 étant l'initialisation du début) *)
|
||||||
|
(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 curr_env = bind_var env id (read_block (T.Variable old_env) (lint k)) in
|
||||||
|
let new_instr = write_block env_var (lint k) (T.Variable id_var) in
|
||||||
|
curr_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
|
||||||
|
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
|
||||||
|
->
|
||||||
|
(* Si f est une externe fonction, on créé directement un FunCall *)
|
||||||
|
[], T.FunCall (function_identifier x, trad_arguments)
|
||||||
|
| _ ->
|
||||||
|
(* Sinon, ça veut dire que nous l'avons défini au préalable *)
|
||||||
|
(* On traduit la fonction *)
|
||||||
|
let defs_func, func = expression env f in
|
||||||
|
(* On récupère le nom de fonction et son expression *)
|
||||||
|
let fname, func_expr =
|
||||||
|
match func with
|
||||||
|
| T.Variable x -> x, fun x -> x
|
||||||
|
| _ ->
|
||||||
|
let fname = make_fresh_variable () in
|
||||||
|
fname, fun x -> T.Define (fname, func, x)
|
||||||
|
in
|
||||||
|
(* On récupère le pointeur qui pointe vers la première case
|
||||||
|
de la fonction *)
|
||||||
|
let get_pointer = read_block (T.Variable fname) (lint 0) in
|
||||||
|
(* On récupère l'appelle de la fonction *)
|
||||||
|
let defs_call =
|
||||||
|
func_expr (T.UnknownFunCall (get_pointer, T.Variable fname :: trad_arguments))
|
||||||
|
in
|
||||||
|
(* Enfin, on concatène toute les parties de la fonction
|
||||||
|
(la traduction de tout les arguments) *)
|
||||||
|
let defs = defs_func @ defs_args in
|
||||||
|
(* Et on renvoie la def de la fonction ainsi que l'appel *)
|
||||||
|
defs, defs_call
|
||||||
in
|
in
|
||||||
program env p
|
program env p
|
||||||
|
;;
|
||||||
|
|
Reference in a new issue