------------------------------------------------------------------------------ -- -- -- GNAT SYSTEM UTILITIES -- -- -- -- C S I N F O -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- Program to 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. 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 : 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 : Pattern := BreakX ("JL"); E_Fields : Pattern := BreakX ("5EFGHIJLOP"); U_Fields : Pattern := BreakX ("1345EFGHIJKLOPQ"); B_Fields : Pattern := BreakX ("12345EFGHIJKLOPQ"); Line : VString; Bad : Boolean; Field : VString := Nul; Fields_Used : VString := Nul; Name : VString := Nul; Next : VString := Nul; Node : VString := Nul; Ref : VString := Nul; Synonym : VString := Nul; Nxtref : VString := Nul; Which_Field : aliased VString := Nul; Node_Search : Pattern := WSP & "-- N_" & Rest * Node; Break_Punc : Pattern := Break (" .,"); Plus_Binary : Pattern := WSP & "-- plus fields for binary operator"; Plus_Unary : Pattern := WSP & "-- plus fields for unary operator"; Plus_Expr : Pattern := WSP & "-- plus fields for expression"; Break_Syn : Pattern := WSP & "-- " & Break (' ') * Synonym & " (" & Break (')') * Field; Break_Field : Pattern := BreakX ('-') * Field; Get_Field : Pattern := BreakX (Decimal_Digit_Set) & Span (Decimal_Digit_Set) * Which_Field; Break_WFld : Pattern := Break (Which_Field'Access); Get_Funcsyn : Pattern := WSP & "function " & Rest * Synonym; Extr_Field : Pattern := BreakX ('-') & "-- " & Rest * Field; Get_Procsyn : Pattern := WSP & "procedure Set_" & Rest * Synonym; Get_Inline : Pattern := WSP & "pragma Inline (" & Break (')') * Name; Set_Name : Pattern := "Set_" & Rest * Name; Func_Rest : Pattern := " function " & Rest * Synonym; Get_Nxtref : Pattern := Break (',') * Nxtref & ','; Test_Syn : Pattern := Break ('=') & "= N_" & (Break (" ,)") or Rest) * Next; Chop_Comma : Pattern := BreakX (',') * Next; Return_Fld : Pattern := WSP & "return " & Break (' ') * Field; Set_Syn : Pattern := " procedure Set_" & Rest * Synonym; Set_Fld : Pattern := WSP & "Set_" & Break (' ') * Field & " (N, Val)"; Break_With : 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 <> 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 fields are not recorded or checked -- by Csinfo, since they are specially handled. This means that he both -- the field definitions, and the corresponding subprograms are 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, "Error_Posted", True); Set (Special, "Etype", True); Set (Special, "Evaluate_Once", True); Set (Special, "First_Itype", 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, "Parens", 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); 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 : 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 : 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 : 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 : 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 : 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"); exception when Done => null; end CSinfo;