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 (* Was in main, but using it in test_parsing_c *)
  30 let get_files path =
  31   let ch =
  32     cmd_to_list (* same as "true, "", _" case *)
  33       (if !Flag.include_headers
  34                           (* FIXME : Could we remove xs ?
  35                              -use_glimpse requires a singleton.
  36                              This is checked some lines before.
  37                              then ("find "^(join " " (x::xs))^" -name \"*.[ch]\"")
  38                              else ("find "^(join " " (x::xs))^" -name \"*.c\"")
  39                           *)
  40       then ("find "^ path ^" -name \"*.[ch]\"")
  41       else ("find "^ path ^" -name \"*.c\"")) in
  42   let cpp =
  43     if !Flag.c_plus_plus
  44     then cmd_to_list ("find "^ path ^" -name \"*.cpp\"")
  45     else [] in
  46   cpp @ ch
  47
  48 let new_test_parse_gen xs =
  49
  50   Flag_parsing_c.debug_typedef := true;
  51   Flag_parsing_c.debug_cpp := true;
  52   Flag_parsing_c.debug_etdt := false;
  53   Flag_parsing_c.filter_msg := true;
  54
  55   (*let dirname_opt =
  56     match xs with
  57     | [x] when is_directory x -> Some x
  58     | _ -> None
  59   in*)
  60
  61   (* old:
  62      let xs = if !Flag.dir then
  63      process_output_to_list ("find " ^ x ^" -name \"*.c\"") else x::xs in
  64   *)
  65   let fullxs = xs +> List.map get_files +> List.concat in
  66
  67   let stat_list = ref [] in
  68   let newscore  = Common.empty_score () in
  69
  70   Common.check_stack_nbfiles (List.length fullxs);
  71
  72   fullxs +> List.iter (fun file ->
  73
  74     pr2 "";
  75     pr2 ("PARSING: " ^ file);
  76
  77     let (xs, stat) = Parse_c.parse_c_and_cpp file in
  78     xs +> List.iter (fun (ast, (s, toks)) ->
  79       Parse_c.print_commentized toks
  80     );
  81
  82     Common.push2 stat stat_list;
  83     let s =
  84       sprintf "bad = %d, timeout = %B"
  85         stat.Parsing_stat.bad stat.Parsing_stat.have_timeout
  86     in
  87     if stat.Parsing_stat.bad =|= 0 && not stat.Parsing_stat.have_timeout
  88     then Hashtbl.add newscore file (Common.Ok)
  89     else Hashtbl.add newscore file (Common.Pb s)
  90   );
  91
  92 (* uses an explicit path; to fix
  93   dirname_opt +> Common.do_option (fun dirname ->
  94     pr2_xxxxxxxxxxxxxxxxx();
  95     pr2 "regression testing  information";
  96     pr2_xxxxxxxxxxxxxxxxx();
  97     let str = Str.global_replace (Str.regexp "/") "__" dirname in
  98     let def = if !Flag_parsing_c.filter_define_error then "_def_" else "" in
  99     let ext = if ext =$= "c" then "" else ext in
 100     let filename = "score_parsing__" ^str ^ def ^ ext ^ ".marshalled" in
 101     if Sys.file_exists filename
 102     then
 103       Common.regression_testing newscore
 104         (Filename.concat score_path
 105            ("score_parsing__" ^str ^ def ^ ext ^ ".marshalled"))
 106   );
 107 *)
 108
 109   if not (null !stat_list)
 110   then begin
 111     Parsing_stat.print_recurring_problematic_tokens !stat_list;
 112     Parsing_stat.print_parsing_stat_list !stat_list;
 113   end;
 114   ()
 115
 116 (* ---------------------------------------------------------------------- *)
 117 let test_parse_gen xs ext =
 118
 119   Flag_parsing_c.debug_typedef := true;
 120   Flag_parsing_c.debug_cpp := true;
 121   Flag_parsing_c.debug_etdt := false;
 122   Flag_parsing_c.filter_msg := true;
 123
 124   (*let dirname_opt =
 125     match xs with
 126     | [x] when is_directory x -> Some x
 127     | _ -> None
 128   in*)
 129
 130   (* old:
 131      let xs = if !Flag.dir then
 132      process_output_to_list ("find " ^ x ^" -name \"*.c\"") else x::xs in
 133   *)
 134   let fullxs = Common.files_of_dir_or_files_no_vcs ext xs in
 135
 136   let stat_list = ref [] in
 137   let newscore  = Common.empty_score () in
 138
 139   Common.check_stack_nbfiles (List.length fullxs);
 140
 141   fullxs +> List.iter (fun file ->
 142     if not (file =~ (".*\\."^ext))
 143     then pr2 ("warning: seems not a ."^ext^" file");
 144
 145
 146     pr2 "";
 147     pr2 ("PARSING: " ^ file);
 148
 149     let (xs, stat) = Parse_c.parse_c_and_cpp file in
 150     xs +> List.iter (fun (ast, (s, toks)) ->
 151       Parse_c.print_commentized toks
 152     );
 153
 154     Common.push2 stat stat_list;
 155     let s =
 156       sprintf "bad = %d, timeout = %B"
 157         stat.Parsing_stat.bad stat.Parsing_stat.have_timeout
 158     in
 159     if stat.Parsing_stat.bad =|= 0 && not stat.Parsing_stat.have_timeout
 160     then Hashtbl.add newscore file (Common.Ok)
 161     else Hashtbl.add newscore file (Common.Pb s)
 162   );
 163
 164 (* uses an explicit path; to fix
 165   dirname_opt +> Common.do_option (fun dirname ->
 166     pr2_xxxxxxxxxxxxxxxxx();
 167     pr2 "regression testing  information";
 168     pr2_xxxxxxxxxxxxxxxxx();
 169     let str = Str.global_replace (Str.regexp "/") "__" dirname in
 170     let def = if !Flag_parsing_c.filter_define_error then "_def_" else "" in
 171     let ext = if ext =$= "c" then "" else ext in
 172     let filename = "score_parsing__" ^str ^ def ^ ext ^ ".marshalled" in
 173     if Sys.file_exists filename
 174     then
 175       Common.regression_testing newscore
 176         (Filename.concat score_path
 177            ("score_parsing__" ^str ^ def ^ ext ^ ".marshalled"))
 178   );
 179 *)
 180
 181   if not (null !stat_list)
 182   then begin
 183     Parsing_stat.print_recurring_problematic_tokens !stat_list;
 184     Parsing_stat.print_parsing_stat_list !stat_list;
 185   end;
 186   ()
 187
 188
 189 let test_parse_c xs =
 190   test_parse_gen xs "c"
 191 let test_parse_h xs =
 192   test_parse_gen xs "h"
 193 let test_parse_ch xs =
 194   test_parse_gen xs "[ch]"
 195
 196 (* could use a simpler parser than heavy parse_c_and_cpp here as there
 197  * is no more cpp stuff in the .i files
 198  *)
 199 let test_parse_i xs =
 200   test_parse_gen xs "i"
 201
 202
 203
 204
 205
 206
 207
 208 (* ---------------------------------------------------------------------- *)
 209 (* file can be   "foo.c"  or "foo.c:main" *)
 210 (* local function that is parameterized by whether to launch gv *)
 211 let local_test_cfg launchgv file =
 212   let (file, specific_func) =
 213     if file =~ "\\(.*\\.c\\):\\(.*\\)"
 214     then
 215       let (a,b) = matched2 file in
 216       a, Some b
 217     else
 218       file, None
 219   in
 220
 221   if not (file =~ ".*\\.c")
 222   then pr2 "warning: seems not a .c file";
 223
 224   let (program, _stat) = Parse_c.parse_c_and_cpp file in
 225
 226   program +> List.iter (fun (e,_) ->
 227     let toprocess =
 228       match specific_func, e with
 229       | None, Ast_c.Definition (defbis,_) ->
 230           Some (Ast_c.str_of_name (defbis.Ast_c.f_name))
 231       | Some s, Ast_c.Definition (defbis,_)  ->
 232           let nm = Ast_c.str_of_name (defbis.Ast_c.f_name) in
 233           if s =$= nm then Some nm else None
 234       | _, _ -> None
 235     in
 236
 237     match toprocess with
 238       None -> ()
 239     | Some fn -> (* old: Flow_to_ast.test !Flag.show_flow def *)
 240         try
 241           let flow = Ast_to_flow.ast_to_control_flow e in
 242           flow +> do_option (fun flow ->
 243             Ast_to_flow.deadcode_detection flow;
 244             let flow = Ast_to_flow.annotate_loop_nodes flow in
 245
 246             let flow' =
 247 (*
 248               if !Flag_cocci.show_before_fixed_flow
 249               then flow
 250               else Ctlcocci_integration.fix_flow_ctl flow
 251 *)
 252               flow
 253             in
 254             let filename =
 255               if launchgv
 256               then Filename.temp_file "output" ".dot"
 257               else
 258                 let fl = Filename.chop_extension (Filename.basename file) in
 259                 fl^":"^fn^".dot" in
 260             Ograph_extended.print_ograph_mutable flow' (filename) launchgv
 261           )
 262         with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x
 263       )
 264
 265 let test_cfg = local_test_cfg true
 266
 267
 268
 269 let test_cfg_ifdef file =
 270   let (ast2, _stat) = Parse_c.parse_c_and_cpp file in
 271   let ast = Parse_c.program_of_program2 ast2 in
 272
 273   let ast = Cpp_ast_c.cpp_ifdef_statementize ast in
 274
 275   ast +> List.iter (fun e ->
 276     (try
 277         let flow = Ast_to_flow.ast_to_control_flow e in
 278         flow +> do_option (fun flow ->
 279           Ast_to_flow.deadcode_detection flow;
 280           let flow = Ast_to_flow.annotate_loop_nodes flow in
 281           Ograph_extended.print_ograph_mutable flow ("/tmp/output.dot") true
 282         )
 283       with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x
 284     )
 285   )
 286
 287 (* ---------------------------------------------------------------------- *)
 288 let test_parse_unparse infile =
 289   if not (infile =~ ".*\\.c")
 290   then pr2 "warning: seems not a .c file";
 291
 292   let (program2, _stat) = Parse_c.parse_c_and_cpp infile in
 293   let program2_with_ppmethod =
 294     program2 +> List.map (fun x -> x, Unparse_c.PPnormal)
 295   in
 296   Unparse_c.pp_program program2_with_ppmethod tmpfile;
 297   Common.command2 ("cat " ^ tmpfile);
 298   (* if want see diff of space => no -b -B *)
 299   Common.command2 (spf "diff -u -p  %s %s" infile tmpfile);
 300   (* +> Transformation.test_simple_trans1;*)
 301   ()
 302
 303
 304 (*
 305 let parse_and_print_sexp file =
 306   let (ast2,_stat) = Parse_c.parse_c_and_cpp file in
 307   let ast = Parse_c.program_of_program2 ast2 in
 308   let _ast =
 309     Type_annoter_c.annotate_program !Type_annoter_c.initial_env ast
 310   in
 311
 312   (*
 313   let sexp = Sexp_ast_c.sexp_of_program ast in
 314   let s = Sexp.to_string_hum sexp in
 315   *)
 316   Sexp_ast_c.show_info := false;
 317   let s = Sexp_ast_c.string_of_program ast in
 318   pr2 s;
 319   ()
 320 *)
 321
 322
 323 let test_type_c infile =
 324   if not (infile =~ ".*\\.c")
 325   then pr2 "warning: seems not a .c file";
 326
 327   Flag_parsing_c.pretty_print_type_info := true;
 328
 329   let (program2, _stat) =  Parse_c.parse_c_and_cpp infile in
 330   let _program2 =
 331     program2
 332     +> Common.unzip
 333     +> (fun (program, infos) ->
 334       Type_annoter_c.annotate_program !Type_annoter_c.initial_env
 335         program +> List.map fst,
 336       infos
 337     )
 338     +> Common.uncurry Common.zip
 339   in
 340   let program2_with_ppmethod =
 341     program2 +> List.map (fun x -> x, Unparse_c.PPnormal)
 342   in
 343   Unparse_c.pp_program program2_with_ppmethod tmpfile;
 344   Common.command2 ("cat " ^ tmpfile);
 345   ();;
 346
 347
 348 (* ---------------------------------------------------------------------- *)
 349 (* ex: demos/platform_ifdef.c *)
 350 let test_comment_annotater infile =
 351   let (program2, _stat) =  Parse_c.parse_c_and_cpp infile in
 352   let asts = program2 +> List.map (fun (ast,_) -> ast) in
 353   let toks = program2 +> List.map (fun (ast, (s, toks)) -> toks) +>
 354     List.flatten in
 355
 356   Flag_parsing_c.pretty_print_comment_info := true;
 357
 358   pr2 "pretty print, before comment annotation: --->";
 359   Common.adjust_pp_with_indent (fun () ->
 360   asts +> List.iter (fun ast ->
 361     Pretty_print_c.pp_toplevel_simple ast;
 362   );
 363   );
 364
 365   let _ = Comment_annotater_c.annotate_program toks asts in
 366
 367   Common.adjust_pp_with_indent (fun () ->
 368   pr2 "pretty print, after comment annotation: --->";
 369   asts +> List.iter (fun ast ->
 370     Pretty_print_c.pp_toplevel_simple ast;
 371   );
 372   );
 373
 374
 375   ()
 376
 377
 378 (* ---------------------------------------------------------------------- *)
 379 (* used by generic_makefile now *)
 380 let test_compare_c file1 file2 =
 381   let (correct, diffxs) = Compare_c.compare_default file1 file2 in
 382   let res = Compare_c.compare_result_to_bool correct in
 383   if res
 384   then raise (Common.UnixExit 0)
 385   else raise (Common.UnixExit (-1))
 386
 387
 388 let test_compare_c_hardcoded () =
 389   Compare_c.compare_default
 390     "tests/compare1.c"
 391     "tests/compare2.c"
 392     (*
 393       "tests/equal_modulo1.c"
 394       "tests/equal_modulo2.c"
 395     *)
 396   +> Compare_c.compare_result_to_string
 397   +> pr2
 398
 399
 400
 401 (* ---------------------------------------------------------------------- *)
 402 let test_attributes file =
 403   let (ast2, _stat) = Parse_c.parse_c_and_cpp file in
 404   let ast = Parse_c.program_of_program2 ast2 in
 405
 406   Visitor_c.vk_program { Visitor_c.default_visitor_c with
 407     Visitor_c.kdef = (fun (k, bigf) (defbis, ii) ->
 408       let sattr  = Ast_c.s_of_attr defbis.f_attr in
 409       pr2 (spf "%-30s: %s" (Ast_c.str_of_name (defbis.f_name)) sattr);
 410     );
 411     Visitor_c.kdecl = (fun (k, bigf) decl ->
 412       match decl with
 413       | DeclList (xs, ii) ->
 414           xs +> List.iter (fun (onedecl, iicomma) ->
 415
 416             let sattr  = Ast_c.s_of_attr onedecl.v_attr in
 417             let idname =
 418               match onedecl.v_namei with
 419               | Some (name, ini) -> Ast_c.str_of_name name
 420               | None -> "novar"
 421             in
 422             pr2 (spf "%-30s: %s" idname sattr);
 423           );
 424       | _ -> ()
 425
 426     );
 427   } ast;
 428   ()
 429
 430
 431 let cpp_options () = [
 432   Cpp_ast_c.I "/home/yyzhou/pad/linux/include";
 433 ] ++
 434   Cpp_ast_c.cpp_option_of_cmdline
 435   (!Flag_parsing_c.cpp_i_opts,!Flag_parsing_c.cpp_d_opts)
 436
 437 let test_cpp file =
 438   let (ast2, _stat) = Parse_c.parse_c_and_cpp file in
 439   let dirname = Filename.dirname file in
 440   let ast = Parse_c.program_of_program2 ast2 in
 441   let ast = Cpp_ast_c.cpp_expand_include (cpp_options()) dirname ast in
 442   let _ast = Cpp_ast_c.cpp_ifdef_statementize ast in
 443
 444
 445   ()
 446
 447
 448
 449 (* CONFIG [ch] ? also do for .c ? maybe less needed now that I
 450  * add local_macros.
 451  *)
 452 let extract_macros ~selection dir =
 453   let ext = "h" in
 454   let fullxs = Common.files_of_dir_or_files_no_vcs ext [dir] in
 455   let macros_and_filename =
 456     fullxs +> List.map (fun file ->
 457       pr2 (spf "processing: %s" file);
 458       let xs = Parse_c.extract_macros file in
 459       file, xs
 460     )
 461   in
 462
 463   let macros =
 464     if selection
 465     then Cpp_analysis_c.extract_dangerous_macros macros_and_filename
 466     else macros_and_filename
 467   in
 468   macros +> List.iter (fun (file, defs) ->
 469     pr ("/* PARSING: " ^ file ^ " */");
 470     defs +> List.iter (fun (s, def) ->
 471       let str = Cpp_token_c.string_of_define_def def in
 472       pr str;
 473     )
 474   );
 475   ()
 476
 477
 478 let test_parse xs =
 479
 480   Flag_parsing_c.filter_msg_define_error := true;
 481   Flag_parsing_c.filter_define_error := true;
 482   Flag_parsing_c.verbose_lexing := false;
 483   Flag_parsing_c.verbose_parsing := false;
 484
 485   let dirname_opt =
 486     match xs with
 487     | [x] when is_directory x -> Some x
 488     | _ -> None
 489   in
 490   dirname_opt +> Common.do_option (fun dir ->
 491
 492     let ext = "h" in
 493     let fullxs = Common.files_of_dir_or_files_no_vcs ext [dir] in
 494
 495     let macros_and_filename =
 496       fullxs +> List.map (fun file ->
 497         pr2 (spf "processing: %s" file);
 498         let xs = Parse_c.extract_macros file in
 499         file, xs
 500       )
 501     in
 502     let macros =
 503       Cpp_analysis_c.extract_dangerous_macros macros_and_filename
 504     in
 505     macros +> List.iter (fun (file, xs) ->
 506       xs +> List.iter (fun (x, def) ->
 507         let (s, params, body) = def in
 508         let str = Cpp_token_c.string_of_define_def def in
 509         pr str;
 510         (* builtins ? *)
 511         Hashtbl.replace !Parse_c._defs_builtins s (s, params, body);
 512       );
 513     );
 514   );
 515
 516   let ext = "[ch]" in
 517
 518   let fullxs = Common.files_of_dir_or_files_no_vcs ext xs in
 519
 520   let stat_list = ref [] in
 521   Common.check_stack_nbfiles (List.length fullxs);
 522
 523   fullxs +> List.iter (fun file ->
 524     if not (file =~ (".*\\."^ext))
 525     then pr2 ("warning: seems not a ."^ext^" file");
 526
 527     pr2 "";
 528     pr2 ("PARSING: " ^ file);
 529
 530     let (xs, stat) = Parse_c.parse_c_and_cpp file in
 531     xs +> List.iter (fun (ast, (s, toks)) ->
 532       Parse_c.print_commentized toks
 533     );
 534
 535     Common.push2 stat stat_list;
 536   );
 537
 538   if not (null !stat_list)
 539   then begin
 540     Parsing_stat.print_recurring_problematic_tokens !stat_list;
 541     Parsing_stat.print_parsing_stat_list !stat_list;
 542   end;
 543   ()
 544
 545
 546
 547
 548
 549
 550
 551
 552 (* ---------------------------------------------------------------------- *)
 553 let test_xxx a  =
 554   ()
 555
 556 (*
 557   ignore(Parse_c.parse_cpp_define_file "standard.h")
 558   pr2 "pr2";
 559   pr  "pr"
 560
 561   Format.print_newline();
 562   Format.printf "@[<v 5>--@,--@,@[<v 5>--@,--@,@]--@,--@,@]";
 563   Format.print_newline();
 564   Format.printf "@[<v>(---@[<v>(---@[<v>(---@,)@]@,)@]@,)@]"
 565 *)
 566
 567
 568
 569 (*****************************************************************************)
 570 (* Main entry for Arg *)
 571 (*****************************************************************************)
 572
 573 let actions () = [
 574   "--tokens-c", "   <file>",
 575   Common.mk_action_1_arg test_tokens_c;
 576   "--parse-c", "   <file or dir>",
 577   Common.mk_action_n_arg test_parse_c;
 578   "--parse-h", "   <file or dir>",
 579   Common.mk_action_n_arg test_parse_h;
 580   "--parse-ch", "   <file or dir>",
 581   Common.mk_action_n_arg test_parse_ch;
 582   "--parse-i", "   <file or dir>",
 583   Common.mk_action_n_arg test_parse_i;
 584   "--parse-c++", "   <file or dir>",
 585   Common.mk_action_n_arg new_test_parse_gen;
 586
 587   "--parse", "   <file or dir>",
 588   Common.mk_action_n_arg test_parse;
 589
 590   "--show-flow", "   <file or file:function>",
 591   Common.mk_action_1_arg (local_test_cfg true);
 592   "--control-flow", "   <file or file:function>",
 593   Common.mk_action_1_arg (local_test_cfg true);
 594   "--control-flow-to-file", "   <file or file:function>",
 595   Common.mk_action_1_arg (local_test_cfg false);
 596   "--test-cfg-ifdef", " <file>",
 597   Common.mk_action_1_arg test_cfg_ifdef;
 598   "--parse-unparse", "   <file>",
 599   Common.mk_action_1_arg test_parse_unparse;
 600 (*  "--parse-and-print-sexp", "   <file>",
 601     Common.mk_action_1_arg parse_and_print_sexp;*)
 602   "--type-c", "   <file>",
 603   Common.mk_action_1_arg test_type_c;
 604   "--compare-c", "   <file1> <file2>",
 605   Common.mk_action_2_arg test_compare_c (* result is in unix code *);
 606   "--comment-annotater-c", "   <file>",
 607   Common.mk_action_1_arg test_comment_annotater;
 608
 609   "--compare-c-hardcoded", "  ",
 610   Common.mk_action_0_arg test_compare_c_hardcoded;
 611
 612   "--test-attributes", " <file>",
 613   Common.mk_action_1_arg test_attributes;
 614   "--test-cpp", " <file>",
 615   Common.mk_action_1_arg test_cpp;
 616
 617   "--extract-macros", " <file or dir>",
 618   Common.mk_action_1_arg (extract_macros ~selection:false) ;
 619
 620   "--extract-macros-select", " <file or dir>",
 621   Common.mk_action_1_arg (extract_macros ~selection:true);
 622
 623
 624   "--xxx", "   <file1> <>",
 625   Common.mk_action_n_arg test_xxx;
 626 ]
 627