structure Translate : TRANSLATE = struct

structure Frame = MipsFrame
structure F = MipsFrame
structure T = Tree

val errormsg = ErrorMsg.errormsg
datatype level = Outermost
	       | FunLevel of {frame: F.frame, parent: level, ptr: unit ref}

datatype exp = Ex of Tree.exp
	     | Nx of Tree.stm
	     | Cx of Temp.label * Temp.label -> Tree.stm
						
type access = level * F.access

val debug_global = true
fun debugSay s = if debug_global then TextIO.print (s ^ "\n") else ()
	      
val fraglist : F.frag list ref = ref []

val outermost = Outermost
fun newLevel {parent=parent : level, name=name, formals=formals} =
    FunLevel{frame=F.newFrame({name=name, formals=true::formals}),
	     parent=parent, ptr = ref ()}
    
fun formals (FunLevel{frame=frame,parent=parent,ptr=ptr}) =
    (map (fn e => (FunLevel{frame=frame,
			    parent=parent,ptr=ptr},e))
	 (tl (F.formals frame)))
  | formals (Outermost) =
    (errormsg "internal compiler error: attempted to get formals of outermost"; [])

fun allocLocal (FunLevel({frame=frame,parent=parent,ptr=ptr})) (escapes:bool) =
    (FunLevel({frame=frame,parent=parent,ptr=ptr}):level, (F.allocLocal frame escapes))
  | allocLocal (Outermost) (_) =
    (errormsg "internal compiler error: attempted to allocate temporary in outermost";
     raise ErrorMsg.Error)
    
fun seq [] = T.EXP (T.CONST 0) (* nil exp *)
  | seq (head::[]) = head
  | seq (head::tail) = T.SEQ (head, seq(tail))

fun unEx (Ex e) = e
  | unEx (Cx genstm) =
    let val r = Temp.newtemp()
	val t = Temp.newlabel () 
	and f = Temp.newlabel()

    in T.ESEQ (seq [T.MOVE(T.TEMP r, T.CONST 1),
		    genstm (t, f), 
		    T.LABEL f,
		    T.MOVE (T.TEMP r, T.CONST 0),
		    T.LABEL t],
	       T.TEMP r)
    end
  | unEx (Nx s) = T.ESEQ (s, T.CONST 0)
		  

fun unNx (Ex e) = T.EXP (e)
  | unNx (Cx genstm) = let val l = Temp.newlabel()
		       in
			   T.SEQ (genstm(l,l), T.LABEL l)
		       end
  | unNx (Nx s) = s

fun unCx (Ex e) = 
    (fn (t, f) =>
	T.CJUMP (T.EQ, e, T.CONST 0, f, t))
  | unCx (Cx genstm) = genstm
  | unCx (Nx _) = (errormsg "Error Nx found where nothing of the sort at all expected";
		   (fn (t, f) => T.JUMP (T.NAME t, [t])))

		  
fun traverseStaticLinks (Outermost, _, _) =
    (errormsg "Hit Outermost while traversing variable reference in traverseStaticLinks.";
     T.CONST 0)
  | traverseStaticLinks (FunLevel{frame=frame,parent=parent,ptr=ptr}, decptr, access) =
    (if (ptr = decptr) then
	 Frame.exp(access, T.TEMP Frame.FP)
     else (* no need to add zero *)
         T.MEM(traverseStaticLinks(parent, decptr, access)))

fun getStaticLink (Outermost, _, _) =
    (errormsg "Hit Outermost while traversing variable reference in getStaticLink.";
     T.CONST 0)
  | getStaticLink (FunLevel{frame=frame,parent=parent,ptr=ptr}, decptr, init) =
    (debugSay "=>getStaticLink";
     if (ptr = decptr) then
        init
     else (* no need to add zero *)
        T.MEM(getStaticLink(parent, decptr, init)))
    
fun procEntryExit ({level=FunLevel({frame=frame,...}),body=body}) = 
    (fraglist := (F.PROC({frame=frame, 
			body=Frame.procEntryExit1(frame,unEx body)})::(!fraglist)))
  | procEntryExit ({level=Outermost,body=_}) =
    (errormsg "internal compiler error: attempted to translate outermost frame")

fun getResult _ = !fraglist

fun printResult _ =
    (TextIO.print "\t.text\n";
    (app (fn (F.PROC({body=body,frame=frame})) =>
	     (TextIO.print ("\t" ^ (Temp.labelname (F.name frame)) ^ ":\n");
	      Printtree.printtree (TextIO.stdOut, body))
	  | _ => ()) (!fraglist);
     (* should this be hardcoded here or in MipsFrame? *)
    TextIO.print "\t.data\n";
    app (fn (F.STRING(label,value)) => TextIO.print (F.string (label,value))
	  | _ => ()) (!fraglist)))
		  
fun levelname Outermost = "Outermost"
  | levelname (FunLevel{frame,parent,ptr}) =
    ("FunLevel(" ^ (Temp.labelname (Frame.name frame)) ^ ")")

fun printLevel l = TextIO.print (levelname l)

fun simpleVar ((FunLevel({frame=decframe,parent=decparent,ptr=decptr}),access) : access, 
	       curlevel : level) =
    (debugSay ("simpleVar: access = " ^ (Frame.accessname access));
     let 
     in
         Ex(traverseStaticLinks (curlevel, decptr, access))
     end)
  | simpleVar ((Outermost,_), _) =
    (errormsg "internal compiler error: attempted to get simplevar in outermost frame";
     raise ErrorMsg.Error)

structure A=Absyn
fun transArithOp (oper, left, right) =
    Ex(T.BINOP((case oper of
		    A.PlusOp => T.PLUS
		  | A.MinusOp => T.MINUS
		  | A.TimesOp => T.MUL
		  | A.DivideOp => T.DIV
		  | _ => (errormsg "internal compiler error"; T.PLUS)),
	       unEx left,unEx right))
fun transComparisonOp (comp, left:exp, right:exp) =
    let val r = Temp.newtemp()
	val t = Temp.newlabel () 
	and f = Temp.newlabel()

    in Ex(T.ESEQ (seq [T.MOVE(T.TEMP r, T.CONST 1),
		       T.CJUMP(
			       (case comp of
				    A.EqOp => T.EQ
				  | A.NeqOp => T.NE
				  | A.LtOp => T.LT
				  | A.LeOp => T.LE
				  | A.GtOp => T.GT
				  | A.GeOp => T.GE
				  | _ => (errormsg "internal compiler error"; T.EQ)),
			       unEx left, unEx right, t, f),	
	       T.LABEL f,
		       T.MOVE (T.TEMP r, T.CONST 0),
		       T.LABEL t],
		  T.TEMP r))
    end


fun transIntValue (intexp:int) = 
    Ex(T.CONST intexp)

fun transStringValue (strexp:string) = 
    let val lab = Temp.newlabel() 
    in
	(fraglist := (F.STRING (lab, strexp))::(!fraglist);
	 Ex(Tree.NAME(lab)))
    end

fun transNilValue(_) = Ex(T.CONST (0))

fun transSeqExp l =
  let fun butlast [] = raise Empty
	| butlast [e] = []
	| butlast (h::t) = h::(butlast t)
      val llen = List.length l
  in
      if llen = 0 then Ex(T.CONST 0)
      else if llen = 1 then hd l
      else
           let val (rest, last) = (butlast l, List.last l) in
               Ex (T.ESEQ(seq (map unNx rest),
			  unEx last))
	   end
  end

fun transIfExp (test, then', else') =
    let val testfn = unCx test
	val thenexp = unEx then'
	val elseexp = unEx else'
	val r = Temp.newtemp()
	val t = Temp.newlabel()
	val f = Temp.newlabel()
	val j = Temp.newlabel()
    in
	Ex (T.ESEQ (seq [testfn(t,f),
		     T.LABEL t,
		     T.MOVE(T.TEMP r, thenexp),
		     T.JUMP(T.NAME j, [j]),
		     T.LABEL t,
		     T.MOVE(T.TEMP r, elseexp),
		     T.LABEL j],
		T.TEMP r))
    end


fun transWhileExp (test, body, doneLabel) = 
    let val testLabel = Temp.newlabel()
	val continueLabel = Temp.newlabel()
	val doneLabel = Temp.newlabel()
    in 
	Nx (seq[T.LABEL testLabel,
		(unCx (Ex (unEx test))) (doneLabel, continueLabel),
		T.LABEL continueLabel,
		unNx body,
		T.JUMP (T.NAME testLabel, [testLabel]),
		T.LABEL doneLabel])
    end

fun transBreakExp (doneLabel) = Nx (T.JUMP (T.NAME doneLabel, [doneLabel]))

fun transForExp (init, limit, body) =
    let val init' = Temp.newtemp()
	val limit' = Temp.newtemp()
	val cntr = Temp.newtemp()
	val done = Temp.newlabel()
	val loop = Temp.newlabel()
	val incr = Temp.newlabel()
    in
	Nx(seq[T.MOVE(T.TEMP init', unEx init),
	       T.MOVE(T.TEMP limit', unEx limit),
	       T.CJUMP(T.LE, T.TEMP init', T.TEMP limit', loop,  done),
	       T.LABEL loop,
	       unNx body,
	       T.CJUMP(T.EQ, T.TEMP cntr, T.TEMP limit', done, incr),
	       T.LABEL incr,	    
	       T.MOVE(T.TEMP cntr, T.BINOP(T.PLUS, T.TEMP cntr, T.CONST 1)),
	       T.JUMP(T.NAME loop, [loop]),
	       T.LABEL done])
    end

fun transAssignExp (lhsexp, rhsexp) = Nx (T.MOVE (T.MEM (unEx lhsexp), unEx rhsexp))
(* not sure about that 'mem' access... *)		    

fun transVarInit (variable, initExp) = 
    let val (_,access) = variable in 
	Nx (T.MOVE (Frame.exp(access, T.TEMP Frame.FP), unEx initExp))
    end

fun transCallExp (label : Temp.label, calllevel : level, funlevel : level, args : exp list) =
    (debugSay ("calllevel : " ^ (levelname calllevel)
	       ^ " funlevel : " ^ (levelname funlevel));
    let val args' = map unEx args in
            case (funlevel,calllevel) of
                 (FunLevel{frame=funframe,parent=funparent,ptr=funptr},
                  FunLevel{frame=callframe,parent=callparent,ptr=callptr}) =>
		 (case funparent of
                   (FunLevel{frame=parentframe,parent=_,ptr=parentptr}) =>
                  (let val staticaccess = hd (Frame.formals funframe)
 		       val static = getStaticLink(calllevel, parentptr,
						  T.MEM(T.TEMP Frame.FP))
		   in
                          Ex (T.CALL (T.NAME label, static::args'))
		  end)
                  | Outermost =>
		    Ex (T.CALL (T.NAME label, (T.CONST 0)::args')))
	   | (Outermost, _) => (Ex (T.CALL (T.NAME label, args')))
	   | (_, Outermost) => (errormsg "Function used in Outermost??"; raise ErrorMsg.Error)
    end)

fun transArrayExp(size : exp, init : exp) = 
    (* declaration of an array *)
    Ex(Frame.externalCall ("initArray", [unEx size, unEx init]))
    
fun transRecordExp (size: exp, inits : exp list) = 
    let val t = Temp.newtemp() in
	Ex(T.ESEQ (seq([T.MOVE(T.TEMP t, Frame.externalCall( "allocRecord", [unEx size]))]
		       @
		       (let val offset = ref 0 in
			    map (fn (e:Tree.exp) => let val ret = 
							 T.MOVE(T.MEM (T.BINOP(T.PLUS, 
									       T.CONST (!offset),
									       T.MEM (T.TEMP t))),
								e)
						 in
						     (offset := (!offset+Frame.wordSize);
						      ret)
						 end)
				(map unEx inits)
				end)),
		   T.TEMP t))
    end

fun transSubscriptVarExp (base : exp, offset : exp) = 
    Ex(T.MEM (T.BINOP (T.PLUS, 
		       T.BINOP (T.MUL, T.CONST Frame.wordSize, unEx offset),
		       T.MEM (unEx base))))
fun transFieldVarExp (varexp : exp, offset : exp) =
    Ex(T.MEM(T.BINOP(T.PLUS, unEx varexp, unEx offset)))
(*
transdecs must build global fraggle list
 -   | transExp A.LetExp{decs=decs, body=body, pos=pos}, level) =

  | transExp A.CallExp{func=func, args=args, pos=pos}, level) =
*)

end