gcc/ada/xsinfo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                               X S I N F O                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000 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 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 --  Program to construct C header file a-sinfo.h (C version of sinfo.ads spec,
  30 --  for use by Gigi, contains all definitions and access functions, but does
  31 --  not contain set procedures, since Gigi never modifies the GNAT tree)
  32
  33 --    Input files:
  34
  35 --       sinfo.ads     Spec of Sinfo package
  36
  37 --    Output files:
  38
  39 --       a-sinfo.h     Corresponding c header file
  40
  41 --  Note: this program assumes that sinfo.ads has passed the error checks
  42 --  which are carried out by the CSinfo utility, so it does not duplicate
  43 --  these checks and assumes the soruce is correct.
  44
  45 --  An optional argument allows the specification of an output file name to
  46 --  override the default a-sinfo.h file name for the generated output file.
  47
  48 with Ada.Command_Line;              use Ada.Command_Line;
  49 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  50 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  51 with Ada.Text_IO;                   use Ada.Text_IO;
  52
  53 with GNAT.Spitbol;                  use GNAT.Spitbol;
  54 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  55
  56 procedure XSinfo is
  57
  58    Done : exception;
  59    Err  : exception;
  60
  61    A         : VString := Nul;
  62    Arg       : VString := Nul;
  63    Comment   : VString := Nul;
  64    Line      : VString := Nul;
  65    N         : VString := Nul;
  66    N1, N2    : VString := Nul;
  67    Nam       : VString := Nul;
  68    Rtn       : VString := Nul;
  69    Sinforev  : VString := Nul;
  70    Term      : VString := Nul;
  71    XSinforev : VString := Nul;
  72
  73    InS       : File_Type;
  74    Ofile     : File_Type;
  75
  76    wsp     : Pattern := Span (' ' & ASCII.HT);
  77    Get_Vsn : Pattern := BreakX ('$') & "$Rev" & "ision: "
  78                           & Break (' ') * Sinforev;
  79    Wsp_For : Pattern := wsp & "for";
  80    Is_Cmnt : Pattern := wsp & "--";
  81    Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
  82    Get_Nam : Pattern := wsp * A & "N_" &  Break (",)") * Nam
  83                           & Len (1) * Term;
  84    Sub_Typ : Pattern := wsp * A & "subtype " &  Break (' ') * N;
  85    No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
  86    Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
  87    Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
  88    Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
  89    Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
  90                           & ") return " & Break (';') * Rtn
  91                           & ';' & wsp & "--" & wsp & Rest * Comment;
  92
  93    NKV : Natural;
  94
  95    M : Match_Result;
  96
  97
  98    procedure Getline;
  99    --  Get non-comment, non-blank line. Also skips "for " rep clauses.
 100
 101    procedure Getline is
 102    begin
 103       loop
 104          Line := Get_Line (InS);
 105
 106          if Line /= ""
 107            and then not Match (Line, Wsp_For)
 108            and then not Match (Line, Is_Cmnt)
 109          then
 110             return;
 111
 112          elsif Match (Line, "   --  End functions (note") then
 113             raise Done;
 114          end if;
 115       end loop;
 116    end Getline;
 117
 118 --  Start of processing for XSinfo
 119
 120 begin
 121    Set_Exit_Status (1);
 122    Anchored_Mode := True;
 123    Match ("$Revision: 1.1 $", "$Rev" & "ision: "  & Break (' ') * XSinforev);
 124
 125    if Argument_Count > 0 then
 126       Create (Ofile, Out_File, Argument (1));
 127    else
 128       Create (Ofile, Out_File, "a-sinfo.h");
 129    end if;
 130
 131    Open (InS, In_File, "sinfo.ads");
 132
 133    --  Get Sinfo rev and write header to output file
 134
 135    loop
 136       Line := Get_Line (InS);
 137       exit when Line = "";
 138
 139       if Match (Line, Get_Vsn) then
 140          Put_Line
 141            (Ofile, "/*                 Generated by xsinfo revision "
 142             & XSinforev & " using                  */");
 143          Put_Line
 144            (Ofile, "/*                         sinfo.ads revision "
 145             & Sinforev & "                         */");
 146
 147       else
 148          Match
 149            (Line,
 150             "--                                 S p e c       ",
 151             "--                              C Header File    ");
 152
 153          Match (Line, "--", "/*");
 154          Match (Line, Rtab (2) * A & "--", M);
 155          Replace (M, A & "*/");
 156          Put_Line (Ofile, Line);
 157       end if;
 158    end loop;
 159
 160    --  Skip to package line
 161
 162    loop
 163       Getline;
 164       exit when Match (Line, "package");
 165    end loop;
 166
 167    --  Skip to first node kind line
 168
 169    loop
 170       Getline;
 171       exit when Match (Line, Typ_Nod);
 172       Put_Line (Ofile, Line);
 173    end loop;
 174
 175    Put_Line (Ofile, "");
 176    NKV := 0;
 177
 178    --  Loop through node kind codes
 179
 180    loop
 181       Getline;
 182
 183       if Match (Line, Get_Nam) then
 184          Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
 185          NKV := NKV + 1;
 186          exit when not Match (Term, ",");
 187
 188       else
 189          Put_Line (Ofile, Line);
 190       end if;
 191    end loop;
 192
 193    Put_Line (Ofile, "");
 194    Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
 195
 196    --  Loop through subtype declarations
 197
 198    loop
 199       Getline;
 200
 201       if not Match (Line, Sub_Typ) then
 202          exit when Match (Line, "   function");
 203          Put_Line (Ofile, Line);
 204
 205       else
 206          Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
 207          Getline;
 208
 209          --  Normal case
 210
 211          if Match (Line, No_Cont) then
 212             Put_Line (Ofile, A & "   " & N1 & ", " & N2 & ')');
 213
 214          --  Continuation case
 215
 216          else
 217             if not Match (Line, Cont_N1) then
 218                raise Err;
 219             end if;
 220
 221             Getline;
 222
 223             if not Match (Line, Cont_N2) then
 224                raise Err;
 225             end if;
 226
 227             Put_Line (Ofile,  A & "   " & N1 & ',');
 228             Put_Line (Ofile,  A & "   " & N2 & ')');
 229          end if;
 230       end if;
 231    end loop;
 232
 233    --  Loop through functions. Note that this loop is terminated by
 234    --  the call to Getfile encountering the end of functions sentinel
 235
 236    loop
 237       if Match (Line, Is_Func) then
 238          Getline;
 239             if not Match (Line, Get_Arg) then
 240                raise Err;
 241             end if;
 242          Put_Line
 243            (Ofile,
 244             A &  "INLINE " & Rpad (Rtn, 9)
 245             & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
 246
 247          Put_Line (Ofile,  A & "   { return " & Comment & " (N); }");
 248
 249       else
 250          Put_Line (Ofile, Line);
 251       end if;
 252
 253       Getline;
 254    end loop;
 255
 256 exception
 257    when Done =>
 258       Put_Line (Ofile, "");
 259       Set_Exit_Status (0);
 260
 261 end XSinfo;