gistfile1.fs

open ExtList
open Util

type tmp        = TMP of int
and  tree_expr  =  VCALL of tmp * tmp list
                 | CCALL of string * tmp list
                 | ICONST of int
                 | SCONST of string
                 | FALSE
                 | TRUE
and block = S of (tmp * tree_expr) | M of (tmp * tree_expr) * (tmp * tree_expr) list

let rec tree_dump t = List.iter tree_dump_item t
and tree_dump_item = function
    | (TMP(i), SCONST(s))        -> Printf.printf "TMP(%d) <- SCONST(%s)\n" i s
    | (TMP(i), ICONST(x))        -> Printf.printf "TMP(%d) <- ICONST(%d)\n" i x
    | (TMP(i), VCALL(TMP(k),tl)) -> Printf.printf "TMP(%d) <- VCALL(TMP(%d) %s)\n" i k (List.fold_left (fun s (TMP(x)) -> s ^ Printf.sprintf "TMP(%d) " x) "" tl)
    | (TMP(i), CCALL(s,tl))      -> Printf.printf "TMP(%d) <- CCALL(%s %s)\n" i s (List.fold_left (fun s (TMP(x)) -> s ^ Printf.sprintf "TMP(%d) " x) "" tl)
    | _ -> Printf.printf "\n"

let rec compile_tree (Ast.Ast(e)) =
    let d = ref 0
    in let tmp () = let () = d := 1 + !d in TMP(!d)
    in let rec context el = match el with
       | S(x)    :: rest -> x :: context rest
       | M(x,xs) :: rest -> xs @ [x] @ context rest
       | []              -> []
    in let unwrap acc x = match x with
       | S(a) -> a :: acc
       | M(a,b) -> acc @ b @ [a]

    in let rec compile_tree_exp = function
           | Ast.Bool(false) -> S ((tmp(), FALSE))
           | Ast.Bool(true)  -> S ((tmp(), TRUE))
           | Ast.Int(d)      -> S ((tmp(), ICONST(d)))
           | Ast.Character(c)-> S ((tmp(), ICONST(c)))
           | Ast.String(s)   -> S ((tmp(), SCONST(s)))
           | Ast.Symbol(s)   -> S ((tmp(), SCONST(s)))
           | Ast.Appl(s, e)  -> compile_call (s,e)
    and compile_call (s,e) = 
       let args    = List.map compile_tree_exp e
       in let tmps = List.map (function S((a,b)) -> a | M((a,b),_) -> a) args
       in match s with
       | Ast.Symbol(fn)  -> let call = (tmp(), CCALL(fn, tmps))
                            in M(call, context args)

       | Ast.Appl _     -> let fnctx = compile_tree_exp s
                           in let fn = match fnctx with S (x) -> x | M(x,_) -> x
                           in let call = (tmp(), VCALL(fst fn, tmps))
                           in M(call, context (fnctx :: args)) 

       | _              -> failwith "bad call"
    in List.map compile_tree_exp e |> List.fold_left unwrap []