Version 1.0.0-rc17 has been released. Some changes are:
[bpt/coccinelle.git] / parsing_c / type_annoter_c.ml
index 7ae25b3..ad91aa0 100644 (file)
@@ -164,6 +164,19 @@ type namedef =
   (* cppext: *)
   | Macro        of string * (define_kind * define_val)
 
+let print_scoped_env e =
+  List.iter
+    (function e ->
+      List.iter
+       (function
+           VarOrFunc(s,_) -> Printf.printf "%s " s
+         | EnumConstant(s,_) -> Printf.printf "%s " s
+         | TypeDef(s,t) -> Printf.printf "%s" s
+         | StructUnionNameDef(s,_) -> Printf.printf "%s " s
+         | Macro(s,_) -> Printf.printf "%s " s)
+       e;
+      Printf.printf "\n")
+    e
 
 (* Because have nested scope, have nested list, hence the list list.
  *
@@ -189,10 +202,10 @@ let initial_env = ref [
 
   (*
    VarOrFunc("malloc",
-            (Lib.al_type(Parse_c.type_of_string "void* (*)(int size)"),
+            (Lib.al_type(Parse_c.type_of_string "void* ( * )(int size)"),
            Ast_c.NotLocalVar));
    VarOrFunc("free",
-            (Lib.al_type(Parse_c.type_of_string "void (*)(void *ptr)"),
+            (Lib.al_type(Parse_c.type_of_string "void ( * )(void *ptr)"),
            Ast_c.NotLocalVar));
   *)
   ]
@@ -334,6 +347,7 @@ let rec find_final_type ty env =
 
 (* ------------------------------------------------------------ *)
 let rec type_unfold_one_step ty env =
+  let rec loop seen ty env =
 
   match Ast_c.unwrap_typeC ty with
   | NoType        -> ty
@@ -365,7 +379,9 @@ let rec type_unfold_one_step ty env =
       (try
           if !typedef_debug then pr2 "type_unfold_one_step: lookup_typedef";
           let (t', env') = lookup_typedef s env in
-          type_unfold_one_step t' env'
+         if List.mem s seen (* avoid pb with recursive typedefs *)
+         then type_unfold_one_step t' env'
+          else loop (s::seen) t' env
        with Not_found ->
           ty
       )
@@ -374,7 +390,8 @@ let rec type_unfold_one_step ty env =
   | TypeOfExpr e ->
       pr2_once ("Type_annoter: not handling typeof");
       ty
-  | TypeOfType t -> type_unfold_one_step t env
+  | TypeOfType t -> type_unfold_one_step t env in
+  loop [] ty env
 
 
 
@@ -391,60 +408,68 @@ let rec type_unfold_one_step ty env =
  * for most tasks.
  *)
 let rec typedef_fix ty env =
-  match Ast_c.unwrap_typeC ty with
-  | NoType  ->
-      ty
-  | BaseType x  ->
-      ty
-  | Pointer t ->
-      Pointer (typedef_fix t env)  +> Ast_c.rewrap_typeC ty
-  | Array (e, t) ->
-      Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty
-  | StructUnion (su, sopt, fields) ->
+  let rec loop seen ty env =
+    match Ast_c.unwrap_typeC ty with
+    | NoType  ->
+       ty
+    | BaseType x  ->
+       ty
+    | Pointer t ->
+       Pointer (typedef_fix t env)  +> Ast_c.rewrap_typeC ty
+    | Array (e, t) ->
+       Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty
+    | StructUnion (su, sopt, fields) ->
       (* normalize, fold.
-       * todo? but what if correspond to a nested struct def ?
-       *)
-      Type_c.structdef_to_struct_name ty
-  | FunctionType ft ->
-      (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty
-  | Enum  (s, enumt) ->
-      (Enum  (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty
-  | EnumName s ->
-      (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty
-
+        * todo? but what if correspond to a nested struct def ?
+      *)
+       Type_c.structdef_to_struct_name ty
+    | FunctionType ft ->
+       (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty
+    | Enum  (s, enumt) ->
+       (Enum  (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty
+    | EnumName s ->
+       (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty
+         
   (* we prefer StructUnionName to StructUnion when it comes to typed metavar *)
-  | StructUnionName (su, s) -> ty
-
+    | StructUnionName (su, s) ->
+       ty
+         
   (* keep the typename but complete with more information *)
-  | TypeName (name, typ) ->
-      let s = Ast_c.str_of_name name in
-      (match typ with
-      | Some _ ->
-          pr2 ("typedef value already there:" ^ s);
-          ty
-      | None ->
-        (try
-          if !typedef_debug then pr2 "typedef_fix: lookup_typedef";
-          let (t', env') = lookup_typedef s env in
-
+    | TypeName (name, typ) ->
+       let s = Ast_c.str_of_name name in
+       (match typ with
+       | Some _ ->
+            pr2 ("typedef value already there:" ^ s);
+            ty
+       | None ->
+            (try
+              if !typedef_debug then pr2 "typedef_fix: lookup_typedef";
+              let (t', env') = lookup_typedef s env in
+             
           (* bugfix: termination bug if use env instead of env' below, because
-           * can have some weird mutually recursive typedef which
-           * each new type alias search for its mutual def.
-           *)
-          TypeName (name, Some (typedef_fix t' env')) +> Ast_c.rewrap_typeC ty
-        with Not_found ->
-          ty
-      ))
+             * can have some weird mutually recursive typedef which
+             * each new type alias search for its mutual def.
+            * seen is an attempt to do better.
+          *)
+             let fixed =
+               if List.mem s seen
+               then loop (s::seen) t' env
+               else typedef_fix t' env' in
+             TypeName (name, Some fixed) +>
+             Ast_c.rewrap_typeC ty
+            with Not_found ->
+              ty))
 
   (* remove paren for better matching with typed metavar. kind of iso again *)
-  | ParenType t ->
-      typedef_fix t env
-  | TypeOfExpr e ->
-      pr2_once ("Type_annoter: not handling typeof");
-      ty
+    | ParenType t ->
+       typedef_fix t env
+    | TypeOfExpr e ->
+       pr2_once ("Type_annoter: not handling typeof");
+       ty
 
-  | TypeOfType t ->
-      typedef_fix t env
+    | TypeOfType t ->
+       typedef_fix t env in
+  loop [] ty env
 
 
 (*****************************************************************************)
@@ -516,7 +541,6 @@ let add_in_scope namedef =
   let (current, older) = Common.uncons !_scoped_env in
   _scoped_env := (namedef::current)::older
 
-
 (* ------------------------------------------------------------ *)
 
 (* sort of hackish... *)
@@ -740,8 +764,7 @@ let annotater_expr_visitor_subpart = (fun (k,bigf) expr ->
     | Ident (ident) ->
         let s = Ast_c.str_of_name ident in
         (match lookup_opt_env lookup_var s with
-        | Some ((typ,local),_nextenv) ->
-            make_info_fix (typ,local)
+        | Some ((typ,local),_nextenv) -> make_info_fix (typ,local)
         | None  ->
             (match lookup_opt_env lookup_macro s with
             | Some ((defkind, defval), _nextenv) ->
@@ -815,7 +838,6 @@ let annotater_expr_visitor_subpart = (fun (k,bigf) expr ->
     (* fields *)
     | RecordAccess  (e, namefld)
     | RecordPtAccess (e, namefld) as x ->
-
         let fld = Ast_c.str_of_name namefld in
 
         k expr; (* recurse to set the types-ref of sub expressions *)
@@ -830,7 +852,7 @@ let annotater_expr_visitor_subpart = (fun (k,bigf) expr ->
                 | Pointer (t) -> Some t
                 | _ -> None
                 )
-            | _ -> raise Impossible
+            | _ -> raise (Impossible 159)
 
           in
           (match topt with
@@ -939,7 +961,7 @@ let annotater_expr_visitor_subpart = (fun (k,bigf) expr ->
             | _ -> k expr; Type_c.noTypeHere
           *)
 
-    | New ty ->
+    | New (_, ty) ->
        k expr;
        pr2_once "Type annotater:not handling New";
        Type_c.noTypeHere (* TODO *)
@@ -1074,8 +1096,17 @@ let rec visit_toplevel ~just_add_in_env ~depth elem =
              match (sto,local) with
              | (_,Ast_c.NotLocalDecl) -> Ast_c.NotLocalVar
              | ((Ast_c.Sto Ast_c.Static, _), Ast_c.LocalDecl) ->
-                 Ast_c.StaticLocalVar (Ast_c.info_of_type t)
-             | (_,Ast_c.LocalDecl) -> Ast_c.LocalVar (Ast_c.info_of_type t)
+                 (match Ast_c.info_of_type t with
+                   (* if there is no info about the type it must not be
+                      present, so we don't know what the variable is *)
+                   None -> Ast_c.NotLocalVar
+                 | Some ii -> Ast_c.StaticLocalVar ii)
+             | (_,Ast_c.LocalDecl) ->
+                 (match Ast_c.info_of_type t with
+                   (* if there is no info about the type it must not be
+                      present, so we don't know what the variable is *)
+                   None -> Ast_c.NotLocalVar
+                 | Some ii -> Ast_c.LocalVar ii)
             in
             var +> Common.do_option (fun (name, iniopt) ->
               let s = Ast_c.str_of_name name in
@@ -1101,7 +1132,7 @@ let rec visit_toplevel ~just_add_in_env ~depth elem =
                   end
             );
           );
-      | MacroDecl _ ->
+      | MacroDecl _ | MacroDeclInit _ ->
           if need_annotate_body
           then k d
       );
@@ -1170,7 +1201,7 @@ let rec visit_toplevel ~just_add_in_env ~depth elem =
                *)
             | iifunc1::iifunc2::ibrace1::ibrace2::ifakestart::isto ->
                 iifunc1, iifunc2
-            | _ -> raise Impossible
+            | _ -> raise (Impossible 160)
           in
           let funcs = Ast_c.str_of_name name in
 
@@ -1188,7 +1219,14 @@ let rec visit_toplevel ~just_add_in_env ~depth elem =
                     match nameopt with
                     | Some name ->
                         let s = Ast_c.str_of_name name in
-                       let local = Ast_c.LocalVar (Ast_c.info_of_type t) in
+                       let local =
+                         (match Ast_c.info_of_type t with
+                           (* if there is no info about the type it must
+                              not be present, so we don't know what the
+                              variable is *)
+                           None -> Ast_c.NotLocalVar
+                         | Some ii -> Ast_c.LocalVar ii)
+                       in
                        add_binding (VarOrFunc (s,(Lib.al_type t,local))) true
                     | None ->
                     pr2 "no type, certainly because Void type ?"
@@ -1226,6 +1264,7 @@ let rec visit_toplevel ~just_add_in_env ~depth elem =
       | EmptyDef _
       | NotParsedCorrectly _
       | FinalDef _
+      | Namespace _
           ->
           k elem
     );