blob: e13676c3b6cecf74687fd6e92dc62a5c77c33642 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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
<<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 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;