640 lines
20 KiB
Ada
640 lines
20 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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 ("J");
|
|
E_Fields : constant Pattern := BreakX ("5EFGHIJOP");
|
|
U_Fields : constant Pattern := BreakX ("1345EFGHIJKOPQ");
|
|
B_Fields : constant Pattern := BreakX ("12345EFGHIJKOPQ");
|
|
|
|
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_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;
|