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