type/type.sml

   1 signature TYPE =
   2 sig
   3   type ident = Symbol.symbol
   4   datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
   5   type variable = ident * vtype
   6   datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list
   7
   8   val typeeq : vtype * vtype -> bool
   9   val castable : vtype * vtype -> bool
  10   val size : vtype -> int
  11   val sizeof : typedef Symbol.table -> vtype -> int
  12   val sizeof_reset : unit -> unit
  13   val alignment : typedef Symbol.table -> vtype -> int
  14   val alignment_reset : unit -> unit
  15   val align : typedef Symbol.table -> vtype -> int -> int
  16   val issmall : vtype -> bool
  17   val defdata : typedef -> typedef
  18   val defmark : typedef -> Mark.ext option
  19
  20   structure Print :
  21   sig
  22     val pp_type : vtype -> string
  23     val pp_typedef : (ident * typedef) -> string
  24   end
  25
  26 end
  27
  28 structure Type :> TYPE =
  29 struct
  30   type ident = Symbol.symbol
  31   datatype vtype = Int | Typedef of ident | Pointer of vtype | Array of vtype | TNull
  32   type variable = ident * vtype
  33   datatype typedef = MarkedTypedef of typedef Mark.marked | Struct of variable list
  34
  35   fun size (Int) = 4
  36     | size (Pointer _) = 8
  37     | size (Array _) = 8
  38     | size (TNull) = 8
  39     | size _ = raise ErrorMsg.InternalError "Type.size on non-small type..."
  40
  41   (************************************************)
  42   (* this is full of shit *************************)
  43   (************************************************)
  44   local
  45     val size_memotable = ref Symbol.empty
  46     val align_memotable = ref Symbol.empty
  47   in
  48     (* determine size of items *)
  49     fun sizeof_reset () = ( size_memotable := Symbol.empty )
  50     fun alignment_reset () = ( align_memotable := Symbol.empty )
  51     fun sizeof _ (Int) = 4
  52       | sizeof _ (Pointer _) = 8
  53       | sizeof _ (Array _) = 8
  54       | sizeof _ (TNull) = raise ErrorMsg.InternalError "Type.sizeof on TNull?"
  55       | sizeof d (Typedef id) =
  56           (case (Symbol.look (!size_memotable) id)
  57           of SOME(r) => r
  58            | NONE =>
  59              let
  60                val r = sizeof_s d (Symbol.look' d id)
  61                val _ = (size_memotable := (Symbol.bind (!size_memotable) (id, r)))
  62              in
  63                r
  64              end)
  65     and sizeof_s d (Struct(l)) =
  66           foldl
  67             (fn ((_,t),curpos) => align d t curpos + sizeof d t)
  68             0
  69             l
  70       | sizeof_s d (MarkedTypedef(a)) = sizeof_s d (Mark.data a)
  71
  72     (* determine alignment of items *)
  73     and alignment _ (Int) = 4
  74       | alignment _ (Pointer _) = 8
  75       | alignment _ (Array _) = 8
  76       | alignment d (Typedef id) =
  77           (case Symbol.look (!align_memotable) id
  78           of SOME(r) => r
  79            | NONE =>
  80              let
  81                val r = alignment_s d (Symbol.look' d id)
  82                val _ = (align_memotable := (Symbol.bind (!align_memotable) (id,r)))
  83              in
  84                r
  85              end)
  86       | alignment _ (TNull) = raise ErrorMsg.InternalError "Type.alignment on TNull?"
  87     and alignment_s d (Struct(members)) =
  88           foldl
  89             (fn ((_,t),al) => Int.max (al, alignment d t))
  90             1
  91             members
  92       | alignment_s d (MarkedTypedef(a)) = alignment_s d (Mark.data a)
  93     and align d t curpos =
  94       let
  95         val al = alignment d t
  96       in
  97         if(curpos mod al) = 0 then curpos
  98         else curpos + al - (curpos mod al)
  99       end
 100   end
 101   (************************************************)
 102   (* end of shit **********************************)
 103   (************************************************)
 104
 105
 106   fun issmall (Int) = true
 107     | issmall (Pointer _) = true
 108     | issmall (Array _) = true
 109     | issmall (TNull) = true
 110     | issmall _ = false
 111
 112   fun typeeq (Int, Int) = true
 113     | typeeq (Typedef a, Typedef b) = (Symbol.name a) = (Symbol.name b)
 114     | typeeq (Pointer a, Pointer b) = typeeq (a, b)
 115     | typeeq (Array a, Array b) = typeeq (a, b)
 116     | typeeq (TNull, TNull) = true
 117     | typeeq _ = false
 118
 119   fun castable (Pointer _, TNull) = true
 120     | castable (Array _, TNull) = true
 121     | castable (a, b) = typeeq (a, b)
 122
 123   fun defdata (MarkedTypedef m) = defdata (Mark.data m)
 124     | defdata m = m
 125
 126   fun defmark (MarkedTypedef m) = Mark.ext m
 127     | defmark _ = NONE
 128
 129   structure Print =
 130   struct
 131     fun pp_ident i = Symbol.name i
 132
 133     fun pp_type (Int) = "int"
 134       | pp_type (Pointer t) = pp_type t ^ "*"
 135       | pp_type (Array t) = pp_type t ^ "[]"
 136       | pp_type (TNull) = "{NULL type}"
 137       | pp_type (Typedef id) = pp_ident id
 138
 139     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"
 140       | pp_typedef (i, MarkedTypedef d) = pp_typedef (i, Mark.data d)
 141   end
 142
 143 end