X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fcsinfo.adb;fp=gcc%2Fada%2Fcsinfo.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=72084f4ff3bf2afc2139444f49f1142a604873a9;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb deleted file mode 100644 index 72084f4f..00000000 --- a/gcc/ada/csinfo.adb +++ /dev/null @@ -1,636 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT SYSTEM UTILITIES -- --- -- --- C S I N F O -- --- -- --- B o d y -- --- -- --- $Revision: 1.1.12.1 $ --- -- --- 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;