Started implementing the typ insert methods.

In contrast to CtoDwarf this time we use the name to identify
everything. To make this work we print the full identifier with stamp
to avoid the problems with anonymous structs and unions.

2 files changed, 99 insertions, 50 deletions

diff --git a/debug/CtoDwarf.ml b/debug/CtoDwarf.ml
index f1e2aea6..dce8d81e 100644
--- a/debug/CtoDwarf.ml
+++ b/debug/CtoDwarf.ml
@@ -65,51 +65,6 @@ let rec mmap f env = function
       (hd' :: tl', env2)
 
 
-(* Helper functions for the attributes *)
-
-let strip_attributes typ =
-  let strip = List.filter (fun a -> a = AConst || a = AVolatile) in 
-  match typ with
-  | TVoid at -> TVoid (strip at)
-  | TInt (k,at) ->  TInt (k,strip at)
-  | TFloat (k,at) -> TFloat(k,strip at)
-  | TPtr (t,at) -> TPtr(t,strip at)
-  | TArray (t,s,at) -> TArray(t,s,strip at)
-  | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at)
-  | TNamed (n,at) -> TNamed(n,strip at)
-  | TStruct (n,at) -> TStruct(n,strip at)
-  | TUnion (n,at) -> TUnion(n,strip at)
-  | TEnum (n,at) -> TEnum(n,strip at)
-  
-
-let strip_last_attribute typ  = 
-  let rec hd_opt l = match l with
-    [] -> None,[]
-  | AConst::rest -> Some AConst,rest
-  | AVolatile::rest -> Some AVolatile,rest 
-  | _::rest -> hd_opt rest in
-  match typ with
-  | TVoid at -> let l,r = hd_opt at in
-    l,TVoid r
-  | TInt (k,at) -> let l,r = hd_opt at in
-    l,TInt (k,r)
-  | TFloat (k,at) -> let l,r = hd_opt at in
-    l,TFloat (k,r)
-  | TPtr (t,at) -> let l,r = hd_opt at in
-    l,TPtr(t,r)
-  | TArray (t,s,at) -> let l,r = hd_opt at in
-    l,TArray(t,s,r)
-  | TFun (t,arg,v,at) -> let l,r = hd_opt at in
-    l,TFun(t,arg,v,r)
-  | TNamed (n,at) -> let l,r = hd_opt at in
-    l,TNamed(n,r)
-  | TStruct (n,at) -> let l,r = hd_opt at in
-    l,TStruct(n,r)
-  | TUnion (n,at) -> let l,r = hd_opt at in
-    l,TUnion(n,r)
-  | TEnum (n,at) -> let l,r = hd_opt at in
-    l,TEnum(n,r)
-
 (*  Dwarf tag for the void type*)
 let rec void_dwarf_tag =
   let void = {
diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml
index be47f2a7..e84172e6 100644
--- a/debug/DebugInformation.ml
+++ b/debug/DebugInformation.ml
@@ -15,6 +15,17 @@ open C
 (* This implements an interface for the collection of debugging 
    information. *)
 
+(* Simple id generator *)
+let id = ref 0
+
+let next_id () =
+  let nid = !id in
+  incr id; nid
+
+let reset_id () =
+  id := 0
+
+
 (* Types for the information of type info *)
 type composite_field =
     {
@@ -39,6 +50,15 @@ type ptr_type = {
     pts: int
   }
 
+type const_type = {
+    const_type: int
+  }
+
+type volatile_type = {
+    volatile_type: int
+  }
+
+
 type array_type = {
     arr_type: int;
     arr_size: int64 option;
@@ -90,20 +110,94 @@ type debug_types =
   | UnionType of composite_type
   | FunctionType of function_type
   | Typedef of typedef
+  | ConstType of const_type
+  | VolatileType of volatile_type
+  | Void
 
 (* All types encountered *)
 let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7
 
-(* The basetypes, pointer, typedefs and enums all must have names *)
-let name_types: (string,int) Hashtbl.t = Hashtbl.create 7
-
-(* Composite types do not need to have a name. We thereore use the stamp for the mapping *)
-let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7
+(* Lookup table for types *)
+let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7
 
 (* Translate a C.typ to a string needed for hashing *)
 let typ_to_string (ty: typ) =
   let buf = Buffer.create 7 in
   let chan = Format.formatter_of_buffer buf in
+  let old = !Cprint.print_idents_in_full in
+  Cprint.print_idents_in_full := true;
   Cprint.typ chan ty;
+  Cprint.print_idents_in_full := old;
   Format.pp_print_flush chan ();
   Buffer.contents buf
+
+(* Helper functions for the attributes *)
+let strip_attributes typ =
+  let strip = List.filter (fun a -> a = AConst || a = AVolatile) in 
+  match typ with
+  | TVoid at -> TVoid (strip at)
+  | TInt (k,at) ->  TInt (k,strip at)
+  | TFloat (k,at) -> TFloat(k,strip at)
+  | TPtr (t,at) -> TPtr(t,strip at)
+  | TArray (t,s,at) -> TArray(t,s,strip at)
+  | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at)
+  | TNamed (n,at) -> TNamed(n,strip at)
+  | TStruct (n,at) -> TStruct(n,strip at)
+  | TUnion (n,at) -> TUnion(n,strip at)
+  | TEnum (n,at) -> TEnum(n,strip at)
+
+let strip_last_attribute typ  = 
+  let rec hd_opt l = match l with
+    [] -> None,[]
+  | AConst::rest -> Some AConst,rest
+  | AVolatile::rest -> Some AVolatile,rest 
+  | _::rest -> hd_opt rest in
+  match typ with
+  | TVoid at -> let l,r = hd_opt at in
+    l,TVoid r
+  | TInt (k,at) -> let l,r = hd_opt at in
+    l,TInt (k,r)
+  | TFloat (k,at) -> let l,r = hd_opt at in
+    l,TFloat (k,r)
+  | TPtr (t,at) -> let l,r = hd_opt at in
+    l,TPtr(t,r)
+  | TArray (t,s,at) -> let l,r = hd_opt at in
+    l,TArray(t,s,r)
+  | TFun (t,arg,v,at) -> let l,r = hd_opt at in
+    l,TFun(t,arg,v,r)
+  | TNamed (n,at) -> let l,r = hd_opt at in
+    l,TNamed(n,r)
+  | TStruct (n,at) -> let l,r = hd_opt at in
+    l,TStruct(n,r)
+  | TUnion (n,at) -> let l,r = hd_opt at in
+    l,TUnion(n,r)
+  | TEnum (n,at) -> let l,r = hd_opt at in
+    l,TEnum(n,r)
+
+(* Does the type already exist? *)
+let exist_type (ty: typ) =
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  Hashtbl.mem lookup_types (typ_to_string ty)
+
+(* Find the type id to an type *)
+let find_type (ty: typ) =
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  Hashtbl.find lookup_types (typ_to_string ty)
+
+(* Add type and information *)
+let insert_type (ty: typ) = 
+  (* We are only interrested in Const and Volatile *)
+  let ty = strip_attributes ty in
+  if not (exist_type ty) then
+    begin
+      let rec typ_aux ty = ()
+      and attr_aux ty = 
+        match strip_last_attribute ty with
+        | Some AConst,t -> 
+            ()
+        | None,t -> typ_aux t
+      in
+      attr_aux ty
+    end