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