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