gcc/ada/csinfo.adb

   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-2005 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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
  32 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  33 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  34 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  35 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  36 with Ada.Text_IO;                   use Ada.Text_IO;
  37
  38 with GNAT.Spitbol;                  use GNAT.Spitbol;
  39 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  40 with GNAT.Spitbol.Table_Boolean;
  41 with GNAT.Spitbol.Table_VString;
  42
  43 procedure 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    begin
 153       <<Sort>>
 154          for J in 1 .. A'Length - 1 loop
 155             if A (J) > A (J + 1) then
 156                Temp := A (J);
 157                A (J) := A (J + 1);
 158                A (J + 1) := Temp;
 159                goto Sort;
 160             end if;
 161          end loop;
 162    end Sort;
 163
 164 --  Start of processing for CSinfo
 165
 166 begin
 167    Anchored_Mode := True;
 168    New_Line;
 169    Open (Infil, In_File, "sinfo.ads");
 170    Put_Line ("Check for field name consistency");
 171
 172    --  Setup table for mapping flag numbers to letters
 173
 174    Set (Flags, "4",  V ("D"));
 175    Set (Flags, "5",  V ("E"));
 176    Set (Flags, "6",  V ("F"));
 177    Set (Flags, "7",  V ("G"));
 178    Set (Flags, "8",  V ("H"));
 179    Set (Flags, "9",  V ("I"));
 180    Set (Flags, "10", V ("J"));
 181    Set (Flags, "11", V ("K"));
 182    Set (Flags, "12", V ("L"));
 183    Set (Flags, "13", V ("M"));
 184    Set (Flags, "14", V ("N"));
 185    Set (Flags, "15", V ("O"));
 186    Set (Flags, "16", V ("P"));
 187    Set (Flags, "17", V ("Q"));
 188    Set (Flags, "18", V ("R"));
 189
 190    --  Special fields table. The following fields are not recorded or checked
 191    --  by Csinfo, since they are specially handled. This means that both the
 192    --  field definitions, and the corresponding subprograms are ignored.
 193
 194    Set (Special, "Analyzed",                  True);
 195    Set (Special, "Assignment_OK",             True);
 196    Set (Special, "Associated_Node",           True);
 197    Set (Special, "Cannot_Be_Constant",        True);
 198    Set (Special, "Chars",                     True);
 199    Set (Special, "Comes_From_Source",         True);
 200    Set (Special, "Do_Overflow_Check",         True);
 201    Set (Special, "Do_Range_Check",            True);
 202    Set (Special, "Entity",                    True);
 203    Set (Special, "Entity_Or_Associated_Node", 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             if Present (Fields, Synonym) then
 260                if Field /= Get (Fields, Synonym) then
 261                   Put_Line
 262                     ("Inconsistent field reference at line" &
 263                      Lineno'Img & " for " & Synonym);
 264                   raise Done;
 265                end if;
 266
 267             else
 268                Set (Fields, Synonym, Field);
 269             end if;
 270
 271             Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
 272             Match (Field, Get_Field);
 273
 274             if Match (Field, "Flag") then
 275                Which_Field := Get (Flags, Which_Field);
 276             end if;
 277
 278             if Match (Fields_Used, Break_WFld) then
 279                Put_Line
 280                  ("Overlapping field at line " & Lineno'Img &
 281                   " for " & Synonym);
 282                raise Done;
 283             end if;
 284
 285             Append (Fields_Used, Which_Field);
 286             Bad := Bad or Match (Fields_Used, N_Fields);
 287          end if;
 288       end if;
 289
 290       if Bad then
 291          Put_Line ("fields conflict with standard fields for node " & Node);
 292       end if;
 293    end loop;
 294
 295    Put_Line ("     OK");
 296    New_Line;
 297    Put_Line ("Check for function consistency");
 298
 299    --  Loop through field function definitions to make sure they are OK
 300
 301    Fields1 := Fields;
 302    loop
 303       Next_Line;
 304       exit when Match (Line, "   -- Node Update");
 305
 306       if Match (Line, Get_Funcsyn)
 307         and then not Present (Special, Synonym)
 308       then
 309          if not Present (Fields1, Synonym) then
 310             Put_Line
 311               ("function on line " &  Lineno &
 312                " is for unused synonym");
 313             raise Done;
 314          end if;
 315
 316          Next_Line;
 317
 318          if not Match (Line, Extr_Field) then
 319             raise Err;
 320          end if;
 321
 322          if Field /= Get (Fields1, Synonym) then
 323             Put_Line ("Wrong field in function " & Synonym);
 324             raise Done;
 325
 326          else
 327             Delete (Fields1, Synonym);
 328          end if;
 329       end if;
 330    end loop;
 331
 332    Put_Line ("     OK");
 333    New_Line;
 334    Put_Line ("Check for missing functions");
 335
 336    declare
 337       List : TV.Table_Array := Convert_To_Array (Fields1);
 338
 339    begin
 340       if List'Length > 0 then
 341          Put_Line ("No function for field synonym " & List (1).Name);
 342          raise Done;
 343       end if;
 344    end;
 345
 346    --  Check field set procedures
 347
 348    Put_Line ("     OK");
 349    New_Line;
 350    Put_Line ("Check for set procedure consistency");
 351
 352    Fields1 := Fields;
 353    loop
 354       Next_Line;
 355       exit when Match (Line, "   -- Inline Pragmas");
 356       exit when Match (Line, "   -- Iterator Procedures");
 357
 358       if Match (Line, Get_Procsyn)
 359         and then not Present (Special, Synonym)
 360       then
 361          if not Present (Fields1, Synonym) then
 362             Put_Line
 363               ("procedure on line " & Lineno & " is for unused synonym");
 364             raise Done;
 365          end if;
 366
 367          Next_Line;
 368
 369          if not Match (Line, Extr_Field) then
 370             raise Err;
 371          end if;
 372
 373          if Field /= Get (Fields1, Synonym) then
 374             Put_Line ("Wrong field in procedure Set_" & Synonym);
 375             raise Done;
 376
 377          else
 378             Delete (Fields1, Synonym);
 379          end if;
 380       end if;
 381    end loop;
 382
 383    Put_Line ("     OK");
 384    New_Line;
 385    Put_Line ("Check for missing set procedures");
 386
 387    declare
 388       List : TV.Table_Array := Convert_To_Array (Fields1);
 389
 390    begin
 391       if List'Length > 0 then
 392          Put_Line ("No procedure for field synonym Set_" & List (1).Name);
 393          raise Done;
 394       end if;
 395    end;
 396
 397    Put_Line ("     OK");
 398    New_Line;
 399    Put_Line ("Check pragma Inlines are all for existing subprograms");
 400
 401    Clear (Fields1);
 402    while not End_Of_File (Infil) loop
 403       Next_Line;
 404
 405       if Match (Line, Get_Inline)
 406         and then not Present (Special, Name)
 407       then
 408          exit when Match (Name, Set_Name);
 409
 410          if not Present (Fields, Name) then
 411             Put_Line
 412               ("Pragma Inline on line " & Lineno &
 413                " does not correspond to synonym");
 414             raise Done;
 415
 416          else
 417             Set (Inlines, Name, Get (Inlines, Name) & 'r');
 418          end if;
 419       end if;
 420    end loop;
 421
 422    Put_Line ("     OK");
 423    New_Line;
 424    Put_Line ("Check no pragma Inlines were omitted");
 425
 426    declare
 427       List : TV.Table_Array := Convert_To_Array (Fields);
 428       Nxt  : VString := Nul;
 429
 430    begin
 431       for M in List'Range loop
 432          Nxt := List (M).Name;
 433
 434          if Get (Inlines, Nxt) /= "r" then
 435             Put_Line ("Incorrect pragma Inlines for " & Nxt);
 436             raise Done;
 437          end if;
 438       end loop;
 439    end;
 440
 441    Put_Line ("     OK");
 442    New_Line;
 443    Clear (Inlines);
 444
 445    Close (Infil);
 446    Open (Infil, In_File, "sinfo.adb");
 447    Lineno := 0;
 448    Put_Line ("Check references in functions in body");
 449
 450    Refscopy := Refs;
 451    loop
 452       Next_Line;
 453       exit when Match (Line, "   -- Field Access Functions --");
 454    end loop;
 455
 456    loop
 457       Next_Line;
 458       exit when Match (Line, "   -- Field Set Procedures --");
 459
 460       if Match (Line, Func_Rest)
 461         and then not Present (Special, Synonym)
 462       then
 463          Ref := Get (Refs, Synonym);
 464          Delete (Refs, Synonym);
 465
 466          if Ref = "" then
 467             Put_Line
 468               ("Function on line " & Lineno & " is for unknown synonym");
 469             raise Err;
 470          end if;
 471
 472          --  Alpha sort of references for this entry
 473
 474          declare
 475             Refa   : VStringA (1 .. 100);
 476             N      : Natural := 0;
 477
 478          begin
 479             loop
 480                exit when not Match (Ref, Get_Nxtref, Nul);
 481                N := N + 1;
 482                Refa (N) := Nxtref;
 483             end loop;
 484
 485             Sort (Refa (1 .. N));
 486             Next_Line;
 487             Next_Line;
 488             Next_Line;
 489
 490             --  Checking references for one entry
 491
 492             for M in 1 .. N loop
 493                Next_Line;
 494
 495                if not Match (Line, Test_Syn) then
 496                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 497                   raise Done;
 498                end if;
 499
 500                Match (Next, Chop_Comma);
 501
 502                if Next /= Refa (M) then
 503                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 504                   raise Done;
 505                end if;
 506             end loop;
 507
 508             Next_Line;
 509             Match (Line, Return_Fld);
 510
 511             if Field /= Get (Fields, Synonym) then
 512                Put_Line
 513                 ("Wrong field for function " & Synonym & " at line " &
 514                  Lineno & " should be " & Get (Fields, Synonym));
 515                raise Done;
 516             end if;
 517          end;
 518       end if;
 519    end loop;
 520
 521    Put_Line ("     OK");
 522    New_Line;
 523    Put_Line ("Check for missing functions in body");
 524
 525    declare
 526       List : TV.Table_Array := Convert_To_Array (Refs);
 527
 528    begin
 529       if List'Length /= 0 then
 530          Put_Line ("Missing function " & List (1).Name & " in body");
 531          raise Done;
 532       end if;
 533    end;
 534
 535    Put_Line ("     OK");
 536    New_Line;
 537    Put_Line ("Check Set procedures in body");
 538    Refs := Refscopy;
 539
 540    loop
 541       Next_Line;
 542       exit when Match (Line, "end");
 543       exit when Match (Line, "   -- Iterator Procedures");
 544
 545       if Match (Line, Set_Syn)
 546         and then not Present (Special, Synonym)
 547       then
 548          Ref := Get (Refs, Synonym);
 549          Delete (Refs, Synonym);
 550
 551          if Ref = "" then
 552             Put_Line
 553               ("Function on line " & Lineno & " is for unknown synonym");
 554             raise Err;
 555          end if;
 556
 557          --  Alpha sort of references for this entry
 558
 559          declare
 560             Refa   : VStringA (1 .. 100);
 561             N      : Natural;
 562
 563          begin
 564             N := 0;
 565
 566             loop
 567                exit when not Match (Ref, Get_Nxtref, Nul);
 568                N := N + 1;
 569                Refa (N) := Nxtref;
 570             end loop;
 571
 572             Sort (Refa (1 .. N));
 573
 574             Next_Line;
 575             Next_Line;
 576             Next_Line;
 577
 578             --  Checking references for one entry
 579
 580             for M in 1 .. N loop
 581                Next_Line;
 582
 583                if not Match (Line, Test_Syn)
 584                  or else Next /= Refa (M)
 585                then
 586                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 587                   raise Err;
 588                end if;
 589             end loop;
 590
 591             loop
 592                Next_Line;
 593                exit when Match (Line, Set_Fld);
 594             end loop;
 595
 596             Match (Field, Break_With);
 597
 598             if Field /= Get (Fields, Synonym) then
 599                Put_Line
 600                  ("Wrong field for procedure Set_" & Synonym &
 601                   " at line " & Lineno & " should be " &
 602                   Get (Fields, Synonym));
 603                raise Done;
 604             end if;
 605
 606             Delete (Fields1, Synonym);
 607          end;
 608       end if;
 609    end loop;
 610
 611    Put_Line ("     OK");
 612    New_Line;
 613    Put_Line ("Check for missing set procedures in body");
 614
 615    declare
 616       List : TV.Table_Array := Convert_To_Array (Fields1);
 617
 618    begin
 619       if List'Length /= 0 then
 620          Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
 621          raise Done;
 622       end if;
 623    end;
 624
 625    Put_Line ("     OK");
 626    New_Line;
 627    Put_Line ("All tests completed successfully, no errors detected");
 628
 629 exception
 630    when Done =>
 631       null;
 632
 633 end CSinfo;