Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                          GNAT SYSTEM UTILITIES                           --

--                                                                          --

--                               C S I N F O                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2010, 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;