(*============================================================================*)
(*== UE Conception de Langages -- Octobre 2006                              ==*)
(*============================================================================*)
(*== Fichier: lb_utils.ml                                                   ==*)
(*== ---------------------------------------------------------------------- ==*)
(*== Auxiliaires de construction de lambda termes pour les fonctions        ==*)
(*== sémantiques                                                            ==*)
(*== + compteur d'adresses                                                  ==*)
(*==                                                                        ==*)
(*============================================================================*)
open Lb_type
open Lb_eval

(*== Construction de lambda termes                                            *)
(*-- Application d'une variable de nom 'x' au terme 't'                       *)
let app_var x t = APP[VAR x; t]

(*-- Pour erreur: une chaîne de caractères                                    *)
let lb_failwith s = 
  STR s

(*-- Alternative                                                              *)
let lb_alt t1 t2 t3 =
  APP[ALT; t1; PAIR(t2,t3)]

(*-- Application diverse                                                      *)
let lb_le t1 t2 =
  APP[OP"LE?"; t1; t2]

let lb_succ t =
  APP[OP"ADD"; t; NUM 1]

let lb_isPair t =
  APP[OP"PAIR?"; t]

let lb_fst t =
  APP[FST; t]

let lb_snd t =
  APP[SND; t]

let lb_eq t1 t2 =
  APP[OP"EQ?"; t1; t2]


(*-- Environnement sémantique initial pour l'évaluateur                       *)
let lb_env0 =
  let env = 
    Cons("ESET",
	 (LBD(["X";"V";"SG"], PAIR(PAIR(VAR"X", VAR"V"), VAR"SG")),Nil),
	 Nil)
  in let env =
    let x, sg = VAR"X", VAR"SG" in
    Cons("EGET",
	 (REC("f",LBD(["X";"SG"], 
	      lb_alt (lb_isPair sg)
		     (lb_alt (lb_eq x (lb_fst (lb_fst sg)))
		             (lb_snd (lb_fst sg))
		             (APP[VAR"f"; x; lb_snd sg]))
		     (STR("EGET: NOT FOUND")))),
	  env),
	  env)
  in let env =
    let n, sg = VAR"N", VAR"SG" in
    Cons("MGET",
	 (REC("f",LBD(["N";"SG"], 
	      lb_alt (lb_isPair sg)
		     (lb_alt (lb_eq n (lb_fst (lb_fst sg)))
		             (lb_snd (lb_fst sg))
		             (APP[VAR"f"; n; lb_snd sg]))
		     (STR("MGET: NOT FOUND")))),
	  env),
	 env)
  in let env =
    Cons("INX",
	 (LBD(["I";"V"], PAIR(VAR"I",VAR"V")), env),
	 env)
  in let env =
    Cons("ISX",
	 (LBD(["I";"V"], APP[OP"EQ?";VAR"I";APP[FST;VAR"V"]]),env),
	 env)
  in let env =
    Cons("INDATA",
	 (LBD(["V"], APP[VAR"INX";NUM 0;VAR"V"]), env),
	 env)
  in let env =
    Cons("ISDATA",
	 (LBD(["V"], APP[VAR"ISX";NUM 0;VAR"V"]), env),
	 env)
  in let env =
    Cons("INADDR",
	 (LBD(["V"], APP[VAR"INX";NUM 1;VAR"V"]), env),
	 env)
  in let env =
    Cons("ISADDR",
	 (LBD(["V"], APP[VAR"ISX";NUM 1;VAR"V"]), env),
	 env)
  in let env =
    Cons("INPROC",
	 (LBD(["V"], APP[VAR"INX";NUM 2;VAR"V"]), env),
	 env)
  in let env =
    Cons("ISPROC",
	 (LBD(["V"], APP[VAR"ISX";NUM 2;VAR"V"]), env),
	 env)
  in let env =
    Cons("INFUN",
	 (LBD(["V"], APP[VAR"INX";NUM 3;VAR"V"]), env),
	 env)
  in let env =
    Cons("ISFUN",
	 (LBD(["V"], APP[VAR"ISX";NUM 3;VAR"V"]), env),
	 env)
  in let env =
    Cons("INCONT",
	 (LBD(["V"], APP[VAR"INX";NUM 4;VAR"V"]), env),
	 env)
  in let env =
    Cons("ISCONT",
	 (LBD(["V"], APP[VAR"ISX";NUM 4;VAR"V"]), env),
	 env)
  in let env =
    Cons("VALOF", (LBD(["X"], APP[SND;VAR"X"]), env), env)
  in
    env

(*-- Pour ajout de la liaison de la variable (de nom) 'x' à la valeur 'v'     *)
(*  dans l'environnement 'sg'                                                 *)
let lb_eset x v sg =
  APP[VAR"ESET";STR x; v; sg]

(*-- Pour accès à la valeur de la variable (de nom) 'x' dans l'environnement  *)
(*  'sg'                                                                      *)
let lb_eget x sg =
  APP[VAR"EGET";STR x; sg]

(*-- Itération de ci-dessus                                                   *)
let rec lb_esets xs vs sg =
  match xs, vs with
    [], [] -> sg
  | x::xs, v::vs -> lb_esets xs vs (lb_eset x v sg)
  | _ -> failwith "internal: 'lb_eset'"

(*-- Pour ajout de la liaison de la valeur 'v' à l'adresse 'x' dans la        *)
(*  mémoire 'm'                                                               *)
let lb_mset x v m =
  APP[VAR"ESET"; x; v; m]

(*-- Pour accès à la valeur de l'adresse 'n' de la mémoire 'm'                 *)
let lb_mget n m =
  APP[VAR"MGET"; n; m]

(*-- Accesseur/constructeurs/reconnaisseurs valeur en environnement            *)
let valOf t = app_var "VALOF" t

let inData t = app_var "INDATA" t
let isData t = app_var "ISDATA" t

let inAddr t = app_var "INADDR" t
let isAddr t = app_var "ISADDR" t

let inProc t = app_var "INPROC" t
let isProc t = app_var "ISPROC" t

let inFun t = app_var "INFUN" t
let isFun t = app_var "ISFUN" t

let inCont t = app_var "INCONT" t
let isCont t = app_var "ISCONT" t

(*-- Continuation/mémoire/environnement initiaux                               *)
let kap0 =
  LBD(["_m"],VAR"_m")

let mu0 = NIL

let sg0 = 
  lb_eset "CONS" (inFun(LBD(["_M";"X";"XS"], PAIR(VAR"X",VAR"XS"))))
    (lb_eset "CAR" (inFun (LBD(["_M";"XS"],APP[FST;VAR"XS"])))
       (lb_eset "CDR" (inFun (LBD(["_M";"XS"],APP[SND;VAR"XS"])))
	  (lb_eset "NIL" (inData NIL) NIL)))

(*== Compteur d'adresses                                                      *)
let reset_addr, new_addr =
  let a = ref 0 in
    (fun() -> a := 0),
    (fun() -> incr a; NUM !a)