(* INTERPRETE ITERATIVO CON FUNZIONI E DICHIARAZIONI (anche ricorsive) CON IMPLEMENTAZIONE DELL"AMBIENTE (catena statica) *) (* DOMINI SINTATTICI: invariati *) type ide = Id of string type exp = Eint of int | Ebool of bool | Var of ide | Pair of exp * exp | First of exp | Snd of exp | Prod of exp * exp | Sum of exp * exp | Diff of exp * exp | Eq of exp * exp | Minus of exp | Iszero of exp | Or of exp * exp | And of exp * exp | Not of exp | Ifthenelse of exp * exp * exp | Fun of ide * exp | Appl of exp * exp | Letrec of ide * exp * exp | Let of ide * exp * exp;; (* DOMINI SEMANTICI: cambia env *) type env = int type proc = exp * env type eval = Funval of proc | Mkpair of eval * eval | Int of int | Bool of bool | Unbound (* Operations on Eval: invariate *) let typecheck (x, y) = match x with | "int" -> (match y with | Int(u) -> true | _ -> false) | "bool" -> (match y with | Bool(u) -> true | _ -> false) | _ -> failwith ("not a valid type") let minus x = if typecheck("int",x) then (match x with | Int(y) -> Int(-y) ) else failwith ("type error") let iszero x = if typecheck("int",x) then (match x with | Int(y) -> Bool(y=0) ) else failwith ("type error") let equ (x,y) = if typecheck("int",x) & typecheck("int",y) then (match (x,y) with | (Int(u), Int(w)) -> Bool(u = w)) else failwith ("type error") let plus (x,y) = if typecheck("int",x) & typecheck("int",y) then (match (x,y) with | (Int(u), Int(w)) -> Int(u+w)) else failwith ("type error") let diff (x,y) = if typecheck("int",x) & typecheck("int",y) then (match (x,y) with | (Int(u), Int(w)) -> Int(u-w)) else failwith ("type error") let mult (x,y) = if typecheck("int",x) & typecheck("int",y) then (match (x,y) with | (Int(u), Int(w)) -> Int(u*w)) else failwith ("type error") let pair (x,y) = Mkpair(x,y) let first x = match x with Mkpair(y,z) -> y |_ -> failwith ("type error") let snd x = match x with Mkpair(y,z) -> z |_ -> failwith ("type error") let et (x,y) = if typecheck("bool",x) & typecheck("bool",y) then (match (x,y) with | (Bool(u), Bool(w)) -> Bool(u & w)) else failwith ("type error") let vel (x,y) = if typecheck("bool",x) & typecheck("bool",y) then (match (x,y) with | (Bool(u), Bool(w)) -> Bool(u or w)) else failwith ("type error") let non x = if typecheck("bool",x) then (match x with | Bool(y) -> Bool(not y) ) else failwith ("type error") (* Mutable stack: aggiunta un'operazione di svuotamento *) type 'x stack = ('x array) * int ref let emptystack(nm,x) = (Array.create nm x, ref(-1)) let push(x,(s,n)) = if !n = (Array.length(s) - 1) then failwith("full stack") else (Array.set s (!n +1) x; n := !n +1) let top(s,n) = if !n = -1 then failwith("top is undefined") else Array.get s !n let pop(s,n) = if !n = -1 then failwith("pop is undefined") else n:= !n -1 let empty(s,n) = if !n = -1 then true else false let lungh(s,n) = !n let access ((s,n), k) = if not(k > !n) & not(k < 0) then Array.get s k else failwith("error in access") let svuota (s,n) = n := -1 (* Etichette: invariate *) type label = Tovisit| Ready;; (* Funzioni di comodo e pile globali: - envstack rimpiazzato da 4 stacks - funzioni per gestire la retention *) let nop () = ();; let stacksize = 100 let cframesize(e) = 20 let tframesize(e) = 20;; let cstack = emptystack(stacksize,emptystack(1,(Tovisit,Eint(0)))) let tempvalstack = emptystack(stacksize,emptystack(1,Unbound));; type tag = Retained| Standard let namestack = emptystack(stacksize,Id("dummy")) let dvalstack = emptystack(stacksize,Unbound) let slinkstack = emptystack(stacksize, -1) let tagstack = emptystack(stacksize, Standard) let retained (n:env) = if access(tagstack,n) = Retained then true else false let currentenv = ref(0);; let newframes(e,rho) = let cframe = emptystack(cframesize(e),(Tovisit,e)) in let tframe = emptystack(tframesize(e),Unbound) in push((Tovisit,e),cframe); push(cframe,cstack); push(tframe,tempvalstack);; (* Operazioni sull'ambiente: nuove *) let emptyenv = -1 let applyenv ((x: env), (y: ide)) = let n = ref(x) in let den = ref(Unbound) in while !n > -1 do if access(namestack,!n)=y then (den := access(dvalstack,!n); n := -1) else n := access(slinkstack,!n) done; !den let bind ((r:env),i,d) = push(i,namestack); push(d,dvalstack); push(Standard,tagstack); push(r,slinkstack); currentenv:= lungh(dvalstack); !currentenv;; let retain () = match tagstack with (a,m) -> Array.set a !currentenv Retained; let cont = ref(lungh(dvalstack)) in while !cont > -1 & retained(!cont) do cont := !cont - 1 done; currentenv := !cont (* Funzioni di valutazione semantica: - piccole modifiche per la retention - inizializzazione - letrec *) let makefun ((a:exp),(x:env)) = (match a with | Fun(ii,aa) -> Funval(a,x) | _ -> failwith ("Non-functional object"));; let applyfun ((a:eval),(b:eval)) = ( match a with | Funval(Fun(ii,aa),x) -> newframes(aa,bind(x,ii,b)) | _ -> failwith ("attempt to apply a non-functional object"));; let sem1 ((e:exp)) = newframes(e,!currentenv); while not(empty(cstack)) do while not(empty(top(cstack))) do let continuation = top(cstack) in let tempstack = top(tempvalstack) in let rho = !currentenv in match top(continuation) with |(Tovisit,x) -> (pop(continuation); push((Ready,x),continuation); match x with | Pair(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Iszero(a) -> push((Tovisit,a),continuation) | Eq(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | First(a) -> push((Tovisit,a),continuation) | Snd(a) -> push((Tovisit,a),continuation) | Prod(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Sum(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Diff(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Minus(a) -> push((Tovisit,a),continuation) | And(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Or(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Not(a) -> push((Tovisit,a),continuation) | Ifthenelse(a,b,c) -> push((Tovisit,a),continuation) | Appl(a,b) -> push((Tovisit,a),continuation); push((Tovisit,b),continuation) | Let(i,a,b) -> push((Tovisit,a),continuation) | (_) -> nop()) |(Ready,x) -> (pop(continuation); match x with | Eint(n) -> push(Int(n),tempstack) | Ebool(b) -> push(Bool(b),tempstack) | Var(i) -> let d = applyenv(rho,i) in if d = Unbound then failwith "Unbound atom" else push(d,tempstack) | Pair(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(pair(firstarg,sndarg),tempstack) | Iszero(a) -> let arg=top(tempstack) in pop(tempstack); push(iszero(arg),tempstack) | Eq(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(equ(firstarg,sndarg),tempstack) | First(a) -> let arg=top(tempstack) in pop(tempstack); push(first(arg),tempstack) | Snd(a) -> let arg=top(tempstack) in pop(tempstack); push(snd(arg),tempstack) | Prod(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(mult(firstarg,sndarg),tempstack) | Sum(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(plus(firstarg,sndarg),tempstack) | Diff(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(diff(firstarg,sndarg),tempstack) | Minus(a) -> let arg=top(tempstack) in pop(tempstack); push(minus(arg),tempstack) | And(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(et(firstarg,sndarg),tempstack) | Or(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(vel(firstarg,sndarg),tempstack) | Not(a) -> let arg=top(tempstack) in pop(tempstack); push(non(arg),tempstack) | Ifthenelse(a,b,c) -> let arg=top(tempstack) in pop(tempstack); if typecheck("bool",arg) then (if arg = Bool(true) then push((Tovisit,b),continuation) else push((Tovisit,c),continuation)) else failwith ("type error") | Fun(i,a) -> push(makefun(Fun(i,a),rho),tempstack) | Appl(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); applyfun(firstarg,sndarg) | Let(i,a,b) -> let arg=top(tempstack) in pop(tempstack); newframes(b,bind(rho,i,arg)) | Letrec(i,a,b) -> newframes(b,bind(rho,i,makefun(a,lungh(dvalstack) + 1)))) done; let valore= top(top(tempvalstack)) in pop(cstack); pop(tempvalstack); push(valore,top(tempvalstack)); (* retention *) if !currentenv < lungh(dvalstack) then retain() else let isaclosure = (match valore with | Funval(f) -> true | (_) -> false) in if isaclosure then retain() else (pop(tagstack); pop(namestack); pop(dvalstack); pop(slinkstack); while not(empty(dvalstack)) & retained(lungh(dvalstack)) do pop(tagstack); pop(namestack); pop(dvalstack); pop(slinkstack) done; currentenv := lungh(dvalstack)) done; top(top(tempvalstack));; let sem ((e:exp)) = svuota(cstack);svuota(tempvalstack);svuota(dvalstack); svuota(namestack);svuota(slinkstack);svuota(tagstack); push(emptystack(1,Unbound),tempvalstack); bind(emptyenv,Id "dummy", Unbound); sem1(e);;