module type struttrt = sig open Ceval open Expr type 'x stack type label = Tovisit| Ready| Revisited val emptyenv : env val applyenv : env * ide -> eval val bind : env * ide * eval -> env val emptystack : int * 'a -> 'a stack val push : 'a * ('a stack) -> unit val top : 'a stack -> 'a val pop : 'a stack -> unit val empty : 'a stack -> bool val lungh : 'a stack -> int val access : ('a stack) * int -> 'a val svuota : 'a stack -> unit val nop : unit -> unit val namestack : ide stack val dvalstack : eval stack val slinkstack : env stack type tag = Standard | Retained val tagstack : tag stack val currentenv : env ref val retained : env -> bool val cstack : ((label * exp) stack) stack val tempvalstack : (eval stack) stack val newframes : exp -> unit val retain : unit -> unit val size : int val emptyclos : exp * env val tproc : (exp * env) array val targ : eval array val tres : eval array val inittables : unit -> unit end (* alfa dei valori concreti, rivisitazione per il condizionale *) module Struttrt: struttrt = struct open Ceval open Expr (* Mutable stack: aggiunta un'operazione per svuotare *) 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: aggiunto il caso per il condizionale *) type label = Tovisit| Ready| Revisited (* Funzioni di comodo e pile globali *) let nop () = () let stacksize = 100 let cframesize(e) = 20 let tframesize(e) = 20 let namestack = emptystack(stacksize,Id("dummy")) let dvalstack = emptystack(stacksize,alfa(Unbound)) let slinkstack = emptystack(stacksize, -1) type tag = Standard | Retained let tagstack = emptystack(stacksize, Standard) let retained (n:env) = if access(tagstack,n) = Retained then true else false let currentenv = ref(0) let cstack = emptystack(stacksize,emptystack(1,(Tovisit,Eint(0)))) let tempvalstack = emptystack(stacksize,emptystack(1,alfa(Unbound))) let newframes(e) = let cframe = emptystack(cframesize(e),(Tovisit,e)) in let tframe = emptystack(tframesize(e),alfa(Unbound)) in push((Tovisit,e),cframe); push(cframe,cstack); push(tframe,tempvalstack) 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 (* Operazioni sull'ambiente: astrazione di Unbound *) let emptyenv = -1 let applyenv ((x: env), (y: ide)) = let n = ref(x) in let den = ref(alfa(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 (* Tabelle per il memoing *) let size = 100 let emptyclos = (Eint 1 ,-1) let tproc = Array.create size emptyclos let targ = Array.create size (alfa Unbound) let tres = Array.create size (alfa Indef) let inittables () = let i = ref(0) in while !i < size do Array.set tproc !i emptyclos; i := !i + 1 done end