; load "Int";

type index = int 
type noi   = int                (* number of instructions      *)
type noa   = int                (* number of arguments         *)
type ca    = int                (* code address                *)

datatype instruction =
    con     of int             
  | add                         (* addition                    *)
  | sub                         (* substraction                *)
  | mul                         (* multiplication              *)
  | leq                         (* less or equal test          *)
  | branch  of noi              (* unconditional branch        *)
  | cbranch of noi              (* conditional branch          *)
  | getS    of index            (* push value from stack       *)
  | putS    of index            (* update value in stack       *)
  | halt                        (* halt machine                *)
  | proc    of noa * noi        (* begin of procedure code     *)
  | getF    of index            (* push value from frame       *)
  | call    of ca               (* call procedure              *)
  | return                      (* return from procedure call  *)
  | callR   of ca               (* call procedure and return   *)
  | getH    of index            (* push value from heap block  *)
  | putH    of index            (* store value into heap block *)
  | new     of noa              (* alloc new heap block of size noa *)
  | arg     of index            (* push value from frame *)
  | eq                          (* test for equality of heap blocks *)
  | len                         (* push size of heap block *)

(* Aufgabe 15.2 *)

datatype 'a state = G of bool * 'a * 'a graph list
withtype 'a graph = 'a state ref

fun cons x gs = ref(G(false, x, gs))

fun assign (g as ref(G(m,x,_))) gs = g := G(m, x, gs)

fun reset nil                              = ()
  | reset ((g as ref(G(true, x, gs)))::xr) =
    (g := G(false, x, gs); reset (gs @ xr))
  | reset ((g as ref(G(false, x, gs)))::xr) = reset xr

fun tree (g as ref(G(_, x, gs))) =
    (g := G(true, x, gs); (tree' gs before reset [g]))
and tree' nil                               = true
  | tree' ((ref(G(true, _, _)))::xr)        = false
  | tree' ((g as ref(G(false, x, gs)))::xr) =
    (g := G(true, x, gs); tree' (gs @ xr))

fun count gs              = count' 0 gs before reset gs
and count' n nil          = n
  | count' n ((g as ref(G(false, x, gs)))::xr) =
    (g := G(true, x, gs); count' (n + 1) (gs @ xr))
  | count' n (g as ref(G(true, x, gs))::xr) = count' n xr
    
(* Aufgabe 15.3 *)

fun cons a xs = a::xs

fun null nil = true
  | null _   = false

fun hd (x::xr) = x
  | hd _       = raise Empty

fun tl (x::xr) = xr
  | tl _       = raise Empty

fun gen n     = gen' nil n
and gen' xs n = if n <= ~1 then xs else gen' (cons n xs) (n - 1)

fun sum xs         = sum' 0 xs
and sum' s (x::xr) = sum' (s + x) xr
  | sum' s nil     = s

val vm_cons = [proc(2, 5), arg 2, arg 1, new 2, return]

val vm_null = [proc(1, 5), con 0, arg 1, eq, return]
val vm_hd   = [proc(1, 4), arg 1, getH 1, return]
val vm_tl   = [proc(1, 4), arg 1, getH 2, return]

val vm_gen = [proc(1, 4), arg 1, con 0, callR 4,
	      proc(2, 14), con ~1, arg 2, leq, cbranch 3,
	      arg 1, return,
	      con 1, arg 2, sub,
	      arg 1, arg 2, new 2,
	      callR 4]

val vm_sum = [proc(1, 4), arg 1, con 0, callR 4,
	      proc(2, 14), con 0, arg 2, eq, cbranch 3,
	      arg 1, return,
	      arg 2, getH 2,
	      arg 2, getH 1, arg 1, add, callR 4]

(* Aufgabe 15.4 *)

signature STORE =
sig
  exception Error
  eqtype value
  val fromInt : int   -> value
  val toInt   : value -> int
  val isInt   : value -> bool
  val pair    : value * value -> value
  val first   : value -> value
  val second  : value -> value
  val updateF : value * value -> unit
  val updateS : value * value -> unit
  val clone   : value -> value
end  

structure Store :> STORE =
  struct
    exception Error
    
   type value = int

    val heapSize = 100
    val heap = Array.array(heapSize, 0)
    val fha = 100000 - heapSize + 1
(*    val fha = valOf(Int.maxInt)-heapSize+1  (* first heap address *) *)
    val hp = ref(fha-1)  (* topmost heap cell allocated *)

    fun isI v = v<fha

    fun getH' ha = Array.sub(heap, ha-fha)

    fun putH'(ha,v) = Array.update(heap, ha-fha, v)

    fun alloc v = (hp:= !hp+1 ; putH'(!hp,v))

    fun cons(x, xs) = if (!hp - fha + 4) > heapSize
                      then raise Error
                      else (alloc(~1);
			    alloc(x);
			    alloc(xs);
			    !hp-2)

    val wc  = ref ~1  (* counter for while loop  *)

    (* Interface Section *)

    fun fromInt i = if isI i then i else raise Error
    fun toInt v = if isI v then v else raise Error
    fun isInt v = isI v
    fun pair(x, xs) = cons(x, xs)
    fun first v = getH' (v + 1)
    fun second v = getH' (v + 2)
    fun updateF(v, x) = putH'(v + 1, x)
    fun updateS(v, x) = putH'(v + 2, x)

    val iwc = ref ~1  (* counter for inner while loop  *)

    fun clone' ha = (iwc:= ha ;
		     while !iwc < ha+3 do
                       (alloc(getH'(!iwc)) ; iwc:= !iwc+1))
			
    fun copyBlock oldba =
	if not(isI(getH' oldba)) then getH' oldba
	else let 
            val newba = !hp+1
	  in
            clone' oldba;
            putH'(oldba,newba); 
            newba 
	  end

    fun clone v =
	if isI v then v
	else
	  let
	    val v' = copyBlock v
	  in
	    (wc := v';
	     while !wc <= !hp do
	       (if isI(getH'(!wc)) then () 
		else putH'(!wc, copyBlock(getH'(!wc))) ;
		wc:= !wc+1);
             wc := fha;
	     while !wc < v' do
	       (putH'(!wc, ~1);
		wc := !wc + 3);
             v')
	  end
  end