(* INTERPRETE ITERATIVO CON FUNZIONI E DICHIARAZIONI (anche ricorsive) *) (* DOMINI SINTATTICI *) 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;; (* SEMANTIC DOMAINS *) type env = ide -> eval and proc = exp * env and eval = Funval of proc | Mkpair of eval * eval | Int of int | Bool of bool | Unbound let emptyenv = function (x: ide) -> Unbound let applyenv ((x: env), (y: ide)) = x y let bind ((r:env), l, (e:eval)) = function lu -> if lu = l then e else r(lu) (* Operations on Eval *) 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 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") (* NUOVI DOMINI PER SIMULARE LA RICORSIONE *) (* Mutable stack *) 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) then Array.get s k else failwith("error in access") (* Etichette *) type label = Tovisit| Ready;; (* Funzioni di comodo e pile globali *) let nop () = ();; let stacksize = 100 let cframesize(e) = 20 let tframesize(e) = 20;; let envstack = emptystack(stacksize,emptyenv) let cstack = emptystack(stacksize,emptystack(1,(Tovisit,Eint(0)))) let tempvalstack = emptystack(stacksize,emptystack(1,Unbound));; 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); push(rho,envstack);; (*SEMANTIC EVALUATION FUNCTIONS *) 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"));; (* val makefun : exp * env -> eval = val applyfun : eval * eval -> unit = *) let sem ((e:exp),(r:env)) = push(emptystack(1,Unbound),tempvalstack); newframes(e,r); while not(empty(cstack)) do while not(empty(top(cstack))) do let continuation = top(cstack) in let tempstack = top(tempvalstack) in let rho = top(envstack) 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) -> push(applyenv(rho,i),tempstack) | Pair(a,b) -> let firstarg=top(tempstack) in pop(tempstack); let sndarg=top(tempstack) in pop(tempstack); push(Mkpair(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) -> let rec ff = function j -> applyenv(bind(rho,i,(makefun(a, ff))),j) in newframes(b,ff)) done; let valore= top(top(tempvalstack)) in pop(envstack); pop(cstack); pop(tempvalstack); push(valore,top(tempvalstack)); done; top(top(tempvalstack));; (* val sem : exp * env -> eval = *) (* ESEMPI *) (* let factorial = Letrec (Id "fact", Fun (Id "x", Ifthenelse (Iszero (Diff (Var (Id "x"), Eint 1)), Eint 1, Prod (Var (Id "x"), Appl (Var (Id "fact"), Diff (Var (Id "x"), Eint 1))))), Appl (Var (Id "fact"), Eint 10));; let expo = Letrec (Id "expo", Fun (Id "x", Let (Id "base", First (Var (Id "x")), Let (Id "espo", Snd (Var (Id "x")), Ifthenelse (Iszero (Var (Id "espo")), Eint 1, Prod (Var (Id "base"), Appl (Var (Id "expo"), Pair (Var (Id "base"), Diff (Var (Id "espo"), Eint 1)))))))), Appl (Var (Id "expo"), Pair (Eint 2, Eint 3)));; # sem(factorial,emptyenv);; - : eval = Int 3628800 # sem(expo,emptyenv);; - : eval = Int 8 *)