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