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-2011, 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 --  An optional argument allows the specification of an output file name to
  39 --  override the default sinfo.h file name for the generated output file.
  40
  41 with Ada.Command_Line;              use Ada.Command_Line;
  42 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  43 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  44 with Ada.Text_IO;                   use Ada.Text_IO;
  45
  46 with GNAT.Spitbol;                  use GNAT.Spitbol;
  47 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  48
  49 with CSinfo;
  50
  51 procedure XSinfo is
  52
  53    Done : exception;
  54    Err  : exception;
  55
  56    A         : VString := Nul;
  57    Arg       : VString := Nul;
  58    Comment   : VString := Nul;
  59    Line      : VString := Nul;
  60    N         : VString := Nul;
  61    N1, N2    : VString := Nul;
  62    Nam       : VString := Nul;
  63    Rtn       : VString := Nul;
  64    Term      : VString := Nul;
  65
  66    InS   : File_Type;
  67    Ofile : File_Type;
  68
  69    wsp     : constant Pattern := Span (' ' & ASCII.HT);
  70    Wsp_For : constant Pattern := wsp & "for";
  71    Is_Cmnt : constant Pattern := wsp & "--";
  72    Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is";
  73    Get_Nam : constant Pattern := wsp * A & "N_" &  Break (",)") * Nam
  74                                  & Len (1) * Term;
  75    Sub_Typ : constant Pattern := wsp * A & "subtype " &  Break (' ') * N;
  76    No_Cont : constant Pattern := wsp & Break (' ') * N1
  77                                  & " .. " & Break (';') * N2;
  78    Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
  79    Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2;
  80    Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam;
  81    Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg
  82                                  & ") return " & Break (';') * Rtn
  83                                  & ';' & wsp & "--" & wsp & Rest * Comment;
  84
  85    NKV : Natural;
  86
  87    M : Match_Result;
  88
  89    procedure Getline;
  90    --  Get non-comment, non-blank line. Also skips "for " rep clauses
  91
  92    -------------
  93    -- Getline --
  94    -------------
  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    --  First run CSinfo to check for errors. Note that CSinfo is also a
 117    --  stand-alone program that can be run separately.
 118
 119    CSinfo;
 120
 121    Set_Exit_Status (1);
 122    Anchored_Mode := True;
 123
 124    if Argument_Count > 0 then
 125       Create (Ofile, Out_File, Argument (1));
 126    else
 127       Create (Ofile, Out_File, "sinfo.h");
 128    end if;
 129
 130    Open (InS, In_File, "sinfo.ads");
 131
 132    --  Write header to output file
 133
 134    loop
 135       Line := Get_Line (InS);
 136       exit when Line = "";
 137
 138       Match
 139         (Line,
 140          "--                                 S p e c       ",
 141          "--                              C Header File    ");
 142
 143       Match (Line, "--", "/*");
 144       Match (Line, Rtab (2) * A & "--", M);
 145       Replace (M, A & "*/");
 146       Put_Line (Ofile, Line);
 147    end loop;
 148
 149    --  Skip to package line
 150
 151    loop
 152       Getline;
 153       exit when Match (Line, "package");
 154    end loop;
 155
 156    --  Skip to first node kind line
 157
 158    loop
 159       Getline;
 160       exit when Match (Line, Typ_Nod);
 161       Put_Line (Ofile, Line);
 162    end loop;
 163
 164    Put_Line (Ofile, "");
 165
 166    Put_Line (Ofile, "#ifdef __cplusplus");
 167    Put_Line (Ofile, "extern ""C"" {");
 168    Put_Line (Ofile, "#endif");
 169
 170    NKV := 0;
 171
 172    --  Loop through node kind codes
 173
 174    loop
 175       Getline;
 176
 177       if Match (Line, Get_Nam) then
 178          Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
 179          NKV := NKV + 1;
 180          exit when not Match (Term, ",");
 181
 182       else
 183          Put_Line (Ofile, Line);
 184       end if;
 185    end loop;
 186
 187    Put_Line (Ofile, "");
 188    Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
 189
 190    --  Loop through subtype declarations
 191
 192    loop
 193       Getline;
 194
 195       if not Match (Line, Sub_Typ) then
 196          exit when Match (Line, "   function");
 197          Put_Line (Ofile, Line);
 198
 199       else
 200          Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
 201          Getline;
 202
 203          --  Normal case
 204
 205          if Match (Line, No_Cont) then
 206             Put_Line (Ofile, A & "   " & N1 & ", " & N2 & ')');
 207
 208          --  Continuation case
 209
 210          else
 211             if not Match (Line, Cont_N1) then
 212                raise Err;
 213             end if;
 214
 215             Getline;
 216
 217             if not Match (Line, Cont_N2) then
 218                raise Err;
 219             end if;
 220
 221             Put_Line (Ofile,  A & "   " & N1 & ',');
 222             Put_Line (Ofile,  A & "   " & N2 & ')');
 223          end if;
 224       end if;
 225    end loop;
 226
 227    --  Loop through functions. Note that this loop is terminated by
 228    --  the call to Getfile encountering the end of functions sentinel
 229
 230    loop
 231       if Match (Line, Is_Func) then
 232          Getline;
 233             if not Match (Line, Get_Arg) then
 234                raise Err;
 235             end if;
 236          Put_Line
 237            (Ofile,
 238             A &  "INLINE " & Rpad (Rtn, 9)
 239             & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
 240
 241          Put_Line (Ofile,  A & "   { return " & Comment & " (N); }");
 242
 243       else
 244          Put_Line (Ofile, Line);
 245       end if;
 246
 247       Getline;
 248    end loop;
 249
 250    --  Can't get here since above loop only left via raise
 251
 252 exception
 253    when Done =>
 254       Close (InS);
 255       Put_Line (Ofile, "");
 256       Put_Line (Ofile, "#ifdef __cplusplus");
 257       Put_Line (Ofile, "}");
 258       Put_Line (Ofile, "#endif");
 259       Close (Ofile);
 260       Set_Exit_Status (0);
 261
 262 end XSinfo;