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-2019, 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, "Is_Controlling_Actual", True); 222 Set (Special, "Is_Overloaded", True); 223 Set (Special, "Is_Static_Expression", True); 224 Set (Special, "Left_Opnd", True); 225 Set (Special, "Must_Not_Freeze", True); 226 Set (Special, "Nkind_In", True); 227 Set (Special, "Parens", True); 228 Set (Special, "Pragma_Name", True); 229 Set (Special, "Raises_Constraint_Error", True); 230 Set (Special, "Right_Opnd", True); 231 232 -- Loop to acquire information from node definitions in sinfo.ads, 233 -- checking for consistency in Op/Flag assignments to each synonym 234 235 loop 236 Bad := False; 237 Next_Line; 238 exit when Match (Line, " -- Node Access Functions"); 239 240 if Match (Line, Node_Search) 241 and then not Match (Node, Break_Punc) 242 then 243 Fields_Used := Nul; 244 245 elsif Node = "" then 246 null; 247 248 elsif Line = "" then 249 Node := Nul; 250 251 elsif Match (Line, Plus_Binary) then 252 Bad := Match (Fields_Used, B_Fields); 253 254 elsif Match (Line, Plus_Unary) then 255 Bad := Match (Fields_Used, U_Fields); 256 257 elsif Match (Line, Plus_Expr) then 258 Bad := Match (Fields_Used, E_Fields); 259 260 elsif not Match (Line, Break_Syn) then 261 null; 262 263 elsif Match (Synonym, "plus") then 264 null; 265 266 else 267 Match (Field, Break_Field); 268 269 if not Present (Special, Synonym) then 270 if Present (Fields, Synonym) then 271 if Field /= Get (Fields, Synonym) then 272 Put_Line 273 ("Inconsistent field reference at line" & 274 Lineno'Img & " for " & Synonym); 275 raise Done; 276 end if; 277 278 else 279 Set (Fields, Synonym, Field); 280 end if; 281 282 Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym)); 283 Match (Field, Get_Field); 284 285 if Match (Field, "Flag") then 286 Which_Field := Get (Flags, Which_Field); 287 end if; 288 289 if Match (Fields_Used, Break_WFld) then 290 Put_Line 291 ("Overlapping field at line " & Lineno'Img & 292 " for " & Synonym); 293 raise Done; 294 end if; 295 296 Append (Fields_Used, Which_Field); 297 Bad := Bad or Match (Fields_Used, N_Fields); 298 end if; 299 end if; 300 301 if Bad then 302 Put_Line ("fields conflict with standard fields for node " & Node); 303 raise Done; 304 end if; 305 end loop; 306 307 Put_Line (" OK"); 308 New_Line; 309 Put_Line ("Check for function consistency"); 310 311 -- Loop through field function definitions to make sure they are OK 312 313 Fields1 := Fields; 314 loop 315 Next_Line; 316 exit when Match (Line, " -- Node Update"); 317 318 if Match (Line, Get_Funcsyn) 319 and then not Present (Special, Synonym) 320 then 321 if not Present (Fields1, Synonym) then 322 Put_Line 323 ("function on line " & Lineno & 324 " is for unused synonym"); 325 raise Done; 326 end if; 327 328 Next_Line; 329 330 if not Match (Line, Extr_Field) then 331 raise Err; 332 end if; 333 334 if Field /= Get (Fields1, Synonym) then 335 Put_Line ("Wrong field in function " & Synonym); 336 raise Done; 337 338 else 339 Delete (Fields1, Synonym); 340 end if; 341 end if; 342 end loop; 343 344 Put_Line (" OK"); 345 New_Line; 346 Put_Line ("Check for missing functions"); 347 348 declare 349 List : constant TV.Table_Array := Convert_To_Array (Fields1); 350 351 begin 352 if List'Length > 0 then 353 Put_Line ("No function for field synonym " & List (1).Name); 354 raise Done; 355 end if; 356 end; 357 358 -- Check field set procedures 359 360 Put_Line (" OK"); 361 New_Line; 362 Put_Line ("Check for set procedure consistency"); 363 364 Fields1 := Fields; 365 loop 366 Next_Line; 367 exit when Match (Line, " -- Inline Pragmas"); 368 exit when Match (Line, " -- Iterator Procedures"); 369 370 if Match (Line, Get_Procsyn) 371 and then not Present (Special, Synonym) 372 then 373 if not Present (Fields1, Synonym) then 374 Put_Line 375 ("procedure on line " & Lineno & " is for unused synonym"); 376 raise Done; 377 end if; 378 379 Next_Line; 380 381 if not Match (Line, Extr_Field) then 382 raise Err; 383 end if; 384 385 if Field /= Get (Fields1, Synonym) then 386 Put_Line ("Wrong field in procedure Set_" & Synonym); 387 raise Done; 388 389 else 390 Delete (Fields1, Synonym); 391 end if; 392 end if; 393 end loop; 394 395 Put_Line (" OK"); 396 New_Line; 397 Put_Line ("Check for missing set procedures"); 398 399 declare 400 List : constant TV.Table_Array := Convert_To_Array (Fields1); 401 402 begin 403 if List'Length > 0 then 404 Put_Line ("No procedure for field synonym Set_" & List (1).Name); 405 raise Done; 406 end if; 407 end; 408 409 Put_Line (" OK"); 410 New_Line; 411 Put_Line ("Check pragma Inlines are all for existing subprograms"); 412 413 Clear (Fields1); 414 while not End_Of_File (Infil) loop 415 Next_Line; 416 417 if Match (Line, Get_Inline) 418 and then not Present (Special, Name) 419 then 420 exit when Match (Name, Set_Name); 421 422 if not Present (Fields, Name) then 423 Put_Line 424 ("Pragma Inline on line " & Lineno & 425 " does not correspond to synonym"); 426 raise Done; 427 428 else 429 Set (Inlines, Name, Get (Inlines, Name) & 'r'); 430 end if; 431 end if; 432 end loop; 433 434 Put_Line (" OK"); 435 New_Line; 436 Put_Line ("Check no pragma Inlines were omitted"); 437 438 declare 439 List : constant TV.Table_Array := Convert_To_Array (Fields); 440 Nxt : VString := Nul; 441 442 begin 443 for M in List'Range loop 444 Nxt := List (M).Name; 445 446 if Get (Inlines, Nxt) /= "r" then 447 Put_Line ("Incorrect pragma Inlines for " & Nxt); 448 raise Done; 449 end if; 450 end loop; 451 end; 452 453 Put_Line (" OK"); 454 New_Line; 455 Clear (Inlines); 456 457 Close (Infil); 458 Open (Infil, In_File, "sinfo.adb"); 459 Lineno := 0; 460 Put_Line ("Check references in functions in body"); 461 462 Refscopy := Refs; 463 loop 464 Next_Line; 465 exit when Match (Line, " -- Field Access Functions --"); 466 end loop; 467 468 loop 469 Next_Line; 470 exit when Match (Line, " -- Field Set Procedures --"); 471 472 if Match (Line, Func_Rest) 473 and then not Present (Special, Synonym) 474 then 475 Ref := Get (Refs, Synonym); 476 Delete (Refs, Synonym); 477 478 if Ref = "" then 479 Put_Line 480 ("Function on line " & Lineno & " is for unknown synonym"); 481 raise Err; 482 end if; 483 484 -- Alpha sort of references for this entry 485 486 declare 487 Refa : VStringA (1 .. 100); 488 N : Natural := 0; 489 490 begin 491 loop 492 exit when not Match (Ref, Get_Nxtref, Nul); 493 N := N + 1; 494 Refa (N) := Nxtref; 495 end loop; 496 497 Sort (Refa (1 .. N)); 498 Next_Line; 499 Next_Line; 500 Next_Line; 501 502 -- Checking references for one entry 503 504 for M in 1 .. N loop 505 Next_Line; 506 507 if not Match (Line, Test_Syn) then 508 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 509 raise Done; 510 end if; 511 512 Match (Next, Chop_Comma); 513 514 if Next /= Refa (M) then 515 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 516 raise Done; 517 end if; 518 end loop; 519 520 Next_Line; 521 Match (Line, Return_Fld); 522 523 if Field /= Get (Fields, Synonym) then 524 Put_Line 525 ("Wrong field for function " & Synonym & " at line " & 526 Lineno & " should be " & Get (Fields, Synonym)); 527 raise Done; 528 end if; 529 end; 530 end if; 531 end loop; 532 533 Put_Line (" OK"); 534 New_Line; 535 Put_Line ("Check for missing functions in body"); 536 537 declare 538 List : constant TV.Table_Array := Convert_To_Array (Refs); 539 540 begin 541 if List'Length /= 0 then 542 Put_Line ("Missing function " & List (1).Name & " in body"); 543 raise Done; 544 end if; 545 end; 546 547 Put_Line (" OK"); 548 New_Line; 549 Put_Line ("Check Set procedures in body"); 550 Refs := Refscopy; 551 552 loop 553 Next_Line; 554 exit when Match (Line, "end"); 555 exit when Match (Line, " -- Iterator Procedures"); 556 557 if Match (Line, Set_Syn) 558 and then not Present (Special, Synonym) 559 then 560 Ref := Get (Refs, Synonym); 561 Delete (Refs, Synonym); 562 563 if Ref = "" then 564 Put_Line 565 ("Function on line " & Lineno & " is for unknown synonym"); 566 raise Err; 567 end if; 568 569 -- Alpha sort of references for this entry 570 571 declare 572 Refa : VStringA (1 .. 100); 573 N : Natural; 574 575 begin 576 N := 0; 577 578 loop 579 exit when not Match (Ref, Get_Nxtref, Nul); 580 N := N + 1; 581 Refa (N) := Nxtref; 582 end loop; 583 584 Sort (Refa (1 .. N)); 585 586 Next_Line; 587 Next_Line; 588 Next_Line; 589 590 -- Checking references for one entry 591 592 for M in 1 .. N loop 593 Next_Line; 594 595 if not Match (Line, Test_Syn) 596 or else Next /= Refa (M) 597 then 598 Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno); 599 raise Err; 600 end if; 601 end loop; 602 603 loop 604 Next_Line; 605 exit when Match (Line, Set_Fld); 606 end loop; 607 608 Match (Field, Break_With); 609 610 if Field /= Get (Fields, Synonym) then 611 Put_Line 612 ("Wrong field for procedure Set_" & Synonym & 613 " at line " & Lineno & " should be " & 614 Get (Fields, Synonym)); 615 raise Done; 616 end if; 617 618 Delete (Fields1, Synonym); 619 end; 620 end if; 621 end loop; 622 623 Put_Line (" OK"); 624 New_Line; 625 Put_Line ("Check for missing set procedures in body"); 626 627 declare 628 List : constant TV.Table_Array := Convert_To_Array (Fields1); 629 begin 630 if List'Length /= 0 then 631 Put_Line ("Missing procedure Set_" & List (1).Name & " in body"); 632 raise Done; 633 end if; 634 end; 635 636 Put_Line (" OK"); 637 New_Line; 638 Put_Line ("All tests completed successfully, no errors detected"); 639 640end CSinfo; 641