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