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