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