(* Lambda termes *)
#open "divers";;
#open "expr";;
#open "am";;
#open "printf";;
#open "global";;
#open "types";;


type Lambda =
  LVar of LocVar
| LConst of int
| LConstStr of string
| LCall  of Lambda*Lambda
| LOpBin of AmInstr*Lambda*Lambda
| LOpUn  of AmInstr*Lambda
| LSeq   of Lambda*Lambda
| LITH   of Lambda*Lambda*Lambda
| LFunction of Lambda*( LocVar list)
| LLet of (Lambda list)*Lambda
| LLetRec of Lambda list*LocVar list*Lambda
| LLetDecl of Lambda list
| LLetRecDecl of Lambda list*LocVar list
| LSpecial of AmInstr list ->AmInstr list
| LMatch of Lambda*(Matchs list)

and Matchs =
  MatchId of Lambda
| MatchConstr of int*Lambda
| MatchConstConstr of int*Lambda;;




let lconst_unit  = LConst 0;;
let lconst_false = lconst_unit;;
let lconst_true  = LConst 1;;

let pr_loc = function
  LocStack n -> printf "s%d" n
| LocEnv n -> printf "e%d" n
| LocDummy (k,i) -> printf "d%d,%d" k i
| LocGlobal n -> printf "g%d" n
| LocImmInt n -> printf "i%d" n
| LocSpecial _ -> pr "sp"
;;


let rec pr_lambda = function
  LVar l -> pr "LVar "; pr_loc l
| LConst n -> printf "LConst %d" n
| LCall (f,x) -> pr "LCall "; pr_lambda f; pr ","; pr_lambda x
| LFunction (l,_) -> pr "LFunction "; pr_lambda l
| LSpecial _ -> pr "LSpecial"
| LOpBin _ -> pr "LOpBin"
| LOpUn _ -> pr "LOpUn"
| _ -> pr "other";;

let transl_loc sp = function
  LocStack n -> LocStack (sp-n)
| loc -> loc;;

let transl_loc_dum sp no = function
  LocStack n -> LocStack (sp+no-n)
| LocDummy (n,_) -> LocDummy (n,no)
| loc -> loc;;

let rec fus_varsenv e1 e2 = match (e1,e2) with
 | _,[] -> e1
 | [],_ -> e2
 | (c1,x1)::q1,(c2,x2)::q2 ->
        if c1>c2 then (c1,x1)::(fus_env q1 e2) else
        if c1<c2 then (c2,x2)::(fus_env e1 q2) else
        (c1,x1)::(c2,x2)::(fus_env q1 q2);;

let rec remove_varsenv e1 e2 = match (e1,e2) with
 | [],_ -> e2
 | (c1,x1)::q1,(c2,x2)::q2 ->
        if c1=c2 then remove_varsenv q1 q2
        else (c2,x2)::remove_varsenv e1 q2
 | _ -> failwith "remove_varsenv";;

let longenv = function
| LFunction (_,e) -> list_length e
| _ -> failwith "longenv";;

let locvar_env = (hashtbl__new 127 : (ID,LocVar) hashtbl__t);;
let loc_of_id id = 
  try
   hashtbl__find locvar_env id
  with
   Not_found -> (global_ids.find id).loc;;
let add_locvar id loc = hashtbl__add locvar_env id loc;;
let remove_locvar id = hashtbl__remove locvar_env id;;
let change_locvar id loc = remove_locvar id; add_locvar id loc;;
let add_envvar vars = let _=it_list (fun envpos var -> add_locvar var (LocEnv envpos); envpos+1) 0 vars in ();;
let init_locvar () = hashtbl__clear locvar_env;
(*  let spec_fst = LocSpecial {VSLab=(-1); VSCode=(fun suite -> First :: suite)}
  and spec_snd = LocSpecial {VSLab=(-1); VSCode=(fun suite -> Second :: suite)}
  and spec_ref = LocSpecial {VSLab=(-1); VSCode=(fun suite -> MakeRef :: suite)}
  in
  add_locvar "hd" spec_fst;
  add_locvar "tl" spec_snd;
  add_locvar "fst" spec_fst;
  add_locvar "snd" spec_snd;
  add_locvar "ref" spec_ref; *)
;;


let rec lambda_of_expr sp expr =
(*
pr "lambda:"; affiche_expr expr; printf " sp=%d vars:" sp;
map (fun (id,loc) -> pr id; pr "="; pr_loc loc; pr " ") vars;
pr "\n";
*)
  let opbin i a b =
        let a=lambda_of_expr sp a in
        let b=lambda_of_expr (sp+1) b in
        LOpBin (i,a,b)
  and opun i a =
        let a=lambda_of_expr sp a in
        LOpUn (i,a)
  and let_letrec decl e =
        (* traduire e, avec les liaisons sur la pile *)
        let spe=it_list (fun s (id,def) -> add_locvar id (LocStack s); s+1) sp decl in
        let e=lambda_of_expr spe e in
        do_list (fun (id,_) -> remove_locvar id) decl;
        e
in
match expr.e_desc with
  ExprCst (CstEntier  n) -> LConst n
| ExprCst (CstBooleen n) -> if n then lconst_true else lconst_false
| ExprCst (CstCar n)	 -> LConst (int_of_char n)
| ExprCst (CstChaine s)  -> LConstStr s
| ExprCst (CstListeVide) -> lconst_unit
| ExprCst (CstUnit)      -> lconst_unit
| ExprIdent id           -> LVar (transl_loc sp (loc_of_id id))
| ExprFunc (x,ex)   ->
        (* Liaisons des variables d'environnement *)
        add_envvar expr.e_vars;
        let body=transl_body x ex in
        do_list remove_locvar expr.e_vars;

        (* Calculer la position des variables d'environnement lors de la construction de la fermeture *)
        let (_,locs) = it_list (fun (s,locs) var -> s+1,transl_loc s (loc_of_id var) ::locs) (sp,[]) expr.e_vars in
        LFunction (body,locs)
| ExprAppl (funct,arg)   -> 
        let a=lambda_of_expr sp arg in
        let b=lambda_of_expr (sp+1) funct in
        LCall (a,b)
| ExprPaire (a,b)        -> opbin MakeCouple a b
| ExprLet (false, decl, e) ->
        let e=let_letrec decl e in
	let lambdas=transl_let sp decl in
        LLet (lambdas,e)
| ExprLet (true, decl, e) ->
        let e=let_letrec decl e in
	let (locs,bodies)=transl_letrec sp decl in
        LLetRec (bodies,locs,e)

| ExprMatch (e,act) ->
      	LMatch (lambda_of_expr sp e, matchs_of_act sp act)

| ExprOp (op, e) ->
        let binary i = match e.e_desc with ExprPaire (a,b) -> opbin i a b | _ -> failwith "lambda_of_expr, bin"

in
match op with
 OpAdd  -> binary Add
|OpMult -> binary Mul
|OpMoins-> binary Sub
|OpDiv  -> binary Div
|OpOu   -> binary Or
|OpEt   -> binary And
|OpInf  -> binary TestLt
|OpInfEgal-> binary TestLtEq
|OpEgal -> binary TestEq
|OpCons -> binary MakeCouple
|OpNot  -> opun Not e
|OpNeg  -> opun Neg e
|OpHead|OpFirst  -> opun First e
|OpTail|OpSecond -> opun Second e
|OpITH  ->
    (match e.e_desc with ExprPaire (t,{e_desc=ExprPaire(a,b)}) ->
        let t=lambda_of_expr sp t in
        let a=lambda_of_expr sp a in
        let b=lambda_of_expr sp b in
        LITH (t,a,b)
    | _ -> failwith "lambda_of_expr, OpITH"
    )
|OpSeq  ->
    (match e.e_desc with ExprPaire (a,b) ->
        let a=lambda_of_expr sp a in
        let b=lambda_of_expr sp b in
        LSeq (a,b)
    | _ -> failwith "lambda_of_expr, OpSeq"
    )
|OpAffect -> binary SetVect0
|OpIndirect -> opun GetVect0 e
|OpRef -> opun MakeRef e


and matchs_of_act sp = function
| (pat,expr)::suite -> 
(   match pat with 
   | PatConstr (constr,x) -> 
      (
      match constr with
      CBloc (n,_,_) -> 
(*      	if x="" then
  MatchConstr (n,lambda_of_expr sp expr) :: (matchs_of_act sp suite)
  else *)
(      	add_locvar x (LocStack sp);
	let res=
      	MatchConstr (n,lambda_of_expr (sp+1) expr) :: (matchs_of_act sp suite) in
	remove_locvar x;
	res
)
      |CCst (n,_) -> MatchConstConstr (n,lambda_of_expr sp expr) ::(matchs_of_act sp suite)

      )
   | PatId x -> 
      	add_locvar x (LocStack sp);
	let res = 
        MatchId (lambda_of_expr (sp+1) expr) :: (matchs_of_act sp suite) in
	remove_locvar x;
	res
)
| [] -> []

and transl_body x a =
  add_locvar x (LocStack 0);
  let body=lambda_of_expr 3 a in
  remove_locvar x;
  body

and transl_let sp decl =
 (* traduire les declarations *)
 let (_,lambdas)=
 it_list 
  (fun (s,lambdas) (id,def) -> (s+1, (lambda_of_expr s def)::lambdas)) 
 (sp,[]) decl
 in
 lambdas

and transl_letrec sp decl = 
 let funcs=map (fun (id,def) -> (id,extractfunc def,def.e_vars)) decl in
 let fids=map fst decl in

 (* Calculer les variables d'environnement *)
 let vars=it_list (fun vars (f,(x,a),v) -> fus_set vars v) [] funcs in
 (* Rajouter les liaisons communes aux corps des fonctions recursives *)
 add_envvar vars;
 (* Traduire les corps *)
 let bodies=it_list (fun bodies (_,(x,a),_) -> (transl_body x a)::bodies) [] funcs in
 do_list remove_locvar vars;

 (* Calculer la position des variables d'environnement lors de la construction de la fermeture *)
 let _=it_list (fun no (f,_,_) -> add_locvar f (LocDummy (no,0)); no-1) (list_length funcs) funcs in
 let (_,locs) = it_list (fun (no,locs) var -> no+1,transl_loc_dum sp no (loc_of_id var) ::locs) (0,[]) vars in
 do_list (fun (f,_,_) -> remove_locvar f) funcs;
 (locs,bodies)

and
lambda_of_letdecl (recurs,decl) = 
 do_list (
 fun (id,{e_type=t}) -> glob id t (LocGlobal !globalsp); incr globalsp
 ) decl;
 if recurs then
  let (locs,bodies)=transl_letrec 0 decl in
  LLetRecDecl (bodies,locs)
 else
  LLetDecl (transl_let 0 decl)
;;





let lambda_of_phrase e =
        init_locvar();
        lambda_of_expr 0 e;;