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
41with Ada.Command_Line;              use Ada.Command_Line;
42with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
43with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
44with Ada.Text_IO;                   use Ada.Text_IO;
45
46with GNAT.Spitbol;                  use GNAT.Spitbol;
47with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
48
49with CSinfo;
50
51procedure 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
115begin
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
252exception
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
262end XSinfo;
263