--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/ada/xtreeprs.adb	Fri Oct 27 22:46:09 2017 +0900
@@ -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;