diff options
Diffstat (limited to 'gcc/ada/xtreeprs.adb')
| -rw-r--r-- | gcc/ada/xtreeprs.adb | 383 |
1 files changed, 383 insertions, 0 deletions
diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb new file mode 100644 index 00000000000..995401e4984 --- /dev/null +++ b/gcc/ada/xtreeprs.adb @@ -0,0 +1,383 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT SYSTEM UTILITIES -- +-- -- +-- X T R E E P R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- 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 construct the spec of the Treeprs package + +-- Input files: + +-- sinfo.ads Spec of Sinfo package +-- treeprs.adt Template for Treeprs package + +-- Output files: + +-- treeprs.ads Spec of Treeprs package + +-- Note: this program assumes that sinfo.ads has passed the error checks which +-- are carried out by the CSinfo utility so it does not duplicate these checks + +-- An optional argument allows the specification of an output file name to +-- override the default treeprs.ads file name for the generated output file. + +with Ada.Command_Line; use Ada.Command_Line; +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_Boolean; use GNAT.Spitbol.Table_Boolean; +with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; + +procedure XTreeprs is + + package TB renames GNAT.Spitbol.Table_Boolean; + package TV renames GNAT.Spitbol.Table_VString; + + Err : exception; + -- Raised on fatal error + + A : VString := Nul; + Ffield : VString := Nul; + Field : VString := Nul; + Fieldno : VString := Nul; + Flagno : VString := Nul; + Line : VString := Nul; + Name : VString := Nul; + Node : VString := Nul; + Outstring : VString := Nul; + Prefix : VString := Nul; + S : VString := Nul; + S1 : VString := Nul; + Sinforev : VString := Nul; + Syn : VString := Nul; + Synonym : VString := Nul; + Temprev : VString := Nul; + Term : VString := Nul; + Treeprsrev : VString := Nul; + + OutS : File_Type; + -- Output file + + InS : File_Type; + -- Read sinfo.ads + + InT : File_Type; + -- Read treeprs.adt + + Special : TB.Table (20); + -- Table of special fields. These fields are not included in the table + -- constructed by Xtreeprs, since they are specially handled in treeprs. + -- This means these field definitions are completely ignored. + + Names : array (1 .. 500) of VString; + -- Table of names of synonyms + + Positions : array (1 .. 500) of Natural; + -- Table of starting positions in Pchars string for synonyms + + Strings : TV.Table (300); + -- Contribution of each synonym to Pchars string, indexed by name + + Count : Natural := 0; + -- Number of synonyms processed so far + + Curpos : Natural := 1; + -- Number of characters generated in Pchars string so far + + Lineno : Natural := 0; + -- Line number in sinfo.ads + + Field_Base : constant := Character'Pos ('#'); + -- Fields 1-5 are represented by the characters #$%&' (i.e. by five + -- contiguous characters starting at # (16#23#)). + + Flag_Base : constant := Character'Pos ('('); + -- Flags 1-18 are represented by the characters ()*+,-./0123456789 + -- (i.e. by 18 contiguous characters starting at (16#28#)). + + Fieldch : Character; + -- Field character, as per above tables + + Sp : aliased Natural; + -- Space left on line for Pchars output + + wsp : Pattern := Span (' ' & ASCII.HT); + + Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Sinforev; + Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: " + & Break (' ') * Temprev; + Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e"; + Get_Node : Pattern := wsp & "-- N_" & Rest * Node; + Tst_Punc : Pattern := Break (" ,."); + Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym + & " (" & Break (')') * Field; + Brk_Min : Pattern := Break ('-') * Ffield; + Is_Flag : Pattern := "Flag" & Rest * Flagno; + Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno; + Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term; + Brk_Node : Pattern := Break (' ') * Node & ' '; + Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1; + + M : Match_Result; + +begin + Anchored_Mode := True; + + Match ("$Revision: 1.33 $", "$Rev" & "ision: " & Break (' ') * Treeprsrev); + + if Argument_Count > 0 then + Create (OutS, Out_File, Argument (1)); + else + Create (OutS, Out_File, "treeprs.ads"); + end if; + + Open (InS, In_File, "sinfo.ads"); + Open (InT, In_File, "treeprs.adt"); + + -- Initialize special fields table + + Set (Special, "Analyzed", True); + Set (Special, "Cannot_Be_Constant", True); + Set (Special, "Chars", True); + Set (Special, "Comes_From_Source", True); + Set (Special, "Error_Posted", True); + Set (Special, "Etype", True); + Set (Special, "Has_No_Side_Effects", 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_Check_Expr", True); + Set (Special, "No_Overflow_Expr", True); + Set (Special, "Paren_Count", True); + Set (Special, "Raises_Constraint_Error", True); + Set (Special, "Right_Opnd", True); + + -- Get sinfo revs and write header to output file + + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + + if Line = "" then + raise Err; + end if; + + exit when Match (Line, Get_SRev); + end loop; + + -- Read template header and generate new header + + loop + Line := Get_Line (InT); + + if Match (Line, Get_TRev) then + Put_Line + (OutS, + "-- Generated by xtreeprs revision " & + Treeprsrev & " using --"); + + Put_Line + (OutS, + "-- sinfo.ads revision " & + Sinforev & " --"); + + Put_Line + (OutS, + "-- treeprs.adt revision " + & Temprev & " --"); + + else + -- Skip lines describing the template + + if Match (Line, "-- This file is a template") then + loop + Line := Get_Line (InT); + exit when Line = ""; + end loop; + end if; + + exit when Match (Line, "package"); + + if Match (Line, Is_Temp, M) then + Replace (M, A & " S p e c "); + end if; + + Put_Line (OutS, Line); + end if; + end loop; + + Put_Line (OutS, Line); + + -- Copy rest of comments up to template insert point to spec + + loop + Line := Get_Line (InT); + exit when Match (Line, "!!TEMPLATE INSERTION POINT"); + Put_Line (OutS, Line); + end loop; + + -- Here we are doing the actual insertions + + Put_Line (OutS, " Pchars : constant String :="); + + -- Loop through comments describing nodes, picking up fields + + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, " type Node_Kind"); + + if Match (Line, Get_Node) + and then not Match (Node, Tst_Punc) + then + Outstring := Node & ' '; + + loop + Line := Get_Line (InS); + exit when Line = ""; + + if Match (Line, Get_Syn) + and then not Match (Synonym, "plus") + and then not Present (Special, Synonym) + then + -- Convert this field into the character used to + -- represent the field according to the table: + + -- Field1 '#' + -- Field2 '$' + -- Field3 '%' + -- Field4 '&' + -- Field5 "'" + -- Flag1 "(" + -- Flag2 ")" + -- Flag3 '*' + -- Flag4 '+' + -- Flag5 ',' + -- Flag6 '-' + -- Flag7 '.' + -- Flag8 '/' + -- Flag9 '0' + -- Flag10 '1' + -- Flag11 '2' + -- Flag12 '3' + -- Flag13 '4' + -- Flag14 '5' + -- Flag15 '6' + -- Flag16 '7' + -- Flag17 '8' + -- Flag18 '9' + + if Match (Field, Brk_Min) then + Field := Ffield; + end if; + + if Match (Field, Is_Flag) then + Fieldch := Char (Flag_Base - 1 + N (Flagno)); + + elsif Match (Field, Is_Field) then + Fieldch := Char (Field_Base - 1 + N (Fieldno)); + + else + Put_Line + (Standard_Error, + "*** Line " & + Lineno & + " has unrecognized field name " & + Field); + raise Err; + end if; + + Append (Outstring, Fieldch & Synonym); + end if; + end loop; + + Set (Strings, Node, Outstring); + end if; + end loop; + + -- Loop through actual definitions of node kind enumeration literals + + loop + loop + Line := Get_Line (InS); + Lineno := Lineno + 1; + exit when Match (Line, Is_Syn); + end loop; + + S := Get (Strings, Syn); + Match (S, Brk_Node, ""); + Count := Count + 1; + Names (Count) := Syn; + Positions (Count) := Curpos; + Curpos := Curpos + Length (S); + Put_Line (OutS, " -- " & Node); + Prefix := V (" "); + exit when Term = ")"; + + -- Loop to output the string literal for Pchars + + loop + Sp := 79 - 4 - Length (Prefix); + exit when (Size (S) <= Sp); + Match (S, Chop_SP, ""); + Put_Line (OutS, Prefix & '"' & S1 & """ &"); + Prefix := V (" "); + end loop; + + Put_Line (OutS, Prefix & '"' & S & """ &"); + end loop; + + Put_Line (OutS, " """";"); + Put_Line (OutS, ""); + Put_Line + (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;"); + Put_Line + (OutS, + " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'("); + + -- Output lines for Pchar_Pos_Array values + + for M in 1 .. Count - 1 loop + Name := Rpad ("N_" & Names (M), 40); + Put_Line (OutS, " " & Name & " => " & Positions (M) & ','); + end loop; + + Name := Rpad ("N_" & Names (Count), 40); + Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");"); + + Put_Line (OutS, ""); + Put_Line (OutS, "end Treeprs;"); + +exception + when Err => + Put_Line (Standard_Error, "*** fatal error"); + Set_Exit_Status (1); + +end XTreeprs; |