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-2008, 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
  27 --  field name usage is consistent and that assertion cross-reference lists
  28 --  are correct, as well as making sure that all the comments on field name
  29 --  usage 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       end if;
 300    end loop;
 301
 302    Put_Line ("     OK");
 303    New_Line;
 304    Put_Line ("Check for function consistency");
 305
 306    --  Loop through field function definitions to make sure they are OK
 307
 308    Fields1 := Fields;
 309    loop
 310       Next_Line;
 311       exit when Match (Line, "   -- Node Update");
 312
 313       if Match (Line, Get_Funcsyn)
 314         and then not Present (Special, Synonym)
 315       then
 316          if not Present (Fields1, Synonym) then
 317             Put_Line
 318               ("function on line " &  Lineno &
 319                " is for unused synonym");
 320             raise Done;
 321          end if;
 322
 323          Next_Line;
 324
 325          if not Match (Line, Extr_Field) then
 326             raise Err;
 327          end if;
 328
 329          if Field /= Get (Fields1, Synonym) then
 330             Put_Line ("Wrong field in function " & Synonym);
 331             raise Done;
 332
 333          else
 334             Delete (Fields1, Synonym);
 335          end if;
 336       end if;
 337    end loop;
 338
 339    Put_Line ("     OK");
 340    New_Line;
 341    Put_Line ("Check for missing functions");
 342
 343    declare
 344       List : constant TV.Table_Array := Convert_To_Array (Fields1);
 345
 346    begin
 347       if List'Length > 0 then
 348          Put_Line ("No function for field synonym " & List (1).Name);
 349          raise Done;
 350       end if;
 351    end;
 352
 353    --  Check field set procedures
 354
 355    Put_Line ("     OK");
 356    New_Line;
 357    Put_Line ("Check for set procedure consistency");
 358
 359    Fields1 := Fields;
 360    loop
 361       Next_Line;
 362       exit when Match (Line, "   -- Inline Pragmas");
 363       exit when Match (Line, "   -- Iterator Procedures");
 364
 365       if Match (Line, Get_Procsyn)
 366         and then not Present (Special, Synonym)
 367       then
 368          if not Present (Fields1, Synonym) then
 369             Put_Line
 370               ("procedure on line " & Lineno & " is for unused synonym");
 371             raise Done;
 372          end if;
 373
 374          Next_Line;
 375
 376          if not Match (Line, Extr_Field) then
 377             raise Err;
 378          end if;
 379
 380          if Field /= Get (Fields1, Synonym) then
 381             Put_Line ("Wrong field in procedure Set_" & Synonym);
 382             raise Done;
 383
 384          else
 385             Delete (Fields1, Synonym);
 386          end if;
 387       end if;
 388    end loop;
 389
 390    Put_Line ("     OK");
 391    New_Line;
 392    Put_Line ("Check for missing set procedures");
 393
 394    declare
 395       List : constant TV.Table_Array := Convert_To_Array (Fields1);
 396
 397    begin
 398       if List'Length > 0 then
 399          Put_Line ("No procedure for field synonym Set_" & List (1).Name);
 400          raise Done;
 401       end if;
 402    end;
 403
 404    Put_Line ("     OK");
 405    New_Line;
 406    Put_Line ("Check pragma Inlines are all for existing subprograms");
 407
 408    Clear (Fields1);
 409    while not End_Of_File (Infil) loop
 410       Next_Line;
 411
 412       if Match (Line, Get_Inline)
 413         and then not Present (Special, Name)
 414       then
 415          exit when Match (Name, Set_Name);
 416
 417          if not Present (Fields, Name) then
 418             Put_Line
 419               ("Pragma Inline on line " & Lineno &
 420                " does not correspond to synonym");
 421             raise Done;
 422
 423          else
 424             Set (Inlines, Name, Get (Inlines, Name) & 'r');
 425          end if;
 426       end if;
 427    end loop;
 428
 429    Put_Line ("     OK");
 430    New_Line;
 431    Put_Line ("Check no pragma Inlines were omitted");
 432
 433    declare
 434       List : constant TV.Table_Array := Convert_To_Array (Fields);
 435       Nxt  : VString := Nul;
 436
 437    begin
 438       for M in List'Range loop
 439          Nxt := List (M).Name;
 440
 441          if Get (Inlines, Nxt) /= "r" then
 442             Put_Line ("Incorrect pragma Inlines for " & Nxt);
 443             raise Done;
 444          end if;
 445       end loop;
 446    end;
 447
 448    Put_Line ("     OK");
 449    New_Line;
 450    Clear (Inlines);
 451
 452    Close (Infil);
 453    Open (Infil, In_File, "sinfo.adb");
 454    Lineno := 0;
 455    Put_Line ("Check references in functions in body");
 456
 457    Refscopy := Refs;
 458    loop
 459       Next_Line;
 460       exit when Match (Line, "   -- Field Access Functions --");
 461    end loop;
 462
 463    loop
 464       Next_Line;
 465       exit when Match (Line, "   -- Field Set Procedures --");
 466
 467       if Match (Line, Func_Rest)
 468         and then not Present (Special, Synonym)
 469       then
 470          Ref := Get (Refs, Synonym);
 471          Delete (Refs, Synonym);
 472
 473          if Ref = "" then
 474             Put_Line
 475               ("Function on line " & Lineno & " is for unknown synonym");
 476             raise Err;
 477          end if;
 478
 479          --  Alpha sort of references for this entry
 480
 481          declare
 482             Refa   : VStringA (1 .. 100);
 483             N      : Natural := 0;
 484
 485          begin
 486             loop
 487                exit when not Match (Ref, Get_Nxtref, Nul);
 488                N := N + 1;
 489                Refa (N) := Nxtref;
 490             end loop;
 491
 492             Sort (Refa (1 .. N));
 493             Next_Line;
 494             Next_Line;
 495             Next_Line;
 496
 497             --  Checking references for one entry
 498
 499             for M in 1 .. N loop
 500                Next_Line;
 501
 502                if not Match (Line, Test_Syn) then
 503                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 504                   raise Done;
 505                end if;
 506
 507                Match (Next, Chop_Comma);
 508
 509                if Next /= Refa (M) then
 510                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 511                   raise Done;
 512                end if;
 513             end loop;
 514
 515             Next_Line;
 516             Match (Line, Return_Fld);
 517
 518             if Field /= Get (Fields, Synonym) then
 519                Put_Line
 520                 ("Wrong field for function " & Synonym & " at line " &
 521                  Lineno & " should be " & Get (Fields, Synonym));
 522                raise Done;
 523             end if;
 524          end;
 525       end if;
 526    end loop;
 527
 528    Put_Line ("     OK");
 529    New_Line;
 530    Put_Line ("Check for missing functions in body");
 531
 532    declare
 533       List : constant TV.Table_Array := Convert_To_Array (Refs);
 534
 535    begin
 536       if List'Length /= 0 then
 537          Put_Line ("Missing function " & List (1).Name & " in body");
 538          raise Done;
 539       end if;
 540    end;
 541
 542    Put_Line ("     OK");
 543    New_Line;
 544    Put_Line ("Check Set procedures in body");
 545    Refs := Refscopy;
 546
 547    loop
 548       Next_Line;
 549       exit when Match (Line, "end");
 550       exit when Match (Line, "   -- Iterator Procedures");
 551
 552       if Match (Line, Set_Syn)
 553         and then not Present (Special, Synonym)
 554       then
 555          Ref := Get (Refs, Synonym);
 556          Delete (Refs, Synonym);
 557
 558          if Ref = "" then
 559             Put_Line
 560               ("Function on line " & Lineno & " is for unknown synonym");
 561             raise Err;
 562          end if;
 563
 564          --  Alpha sort of references for this entry
 565
 566          declare
 567             Refa   : VStringA (1 .. 100);
 568             N      : Natural;
 569
 570          begin
 571             N := 0;
 572
 573             loop
 574                exit when not Match (Ref, Get_Nxtref, Nul);
 575                N := N + 1;
 576                Refa (N) := Nxtref;
 577             end loop;
 578
 579             Sort (Refa (1 .. N));
 580
 581             Next_Line;
 582             Next_Line;
 583             Next_Line;
 584
 585             --  Checking references for one entry
 586
 587             for M in 1 .. N loop
 588                Next_Line;
 589
 590                if not Match (Line, Test_Syn)
 591                  or else Next /= Refa (M)
 592                then
 593                   Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
 594                   raise Err;
 595                end if;
 596             end loop;
 597
 598             loop
 599                Next_Line;
 600                exit when Match (Line, Set_Fld);
 601             end loop;
 602
 603             Match (Field, Break_With);
 604
 605             if Field /= Get (Fields, Synonym) then
 606                Put_Line
 607                  ("Wrong field for procedure Set_" & Synonym &
 608                   " at line " & Lineno & " should be " &
 609                   Get (Fields, Synonym));
 610                raise Done;
 611             end if;
 612
 613             Delete (Fields1, Synonym);
 614          end;
 615       end if;
 616    end loop;
 617
 618    Put_Line ("     OK");
 619    New_Line;
 620    Put_Line ("Check for missing set procedures in body");
 621
 622    declare
 623       List : constant TV.Table_Array := Convert_To_Array (Fields1);
 624
 625    begin
 626       if List'Length /= 0 then
 627          Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
 628          raise Done;
 629       end if;
 630    end;
 631
 632    Put_Line ("     OK");
 633    New_Line;
 634    Put_Line ("All tests completed successfully, no errors detected");
 635
 636 exception
 637    when Done =>
 638       null;
 639
 640 end CSinfo;