1------------------------------------------------------------------------------ 2-- -- 3-- GNAT SYSTEM UTILITIES -- 4-- -- 5-- C S I N F O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage 27-- is consistent and that assertion cross-reference lists are correct, as well 28-- as making sure that all the comments on field name usage are consistent. 29 30-- Note that this is used both as a standalone program, and as a procedure 31-- called by XSinfo. This raises an unhandled exception if it finds any 32-- errors; we don't attempt any sophisticated error recovery. 33 34with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 35with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; 36with Ada.Strings.Maps; use Ada.Strings.Maps; 37with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 38with Ada.Text_IO; use Ada.Text_IO; 39 40with GNAT.Spitbol; use GNAT.Spitbol; 41with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; 42with GNAT.Spitbol.Table_Boolean; 43with GNAT.Spitbol.Table_VString; 44 45procedure CSinfo is 46 47 package TB renames GNAT.Spitbol.Table_Boolean; 48 package TV renames GNAT.Spitbol.Table_VString; 49 use TB, TV; 50 51 Infil : File_Type; 52 Lineno : Natural := 0; 53 54 Err : exception; 55 -- Raised on fatal error 56 57 Done : exception; 58 -- Raised after error is found to terminate run 59 60 WSP : constant Pattern := Span (' ' & ASCII.HT); 61 62 Fields : TV.Table (300); 63 Fields1 : TV.Table (300); 64 Refs : TV.Table (300); 65 Refscopy : TV.Table (300); 66 Special : TB.Table (50); 67 Inlines : TV.Table (100); 68 69 -- The following define the standard fields used for binary operator, 70 -- unary operator, and other expression nodes. Numbers in the range 1-5 71 -- refer to the Fieldn fields. Letters D-R refer to flags: 72 73 -- D = Flag4 74 -- E = Flag5 75 -- F = Flag6 76 -- G = Flag7 77 -- H = Flag8 78 -- I = Flag9 79 -- J = Flag10 80 -- K = Flag11 81 -- L = Flag12 82 -- M = Flag13 83 -- N = Flag14 84 -- O = Flag15 85 -- P = Flag16 86 -- Q = Flag17 87 -- R = Flag18 88 89 Flags : TV.Table (20); 90 -- Maps flag numbers to letters 91 92 N_Fields : constant Pattern := BreakX ("JL"); 93 E_Fields : constant Pattern := BreakX ("5EFGHIJLOP"); 94 U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ"); 95 B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ"); 96 97 Line : VString; 98 Bad : Boolean; 99 100 Field : constant VString := Nul; 101 Fields_Used : VString := Nul; 102 Name : constant VString := Nul; 103 Next : constant VString := Nul; 104 Node : VString := Nul; 105 Ref : VString := Nul; 106 Synonym : constant VString := Nul; 107 Nxtref : constant VString := Nul; 108 109 Which_Field : aliased VString := Nul; 110 111 Node_Search : constant Pattern := WSP & "-- N_" & Rest * Node; 112 Break_Punc : constant Pattern := Break (" .,"); 113 Plus_Binary : constant Pattern := WSP 114 & "-- plus fields for binary operator"; 115 Plus_Unary : constant Pattern := WSP 116 & "-- plus fields for unary operator"; 117 Plus_Expr : constant Pattern := WSP 118 & "-- plus fields for expression"; 119 Break_Syn : constant Pattern := WSP & "-- " 120 & Break (' ') * Synonym 121 & " (" & Break (')') * Field; 122 Break_Field : constant Pattern := BreakX ('-') * Field; 123 Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) 124 & Span (Decimal_Digit_Set) * Which_Field; 125 Break_WFld : constant Pattern := Break (Which_Field'Access); 126 Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym; 127 Extr_Field : constant Pattern := BreakX ('-') & "-- " & Rest * Field; 128 Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym; 129 Get_Inline : constant Pattern := WSP & "pragma Inline (" 130 & Break (')') * Name; 131 Set_Name : constant Pattern := "Set_" & Rest * Name; 132 Func_Rest : constant Pattern := " function " & Rest * Synonym; 133 Get_Nxtref : constant Pattern := Break (',') * Nxtref & ','; 134 Test_Syn : constant Pattern := Break ('=') & "= N_" 135 & (Break (" ,)") or Rest) * Next; 136 Chop_Comma : constant Pattern := BreakX (',') * Next; 137 Return_Fld : constant Pattern := WSP & "return " & Break (' ') * Field; 138 Set_Syn : constant Pattern := " procedure Set_" & Rest * Synonym; 139 Set_Fld : constant Pattern := WSP & "Set_" & Break (' ') * Field 140 & " (N, Val)"; 141 Break_With : constant Pattern := Break ('_') ** Field & "_With_Parent"; 142 143 type VStringA is array (Natural range <>) of VString; 144 145 procedure Next_Line; 146 -- Read next line trimmed from Infil into Line and bump Lineno 147 148 procedure Sort (A : in out VStringA); 149 -- Sort a (small) array of VString's 150 151 procedure Next_Line is 152 begin 153 Line := Get_Line (Infil); 154 Trim (Line); 155 Lineno := Lineno + 1; 156 end Next_Line; 157 158 procedure Sort (A : in out VStringA) is 159 Temp : VString; 160 begin 161 <<Sort>> 162 for J in 1 .. A'Length - 1 loop 163 if A (J) > A (J + 1) then 164 Temp := A (J); 165 A (J) := A (J + 1); 166 A (J + 1) := Temp; 167 goto Sort; 168 end if; 169 end loop; 170 end Sort; 171 172-- Start of processing for CSinfo 173 174begin 175 Anchored_Mode := True; 176 New_Line; 177 Open (Infil, In_File, "sinfo.ads"); 178 Put_Line ("Check for field name consistency"); 179 180 -- Setup table for mapping flag numbers to letters 181 182 Set (Flags, "4", V ("D")); 183 Set (Flags, "5", V ("E")); 184 Set (Flags, "6", V ("F")); 185 Set (Flags, "7", V ("G")); 186 Set (Flags, "8", V ("H")); 187 Set (Flags, "9", V ("I")); 188 Set (Flags, "10", V ("J")); 189 Set (Flags, "11", V ("K")); 190 Set (Flags, "12", V ("L")); 191 Set (Flags, "13", V ("M")); 192 Set (Flags, "14", V ("N")); 193 Set (Flags, "15", V ("O")); 194 Set (Flags, "16", V ("P")); 195 Set (Flags, "17", V ("Q")); 196 Set (Flags, "18", V ("R")); 197 198 -- Special fields table. The following names are not recorded or checked 199 -- by Csinfo, since they are specially handled. This means that any field 200 -- definition or subprogram with a matching name is ignored. 201 202 Set (Special, "Analyzed", True); 203 Set (Special, "Assignment_OK", True); 204 Set (Special, "Associated_Node", True); 205 Set (Special, "Cannot_Be_Constant", True); 206 Set (Special, "Chars", True); 207 Set (Special, "Comes_From_Source", True); 208 Set (Special, "Do_Overflow_Check", True); 209 Set (Special, "Do_Range_Check", True); 210 Set (Special, "Entity", True); 211 Set (Special, "Entity_Or_Associated_Node", True); 212 Set (Special, "Error_Posted", True); 213 Set (Special, "Etype", True); 214 Set (Special, "Evaluate_Once", True); 215 Set (Special, "First_Itype", True); 216 Set (Special, "Has_Aspect_Specifications", True); 217 Set (Special, "Has_Dynamic_Itype", True); 218 Set (Special, "Has_Dynamic_Range_Check", True); 219 Set (Special, "Has_Dynamic_Length_Check", True); 220 Set (Special, "Has_Private_View", True); 221 Set (Special, "Implicit_With_From_Instantiation", True); 222 Set (Special, "Is_Controlling_Actual", True); 223 Set (Special, "Is_Overloaded", True); 224 Set (Special, "Is_Static_Expression", True); 225 Set (Special, "Left_Opnd", True); 226 Set (Special, "Must_Not_Freeze", True); 227 Set (Special, "Nkind_In", True); 228 Set (Special, "Parens", True); 229 Set (Special, "Pragma_Name", True); 230 Set (Special, "Raises_Constraint_Error", True); 231 Set (Special, "Right_Opnd", True); 232 233 -- Loop to acquire information from node definitions in sinfo.ads, 234 -- checking for consistency in Op/Flag assignments to each synonym 235 236 loop 237 Bad := False; 238 Next_Line; 239 exit when Match (Line, " -- Node Access Functions"); 240 241 if Match (Line, Node_Search) 242 and then not Match (Node, Break_Punc) 243 then 244 Fields_Used := Nul; 245 246 elsif Node = "" then 247 null; 248 249 elsif Line = "" then 250 Node := Nul; 251 252 elsif Match (Line, Plus_Binary) then 253 Bad := Match (Fields_Used, B_Fields); 254 255 elsif Match (Line, Plus_Unary) then 256 Bad := Match (Fields_Used, U_Fields); 257 258 elsif Match (Line, Plus_Expr) then 259 Bad := Match (Fields_Used, E_Fields); 260 261 elsif not Match (Line, Break_Syn) then 262 null; 263 264 elsif Match (Synonym, "plus") then 265 null; 266 267 else 268 Match (Field, Break_Field); 269 270 if not Present (Special, Synonym) then 271 if Present (Fields, Synonym) then 272 if Field /= Get (Fields, Synonym) then 273 Put_Line 274 ("Inconsistent field reference at line" & 275 Lineno'Img & " for " & Synonym); 276 raise Done; 277 end if; 278 279 else 280 Set (Fields, Synonym, Field); 281 end if; 282 283 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym)); 284 Match (Field, Get_Field); 285 286 if Match (Field, "Flag") then 287 Which_Field := Get (Flags, Which_Field); 288 end if; 289 290 if Match (Fields_Used, Break_WFld) then 291 Put_Line 292 ("Overlapping field at line " & Lineno'Img & 293 " for " & Synonym); 294 raise Done; 295 end if; 296 297 Append (Fields_Used, Which_Field); 298 Bad := Bad or Match (Fields_Used, N_Fields); 299 end if; 300 end if; 301 302 if Bad then 303 Put_Line ("fields conflict with standard fields for node " & Node); 304 raise Done; 305 end if; 306 end loop; 307 308 Put_Line (" OK"); 309 New_Line; 310 Put_Line ("Check for function consistency"); 311 312 -- Loop through field function definitions to make sure they are OK 313 314 Fields1 := Fields; 315 loop 316 Next_Line; 317 exit when Match (Line, " -- Node Update"); 318 319 if Match (Line, Get_Funcsyn) 320 and then not Present (Special, Synonym) 321 then 322 if not Present (Fields1, Synonym) then 323 Put_Line 324 ("function on line " & Lineno & 325 " is for unused synonym"); 326 raise Done; 327 end if; 328 329 Next_Line; 330 331 if not Match (Line, Extr_Field) then 332 raise Err; 333 end if; 334 335 if Field /= Get (Fields1, Synonym) then 336 Put_Line ("Wrong field in function " & Synonym); 337 raise Done; 338 339 else 340 Delete (Fields1, Synonym); 341 end if; 342 end if; 343 end loop; 344 345 Put_Line (" OK"); 346 New_Line; 347 Put_Line ("Check for missing functions"); 348 349 declare 350 List : constant TV.Table_Array := Convert_To_Array (Fields1); 351 352 begin 353 if List'Length > 0 then 354 Put_Line ("No function for field synonym " & List (1).Name); 355 raise Done; 356 end if; 357 end; 358 359 -- Check field set procedures 360 361 Put_Line (" OK"); 362 New_Line; 363 Put_Line ("Check for set procedure consistency"); 364 365 Fields1 := Fields; 366 loop 367 Next_Line; 368 exit when Match (Line, " -- Inline Pragmas"); 369 exit when Match (Line, " -- Iterator Procedures"); 370 371 if Match (Line, Get_Procsyn) 372 and then not Present (Special, Synonym) 373 then 374 if not Present (Fields1, Synonym) then 375 Put_Line 376 ("procedure on line " & Lineno & " is for unused synonym"); 377 raise Done; 378 end if; 379 380 Next_Line; 381 382 if not Match (Line, Extr_Field) then 383 raise Err; 384 end if; 385 386 if Field /= Get (Fields1, Synonym) then 387 Put_Line ("Wrong field in procedure Set_" & Synonym); 388 raise Done; 389 390 else 391 Delete (Fields1, Synonym); 392 end if; 393 end if; 394 end loop; 395 396 Put_Line (" OK"); 397 New_Line; 398 Put_Line ("Check for missing set procedures"); 399 400 declare 401 List : constant TV.Table_Array := Convert_To_Array (Fields1); 402 403 begin 404 if List'Length > 0 then 405 Put_Line ("No procedure for field synonym Set_" & List (1).Name); 406 raise Done; 407 end if; 408 end; 409 410 Put_Line (" OK"); 411 New_Line; 412 Put_Line ("Check pragma Inlines are all for existing subprograms"); 413 414 Clear (Fields1); 415 while not End_Of_File (Infil) loop 416 Next_Line; 417 418 if Match (Line, Get_Inline) 419 and then not Present (Special, Name) 420 then 421 exit when Match (Name, Set_Name); 422 423 if not Present (Fields, Name) then 424 Put_Line 425 ("Pragma Inline on line " & Lineno & 426 " does not correspond to synonym"); 427 raise Done; 428 429 else 430 Set (Inlines, Name, Get (Inlines, Name) & 'r'); 431 end if; 432 end if; 433 end loop; 434 435 Put_Line (" OK"); 436 New_Line; 437 Put_Line ("Check no pragma Inlines were omitted"); 438 439 declare 440 List : constant TV.Table_Array := Convert_To_Array (Fields); 441 Nxt : VString := Nul; 442 443 begin 444 for M in List'Range loop 445 Nxt := List (M).Name; 446 447 if Get (Inlines, Nxt) /= "r" then 448 Put_Line ("Incorrect pragma Inlines for " & Nxt); 449 raise Done; 450 end if; 451 end loop; 452 end; 453 454 Put_Line (" OK"); 455 New_Line; 456 Clear (Inlines); 457 458 Close (Infil); 459 Open (Infil, In_File, "sinfo.adb"); 460 Lineno := 0; 461 Put_Line ("Check references in functions in body"); 462 463 Refscopy := Refs; 464 loop 465 Next_Line; 466 exit when Match (Line, " -- Field Access Functions --"); 467 end loop; 468 469 loop 470 Next_Line; 471 exit when Match (Line, " -- Field Set Procedures --"); 472 473 if Match (Line, Func_Rest) 474 and then not Present (Special, Synonym) 475 then 476 Ref := Get (Refs, Synonym); 477 Delete (Refs, Synonym); 478 479 if Ref = "" then 480 Put_Line 481 ("Function on line " & Lineno & " is for unknown synonym"); 482 raise Err; 483 end if; 484 485 -- Alpha sort of references for this entry 486 487 declare 488 Refa : VStringA (1 .. 100); 489 N : Natural := 0; 490 491 begin 492 loop 493 exit when not Match (Ref, Get_Nxtref, Nul); 494 N := N + 1; 495 Refa (N) := Nxtref; 496 end loop; 497 498 Sort (Refa (1 .. N)); 499 Next_Line; 500 Next_Line; 501 Next_Line; 502 503 -- Checking references for one entry 504 505 for M in 1 .. N loop 506 Next_Line; 507 508 if not Match (Line, Test_Syn) then 509 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 510 raise Done; 511 end if; 512 513 Match (Next, Chop_Comma); 514 515 if Next /= Refa (M) then 516 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 517 raise Done; 518 end if; 519 end loop; 520 521 Next_Line; 522 Match (Line, Return_Fld); 523 524 if Field /= Get (Fields, Synonym) then 525 Put_Line 526 ("Wrong field for function " & Synonym & " at line " & 527 Lineno & " should be " & Get (Fields, Synonym)); 528 raise Done; 529 end if; 530 end; 531 end if; 532 end loop; 533 534 Put_Line (" OK"); 535 New_Line; 536 Put_Line ("Check for missing functions in body"); 537 538 declare 539 List : constant TV.Table_Array := Convert_To_Array (Refs); 540 541 begin 542 if List'Length /= 0 then 543 Put_Line ("Missing function " & List (1).Name & " in body"); 544 raise Done; 545 end if; 546 end; 547 548 Put_Line (" OK"); 549 New_Line; 550 Put_Line ("Check Set procedures in body"); 551 Refs := Refscopy; 552 553 loop 554 Next_Line; 555 exit when Match (Line, "end"); 556 exit when Match (Line, " -- Iterator Procedures"); 557 558 if Match (Line, Set_Syn) 559 and then not Present (Special, Synonym) 560 then 561 Ref := Get (Refs, Synonym); 562 Delete (Refs, Synonym); 563 564 if Ref = "" then 565 Put_Line 566 ("Function on line " & Lineno & " is for unknown synonym"); 567 raise Err; 568 end if; 569 570 -- Alpha sort of references for this entry 571 572 declare 573 Refa : VStringA (1 .. 100); 574 N : Natural; 575 576 begin 577 N := 0; 578 579 loop 580 exit when not Match (Ref, Get_Nxtref, Nul); 581 N := N + 1; 582 Refa (N) := Nxtref; 583 end loop; 584 585 Sort (Refa (1 .. N)); 586 587 Next_Line; 588 Next_Line; 589 Next_Line; 590 591 -- Checking references for one entry 592 593 for M in 1 .. N loop 594 Next_Line; 595 596 if not Match (Line, Test_Syn) 597 or else Next /= Refa (M) 598 then 599 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 600 raise Err; 601 end if; 602 end loop; 603 604 loop 605 Next_Line; 606 exit when Match (Line, Set_Fld); 607 end loop; 608 609 Match (Field, Break_With); 610 611 if Field /= Get (Fields, Synonym) then 612 Put_Line 613 ("Wrong field for procedure Set_" & Synonym & 614 " at line " & Lineno & " should be " & 615 Get (Fields, Synonym)); 616 raise Done; 617 end if; 618 619 Delete (Fields1, Synonym); 620 end; 621 end if; 622 end loop; 623 624 Put_Line (" OK"); 625 New_Line; 626 Put_Line ("Check for missing set procedures in body"); 627 628 declare 629 List : constant TV.Table_Array := Convert_To_Array (Fields1); 630 begin 631 if List'Length /= 0 then 632 Put_Line ("Missing procedure Set_" & List (1).Name & " in body"); 633 raise Done; 634 end if; 635 end; 636 637 Put_Line (" OK"); 638 New_Line; 639 Put_Line ("All tests completed successfully, no errors detected"); 640 641end CSinfo; 642