Initial import of l5c

[snipe.git] / type / type.sml

diff --git a/type/type.sml b/type/type.sml
new file mode 100644 (file)
index 0000000..69f35f8
--- /dev/null
+++ b/type/type.sml
@@ -0,0 +1,143 @@
+signature TYPE =
+sig
+  type ident = Symbol.symbol
+  datatype vtype = Int | 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 | 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) = 4
+    | size (Pointer _) = 8
+    | size (Array _) = 8
+    | size (TNull) = 8
+    | 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) = 4
+      | sizeof _ (Pointer _) = 8
+      | sizeof _ (Array _) = 8
+      | 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) = 4
+      | alignment _ (Pointer _) = 8
+      | alignment _ (Array _) = 8
+      | 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 (Pointer _) = true
+    | issmall (Array _) = true
+    | issmall (TNull) = true
+    | issmall _ = false
+
+  fun typeeq (Int, Int) = 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 (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