Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                          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;