aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/xtreeprs.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/xtreeprs.adb')
-rw-r--r--gcc-4.9/gcc/ada/xtreeprs.adb357
1 files changed, 357 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/xtreeprs.adb b/gcc-4.9/gcc/ada/xtreeprs.adb
new file mode 100644
index 000000000..416e5cbba
--- /dev/null
+++ b/gcc-4.9/gcc/ada/xtreeprs.adb
@@ -0,0 +1,357 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT SYSTEM UTILITIES --
+-- --
+-- X T R E E P R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2010, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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 Ada.Streams.Stream_IO; use Ada.Streams.Stream_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;
+ Syn : VString := Nul;
+ Synonym : VString := Nul;
+ Term : VString := Nul;
+
+ subtype Sfile is Ada.Streams.Stream_IO.File_Type;
+
+ OutS : Sfile;
+ -- Output file
+
+ InS : Ada.Text_IO.File_Type;
+ -- Read sinfo.ads
+
+ InT : Ada.Text_IO.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 : constant Pattern := Span (' ' & ASCII.HT);
+ Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
+ Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node;
+ Tst_Punc : constant Pattern := Break (" ,.");
+ Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym
+ & " (" & Break (')') * Field;
+ Brk_Min : constant Pattern := Break ('-') * Ffield;
+ Is_Flag : constant Pattern := "Flag" & Rest * Flagno;
+ Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno;
+ Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn
+ & Len (1) * Term;
+ Brk_Node : constant Pattern := Break (' ') * Node & ' ';
+ Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1;
+
+ M : Match_Result;
+
+ procedure Put_Line (F : Sfile; S : String);
+ procedure Put_Line (F : Sfile; S : VString);
+ -- Local version of Put_Line ensures Unix style line endings
+
+ procedure Put_Line (F : Sfile; S : String) is
+ begin
+ String'Write (Stream (F), S);
+ Character'Write (Stream (F), ASCII.LF);
+ end Put_Line;
+
+ procedure Put_Line (F : Sfile; S : VString) is
+ begin
+ Put_Line (F, To_String (S));
+ end Put_Line;
+
+-- Start of processing for XTreeprs
+
+begin
+ Anchored_Mode := True;
+
+ 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);
+
+ -- Read template header and generate new header
+
+ loop
+ Line := Get_Line (InT);
+
+ -- 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 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 "'"
+ -- 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;