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