(*============================================================================*)
(*== UE Conception de Langages -- Octobre 2006                              ==*)
(*============================================================================*)
(*== Fichier: lsrc_sem.ml                                                   ==*)
(*== ---------------------------------------------------------------------- ==*)
(*== Définition des fonctions sémantiques du langage source.                 ==*)
(*==  Conventions de nommage:                                               ==*)
(*==    'kap': continuation                                                 ==*)
(*==    'sg' : environnement                                                ==*)
(*==    'mu' : mémoire                                                      ==*)
(*============================================================================*)
open Lb_type
open Lb_utils
open Lsrc_ast

(* == Sémantique d'un programme ('p')                                         *)
let rec semProg p sg mu =
  match p with
    ASTProg(ds, ss) -> semStats ss kap0 (semDecs ds sg mu) mu

(* == Sémantique d'une déclaration ('d')                                      *)
and semDec d sg mu =
  match d with
    ASTCst(x,e) -> lb_eset x (inData(semExp e sg mu)) sg
  | ASTVar(x) -> lb_eset x (inAddr (new_addr())) sg
  | ASTFun(f,xs,e) -> 
      let vs = List.map (fun x -> "_"^x) xs in
      let sgf = lb_esets xs (List.map (fun v -> inData(VAR v)) vs) sg in
        lb_eset f (inFun(LBD("_m"::vs, semExp e sgf (VAR"_m")))) sg
  | ASTFunRec(f,xs,e) -> 
      let vs = List.map (fun x -> "_"^x) xs in
      let sgf = lb_esets xs (List.map (fun v -> inData(VAR v)) vs) sg in
      let e = fun_rec f e in
        lb_eset f (inFun(LBD(["_m"],REC(f,LBD(vs,semExp e sgf (VAR"_m")))))) sg
  | ASTProc(p,xs,s) ->
      let vs = List.map (fun x -> "_"^x) xs in
      let sgp = lb_esets xs (List.map (fun v -> inData(VAR v)) vs) sg in
        lb_eset p (inProc(LBD("_m"::vs, 
	    		      semStat s kap0 sgp (VAR"_m"))))
                sg
  | ASTProcRec(p,xs,s) ->
      let vs = List.map (fun x -> "_"^x) xs in
      let sgp = lb_esets xs (List.map (fun v -> inData(VAR v)) vs) sg in
      let s = proc_rec p s in
        lb_eset p (inProc(REC(p,LBD("_m"::vs, 
		    		    semStat s kap0 sgp (VAR"_m")))))
                sg

(* == Sémantique d'une suite de déclarations ('ds')                           *)
and semDecs ds sg mu =
  match ds with
    [] -> sg
  | d::ds -> semDecs ds (semDec d sg mu) mu

(* == Sémantique d'une instruction ('s')                                      *)
and semStat s kap sg mu =
  match s with 
    ASTSet(x,e) -> 
      let a = lb_eget x sg in
        lb_alt (isAddr a)
	       (APP[kap;lb_mset (valOf a) (semExp e sg mu) mu])
	       (lb_failwith (x^": not a mutable identifier"))
  | ASTCall("Print", es) ->
      APP[kap; 
	  APP[LBD(["_"],mu);
	      APP(OP"PRINT"::(List.map (fun e -> semExp e sg mu) es))]]
  | ASTCall("Println", es) ->
      APP[kap; 
	  APP[LBD(["_"],mu);
	      APP(OP"PRINT"::
		  ((List.map (fun e -> semExp e sg mu) es)@[(STR"\n")]))]]
  | ASTCall(p, es) -> 
      let v = lb_eget p sg in
        lb_alt (isProc v)
	       (APP[kap;
		    APP((valOf v)::mu::(List.map (fun e -> semExp e sg mu) es))])
	       (lb_failwith (p^": not a procedure"))
  | ASTCallRec(p, es) -> 
      APP[kap;APP((VAR p)::mu::(List.map (fun e -> semExp e sg mu) es))]
  | ASTBloc(ds,ss) -> 
      semStats ss kap (semDecs ds sg mu) mu
  | ASTLoop(s) -> 
      APP[kap;
	  APP[REC("_k", LBD(["_m"], semStat s (VAR"_k") sg (VAR"_m"))); 
	      mu]]
  | ASTLoopW(e,s) ->
      APP[REC("_k", LBD(["_m"],
	   lb_alt (semExp e sg (VAR"_m"))
		  (semStat s (VAR"_k") sg (VAR"_m"))
		  (APP[kap; VAR"_m"])));
	  mu]
  | ASTLoopU(e,s) ->
      APP[REC("_k", LBD(["_m"],
	   lb_alt (semExp e sg (VAR"_m"))
		  (APP[kap; VAR"_m"]) 
		  (semStat s (VAR"_k") sg (VAR"_m"))));
	  mu]
  | ASTLoopF(i,ASTNrng(e1,e2),s) ->
      let s' =
	ASTBloc(
	    [ASTVar "_end"],
	    [ASTSet("_end", e2);
	     ASTSet(i, e1);
	     ASTLoopW(
		 ASTApp("LE?",[ASTId i; ASTId "_end"]),
		 ASTBloc(
		     [],
		     [s; ASTSet(i, ASTApp("ADD",[ASTId i; ASTNum 1]))]
		   )
	       )
	    ]
	  )
      in
	semStat s' kap sg mu
  | ASTLoopF(i,ASTLrng e,s) ->
      let s' =
	ASTBloc(
	    [ASTVar "_is"],
	    [ASTSet("_is", e);
	     ASTLoopW(
		 ASTApp("PAIR?",[ASTId "_is"]),
		 ASTBloc(
		     [],
		     [ASTSet(i, ASTApp("CAR",[ASTId "_is"]));
		      s; 
		      ASTSet("_is", ASTApp("CDR",[ASTId "_is"]))]
		   )
	       )
	    ]
	  )
      in
	semStat s' kap sg mu
  | ASTBreak -> mu
  | ASTIf1(e,s) ->
      lb_alt (semExp e sg mu)
	     (semStat s kap sg mu)
	     mu
  | ASTIf2(e,s1,s2) ->
      lb_alt (semExp e sg mu)
	     (semStat s1 kap sg mu)
	     (semStat s2 kap sg mu)
  | ASTTry(s, cs) ->
      semStat s kap (esetCatches cs kap sg) mu
  | ASTRaise x -> 
      let v = lb_eget x sg in
        lb_alt (isCont v)
	       (APP[(valOf v); mu])
               (lb_failwith (x^": not a continuation"))

(* == Auxiliaire: construit l'environnement pour la capture des exceptions    *)
(*   Avec 'cs' suite des cas de capture d'exceptions                          *)
(*        'cs'=('x','s') où 'x' est le nom de l'exception                     *)
(*                          et 's' l'instruction associée                     *)
and esetCatches cs kap sg =
  match cs with
    [] -> sg
  | (x,s)::cs -> 
      esetCatches cs 
	          kap 
	          (lb_eset x (inCont(LBD(["_m"], semStat s kap sg (VAR"_m")))) sg)

(* == Sémantique d'une suite d'instructions ('ss')                            *)
and semStats ss kap sg mu =
  match ss with
    [] -> APP[kap;mu]
  | s::ss -> semStat s (LBD(["_m"],semStats ss kap sg (VAR"_m"))) sg mu

(* == Sémantique d'une expression ('e')                                       *)
and semExp e sg mu =
  let rec loop e =
    match e with
      ASTNum n -> NUM n
    | ASTStr s -> STR s
    | ASTId x -> 
	let v = lb_eget x sg in
          lb_alt (isAddr v)
	         (lb_mget (valOf v) mu)
	         (valOf v)
    | ASTApp("IF",[e1;e2;e3]) ->
	lb_alt (loop e1) (loop e2) (loop e3)
    | ASTApp(f, es) ->
	if is_op f then
	  APP((OP f)::(List.map loop es))
	else
	  let v = lb_eget f sg in
            lb_alt (isFun v)
	           (APP((valOf v)::mu::(List.map loop es)))
                   (lb_failwith (f^": not a function"))
    | ASTAppRec(f, es) ->
	APP((VAR f)::(List.map loop es))
  in
   (loop e)