gcc/ada/xtreeprs.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                             X T R E E P R S                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  Program to construct the spec of the Treeprs package
  27
  28 --    Input files:
  29
  30 --       sinfo.ads     Spec of Sinfo package
  31 --       treeprs.adt   Template for Treeprs package
  32
  33 --    Output files:
  34
  35 --       treeprs.ads   Spec of Treeprs package
  36
  37 --  Note: this program assumes that sinfo.ads has passed the error checks which
  38 --  are carried out by the CSinfo utility so it does not duplicate these checks
  39
  40 --  An optional argument allows the specification of an output file name to
  41 --  override the default treeprs.ads file name for the generated output file.
  42
  43 with Ada.Command_Line;              use Ada.Command_Line;
  44 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  45 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  46 with Ada.Text_IO;                   use Ada.Text_IO;
  47 with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
  48
  49 with GNAT.Spitbol;                  use GNAT.Spitbol;
  50 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  51 with GNAT.Spitbol.Table_Boolean;    use GNAT.Spitbol.Table_Boolean;
  52 with GNAT.Spitbol.Table_VString;    use GNAT.Spitbol.Table_VString;
  53
  54 procedure XTreeprs is
  55
  56    package TB renames GNAT.Spitbol.Table_Boolean;
  57    package TV renames GNAT.Spitbol.Table_VString;
  58
  59    Err : exception;
  60    --  Raised on fatal error
  61
  62    pragma Warnings (Off);
  63    --  Following variables are assigned by * operator
  64
  65    A         : VString := Nul;
  66    Ffield    : VString := Nul;
  67    Field     : VString := Nul;
  68    Fieldno   : VString := Nul;
  69    Flagno    : VString := Nul;
  70    Line      : VString := Nul;
  71    Name      : VString := Nul;
  72    Node      : VString := Nul;
  73    Outstring : VString := Nul;
  74    Prefix    : VString := Nul;
  75    S         : VString := Nul;
  76    S1        : VString := Nul;
  77    Syn       : VString := Nul;
  78    Synonym   : VString := Nul;
  79    Term      : VString := Nul;
  80
  81    pragma Warnings (On);
  82
  83    subtype Sfile is Ada.Streams.Stream_IO.File_Type;
  84
  85    OutS : Sfile;
  86    --  Output file
  87
  88    InS : Ada.Text_IO.File_Type;
  89    --  Read sinfo.ads
  90
  91    InT : Ada.Text_IO.File_Type;
  92    --  Read treeprs.adt
  93
  94    Special : TB.Table (20);
  95    --  Table of special fields. These fields are not included in the table
  96    --  constructed by Xtreeprs, since they are specially handled in treeprs.
  97    --  This means these field definitions are completely ignored.
  98
  99    Names : array (1 .. 500) of VString;
 100    --  Table of names of synonyms
 101
 102    Positions : array (1 .. 500) of Natural;
 103    --  Table of starting positions in Pchars string for synonyms
 104
 105    Strings : TV.Table (300);
 106    --  Contribution of each synonym to Pchars string, indexed by name
 107
 108    Count  : Natural := 0;
 109    --  Number of synonyms processed so far
 110
 111    Curpos : Natural := 1;
 112    --  Number of characters generated in Pchars string so far
 113
 114    Lineno : Natural := 0;
 115    --  Line number in sinfo.ads
 116
 117    Field_Base : constant := Character'Pos ('#');
 118    --  Fields 1-5 are represented by the characters #$%&' (i.e. by five
 119    --  contiguous characters starting at # (16#23#)).
 120
 121    Flag_Base : constant := Character'Pos ('(');
 122    --  Flags 1-18 are represented by the characters ()*+,-./0123456789
 123    --  (i.e. by 18 contiguous characters starting at (16#28#)).
 124
 125    Fieldch : Character;
 126    --  Field character, as per above tables
 127
 128    Sp : aliased Natural;
 129    --  Space left on line for Pchars output
 130
 131    wsp      : constant Pattern := Span (' ' & ASCII.HT);
 132    Is_Temp  : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
 133    Get_Node : constant Pattern := wsp & "--  N_" & Rest * Node;
 134    Tst_Punc : constant Pattern := Break (" ,.");
 135    Get_Syn  : constant Pattern := Span (' ') & "--  " & Break (' ') * Synonym
 136                                   & " (" & Break (')') * Field;
 137    Brk_Min  : constant Pattern := Break ('-') * Ffield;
 138    Is_Flag  : constant Pattern := "Flag" & Rest * Flagno;
 139    Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno;
 140    Is_Syn   : constant Pattern := wsp & "N_" & Break (",)") * Syn
 141                                   & Len (1) * Term;
 142    Brk_Node : constant Pattern := Break (' ') * Node & ' ';
 143    Chop_SP  : constant Pattern := Len (Sp'Unrestricted_Access) * S1;
 144
 145    M : Match_Result;
 146
 147    procedure Put_Line (F : Sfile; S : String);
 148    procedure Put_Line (F : Sfile; S : VString);
 149    --  Local version of Put_Line ensures Unix style line endings
 150
 151    procedure Put_Line (F : Sfile; S : String) is
 152    begin
 153       String'Write (Stream (F), S);
 154       Character'Write (Stream (F), ASCII.LF);
 155    end Put_Line;
 156
 157    procedure Put_Line (F : Sfile; S : VString) is
 158    begin
 159       Put_Line (F, To_String (S));
 160    end Put_Line;
 161
 162 --  Start of processing for XTreeprs
 163
 164 begin
 165    Anchored_Mode := True;
 166
 167    if Argument_Count > 0 then
 168       Create (OutS, Out_File, Argument (1));
 169    else
 170       Create (OutS, Out_File, "treeprs.ads");
 171    end if;
 172
 173    Open (InS, In_File, "sinfo.ads");
 174    Open (InT, In_File, "treeprs.adt");
 175
 176    --  Initialize special fields table
 177
 178    Set (Special, "Analyzed",                True);
 179    Set (Special, "Cannot_Be_Constant",      True);
 180    Set (Special, "Chars",                   True);
 181    Set (Special, "Comes_From_Source",       True);
 182    Set (Special, "Error_Posted",            True);
 183    Set (Special, "Etype",                   True);
 184    Set (Special, "Has_No_Side_Effects",     True);
 185    Set (Special, "Is_Controlling_Actual",   True);
 186    Set (Special, "Is_Overloaded",           True);
 187    Set (Special, "Is_Static_Expression",    True);
 188    Set (Special, "Left_Opnd",               True);
 189    Set (Special, "Must_Check_Expr",         True);
 190    Set (Special, "No_Overflow_Expr",        True);
 191    Set (Special, "Paren_Count",             True);
 192    Set (Special, "Raises_Constraint_Error", True);
 193    Set (Special, "Right_Opnd",              True);
 194
 195    --  Read template header and generate new header
 196
 197    loop
 198       Line := Get_Line (InT);
 199
 200       --  Skip lines describing the template
 201
 202       if Match (Line, "--  This file is a template") then
 203          loop
 204             Line := Get_Line (InT);
 205             exit when Line = "";
 206          end loop;
 207       end if;
 208
 209       exit when Match (Line, "package");
 210
 211       if Match (Line, Is_Temp, M) then
 212          Replace (M, A & "    S p e c    ");
 213       end if;
 214
 215       Put_Line (OutS, Line);
 216    end loop;
 217
 218    Put_Line (OutS, Line);
 219
 220    --  Copy rest of comments up to template insert point to spec
 221
 222    loop
 223       Line := Get_Line (InT);
 224       exit when Match (Line, "!!TEMPLATE INSERTION POINT");
 225       Put_Line (OutS, Line);
 226    end loop;
 227
 228    --  Here we are doing the actual insertions
 229
 230    Put_Line (OutS, "   Pchars : constant String :=");
 231
 232    --  Loop through comments describing nodes, picking up fields
 233
 234    loop
 235       Line := Get_Line (InS);
 236       Lineno := Lineno + 1;
 237       exit when Match (Line, "   type Node_Kind");
 238
 239       if Match (Line, Get_Node)
 240         and then not Match (Node, Tst_Punc)
 241       then
 242          Outstring := Node & ' ';
 243
 244          loop
 245             Line := Get_Line (InS);
 246             exit when Line = "";
 247
 248             if Match (Line, Get_Syn)
 249               and then not Match (Synonym, "plus")
 250               and then not Present (Special, Synonym)
 251             then
 252                --  Convert this field into the character used to
 253                --  represent the field according to the table:
 254
 255                --    Field1       '#'
 256                --    Field2       '$'
 257                --    Field3       '%'
 258                --    Field4       '&'
 259                --    Field5       "'"
 260                --    Flag1        "("
 261                --    Flag2        ")"
 262                --    Flag3        '*'
 263                --    Flag4        '+'
 264                --    Flag5        ','
 265                --    Flag6        '-'
 266                --    Flag7        '.'
 267                --    Flag8        '/'
 268                --    Flag9        '0'
 269                --    Flag10       '1'
 270                --    Flag11       '2'
 271                --    Flag12       '3'
 272                --    Flag13       '4'
 273                --    Flag14       '5'
 274                --    Flag15       '6'
 275                --    Flag16       '7'
 276                --    Flag17       '8'
 277                --    Flag18       '9'
 278
 279                if Match (Field, Brk_Min) then
 280                   Field := Ffield;
 281                end if;
 282
 283                if Match (Field, Is_Flag) then
 284                   Fieldch := Char (Flag_Base - 1 + N (Flagno));
 285
 286                elsif Match (Field, Is_Field) then
 287                   Fieldch := Char (Field_Base - 1 + N (Fieldno));
 288
 289                else
 290                   Put_Line
 291                     (Standard_Error,
 292                      "*** Line " &
 293                       Lineno &
 294                       " has unrecognized field name " &
 295                       Field);
 296                   raise Err;
 297                end if;
 298
 299                Append (Outstring, Fieldch & Synonym);
 300             end if;
 301          end loop;
 302
 303          Set (Strings, Node, Outstring);
 304       end if;
 305    end loop;
 306
 307    --  Loop through actual definitions of node kind enumeration literals
 308
 309    loop
 310       loop
 311          Line := Get_Line (InS);
 312          Lineno := Lineno + 1;
 313          exit when Match (Line, Is_Syn);
 314       end loop;
 315
 316       S := Get (Strings, Syn);
 317       Match (S, Brk_Node, "");
 318       Count := Count + 1;
 319       Names (Count) := Syn;
 320       Positions (Count) := Curpos;
 321       Curpos := Curpos + Length (S);
 322       Put_Line (OutS, "      --  " & Node);
 323       Prefix := V ("      ");
 324       exit when Term = ")";
 325
 326       --  Loop to output the string literal for Pchars
 327
 328       loop
 329          Sp := 79 - 4 - Length (Prefix);
 330          exit when Size (S) <= Sp;
 331          Match (S, Chop_SP, "");
 332          Put_Line (OutS, Prefix & '"' & S1 & """ &");
 333          Prefix := V ("         ");
 334       end loop;
 335
 336       Put_Line (OutS, Prefix & '"' & S & """ &");
 337    end loop;
 338
 339    Put_Line (OutS, "      """";");
 340    Put_Line (OutS, "");
 341    Put_Line
 342      (OutS, "   type Pchar_Pos_Array is array (Node_Kind) of Positive;");
 343    Put_Line
 344      (OutS,
 345       "   Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
 346
 347    --  Output lines for Pchar_Pos_Array values
 348
 349    for M in 1 .. Count - 1 loop
 350       Name := Rpad ("N_" & Names (M), 40);
 351       Put_Line (OutS, "      " & Name & " => " & Positions (M) & ',');
 352    end loop;
 353
 354    Name := Rpad ("N_" & Names (Count), 40);
 355    Put_Line (OutS, "      " & Name & " => " & Positions (Count) & ");");
 356
 357    Put_Line (OutS, "");
 358    Put_Line (OutS, "end Treeprs;");
 359
 360 exception
 361    when Err =>
 362       Put_Line (Standard_Error, "*** fatal error");
 363       Set_Exit_Status (1);
 364
 365 end XTreeprs;