Fix up for MLton build.

[snipe.git] / type / type.sml

signature TYPE =
sig
  type ident = Symbol.symbol
  datatype vtype = Int | String | Typedef of ident | Pointer of vtype | Array of vtype | TNull
  type variable = ident * vtype
  datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list

  val typeeq : vtype * vtype -> bool
  val castable : vtype * vtype -> bool
  val size : vtype -> int
  val sizeof : typedef Symbol.table -> vtype -> int
  val sizeof_reset : unit -> unit
  val alignment : typedef Symbol.table -> vtype -> int
  val alignment_reset : unit -> unit
  val align : typedef Symbol.table -> vtype -> int -> int
  val issmall : vtype -> bool
  val defdata : typedef -> typedef
  val defmark : typedef -> Mark.ext option

  structure Print :
  sig
    val pp_type : vtype -> string
    val pp_typedef : (ident * typedef) -> string
  end

end

structure Type :> TYPE =
struct
  type ident = Symbol.symbol
  datatype vtype = Int | String | Typedef of ident | Pointer of vtype | Array of vtype | TNull
  type variable = ident * vtype
  datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list

  fun size (Int) = 1
    | size (String) = 1
    | size (Pointer _) = 1
    | size (Array _) = 1
    | size (TNull) = 1
    | size _ = raise ErrorMsg.InternalError "Type.size on non-small type..."

  (************************************************)
  (* this is full of shit *************************)
  (************************************************)
  local
    val size_memotable = ref Symbol.empty
    val align_memotable = ref Symbol.empty
  in
    (* determine size of items *)
    fun sizeof_reset () = ( size_memotable := Symbol.empty )
    fun alignment_reset () = ( align_memotable := Symbol.empty )
    fun sizeof _ (Int) = 1
      | sizeof _ (String) = 1
      | sizeof _ (Pointer _) = 1
      | sizeof _ (Array _) = 1
      | sizeof _ (TNull) = raise ErrorMsg.InternalError "Type.sizeof on TNull?"
      | sizeof d (Typedef id) =
          (case (Symbol.look (!size_memotable) id)
          of SOME(r) => r
           | NONE =>
             let
               val r = sizeof_s d (Symbol.look' d id)
               val _ = (size_memotable := (Symbol.bind (!size_memotable) (id, r)))
             in
               r
             end)
    and sizeof_s d (Struct(l)) =
          foldl
            (fn ((_,t),curpos) => align d t curpos + sizeof d t)
            0
            l
      | sizeof_s d (MarkedTypedef(a)) = sizeof_s d (Mark.data a)

    (* determine alignment of items *)
    and alignment _ (Int) = 1
      | alignment _ (String) = 1
      | alignment _ (Pointer _) = 1
      | alignment _ (Array _) = 1
      | alignment d (Typedef id) =
          (case Symbol.look (!align_memotable) id
          of SOME(r) => r
           | NONE =>
             let
               val r = alignment_s d (Symbol.look' d id)
               val _ = (align_memotable := (Symbol.bind (!align_memotable) (id,r)))
             in
               r
             end)
      | alignment _ (TNull) = raise ErrorMsg.InternalError "Type.alignment on TNull?"
    and alignment_s d (Struct(members)) =
          foldl
            (fn ((_,t),al) => Int.max (al, alignment d t))
            1
            members
      | alignment_s d (MarkedTypedef(a)) = alignment_s d (Mark.data a)
    and align d t curpos = 
      let
        val al = alignment d t
      in
        if(curpos mod al) = 0 then curpos
        else curpos + al - (curpos mod al)
      end
  end
  (************************************************)
  (* end of shit **********************************)
  (************************************************)


  fun issmall (Int) = true
    | issmall (String) = true
    | issmall (Pointer _) = true
    | issmall (Array _) = true
    | issmall (TNull) = true
    | issmall _ = false

  fun typeeq (Int, Int) = true
    | typeeq (String, String) = true
    | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b)
    | typeeq (Pointer a, Pointer b) = typeeq (a, b)
    | typeeq (Array a, Array b) = typeeq (a, b)
    | typeeq (TNull, TNull) = true
    | typeeq _ = false

  fun castable (Pointer _, TNull) = true
    | castable (Array _, TNull) = true
    | castable (a, b) = typeeq (a, b)

  fun defdata (MarkedTypedef m) = defdata (Mark.data m)
    | defdata m = m

  fun defmark (MarkedTypedef m) = Mark.ext m
    | defmark _ = NONE

  structure Print =
  struct
    fun pp_ident i = Symbol.name i

    fun pp_type (Int) = "int"
      | pp_type (String) = "string"
      | pp_type (Pointer t) = pp_type t ^ "*"
      | pp_type (Array t) = pp_type t ^ "[]"
      | pp_type (TNull) = "{NULL type}"
      | pp_type (Typedef id) = pp_ident id

    and pp_typedef (i, Struct (v)) = "struct " ^ (pp_ident i) ^ " {\n" ^ (String.concat (map (fn (i', t) => "  " ^ (pp_ident i') ^ " : " ^ (pp_type t) ^ ";\n") v)) ^ "}\n"
      | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d)
  end

end