--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT SYSTEM UTILITIES --
+-- --
+-- C E I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision$ --
+-- --
+-- Copyright (C) 1998 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Program to check consistency of einfo.ads and einfo.adb. Checks that
+-- field name usage is consistent, including comments mentioning fields.
+
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+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_VString;
+
+procedure CEinfo is
+
+ package TV renames GNAT.Spitbol.Table_VString;
+ use TV;
+
+ Infil : File_Type;
+ Lineno : Natural := 0;
+
+ Err : exception;
+ -- Raised on fatal error
+
+ Fieldnm : VString;
+ Accessfunc : VString;
+ Line : VString;
+
+ Fields : GNAT.Spitbol.Table_VString.Table (500);
+ -- Maps field names to underlying field access name
+
+ UC : Pattern := Any ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
+
+ Fnam : Pattern := (UC & Break (' ')) * Fieldnm;
+
+ Field_Def : Pattern := "-- " & Fnam & " (" & Break (')') * Accessfunc;
+
+ Field_Ref : Pattern := " -- " & Fnam & Break ('(') & Len (1) &
+ Break (')') * Accessfunc;
+
+ Field_Com : Pattern := " -- " & Fnam & Span (' ') &
+ (Break (' ') or Rest) * Accessfunc;
+
+ Func_Hedr : Pattern := " function " & Fnam;
+
+ Func_Retn : Pattern := " return " & Break (' ') * Accessfunc;
+
+ Proc_Hedr : Pattern := " procedure " & Fnam;
+
+ Proc_Setf : Pattern := " Set_" & Break (' ') * Accessfunc;
+
+ procedure Next_Line;
+ -- Read next line trimmed from Infil into Line and bump Lineno
+
+ procedure Next_Line is
+ begin
+ Line := Get_Line (Infil);
+ Trim (Line);
+ Lineno := Lineno + 1;
+ end Next_Line;
+
+-- Start of processing for CEinfo
+
+begin
+ Anchored_Mode := True;
+ New_Line;
+ Open (Infil, In_File, "einfo.ads");
+
+ Put_Line ("Acquiring field names from spec");
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Access Kinds --");
+
+ if Match (Line, Field_Def) then
+ Set (Fields, Fieldnm, Accessfunc);
+ end if;
+ end loop;
+
+ Put_Line ("Checking consistent references in spec");
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Description of Defined");
+ end loop;
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Component_Alignment Control");
+
+ if Match (Line, Field_Ref) then
+ if Accessfunc /= "synth"
+ and then
+ Accessfunc /= "special"
+ and then
+ Accessfunc /= Get (Fields, Fieldnm)
+ then
+ if Present (Fields, Fieldnm) then
+ Put_Line ("*** field name incorrect at line " & Lineno);
+ Put_Line (" found field " & Accessfunc);
+ Put_Line (" expecting field " & Get (Fields, Fieldnm));
+
+ else
+ Put_Line
+ ("*** unknown field name " & Fieldnm & " at line " & Lineno);
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ Close (Infil);
+ Open (Infil, In_File, "einfo.adb");
+ Lineno := 0;
+
+ Put_Line ("Check listing of fields in body");
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Attribute Access Functions --");
+
+ if Match (Line, Field_Com)
+ and then Fieldnm /= "(unused)"
+ and then Accessfunc /= Get (Fields, Fieldnm)
+ then
+ if Present (Fields, Fieldnm) then
+ Put_Line ("*** field name incorrect at line " & Lineno);
+ Put_Line (" found field " & Accessfunc);
+ Put_Line (" expecting field " & Get (Fields, Fieldnm));
+
+ else
+ Put_Line
+ ("*** unknown field name " & Fieldnm & " at line " & Lineno);
+ end if;
+ end if;
+ end loop;
+
+ Put_Line ("Check references in access routines in body");
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Classification Functions --");
+
+ if Match (Line, Func_Hedr) then
+ null;
+
+ elsif Match (Line, Func_Retn)
+ and then Accessfunc /= Get (Fields, Fieldnm)
+ and then Fieldnm /= "Mechanism"
+ then
+ Put_Line ("*** incorrect field at line " & Lineno);
+ Put_Line (" found field " & Accessfunc);
+ Put_Line (" expecting field " & Get (Fields, Fieldnm));
+ end if;
+ end loop;
+
+ Put_Line ("Check references in set routines in body");
+
+ loop
+ Next_Line;
+ exit when Match (Line, " -- Attribute Set Procedures");
+ end loop;
+
+ loop
+ Next_Line;
+ exit when Match (Line, " ------------");
+
+ if Match (Line, Proc_Hedr) then
+ null;
+
+ elsif Match (Line, Proc_Setf)
+ and then Accessfunc /= Get (Fields, Fieldnm)
+ and then Fieldnm /= "Mechanism"
+ then
+ Put_Line ("*** incorrect field at line " & Lineno);
+ Put_Line (" found field " & Accessfunc);
+ Put_Line (" expecting field " & Get (Fields, Fieldnm));
+ end if;
+ end loop;
+
+ Put_Line ("All tests completed successfully, no errors detected");
+
+end CEinfo;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT SYSTEM UTILITIES --
+-- --
+-- C S I N F O --
+-- --
+-- B o d y --
+-- --
+-- $Revision$
+-- --
+-- 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. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- 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;
OSDN Git Service
