type/type.sml

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