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