| 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_c_and_cpp 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 | (* uses an explicit path; to fix |
| 77 | dirname_opt +> Common.do_option (fun dirname -> |
| 78 | pr2_xxxxxxxxxxxxxxxxx(); |
| 79 | pr2 "regression testing information"; |
| 80 | pr2_xxxxxxxxxxxxxxxxx(); |
| 81 | let str = Str.global_replace (Str.regexp "/") "__" dirname in |
| 82 | let def = if !Flag_parsing_c.filter_define_error then "_def_" else "" in |
| 83 | let ext = if ext =$= "c" then "" else ext in |
| 84 | let filename = "score_parsing__" ^str ^ def ^ ext ^ ".marshalled" in |
| 85 | if Sys.file_exists filename |
| 86 | then |
| 87 | Common.regression_testing newscore |
| 88 | (Filename.concat score_path |
| 89 | ("score_parsing__" ^str ^ def ^ ext ^ ".marshalled")) |
| 90 | ); |
| 91 | *) |
| 92 | |
| 93 | if not (null !stat_list) |
| 94 | then begin |
| 95 | Parsing_stat.print_recurring_problematic_tokens !stat_list; |
| 96 | Parsing_stat.print_parsing_stat_list !stat_list; |
| 97 | end; |
| 98 | () |
| 99 | |
| 100 | |
| 101 | let test_parse_c xs = |
| 102 | test_parse_gen xs "c" |
| 103 | let test_parse_h xs = |
| 104 | test_parse_gen xs "h" |
| 105 | let test_parse_ch xs = |
| 106 | test_parse_gen xs "[ch]" |
| 107 | |
| 108 | (* could use a simpler parser than heavy parse_c_and_cpp here as there |
| 109 | * is no more cpp stuff in the .i files |
| 110 | *) |
| 111 | let test_parse_i xs = |
| 112 | test_parse_gen xs "i" |
| 113 | |
| 114 | |
| 115 | |
| 116 | |
| 117 | |
| 118 | |
| 119 | |
| 120 | (* ---------------------------------------------------------------------- *) |
| 121 | (* file can be "foo.c" or "foo.c:main" *) |
| 122 | (* local function that is parameterized by whether to launch gv *) |
| 123 | let local_test_cfg launchgv file = |
| 124 | let (file, specific_func) = |
| 125 | if file =~ "\\(.*\\.c\\):\\(.*\\)" |
| 126 | then |
| 127 | let (a,b) = matched2 file in |
| 128 | a, Some b |
| 129 | else |
| 130 | file, None |
| 131 | in |
| 132 | |
| 133 | if not (file =~ ".*\\.c") |
| 134 | then pr2 "warning: seems not a .c file"; |
| 135 | |
| 136 | let (program, _stat) = Parse_c.parse_c_and_cpp file in |
| 137 | |
| 138 | program +> List.iter (fun (e,_) -> |
| 139 | let toprocess = |
| 140 | match specific_func, e with |
| 141 | | None, _ -> true |
| 142 | | Some s, Ast_c.Definition (defbis,_) -> |
| 143 | s =$= Ast_c.str_of_name (defbis.Ast_c.f_name) |
| 144 | | _, _ -> false |
| 145 | in |
| 146 | |
| 147 | if toprocess |
| 148 | then |
| 149 | (* old: Flow_to_ast.test !Flag.show_flow def *) |
| 150 | (try |
| 151 | let flow = Ast_to_flow.ast_to_control_flow e in |
| 152 | flow +> do_option (fun flow -> |
| 153 | Ast_to_flow.deadcode_detection flow; |
| 154 | let flow = Ast_to_flow.annotate_loop_nodes flow in |
| 155 | |
| 156 | let flow' = |
| 157 | (* |
| 158 | if !Flag_cocci.show_before_fixed_flow |
| 159 | then flow |
| 160 | else Ctlcocci_integration.fix_flow_ctl flow |
| 161 | *) |
| 162 | flow |
| 163 | in |
| 164 | let filename = Filename.temp_file "output" ".dot" in |
| 165 | Ograph_extended.print_ograph_mutable flow' (filename) launchgv |
| 166 | ) |
| 167 | with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x |
| 168 | ) |
| 169 | ) |
| 170 | |
| 171 | let test_cfg = local_test_cfg true |
| 172 | |
| 173 | |
| 174 | |
| 175 | let test_cfg_ifdef file = |
| 176 | let (ast2, _stat) = Parse_c.parse_c_and_cpp file in |
| 177 | let ast = Parse_c.program_of_program2 ast2 in |
| 178 | |
| 179 | let ast = Cpp_ast_c.cpp_ifdef_statementize ast in |
| 180 | |
| 181 | ast +> List.iter (fun e -> |
| 182 | (try |
| 183 | let flow = Ast_to_flow.ast_to_control_flow e in |
| 184 | flow +> do_option (fun flow -> |
| 185 | Ast_to_flow.deadcode_detection flow; |
| 186 | let flow = Ast_to_flow.annotate_loop_nodes flow in |
| 187 | Ograph_extended.print_ograph_mutable flow ("/tmp/output.dot") true |
| 188 | ) |
| 189 | with Ast_to_flow.Error (x) -> Ast_to_flow.report_error x |
| 190 | ) |
| 191 | ) |
| 192 | |
| 193 | (* ---------------------------------------------------------------------- *) |
| 194 | let test_parse_unparse infile = |
| 195 | if not (infile =~ ".*\\.c") |
| 196 | then pr2 "warning: seems not a .c file"; |
| 197 | |
| 198 | let (program2, _stat) = Parse_c.parse_c_and_cpp infile in |
| 199 | let program2_with_ppmethod = |
| 200 | program2 +> List.map (fun x -> x, Unparse_c.PPnormal) |
| 201 | in |
| 202 | Unparse_c.pp_program program2_with_ppmethod tmpfile; |
| 203 | Common.command2 ("cat " ^ tmpfile); |
| 204 | (* if want see diff of space => no -b -B *) |
| 205 | Common.command2 (spf "diff -u -p %s %s" infile tmpfile); |
| 206 | (* +> Transformation.test_simple_trans1;*) |
| 207 | () |
| 208 | |
| 209 | |
| 210 | (* |
| 211 | let parse_and_print_sexp file = |
| 212 | let (ast2,_stat) = Parse_c.parse_c_and_cpp file in |
| 213 | let ast = Parse_c.program_of_program2 ast2 in |
| 214 | let _ast = |
| 215 | Type_annoter_c.annotate_program !Type_annoter_c.initial_env ast |
| 216 | in |
| 217 | |
| 218 | (* |
| 219 | let sexp = Sexp_ast_c.sexp_of_program ast in |
| 220 | let s = Sexp.to_string_hum sexp in |
| 221 | *) |
| 222 | Sexp_ast_c.show_info := false; |
| 223 | let s = Sexp_ast_c.string_of_program ast in |
| 224 | pr2 s; |
| 225 | () |
| 226 | *) |
| 227 | |
| 228 | |
| 229 | let test_type_c infile = |
| 230 | if not (infile =~ ".*\\.c") |
| 231 | then pr2 "warning: seems not a .c file"; |
| 232 | |
| 233 | Flag_parsing_c.pretty_print_type_info := true; |
| 234 | |
| 235 | let (program2, _stat) = Parse_c.parse_c_and_cpp infile in |
| 236 | let _program2 = |
| 237 | program2 |
| 238 | +> Common.unzip |
| 239 | +> (fun (program, infos) -> |
| 240 | Type_annoter_c.annotate_program !Type_annoter_c.initial_env |
| 241 | program +> List.map fst, |
| 242 | infos |
| 243 | ) |
| 244 | +> Common.uncurry Common.zip |
| 245 | in |
| 246 | let program2_with_ppmethod = |
| 247 | program2 +> List.map (fun x -> x, Unparse_c.PPnormal) |
| 248 | in |
| 249 | Unparse_c.pp_program program2_with_ppmethod tmpfile; |
| 250 | Common.command2 ("cat " ^ tmpfile); |
| 251 | ();; |
| 252 | |
| 253 | |
| 254 | (* ---------------------------------------------------------------------- *) |
| 255 | (* ex: demos/platform_ifdef.c *) |
| 256 | let test_comment_annotater infile = |
| 257 | let (program2, _stat) = Parse_c.parse_c_and_cpp infile in |
| 258 | let asts = program2 +> List.map (fun (ast,_) -> ast) in |
| 259 | let toks = program2 +> List.map (fun (ast, (s, toks)) -> toks) +> |
| 260 | List.flatten in |
| 261 | |
| 262 | Flag_parsing_c.pretty_print_comment_info := true; |
| 263 | |
| 264 | pr2 "pretty print, before comment annotation: --->"; |
| 265 | Common.adjust_pp_with_indent (fun () -> |
| 266 | asts +> List.iter (fun ast -> |
| 267 | Pretty_print_c.pp_toplevel_simple ast; |
| 268 | ); |
| 269 | ); |
| 270 | |
| 271 | let _ = Comment_annotater_c.annotate_program toks asts in |
| 272 | |
| 273 | Common.adjust_pp_with_indent (fun () -> |
| 274 | pr2 "pretty print, after comment annotation: --->"; |
| 275 | asts +> List.iter (fun ast -> |
| 276 | Pretty_print_c.pp_toplevel_simple ast; |
| 277 | ); |
| 278 | ); |
| 279 | |
| 280 | |
| 281 | () |
| 282 | |
| 283 | |
| 284 | (* ---------------------------------------------------------------------- *) |
| 285 | (* used by generic_makefile now *) |
| 286 | let test_compare_c file1 file2 = |
| 287 | let (correct, diffxs) = Compare_c.compare_default file1 file2 in |
| 288 | let res = Compare_c.compare_result_to_bool correct in |
| 289 | if res |
| 290 | then raise (Common.UnixExit 0) |
| 291 | else raise (Common.UnixExit (-1)) |
| 292 | |
| 293 | |
| 294 | let test_compare_c_hardcoded () = |
| 295 | Compare_c.compare_default |
| 296 | "tests/compare1.c" |
| 297 | "tests/compare2.c" |
| 298 | (* |
| 299 | "tests/equal_modulo1.c" |
| 300 | "tests/equal_modulo2.c" |
| 301 | *) |
| 302 | +> Compare_c.compare_result_to_string |
| 303 | +> pr2 |
| 304 | |
| 305 | |
| 306 | |
| 307 | (* ---------------------------------------------------------------------- *) |
| 308 | let test_attributes file = |
| 309 | let (ast2, _stat) = Parse_c.parse_c_and_cpp file in |
| 310 | let ast = Parse_c.program_of_program2 ast2 in |
| 311 | |
| 312 | Visitor_c.vk_program { Visitor_c.default_visitor_c with |
| 313 | Visitor_c.kdef = (fun (k, bigf) (defbis, ii) -> |
| 314 | let sattr = Ast_c.s_of_attr defbis.f_attr in |
| 315 | pr2 (spf "%-30s: %s" (Ast_c.str_of_name (defbis.f_name)) sattr); |
| 316 | ); |
| 317 | Visitor_c.kdecl = (fun (k, bigf) decl -> |
| 318 | match decl with |
| 319 | | DeclList (xs, ii) -> |
| 320 | xs +> List.iter (fun (onedecl, iicomma) -> |
| 321 | |
| 322 | let sattr = Ast_c.s_of_attr onedecl.v_attr in |
| 323 | let idname = |
| 324 | match onedecl.v_namei with |
| 325 | | Some (name, ini) -> Ast_c.str_of_name name |
| 326 | | None -> "novar" |
| 327 | in |
| 328 | pr2 (spf "%-30s: %s" idname sattr); |
| 329 | ); |
| 330 | | _ -> () |
| 331 | |
| 332 | ); |
| 333 | } ast; |
| 334 | () |
| 335 | |
| 336 | |
| 337 | let cpp_options () = [ |
| 338 | Cpp_ast_c.I "/home/yyzhou/pad/linux/include"; |
| 339 | ] ++ |
| 340 | Cpp_ast_c.cpp_option_of_cmdline |
| 341 | (!Flag_parsing_c.cpp_i_opts,!Flag_parsing_c.cpp_d_opts) |
| 342 | |
| 343 | let test_cpp file = |
| 344 | let (ast2, _stat) = Parse_c.parse_c_and_cpp file in |
| 345 | let dirname = Filename.dirname file in |
| 346 | let ast = Parse_c.program_of_program2 ast2 in |
| 347 | let ast = Cpp_ast_c.cpp_expand_include (cpp_options()) dirname ast in |
| 348 | let _ast = Cpp_ast_c.cpp_ifdef_statementize ast in |
| 349 | |
| 350 | |
| 351 | () |
| 352 | |
| 353 | |
| 354 | |
| 355 | (* CONFIG [ch] ? also do for .c ? maybe less needed now that I |
| 356 | * add local_macros. |
| 357 | *) |
| 358 | let extract_macros ~selection dir = |
| 359 | let ext = "h" in |
| 360 | let fullxs = Common.files_of_dir_or_files_no_vcs ext [dir] in |
| 361 | let macros_and_filename = |
| 362 | fullxs +> List.map (fun file -> |
| 363 | pr2 (spf "processing: %s" file); |
| 364 | let xs = Parse_c.extract_macros file in |
| 365 | file, xs |
| 366 | ) |
| 367 | in |
| 368 | |
| 369 | let macros = |
| 370 | if selection |
| 371 | then Cpp_analysis_c.extract_dangerous_macros macros_and_filename |
| 372 | else macros_and_filename |
| 373 | in |
| 374 | macros +> List.iter (fun (file, defs) -> |
| 375 | pr ("/* PARSING: " ^ file ^ " */"); |
| 376 | defs +> List.iter (fun (s, def) -> |
| 377 | let str = Cpp_token_c.string_of_define_def def in |
| 378 | pr str; |
| 379 | ) |
| 380 | ); |
| 381 | () |
| 382 | |
| 383 | |
| 384 | let test_parse xs = |
| 385 | |
| 386 | Flag_parsing_c.filter_msg_define_error := true; |
| 387 | Flag_parsing_c.filter_define_error := true; |
| 388 | Flag_parsing_c.verbose_lexing := false; |
| 389 | Flag_parsing_c.verbose_parsing := false; |
| 390 | |
| 391 | let dirname_opt = |
| 392 | match xs with |
| 393 | | [x] when is_directory x -> Some x |
| 394 | | _ -> None |
| 395 | in |
| 396 | dirname_opt +> Common.do_option (fun dir -> |
| 397 | |
| 398 | let ext = "h" in |
| 399 | let fullxs = Common.files_of_dir_or_files_no_vcs ext [dir] in |
| 400 | |
| 401 | let macros_and_filename = |
| 402 | fullxs +> List.map (fun file -> |
| 403 | pr2 (spf "processing: %s" file); |
| 404 | let xs = Parse_c.extract_macros file in |
| 405 | file, xs |
| 406 | ) |
| 407 | in |
| 408 | let macros = |
| 409 | Cpp_analysis_c.extract_dangerous_macros macros_and_filename |
| 410 | in |
| 411 | macros +> List.iter (fun (file, xs) -> |
| 412 | xs +> List.iter (fun (x, def) -> |
| 413 | let (s, params, body) = def in |
| 414 | let str = Cpp_token_c.string_of_define_def def in |
| 415 | pr str; |
| 416 | (* builtins ? *) |
| 417 | Hashtbl.replace !Parse_c._defs_builtins s (s, params, body); |
| 418 | ); |
| 419 | ); |
| 420 | ); |
| 421 | |
| 422 | let ext = "[ch]" in |
| 423 | |
| 424 | let fullxs = Common.files_of_dir_or_files_no_vcs ext xs in |
| 425 | |
| 426 | let stat_list = ref [] in |
| 427 | Common.check_stack_nbfiles (List.length fullxs); |
| 428 | |
| 429 | fullxs +> List.iter (fun file -> |
| 430 | if not (file =~ (".*\\."^ext)) |
| 431 | then pr2 ("warning: seems not a ."^ext^" file"); |
| 432 | |
| 433 | pr2 ""; |
| 434 | pr2 ("PARSING: " ^ file); |
| 435 | |
| 436 | let (xs, stat) = Parse_c.parse_c_and_cpp file in |
| 437 | xs +> List.iter (fun (ast, (s, toks)) -> |
| 438 | Parse_c.print_commentized toks |
| 439 | ); |
| 440 | |
| 441 | Common.push2 stat stat_list; |
| 442 | ); |
| 443 | |
| 444 | if not (null !stat_list) |
| 445 | then begin |
| 446 | Parsing_stat.print_recurring_problematic_tokens !stat_list; |
| 447 | Parsing_stat.print_parsing_stat_list !stat_list; |
| 448 | end; |
| 449 | () |
| 450 | |
| 451 | |
| 452 | |
| 453 | |
| 454 | |
| 455 | |
| 456 | |
| 457 | |
| 458 | (* ---------------------------------------------------------------------- *) |
| 459 | let test_xxx a = |
| 460 | () |
| 461 | |
| 462 | (* |
| 463 | ignore(Parse_c.parse_cpp_define_file "standard.h") |
| 464 | pr2 "pr2"; |
| 465 | pr "pr" |
| 466 | |
| 467 | Format.print_newline(); |
| 468 | Format.printf "@[<v 5>--@,--@,@[<v 5>--@,--@,@]--@,--@,@]"; |
| 469 | Format.print_newline(); |
| 470 | Format.printf "@[<v>(---@[<v>(---@[<v>(---@,)@]@,)@]@,)@]" |
| 471 | *) |
| 472 | |
| 473 | |
| 474 | |
| 475 | (*****************************************************************************) |
| 476 | (* Main entry for Arg *) |
| 477 | (*****************************************************************************) |
| 478 | |
| 479 | let actions () = [ |
| 480 | "-tokens_c", " <file>", |
| 481 | Common.mk_action_1_arg test_tokens_c; |
| 482 | "-parse_c", " <file or dir>", |
| 483 | Common.mk_action_n_arg test_parse_c; |
| 484 | "-parse_h", " <file or dir>", |
| 485 | Common.mk_action_n_arg test_parse_h; |
| 486 | "-parse_ch", " <file or dir>", |
| 487 | Common.mk_action_n_arg test_parse_ch; |
| 488 | "-parse_i", " <file or dir>", |
| 489 | Common.mk_action_n_arg test_parse_i; |
| 490 | |
| 491 | "-parse", " <file or dir>", |
| 492 | Common.mk_action_n_arg test_parse; |
| 493 | |
| 494 | "-show_flow", " <file or file:function>", |
| 495 | Common.mk_action_1_arg (local_test_cfg true); |
| 496 | "-control_flow", " <file or file:function>", |
| 497 | Common.mk_action_1_arg (local_test_cfg true); |
| 498 | "-control_flow_to_file", " <file or file:function>", |
| 499 | Common.mk_action_1_arg (local_test_cfg false); |
| 500 | "-test_cfg_ifdef", " <file>", |
| 501 | Common.mk_action_1_arg test_cfg_ifdef; |
| 502 | "-parse_unparse", " <file>", |
| 503 | Common.mk_action_1_arg test_parse_unparse; |
| 504 | (* "-parse_and_print_sexp", " <file>", |
| 505 | Common.mk_action_1_arg parse_and_print_sexp;*) |
| 506 | "-type_c", " <file>", |
| 507 | Common.mk_action_1_arg test_type_c; |
| 508 | "-compare_c", " <file1> <file2>", |
| 509 | Common.mk_action_2_arg test_compare_c (* result is in unix code *); |
| 510 | "-comment_annotater_c", " <file>", |
| 511 | Common.mk_action_1_arg test_comment_annotater; |
| 512 | |
| 513 | "-compare_c_hardcoded", " ", |
| 514 | Common.mk_action_0_arg test_compare_c_hardcoded; |
| 515 | |
| 516 | "-test_attributes", " <file>", |
| 517 | Common.mk_action_1_arg test_attributes; |
| 518 | "-test_cpp", " <file>", |
| 519 | Common.mk_action_1_arg test_cpp; |
| 520 | |
| 521 | "-extract_macros", " <file or dir>", |
| 522 | Common.mk_action_1_arg (extract_macros ~selection:false) ; |
| 523 | |
| 524 | "-extract_macros_select", " <file or dir>", |
| 525 | Common.mk_action_1_arg (extract_macros ~selection:true); |
| 526 | |
| 527 | |
| 528 | "-xxx", " <file1> <>", |
| 529 | Common.mk_action_n_arg test_xxx; |
| 530 | ] |
| 531 | |