(* clang.sml
 *
 * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
 * All rights reserved.
 *
 * An tree representation of programs in a C-like language (e.g., C, CUDA,
 * or OpenCL).  The purpose of this code is to commonality between the various
 * backends, which are all generating C-like code.
 *)

structure CLang =
  struct

    type var = string
    type attr = string		(* e.g., "static", "kernel", etc ... *)

    datatype ty
      = T_Num of RawTypes.ty
      | T_Ptr of ty
      | T_Array of ty * int option
      | T_Named of string

    val voidTy = T_Named "void"
    val charPtr = T_Ptr(T_Num(RawTypes.RT_UInt8))
    val int32 = T_Num(RawTypes.RT_Int32)
    val int64 = T_Num(RawTypes.RT_Int64)
    val float = T_Num(RawTypes.RT_Float)
    val double = T_Num(RawTypes.RT_Double)

    datatype decl
      = D_Comment of string list
    (* verbatim text (e.g., preprocessor directives) *)
      | D_Verbatim of string list
    (* global variable declaration *)
      | D_Var of attr list * ty * var * initializer option
    (* function definition *)
      | D_Func of attr list * ty * string * param list * stm
    (* typedef of struct type *)
      | D_StructDef of (ty * string) list * string

    and initializer
      = I_Exp of exp
      | I_Struct of (string * initializer) list
      | I_Array of (int * initializer) list

    and param = PARAM of attr list * ty * var

    and stm
      = S_Block of stm list		(* "{" stms "}" *)
      | S_Comment of string list
      | S_Decl of ty * var * exp option	(* ty var [ '=' exp ]';' *)
      | S_Assign of exp * exp		(* lvalue '=' exp ';' *)
      | S_If of exp * stm * stm		(* 'if' exp stm 'else' stm *)
      | S_While of exp * stm		(* 'while' exp stm *)
      | S_Call of string * exp list
      | S_Return of exp option		(* 'return' [ exp ] ';' *)

    and exp
      = E_Grp of exp			(* "(" e ")" *)
      | E_BinOp of exp * binop * exp	(* e op e *)
      | E_UnOp of unop * exp		(* op e *)
      | E_Apply of string * exp list	(* f "(" ... ")" *)
      | E_Subscript of exp * exp	(* e "[" e "]" *)
      | E_Select of exp * string	(* e "." f *)
      | E_Indirect of exp * string	(* e "->" f *)
      | E_Cast of ty * exp		(* "(" ty ")" e *)
      | E_Var of var
      | E_Int of IntegerLit.integer * ty
      | E_Flt of FloatLit.float * ty
      | E_Bool of bool
      | E_Str of string
      | E_Sizeof of ty			(* "sizeof(" ty ")" *)

  (* binary operators in increasing order of precedence *)
    and binop
      = #||
      | #&&
      | #== | #!=
      | #< | #<= | #>= | #>
      | #+ | #-
      | #* | #/ | #%

    and unop = %- | %! | %& | %* | %~

  (* smart constructors that add E_Grp wrappers based on operator precedence *)
    local
      val commaP	= 0
      val assignP	= 1
      val condP		= 2
      val lorP		= 3
      val landP		= 4
      val borP		= 5
      val bandP		= 6
      val eqP		= 7
      val relP		= 8
      val shiftP	= 9
      val addP		= 10
      val mulP		= 11
      val unaryP	= 12
      val preP		= 13
      val compundP	= 14	(* compound literal *)
      val postP		= 15
      val callP		= 16
      val subP		= 17
      val atomP		= 18
      fun precOfBinop rator = (case rator
	     of #|| => lorP
	      | #&& => landP
	      | #== => eqP | #!= => eqP
	      | #< => relP | #<= => relP | #>= => relP | #> => relP
	      | #+ => addP | #- => addP
	      | #* => mulP | #/ => mulP | #% => mulP
	    (* end case *))
      fun prec (E_Grp _) = atomP
	| prec (E_BinOp(_, rator, _)) = precOfBinop rator
	| prec (E_UnOp(rator, _)) = preP
	| prec (E_Apply _) = callP
	| prec (E_Subscript _) = postP
	| prec (E_Select _) = postP
	| prec (E_Indirect _) = postP
	| prec (E_Cast _) = unaryP
	| prec (E_Var _) = atomP
	| prec (E_Int _) = atomP
	| prec (E_Flt _) = atomP
	| prec (E_Bool _) = atomP
	| prec (E_Str _) = atomP
	| prec (E_Sizeof _) = callP
    in
    fun mkGrp e = if (prec e < atomP) then E_Grp e else e
  (* Note that all C binary operators are left associative. *)
    fun mkBinOp (e1, rator, e2) = let
	  val p = precOfBinop rator
	  val e1' = if prec e1 < p then E_Grp e1 else e1
	  val e2' = if prec e2 <= p then E_Grp e2 else e2
	  in
	    E_BinOp(e1', rator, e2')
	  end
    fun mkUnOp (rator, e) = if prec e < unaryP
	  then E_UnOp(rator, E_Grp e)
	  else E_UnOp(rator, e)
    fun mkApply (f, args) = E_Apply(f, args)
    fun mkSubscript(e1, e2) = if prec e1 < postP
	  then E_Subscript(E_Grp e1, e2)
	  else E_Subscript(e1, e2)
    fun mkSelect (e, f) = if prec e < postP
	  then E_Select(E_Grp e, f)
	  else E_Select(e, f)
    fun mkIndirect (e, f) = if prec e < postP
	  then E_Indirect(E_Grp e, f)
	  else E_Indirect(e, f)
    fun mkCast (ty, e) = E_Cast(ty, e)
    val mkVar = E_Var
    val mkInt = E_Int
    val mkFlt = E_Flt
    val mkBool = E_Bool
    val mkStr = E_Str
    val mkSizeof = E_Sizeof
    end (* local *)

    val skip = S_Block[]

    local
      fun paren (e as E_Grp _) = e
	| paren e = E_Grp e
    in
    fun mkBlock [stm] = stm
      | mkBlock stms = S_Block stms
    val mkDecl = S_Decl
    val mkAssign = S_Assign
    fun mkIfThenElse (e, b1, b2) = S_If(paren e, b1, b2)
    fun mkIfThen (e, b) = mkIfThenElse (e, b, skip)
    fun mkWhile (e, b) = S_While(paren e, b)
    val mkCall = S_Call
    val mkReturn = S_Return
    end (* local *)

  (* utility functions *)

    fun varToString x = x

    fun binopToString rator = (case rator
	   of #|| => "||"
	    | #&& => "&&"
	    | #== => "=="
	    | #!= => "!="
	    | #< => "<"
	    | #<= => "<="
	    | #>= => ">="
	    | #> => ">"
	    | #+ => "+"
	    | #- => "-"
	    | #* => "*"
	    | #/ => "/"
	    | #% => "%"
	  (* end case *))

    fun unopToString rator = (case rator
	   of %- => "-"
	    | %! => "!"
	    | %& => "&"
	    | %* => "*"
	    | %~ => "~"
	  (* end case *))

    fun expToString e = let
	  fun e2s (e, l) = (case e
	       of E_Grp e => "(" :: e2s(e, ")"::l)
		| E_BinOp(e1, rator, e2) => e2s(e1, binopToString rator :: e2s(e2, l))
		| E_UnOp(rator, e) => unopToString rator :: e2s(e, l)
		| E_Apply(f, es) => let
		    fun args2s ([], l) = l
		      | args2s ([e], l) = e2s(e, l)
		      | args2s (e::es, l) = e2s(e, ","::args2s(es, l))
		    in
		      f :: "(" :: args2s(es, ")"::l)
		    end
		| E_Subscript(e1, e2) => e2s(e1, "[" :: e2s(e2, "]"::l))
		| E_Select(e, f) => e2s(e, "." :: f :: l)
		| E_Indirect(e, f) => e2s(e, "->" :: f :: l)
		| E_Cast(ty, e) => "(ty)" :: e2s(e, l)  (* FIXME *)
		| E_Var x => x::l
		| E_Int(n, _) => IntegerLit.toString n :: l
		| E_Flt(f, _) => FloatLit.toString f :: l
		| E_Bool b => Bool.toString b :: l
		| E_Str s => concat["\"", String.toCString s, "\""] :: l
		| E_Sizeof ty => "sizeof(ty)" :: l
	      (* end case *))
	  in
	    String.concat(e2s(e, []))
	  end

  end