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