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-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
  34 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  35 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  36 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  37 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  38 with Ada.Text_IO;                   use Ada.Text_IO;
  39
  40 with GNAT.Spitbol;                  use GNAT.Spitbol;
  41 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  42 with GNAT.Spitbol.Table_Boolean;
  43 with GNAT.Spitbol.Table_VString;
  44
  45 procedure 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
 174 begin
 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
 641 end CSinfo;