parsing_c/test_parsing_c.ml

   1 open Common
   2
   3 open Ast_c
   4
   5 let score_path = "/home/pad/c-yacfe/tmp"
   6
   7 let tmpfile = "/tmp/output.c"
   8
   9 module Ast_to_flow = Control_flow_c_build
  10
  11 (*****************************************************************************)
  12 (* Subsystem testing *)
  13 (*****************************************************************************)
  14
  15 let test_tokens_c file =
  16   if not (file =~ ".*\\.c")
  17   then pr2 "warning: seems not a .c file";
  18
  19   Flag_parsing_c.debug_lexer := true;
  20   Flag_parsing_c.verbose_lexing := true;
  21   Flag_parsing_c.verbose_parsing := true;
  22
  23   Parse_c.tokens file +> List.iter (fun x -> pr2_gen x);
  24   ()
  25
  26
  27
  28 (* ---------------------------------------------------------------------- *)
  29 let test_parse_gen xs ext =
  30
  31   Flag_parsing_c.debug_typedef := true;
  32   Flag_parsing_c.debug_cpp := true;
  33   Flag_parsing_c.debug_etdt := false;
  34   Flag_parsing_c.filter_msg := true;
  35
  36   let dirname_opt =
  37     match xs with
  38     | [x] when is_directory x -> Some x
  39     | _ -> None
  40   in
  41
  42   (* old:
  43      let xs = if !Flag.dir then
  44      process_output_to_list ("find " ^ x ^" -name \"*.c\"") else x::xs in
  45   *)
  46   let fullxs = Common.files_of_dir_or_files_no_vcs ext xs in
  47
  48   let stat_list = ref [] in
  49   let newscore  = Common.empty_score () in
  50
  51   Common.check_stack_nbfiles (List.length fullxs);
  52
  53   fullxs +> List.iter (fun file ->
  54     if not (file =~ (".*\\."^ext))
  55     then pr2 ("warning: seems not a ."^ext^" file");
  56
  57
  58     pr2 "";
  59     pr2 ("PARSING: " ^ file);
  60
  61     let (xs, stat) = Parse_c.parse_print_error_heuristic file in
  62     xs +> List.iter (fun (ast, (s, toks)) ->
  63       Parse_c.print_commentized toks
  64     );
  65
  66     Common.push2 stat stat_list;
  67     let s =
  68       sprintf "bad = %d, timeout = %B"
  69         stat.Parsing_stat.bad stat.Parsing_stat.have_timeout
  70     in
  71     if stat.Parsing_stat.bad =|= 0 && not stat.Parsing_stat.have_timeout
  72     then Hashtbl.add newscore file (Common.Ok)
  73     else Hashtbl.add newscore file (Common.Pb s)
  74   );
  75
  76   dirname_opt +> Common.do_option (fun dirname ->
  77     pr2_xxxxxxxxxxxxxxxxx();
  78     pr2 "regression testing  information";
  79     pr2_xxxxxxxxxxxxxxxxx();
  80     let str = Str.global_replace (Str.regexp "/") "__" dirname in
  81     let def = if !Flag_parsing_c.filter_define_error then "_def_" else "" in
  82     let ext = if ext =$= "c" then "" else ext in
  83     Common.regression_testing newscore
  84       (Filename.concat score_path
  85        ("score_parsing__" ^str ^ def ^ ext ^ ".marshalled"))
  86   );
  87
  88   if not (null !stat_list)
  89   then begin
  90     Parsing_stat.print_recurring_problematic_tokens !stat_list;
  91     Parsing_stat.print_parsing_stat_list !stat_list;
  92   end;
  93   ()
  94
  95
  96 let test_parse_c xs =
  97   test_parse_gen xs "c"
  98 let test_parse_h xs =
  99   test_parse_gen xs "h"
 100 let test_parse_ch xs =
 101   test_parse_gen xs "[ch]"
 102
 103
 104 (* ---------------------------------------------------------------------- *)
 105
 106 let test_parse xs =
 107
 108   Flag_parsing_c.filter_msg_define_error := true;
 109   Flag_parsing_c.filter_define_error := true;
 110   Flag_parsing_c.verbose_lexing := false;
 111   Flag_parsing_c.verbose_parsing := false;
 112
 113   let dirname_opt =
 114     match xs with
 115     | [x] when is_directory x -> Some x
 116     | _ -> None
 117   in
 118   dirname_opt +> Common.do_option (fun dir ->
 119
 120     let ext = "h" in
 121     let fullxs = Common.files_of_dir_or_files_no_vcs ext [dir] in
 122     fullxs +> List.iter (fun file ->
 123       let xs = Parse_c.parse_cpp_define_file file in
 124       xs +> List.iter (fun (x, def) ->
 125         let (s, params, body) = def in
 126         Hashtbl.replace !Parse_c._defs s (s, params, body);
 127       );
 128     );
 129   );
 130
 131   let ext = "[ch]" in
 132
 133   let fullxs = Common.files_of_dir_or_files_no_vcs ext xs in
 134
 135   let stat_list = ref [] in
 136   Common.check_stack_nbfiles (List.length fullxs);
 137
 138   fullxs +> List.iter (fun file ->
 139     if not (file =~ (".*\\."^ext))
 140     then pr2 ("warning: seems not a ."^ext^" file");
 141
 142     pr2 "";
 143     pr2 ("PARSING: " ^ file);
 144
 145     let (xs, stat) = Parse_c.parse_print_error_heuristic file in
 146     xs +> List.iter (fun (ast, (s, toks)) ->
 147       Parse_c.print_commentized toks
 148     );
 149
 150     Common.push2 stat stat_list;
 151   );
 152
 153   if not (null !stat_list)
 154   then begin
 155     Parsing_stat.print_recurring_problematic_tokens !stat_list;
 156     Parsing_stat.print_parsing_stat_list !stat_list;
 157   end;
 158   ()
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168 (* ---------------------------------------------------------------------- *)
 169 (* file can be   "foo.c"  or "foo.c:main" *)
 170 let test_cfg file =
 171   let (file, specific_func) =
 172     if file =~ "\\(.*\\.c\\):\\(.*\\)"
 173     then
 174       let (a,b) = matched2 file in
 175       a, Some b
 176     else
 177       file, None
 178   in
 179
 180   if not (file =~ ".*\\.c")
 181   then pr2 "warning: seems not a .c file";
 182
 183   let (program, _stat) = Parse_c.parse_print_error_heuristic file in
 184
 185   program +> List.iter (fun (e,_) ->
 186     let toprocess =
 187       match specific_func, e with
 188       | None, _ -> true
 189       | Some s, Ast_c.Definition (defbis,_)  ->
 190           s =$= Ast_c.str_of_name (defbis.Ast_c.f_name)
 191       | _, _ -> false
 192     in
 193
 194     if toprocess
 195     then
 196       (* old: Flow_to_ast.test !Flag.show_flow def *)
 197       (try
 198           let flow = Ast_to_flow.ast_to_control_flow e in
 199           flow +> do_option (fun flow ->
 200             Ast_to_flow.deadcode_detection flow;
 201             let flow = Ast_to_flow.annotate_loop_nodes flow in
 202
 203             let flow' =
 204 (*
 205               if !Flag_cocci.show_before_fixed_flow
 206               then flow
 207               else Ctlcocci_integration.fix_flow_ctl flow
 208 *)
 209               flow
 210             in
 211             let filename = Filename.temp_file "output" ".dot" in
 212             Ograph_extended.print_ograph_mutable flow' (filename) true
 213           )
 214         with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x
 215       )
 216   )
 217
 218
 219
 220 let test_cfg_ifdef file =
 221   let (ast2, _stat) = Parse_c.parse_print_error_heuristic file in
 222   let ast = Parse_c.program_of_program2 ast2 in
 223
 224   let ast = Cpp_ast_c.cpp_ifdef_statementize ast in
 225
 226   ast +> List.iter (fun e ->
 227     (try
 228         let flow = Ast_to_flow.ast_to_control_flow e in
 229         flow +> do_option (fun flow ->
 230           Ast_to_flow.deadcode_detection flow;
 231           let flow = Ast_to_flow.annotate_loop_nodes flow in
 232           Ograph_extended.print_ograph_mutable flow ("/tmp/output.dot") true
 233         )
 234       with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x
 235     )
 236   )
 237
 238 (* ---------------------------------------------------------------------- *)
 239 let test_parse_unparse infile =
 240   if not (infile =~ ".*\\.c")
 241   then pr2 "warning: seems not a .c file";
 242
 243   let (program2, _stat) = Parse_c.parse_print_error_heuristic infile in
 244   let program2_with_ppmethod =
 245     program2 +> List.map (fun x -> x, Unparse_c.PPnormal)
 246   in
 247   Unparse_c.pp_program program2_with_ppmethod tmpfile;
 248   Common.command2 ("cat " ^ tmpfile);
 249   (* if want see diff of space => no -b -B *)
 250   Common.command2 (spf "diff -u -p  %s %s" infile tmpfile);
 251   (* +> Transformation.test_simple_trans1;*)
 252   ()
 253
 254
 255
 256
 257 let test_type_c infile =
 258   if not (infile =~ ".*\\.c")
 259   then pr2 "warning: seems not a .c file";
 260
 261   Flag_parsing_c.pretty_print_type_info := true;
 262
 263   let (program2, _stat) =  Parse_c.parse_print_error_heuristic infile in
 264   let _program2 =
 265     program2
 266     +> Common.unzip
 267     +> (fun (program, infos) ->
 268       Type_annoter_c.annotate_program !Type_annoter_c.initial_env
 269         program +> List.map fst,
 270       infos
 271     )
 272     +> Common.uncurry Common.zip
 273   in
 274   let program2_with_ppmethod =
 275     program2 +> List.map (fun x -> x, Unparse_c.PPnormal)
 276   in
 277   Unparse_c.pp_program program2_with_ppmethod tmpfile;
 278   Common.command2 ("cat " ^ tmpfile);
 279   ();;
 280
 281
 282 (* ---------------------------------------------------------------------- *)
 283 (* ex: demos/platform_ifdef.c *)
 284 let test_comment_annotater infile =
 285   let (program2, _stat) =  Parse_c.parse_print_error_heuristic infile in
 286   let asts = program2 +> List.map (fun (ast,_) -> ast) in
 287   let toks = program2 +> List.map (fun (ast, (s, toks)) -> toks) +>
 288     List.flatten in
 289
 290   Flag_parsing_c.pretty_print_comment_info := true;
 291
 292   pr2 "pretty print, before comment annotation: --->";
 293   Common.adjust_pp_with_indent (fun () ->
 294   asts +> List.iter (fun ast ->
 295     Pretty_print_c.pp_toplevel_simple ast;
 296   );
 297   );
 298
 299   let _ = Comment_annotater_c.annotate_program toks asts in
 300
 301   Common.adjust_pp_with_indent (fun () ->
 302   pr2 "pretty print, after comment annotation: --->";
 303   asts +> List.iter (fun ast ->
 304     Pretty_print_c.pp_toplevel_simple ast;
 305   );
 306   );
 307
 308
 309   ()
 310
 311
 312 (* ---------------------------------------------------------------------- *)
 313 (* used by generic_makefile now *)
 314 let test_compare_c file1 file2 =
 315   let (correct, diffxs) = Compare_c.compare_default file1 file2 in
 316   let res = Compare_c.compare_result_to_bool correct in
 317   if res
 318   then raise (Common.UnixExit 0)
 319   else raise (Common.UnixExit (-1))
 320
 321
 322 let test_compare_c_hardcoded () =
 323   Compare_c.compare_default
 324     "tests/compare1.c"
 325     "tests/compare2.c"
 326     (*
 327       "tests/equal_modulo1.c"
 328       "tests/equal_modulo2.c"
 329     *)
 330   +> Compare_c.compare_result_to_string
 331   +> pr2
 332
 333
 334
 335 (* ---------------------------------------------------------------------- *)
 336 let test_attributes file =
 337   let (ast2, _stat) = Parse_c.parse_c_and_cpp file in
 338   let ast = Parse_c.program_of_program2 ast2 in
 339
 340   Visitor_c.vk_program { Visitor_c.default_visitor_c with
 341     Visitor_c.kdef = (fun (k, bigf) (defbis, ii) ->
 342       let sattr  = Ast_c.s_of_attr defbis.f_attr in
 343       pr2 (spf "%-30s: %s" (Ast_c.str_of_name (defbis.f_name)) sattr);
 344     );
 345     Visitor_c.kdecl = (fun (k, bigf) decl ->
 346       match decl with
 347       | DeclList (xs, ii) ->
 348           xs +> List.iter (fun (onedecl, iicomma) ->
 349
 350             let sattr  = Ast_c.s_of_attr onedecl.v_attr in
 351             let idname =
 352               match onedecl.v_namei with
 353               | Some (name, ini) -> Ast_c.str_of_name name
 354               | None -> "novar"
 355             in
 356             pr2 (spf "%-30s: %s" idname sattr);
 357           );
 358       | _ -> ()
 359
 360     );
 361   } ast;
 362   ()
 363
 364
 365 let cpp_options () = [
 366   Cpp_ast_c.I "/home/yyzhou/pad/linux/include";
 367 ] ++
 368   Cpp_ast_c.cpp_option_of_cmdline
 369   (!Flag_parsing_c.cpp_i_opts,!Flag_parsing_c.cpp_d_opts)
 370
 371 let test_cpp file =
 372   let (ast2, _stat) = Parse_c.parse_c_and_cpp file in
 373   let dirname = Filename.dirname file in
 374   let ast = Parse_c.program_of_program2 ast2 in
 375   let _ast' = Cpp_ast_c.cpp_expand_include (cpp_options()) dirname ast in
 376
 377   ()
 378
 379
 380
 381 let extract_macros ~selection x =
 382   (* CONFIG [ch] ? also do for .c ? maybe less needed now that I
 383    * add local_macros.
 384    *)
 385
 386   let ext = "h" in
 387   let fullxs = Common.files_of_dir_or_files_no_vcs ext [x] in
 388   fullxs +> List.iter (fun file ->
 389
 390     pr ("/* PARSING: " ^ file ^ " */");
 391     let xs = Parse_c.parse_cpp_define_file file in
 392     xs +> List.iter (fun (x, def) ->
 393       let (s, params, body) = def in
 394       assert(s = x);
 395       (match params, body with
 396       | Cpp_token_c.NoParam, Cpp_token_c.DefineBody [Parser_c.TInt _]
 397       | Cpp_token_c.NoParam, Cpp_token_c.DefineBody [] ->
 398           ()
 399       | _ ->
 400
 401           let s1 =
 402             match params with
 403             | Cpp_token_c.NoParam -> spf "#define %s " s
 404             | Cpp_token_c.Params xs ->
 405                 spf "#define %s(%s) "
 406                   s (Common.join "," xs)
 407           in
 408           let s2, bodytoks =
 409             match body with
 410             | Cpp_token_c.DefineHint _ ->
 411                 failwith "weird, hint in regular header file"
 412             | Cpp_token_c.DefineBody xs ->
 413                 Common.join " " (xs +> List.map Token_helpers.str_of_tok),
 414                 xs
 415           in
 416
 417           let print =
 418             match () with
 419             | () when s ==~ Parsing_hacks.regexp_annot -> true
 420             | () when List.exists (function
 421               | Parser_c.Tattribute _ -> true
 422               | _ -> false) bodytoks -> true
 423             | () -> false
 424           in
 425           if print || not selection then pr (s1 ^ s2)
 426       );
 427     );
 428   );
 429   ()
 430
 431
 432
 433 (* ---------------------------------------------------------------------- *)
 434 let test_xxx a  =
 435   ()
 436
 437 (*
 438   ignore(Parse_c.parse_cpp_define_file "standard.h")
 439   pr2 "pr2";
 440   pr  "pr"
 441
 442   Format.print_newline();
 443   Format.printf "@[<v 5>--@,--@,@[<v 5>--@,--@,@]--@,--@,@]";
 444   Format.print_newline();
 445   Format.printf "@[<v>(---@[<v>(---@[<v>(---@,)@]@,)@]@,)@]"
 446 *)
 447
 448
 449
 450 (*****************************************************************************)
 451 (* Main entry for Arg *)
 452 (*****************************************************************************)
 453
 454 let actions () = [
 455   "-tokens_c", "   <file>",
 456   Common.mk_action_1_arg test_tokens_c;
 457   "-parse_c", "   <file or dir>",
 458   Common.mk_action_n_arg test_parse_c;
 459   "-parse_h", "   <file or dir>",
 460   Common.mk_action_n_arg test_parse_h;
 461   "-parse_ch", "   <file or dir>",
 462   Common.mk_action_n_arg test_parse_ch;
 463
 464   "-parse", "   <file or dir>",
 465   Common.mk_action_n_arg test_parse;
 466
 467   "-show_flow", "   <file or file:function>",
 468   Common.mk_action_1_arg test_cfg;
 469   "-control_flow", "   <file or file:function>",
 470   Common.mk_action_1_arg test_cfg;
 471   "-test_cfg_ifdef", " <file>",
 472   Common.mk_action_1_arg test_cfg_ifdef;
 473   "-parse_unparse", "   <file>",
 474   Common.mk_action_1_arg test_parse_unparse;
 475   "-type_c", "   <file>",
 476   Common.mk_action_1_arg test_type_c;
 477   "-compare_c", "   <file1> <file2>",
 478   Common.mk_action_2_arg test_compare_c (* result is in unix code *);
 479   "-comment_annotater_c", "   <file>",
 480   Common.mk_action_1_arg test_comment_annotater;
 481
 482   "-compare_c_hardcoded", "  ",
 483   Common.mk_action_0_arg test_compare_c_hardcoded;
 484
 485   "-test_attributes", " <file>",
 486   Common.mk_action_1_arg test_attributes;
 487   "-test_cpp", " <file>",
 488   Common.mk_action_1_arg test_cpp;
 489
 490   "-extract_macros", " <file or dir>",
 491   Common.mk_action_1_arg (extract_macros ~selection:false) ;
 492
 493   "-extract_macros_select", " <file or dir>",
 494   Common.mk_action_1_arg (extract_macros ~selection:true);
 495
 496
 497   "-xxx", "   <file1> <>",
 498   Common.mk_action_n_arg test_xxx;
 499 ]
 500