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 --                                                                          --
  10 --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 --  Program to construct C header file a-sinfo.h (C version of sinfo.ads spec,
  29 --  for use by Gigi, contains all definitions and access functions, but does
  30 --  not contain set procedures, since Gigi never modifies the GNAT tree)
  31
  32 --    Input files:
  33
  34 --       sinfo.ads     Spec of Sinfo package
  35
  36 --    Output files:
  37
  38 --       a-sinfo.h     Corresponding c header file
  39
  40 --  Note: this program assumes that sinfo.ads has passed the error checks
  41 --  which are carried out by the CSinfo utility, so it does not duplicate
  42 --  these checks and assumes the soruce is correct.
  43
  44 --  An optional argument allows the specification of an output file name to
  45 --  override the default a-sinfo.h file name for the generated output file.
  46
  47 with Ada.Command_Line;              use Ada.Command_Line;
  48 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  49 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  50 with Ada.Text_IO;                   use Ada.Text_IO;
  51
  52 with GNAT.Spitbol;                  use GNAT.Spitbol;
  53 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  54
  55 procedure XSinfo is
  56
  57    Done : exception;
  58    Err  : exception;
  59
  60    A         : VString := Nul;
  61    Arg       : VString := Nul;
  62    Comment   : VString := Nul;
  63    Line      : VString := Nul;
  64    N         : VString := Nul;
  65    N1, N2    : VString := Nul;
  66    Nam       : VString := Nul;
  67    Rtn       : VString := Nul;
  68    Term      : VString := Nul;
  69
  70    InS       : File_Type;
  71    Ofile     : File_Type;
  72
  73    wsp     : Pattern := Span (' ' & ASCII.HT);
  74    Wsp_For : Pattern := wsp & "for";
  75    Is_Cmnt : Pattern := wsp & "--";
  76    Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
  77    Get_Nam : Pattern := wsp * A & "N_" &  Break (",)") * Nam
  78                           & Len (1) * Term;
  79    Sub_Typ : Pattern := wsp * A & "subtype " &  Break (' ') * N;
  80    No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
  81    Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
  82    Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
  83    Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
  84    Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
  85                           & ") return " & Break (';') * Rtn
  86                           & ';' & wsp & "--" & wsp & Rest * Comment;
  87
  88    NKV : Natural;
  89
  90    M : Match_Result;
  91
  92
  93    procedure Getline;
  94    --  Get non-comment, non-blank line. Also skips "for " rep clauses.
  95
  96    procedure Getline is
  97    begin
  98       loop
  99          Line := Get_Line (InS);
 100
 101          if Line /= ""
 102            and then not Match (Line, Wsp_For)
 103            and then not Match (Line, Is_Cmnt)
 104          then
 105             return;
 106
 107          elsif Match (Line, "   --  End functions (note") then
 108             raise Done;
 109          end if;
 110       end loop;
 111    end Getline;
 112
 113 --  Start of processing for XSinfo
 114
 115 begin
 116    Set_Exit_Status (1);
 117    Anchored_Mode := True;
 118
 119    if Argument_Count > 0 then
 120       Create (Ofile, Out_File, Argument (1));
 121    else
 122       Create (Ofile, Out_File, "a-sinfo.h");
 123    end if;
 124
 125    Open (InS, In_File, "sinfo.ads");
 126
 127    --  Write header to output file
 128
 129    loop
 130       Line := Get_Line (InS);
 131       exit when Line = "";
 132
 133       Match
 134         (Line,
 135          "--                                 S p e c       ",
 136          "--                              C Header File    ");
 137
 138       Match (Line, "--", "/*");
 139       Match (Line, Rtab (2) * A & "--", M);
 140       Replace (M, A & "*/");
 141       Put_Line (Ofile, Line);
 142    end loop;
 143
 144    --  Skip to package line
 145
 146    loop
 147       Getline;
 148       exit when Match (Line, "package");
 149    end loop;
 150
 151    --  Skip to first node kind line
 152
 153    loop
 154       Getline;
 155       exit when Match (Line, Typ_Nod);
 156       Put_Line (Ofile, Line);
 157    end loop;
 158
 159    Put_Line (Ofile, "");
 160    NKV := 0;
 161
 162    --  Loop through node kind codes
 163
 164    loop
 165       Getline;
 166
 167       if Match (Line, Get_Nam) then
 168          Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
 169          NKV := NKV + 1;
 170          exit when not Match (Term, ",");
 171
 172       else
 173          Put_Line (Ofile, Line);
 174       end if;
 175    end loop;
 176
 177    Put_Line (Ofile, "");
 178    Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
 179
 180    --  Loop through subtype declarations
 181
 182    loop
 183       Getline;
 184
 185       if not Match (Line, Sub_Typ) then
 186          exit when Match (Line, "   function");
 187          Put_Line (Ofile, Line);
 188
 189       else
 190          Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
 191          Getline;
 192
 193          --  Normal case
 194
 195          if Match (Line, No_Cont) then
 196             Put_Line (Ofile, A & "   " & N1 & ", " & N2 & ')');
 197
 198          --  Continuation case
 199
 200          else
 201             if not Match (Line, Cont_N1) then
 202                raise Err;
 203             end if;
 204
 205             Getline;
 206
 207             if not Match (Line, Cont_N2) then
 208                raise Err;
 209             end if;
 210
 211             Put_Line (Ofile,  A & "   " & N1 & ',');
 212             Put_Line (Ofile,  A & "   " & N2 & ')');
 213          end if;
 214       end if;
 215    end loop;
 216
 217    --  Loop through functions. Note that this loop is terminated by
 218    --  the call to Getfile encountering the end of functions sentinel
 219
 220    loop
 221       if Match (Line, Is_Func) then
 222          Getline;
 223             if not Match (Line, Get_Arg) then
 224                raise Err;
 225             end if;
 226          Put_Line
 227            (Ofile,
 228             A &  "INLINE " & Rpad (Rtn, 9)
 229             & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
 230
 231          Put_Line (Ofile,  A & "   { return " & Comment & " (N); }");
 232
 233       else
 234          Put_Line (Ofile, Line);
 235       end if;
 236
 237       Getline;
 238    end loop;
 239
 240 exception
 241    when Done =>
 242       Put_Line (Ofile, "");
 243       Set_Exit_Status (0);
 244
 245 end XSinfo;