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