[thirdparty/gcc.git] / gcc / ada / csinfo.adb

------------------------------------------------------------------------------
--                                                                          --
--                          GNAT SYSTEM UTILITIES                           --
--                                                                          --
--                               C S I N F O                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2020, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  Check consistency of sinfo.ads and sinfo.adb. Checks that field name usage
--  is consistent and that assertion cross-reference lists are correct, as well
--  as making sure that all the comments on field name usage are consistent.

--  Note that this is used both as a standalone program, and as a procedure
--  called by XSinfo. This raises an unhandled exception if it finds any
--  errors; we don't attempt any sophisticated error recovery.

with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
with Ada.Strings.Maps;              use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
with Ada.Text_IO;                   use Ada.Text_IO;

with GNAT.Spitbol;                  use GNAT.Spitbol;
with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
with GNAT.Spitbol.Table_Boolean;
with GNAT.Spitbol.Table_VString;

procedure CSinfo is

   package TB renames GNAT.Spitbol.Table_Boolean;
   package TV renames GNAT.Spitbol.Table_VString;
   use TB, TV;

   Infil  : File_Type;
   Lineno : Natural := 0;

   Err : exception;
   --  Raised on fatal error

   Done : exception;
   --  Raised after error is found to terminate run

   WSP : constant Pattern := Span (' ' & ASCII.HT);

   Fields   : TV.Table (300);
   Fields1  : TV.Table (300);
   Refs     : TV.Table (300);
   Refscopy : TV.Table (300);
   Special  : TB.Table (50);
   Inlines  : TV.Table (100);

   --  The following define the standard fields used for binary operator,
   --  unary operator, and other expression nodes. Numbers in the range 1-5
   --  refer to the Fieldn fields. Letters D-R refer to flags:

   --      D = Flag4
   --      E = Flag5
   --      F = Flag6
   --      G = Flag7
   --      H = Flag8
   --      I = Flag9
   --      J = Flag10
   --      K = Flag11
   --      L = Flag12
   --      M = Flag13
   --      N = Flag14
   --      O = Flag15
   --      P = Flag16
   --      Q = Flag17
   --      R = Flag18

   Flags : TV.Table (20);
   --  Maps flag numbers to letters

   N_Fields : constant Pattern := BreakX ("JL");
   E_Fields : constant Pattern := BreakX ("5EFGHIJLOP");
   U_Fields : constant Pattern := BreakX ("1345EFGHIJKLOPQ");
   B_Fields : constant Pattern := BreakX ("12345EFGHIJKLOPQ");

   Line : VString;
   Bad  : Boolean;

   Field       : constant VString := Nul;
   Fields_Used : VString := Nul;
   Name        : constant VString := Nul;
   Next        : constant VString := Nul;
   Node        : VString := Nul;
   Ref         : VString := Nul;
   Synonym     : constant VString := Nul;
   Nxtref      : constant VString := Nul;

   Which_Field : aliased VString := Nul;

   Node_Search : constant Pattern := WSP & "--  N_" & Rest * Node;
   Break_Punc  : constant Pattern := Break (" .,");
   Plus_Binary : constant Pattern := WSP
                                     & "--  plus fields for binary operator";
   Plus_Unary  : constant Pattern := WSP
                                     & "--  plus fields for unary operator";
   Plus_Expr   : constant Pattern := WSP
                                     & "--  plus fields for expression";
   Break_Syn   : constant Pattern := WSP &  "--  "
                                     & Break (' ') * Synonym
                                     & " (" & Break (')') * Field;
   Break_Field : constant Pattern := BreakX ('-') * Field;
   Get_Field   : constant Pattern := BreakX (Decimal_Digit_Set)
                                     & Span (Decimal_Digit_Set) * Which_Field;
   Break_WFld  : constant Pattern := Break (Which_Field'Access);
   Get_Funcsyn : constant Pattern := WSP & "function " & Rest * Synonym;
   Extr_Field  : constant Pattern := BreakX ('-') & "-- " & Rest * Field;
   Get_Procsyn : constant Pattern := WSP & "procedure Set_" & Rest * Synonym;
   Get_Inline  : constant Pattern := WSP & "pragma Inline ("
                                     & Break (')') * Name;
   Set_Name    : constant Pattern := "Set_" & Rest * Name;
   Func_Rest   : constant Pattern := "   function " & Rest * Synonym;
   Get_Nxtref  : constant Pattern := Break (',') * Nxtref & ',';
   Test_Syn    : constant Pattern := Break ('=') & "= N_"
                                     & (Break (" ,)") or Rest) * Next;
   Chop_Comma  : constant Pattern := BreakX (',') * Next;
   Return_Fld  : constant Pattern := WSP & "return " & Break (' ') * Field;
   Set_Syn     : constant Pattern := "   procedure Set_" & Rest * Synonym;
   Set_Fld     : constant Pattern := WSP & "Set_" & Break (' ') * Field
                                     & " (N, Val)";
   Break_With  : constant Pattern := Break ('_') ** Field & "_With_Parent";

   type VStringA is array (Natural range <>) of VString;

   procedure Next_Line;
   --  Read next line trimmed from Infil into Line and bump Lineno

   procedure Sort (A : in out VStringA);
   --  Sort a (small) array of VString's

   procedure Next_Line is
   begin
      Line := Get_Line (Infil);
      Trim (Line);
      Lineno := Lineno + 1;
   end Next_Line;

   procedure Sort (A : in out VStringA) is
      Temp : VString;
   begin
      <<Sort>>
         for J in 1 .. A'Length - 1 loop
            if A (J) > A (J + 1) then
               Temp := A (J);
               A (J) := A (J + 1);
               A (J + 1) := Temp;
               goto Sort;
            end if;
         end loop;
   end Sort;

--  Start of processing for CSinfo

begin
   Anchored_Mode := True;
   New_Line;
   Open (Infil, In_File, "sinfo.ads");
   Put_Line ("Check for field name consistency");

   --  Setup table for mapping flag numbers to letters

   Set (Flags, "4",  V ("D"));
   Set (Flags, "5",  V ("E"));
   Set (Flags, "6",  V ("F"));
   Set (Flags, "7",  V ("G"));
   Set (Flags, "8",  V ("H"));
   Set (Flags, "9",  V ("I"));
   Set (Flags, "10", V ("J"));
   Set (Flags, "11", V ("K"));
   Set (Flags, "12", V ("L"));
   Set (Flags, "13", V ("M"));
   Set (Flags, "14", V ("N"));
   Set (Flags, "15", V ("O"));
   Set (Flags, "16", V ("P"));
   Set (Flags, "17", V ("Q"));
   Set (Flags, "18", V ("R"));

   --  Special fields table. The following names are not recorded or checked
   --  by Csinfo, since they are specially handled. This means that any field
   --  definition or subprogram with a matching name is ignored.

   Set (Special, "Analyzed",                         True);
   Set (Special, "Assignment_OK",                    True);
   Set (Special, "Associated_Node",                  True);
   Set (Special, "Cannot_Be_Constant",               True);
   Set (Special, "Chars",                            True);
   Set (Special, "Comes_From_Source",                True);
   Set (Special, "Do_Overflow_Check",                True);
   Set (Special, "Do_Range_Check",                   True);
   Set (Special, "Entity",                           True);
   Set (Special, "Entity_Or_Associated_Node",        True);
   Set (Special, "Error_Posted",                     True);
   Set (Special, "Etype",                            True);
   Set (Special, "Evaluate_Once",                    True);
   Set (Special, "First_Itype",                      True);
   Set (Special, "Has_Aspect_Specifications",        True);
   Set (Special, "Has_Dynamic_Itype",                True);
   Set (Special, "Has_Dynamic_Range_Check",          True);
   Set (Special, "Has_Dynamic_Length_Check",         True);
   Set (Special, "Has_Private_View",                 True);
   Set (Special, "Is_Controlling_Actual",            True);
   Set (Special, "Is_Overloaded",                    True);
   Set (Special, "Is_Static_Expression",             True);
   Set (Special, "Left_Opnd",                        True);
   Set (Special, "Must_Not_Freeze",                  True);
   Set (Special, "Nkind_In",                         True);
   Set (Special, "Parens",                           True);
   Set (Special, "Pragma_Name",                      True);
   Set (Special, "Raises_Constraint_Error",          True);
   Set (Special, "Right_Opnd",                       True);

   --  Loop to acquire information from node definitions in sinfo.ads,
   --  checking for consistency in Op/Flag assignments to each synonym

   loop
      Bad := False;
      Next_Line;
      exit when Match (Line, "   -- Node Access Functions");

      if Match (Line, Node_Search)
        and then not Match (Node, Break_Punc)
      then
         Fields_Used := Nul;

      elsif Node = "" then
         null;

      elsif Line = "" then
         Node := Nul;

      elsif Match (Line, Plus_Binary) then
         Bad := Match (Fields_Used, B_Fields);

      elsif Match (Line, Plus_Unary) then
         Bad := Match (Fields_Used, U_Fields);

      elsif Match (Line, Plus_Expr) then
         Bad := Match (Fields_Used, E_Fields);

      elsif not Match (Line, Break_Syn) then
         null;

      elsif Match (Synonym, "plus") then
         null;

      else
         Match (Field, Break_Field);

         if not Present (Special, Synonym) then
            if Present (Fields, Synonym) then
               if Field /= Get (Fields, Synonym) then
                  Put_Line
                    ("Inconsistent field reference at line" &
                     Lineno'Img & " for " & Synonym);
                  raise Done;
               end if;

            else
               Set (Fields, Synonym, Field);
            end if;

            Set (Refs, Synonym, Node & ',' & Get (Refs, Synonym));
            Match (Field, Get_Field);

            if Match (Field, "Flag") then
               Which_Field := Get (Flags, Which_Field);
            end if;

            if Match (Fields_Used, Break_WFld) then
               Put_Line
                 ("Overlapping field at line " & Lineno'Img &
                  " for " & Synonym);
               raise Done;
            end if;

            Append (Fields_Used, Which_Field);
            Bad := Bad or Match (Fields_Used, N_Fields);
         end if;
      end if;

      if Bad then
         Put_Line ("fields conflict with standard fields for node " & Node);
         raise Done;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for function consistency");

   --  Loop through field function definitions to make sure they are OK

   Fields1 := Fields;
   loop
      Next_Line;
      exit when Match (Line, "   -- Node Update");

      if Match (Line, Get_Funcsyn)
        and then not Present (Special, Synonym)
      then
         if not Present (Fields1, Synonym) then
            Put_Line
              ("function on line " &  Lineno &
               " is for unused synonym");
            raise Done;
         end if;

         Next_Line;

         if not Match (Line, Extr_Field) then
            raise Err;
         end if;

         if Field /= Get (Fields1, Synonym) then
            Put_Line ("Wrong field in function " & Synonym);
            raise Done;

         else
            Delete (Fields1, Synonym);
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing functions");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);

   begin
      if List'Length > 0 then
         Put_Line ("No function for field synonym " & List (1).Name);
         raise Done;
      end if;
   end;

   --  Check field set procedures

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for set procedure consistency");

   Fields1 := Fields;
   loop
      Next_Line;
      exit when Match (Line, "   -- Inline Pragmas");
      exit when Match (Line, "   -- Iterator Procedures");

      if Match (Line, Get_Procsyn)
        and then not Present (Special, Synonym)
      then
         if not Present (Fields1, Synonym) then
            Put_Line
              ("procedure on line " & Lineno & " is for unused synonym");
            raise Done;
         end if;

         Next_Line;

         if not Match (Line, Extr_Field) then
            raise Err;
         end if;

         if Field /= Get (Fields1, Synonym) then
            Put_Line ("Wrong field in procedure Set_" & Synonym);
            raise Done;

         else
            Delete (Fields1, Synonym);
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing set procedures");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);

   begin
      if List'Length > 0 then
         Put_Line ("No procedure for field synonym Set_" & List (1).Name);
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check pragma Inlines are all for existing subprograms");

   Clear (Fields1);
   while not End_Of_File (Infil) loop
      Next_Line;

      if Match (Line, Get_Inline)
        and then not Present (Special, Name)
      then
         exit when Match (Name, Set_Name);

         if not Present (Fields, Name) then
            Put_Line
              ("Pragma Inline on line " & Lineno &
               " does not correspond to synonym");
            raise Done;

         else
            Set (Inlines, Name, Get (Inlines, Name) & 'r');
         end if;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check no pragma Inlines were omitted");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields);
      Nxt  : VString := Nul;

   begin
      for M in List'Range loop
         Nxt := List (M).Name;

         if Get (Inlines, Nxt) /= "r" then
            Put_Line ("Incorrect pragma Inlines for " & Nxt);
            raise Done;
         end if;
      end loop;
   end;

   Put_Line ("     OK");
   New_Line;
   Clear (Inlines);

   Close (Infil);
   Open (Infil, In_File, "sinfo.adb");
   Lineno := 0;
   Put_Line ("Check references in functions in body");

   Refscopy := Refs;
   loop
      Next_Line;
      exit when Match (Line, "   -- Field Access Functions --");
   end loop;

   loop
      Next_Line;
      exit when Match (Line, "   -- Field Set Procedures --");

      if Match (Line, Func_Rest)
        and then not Present (Special, Synonym)
      then
         Ref := Get (Refs, Synonym);
         Delete (Refs, Synonym);

         if Ref = "" then
            Put_Line
              ("Function on line " & Lineno & " is for unknown synonym");
            raise Err;
         end if;

         --  Alpha sort of references for this entry

         declare
            Refa   : VStringA (1 .. 100);
            N      : Natural := 0;

         begin
            loop
               exit when not Match (Ref, Get_Nxtref, Nul);
               N := N + 1;
               Refa (N) := Nxtref;
            end loop;

            Sort (Refa (1 .. N));
            Next_Line;
            Next_Line;
            Next_Line;

            --  Checking references for one entry

            for M in 1 .. N loop
               Next_Line;

               if not Match (Line, Test_Syn) then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Done;
               end if;

               Match (Next, Chop_Comma);

               if Next /= Refa (M) then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Done;
               end if;
            end loop;

            Next_Line;
            Match (Line, Return_Fld);

            if Field /= Get (Fields, Synonym) then
               Put_Line
                ("Wrong field for function " & Synonym & " at line " &
                 Lineno & " should be " & Get (Fields, Synonym));
               raise Done;
            end if;
         end;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing functions in body");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Refs);

   begin
      if List'Length /= 0 then
         Put_Line ("Missing function " & List (1).Name & " in body");
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check Set procedures in body");
   Refs := Refscopy;

   loop
      Next_Line;
      exit when Match (Line, "end");
      exit when Match (Line, "   -- Iterator Procedures");

      if Match (Line, Set_Syn)
        and then not Present (Special, Synonym)
      then
         Ref := Get (Refs, Synonym);
         Delete (Refs, Synonym);

         if Ref = "" then
            Put_Line
              ("Function on line " & Lineno & " is for unknown synonym");
            raise Err;
         end if;

         --  Alpha sort of references for this entry

         declare
            Refa   : VStringA (1 .. 100);
            N      : Natural;

         begin
            N := 0;

            loop
               exit when not Match (Ref, Get_Nxtref, Nul);
               N := N + 1;
               Refa (N) := Nxtref;
            end loop;

            Sort (Refa (1 .. N));

            Next_Line;
            Next_Line;
            Next_Line;

            --  Checking references for one entry

            for M in 1 .. N loop
               Next_Line;

               if not Match (Line, Test_Syn)
                 or else Next /= Refa (M)
               then
                  Put_Line ("Expecting N_" & Refa (M) & " at line " & Lineno);
                  raise Err;
               end if;
            end loop;

            loop
               Next_Line;
               exit when Match (Line, Set_Fld);
            end loop;

            Match (Field, Break_With);

            if Field /= Get (Fields, Synonym) then
               Put_Line
                 ("Wrong field for procedure Set_" & Synonym &
                  " at line " & Lineno & " should be " &
                  Get (Fields, Synonym));
               raise Done;
            end if;

            Delete (Fields1, Synonym);
         end;
      end if;
   end loop;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("Check for missing set procedures in body");

   declare
      List : constant TV.Table_Array := Convert_To_Array (Fields1);
   begin
      if List'Length /= 0 then
         Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
         raise Done;
      end if;
   end;

   Put_Line ("     OK");
   New_Line;
   Put_Line ("All tests completed successfully, no errors detected");

end CSinfo;
Commit	Line	Data
210c4ef4 GB	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT SYSTEM UTILITIES --
	4	-- --
	5	-- C S I N F O --
	6	-- --
	7	-- B o d y --
	8	-- --
4b490c1e	9	-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
210c4ef4 GB	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- --
d6ca724c	13	-- ware Foundation; either version 3, or (at your option) any later ver- --
210c4ef4 GB	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 --
d6ca724c AC	18	-- Public License distributed with GNAT; see file COPYING3. If not, go to --
d6ca724c AC	19	-- http://www.gnu.org/licenses for a complete copy of the license. --
210c4ef4 GB	20	-- --
210c4ef4 GB	21	-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc	22	-- Extensive contributions were provided by Ada Core Technologies Inc. --
210c4ef4 GB	23	-- --
	24	------------------------------------------------------------------------------
	25
d347f572 AC	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.
210c4ef4 GB	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
d6ca724c	60	WSP : constant Pattern := Span (' ' & ASCII.HT);
210c4ef4 GB	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
d6ca724c AC	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");
210c4ef4 GB	96
	97	Line : VString;
	98	Bad : Boolean;
	99
d6ca724c	100	Field : constant VString := Nul;
210c4ef4	101	Fields_Used : VString := Nul;
d6ca724c AC	102	Name : constant VString := Nul;
d6ca724c AC	103	Next : constant VString := Nul;
210c4ef4 GB	104	Node : VString := Nul;
210c4ef4 GB	105	Ref : VString := Nul;
d6ca724c AC	106	Synonym : constant VString := Nul;
d6ca724c AC	107	Nxtref : constant VString := Nul;
210c4ef4 GB	108
	109	Which_Field : aliased VString := Nul;
	110
d6ca724c AC	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";
210c4ef4 GB	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;
210c4ef4 GB	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
d6ca724c AC	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.
2400f4e5	201
39ad1665 AC	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);
39ad1665 AC	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);
210c4ef4 GB	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
210c4ef4 GB	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);
d0995fa2	303	raise Done;
210c4ef4 GB	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
d6ca724c	349	List : constant TV.Table_Array := Convert_To_Array (Fields1);
210c4ef4 GB	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
d6ca724c	400	List : constant TV.Table_Array := Convert_To_Array (Fields1);
210c4ef4 GB	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
d6ca724c	439	List : constant TV.Table_Array := Convert_To_Array (Fields);
210c4ef4 GB	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
d6ca724c	538	List : constant TV.Table_Array := Convert_To_Array (Refs);
210c4ef4 GB	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
d6ca724c	628	List : constant TV.Table_Array := Convert_To_Array (Fields1);
210c4ef4 GB	629	begin
	630	if List'Length /= 0 then
	631	Put_Line ("Missing procedure Set_" & List (1).Name & " in body");
	632	raise Done;
	633	end if;
	634	end;
	635
	636	Put_Line (" OK");
	637	New_Line;
	638	Put_Line ("All tests completed successfully, no errors detected");
	639
210c4ef4	640	end CSinfo;