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
46with Ada.Command_Line;              use Ada.Command_Line;
47with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
48with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
49with Ada.Text_IO;                   use Ada.Text_IO;
50
51with GNAT.Spitbol;                  use GNAT.Spitbol;
52with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
53
54procedure 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
114begin
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
239exception
240   when Done =>
241      Put_Line (Ofile, "");
242      Set_Exit_Status (0);
243
244end XSinfo;
245