File : 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;