|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT SYSTEM UTILITIES --
|
|
|
4 -- --
|
|
|
5 -- X E I N F O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 einfo.h (C version of einfo.ads spec)
|
|
|
27 -- for use by Gigi. This header file contains all definitions and access
|
|
|
28 -- functions, but does not contain set procedures, since Gigi is not allowed
|
|
|
29 -- to modify the GNAT tree.
|
|
|
30
|
|
|
31 -- Input files:
|
|
|
32
|
|
|
33 -- einfo.ads spec of Einfo package
|
|
|
34 -- einfo.adb body of Einfo package
|
|
|
35
|
|
|
36 -- Output files:
|
|
|
37
|
|
|
38 -- einfo.h corresponding C header file
|
|
|
39
|
|
|
40 -- Note: It is assumed that the input files have been compiled without errors
|
|
|
41
|
|
|
42 -- An optional argument allows the specification of an output file name to
|
|
|
43 -- override the default einfo.h file name for the generated output file.
|
|
|
44
|
|
|
45 -- Most, but not all of the functions in Einfo can be inlined in the C header.
|
|
|
46 -- They are the functions identified by pragma Inline in the spec. Functions
|
|
|
47 -- that cannot be inlined are simply defined in the header.
|
|
|
48
|
|
|
49 with Ada.Command_Line; use Ada.Command_Line;
|
|
|
50 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
|
|
51 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
|
|
52 with Ada.Strings.Maps; use Ada.Strings.Maps;
|
|
|
53 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
|
|
54 with Ada.Text_IO; use Ada.Text_IO;
|
|
|
55
|
|
|
56 with GNAT.Spitbol; use GNAT.Spitbol;
|
|
|
57 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
|
|
58 with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
|
|
59
|
|
|
60 with CEinfo;
|
|
|
61
|
|
|
62 procedure XEinfo is
|
|
|
63
|
|
|
64 package TB renames GNAT.Spitbol.Table_Boolean;
|
|
|
65
|
|
|
66 Err : exception;
|
|
|
67
|
|
|
68 A : VString := Nul;
|
|
|
69 B : VString := Nul;
|
|
|
70 C : VString := Nul;
|
|
|
71 Expr : VString := Nul;
|
|
|
72 Filler : VString := Nul;
|
|
|
73 Fline : VString := Nul;
|
|
|
74 Formal : VString := Nul;
|
|
|
75 Formaltyp : VString := Nul;
|
|
|
76 FN : VString := Nul;
|
|
|
77 Line : VString := Nul;
|
|
|
78 N : VString := Nul;
|
|
|
79 N1 : VString := Nul;
|
|
|
80 N2 : VString := Nul;
|
|
|
81 N3 : VString := Nul;
|
|
|
82 Nam : VString := Nul;
|
|
|
83 Name : VString := Nul;
|
|
|
84 NewS : VString := Nul;
|
|
|
85 Nextlin : VString := Nul;
|
|
|
86 OldS : VString := Nul;
|
|
|
87 Rtn : VString := Nul;
|
|
|
88 Term : VString := Nul;
|
|
|
89
|
|
|
90 InB : File_Type;
|
|
|
91 -- Used to read initial header from body
|
|
|
92
|
|
|
93 InF : File_Type;
|
|
|
94 -- Used to read full text of both spec and body
|
|
|
95
|
|
|
96 Ofile : File_Type;
|
|
|
97 -- Used to write output file
|
|
|
98
|
|
|
99 wsp : constant Pattern := NSpan (' ' & ASCII.HT);
|
|
|
100 Comment : constant Pattern := wsp & "--";
|
|
|
101 For_Rep : constant Pattern := wsp & "for";
|
|
|
102 Get_Func : constant Pattern := wsp * A & "function" & wsp
|
|
|
103 & Break (' ') * Name;
|
|
|
104 Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
|
|
|
105 Get_Pack : constant Pattern := wsp & "package ";
|
|
|
106 Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
|
|
|
107 Find_Fun : constant Pattern := wsp & "function";
|
|
|
108 F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
|
|
109 G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
|
|
|
110 & wsp & "is" & wsp & Break (" ;") * OldS
|
|
|
111 & wsp & ';' & wsp & Rtab (0);
|
|
|
112 F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
|
|
|
113 " is (";
|
|
|
114 Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
|
|
|
115 & Len (1) * Term;
|
|
|
116 Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
|
|
117 Get_N1 : constant Pattern := wsp & Break (' ') * N1;
|
|
|
118 Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
|
|
|
119 Get_N3 : constant Pattern := wsp & Break (';') * N3;
|
|
|
120 Get_FN : constant Pattern := wsp * C & "function" & wsp
|
|
|
121 & Break (" (") * FN;
|
|
|
122 Is_Rturn : constant Pattern := BreakX ('r') & "return";
|
|
|
123 Is_Begin : constant Pattern := wsp & "begin";
|
|
|
124 Get_Asrt : constant Pattern := wsp & "pragma Assert";
|
|
|
125 Semicoln : constant Pattern := BreakX (';');
|
|
|
126 Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
|
|
|
127 Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
|
|
|
128 Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
|
|
|
129 Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
|
|
|
130 Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
|
|
|
131 Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
|
|
|
132 Get_B4 : constant Pattern := BreakX (' ') * A & " or else " & Rest * B;
|
|
|
133 To_Paren : constant Pattern := wsp * Filler & '(';
|
|
|
134 Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
|
|
|
135 & BreakX (" );") * Formaltyp;
|
|
|
136 Nxt_Fml : constant Pattern := wsp & "; ";
|
|
|
137 Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
|
|
|
138 Rem_Prn : constant Pattern := wsp & ')';
|
|
|
139
|
|
|
140 M : Match_Result;
|
|
|
141
|
|
|
142 Lineno : Natural := 0;
|
|
|
143 -- Line number in spec
|
|
|
144
|
|
|
145 V : Natural;
|
|
|
146 Ctr : Natural;
|
|
|
147
|
|
|
148 Inlined : TB.Table (200);
|
|
|
149 -- Inlined<N> = True for inlined function, False otherwise
|
|
|
150
|
|
|
151 Lastinlined : Boolean;
|
|
|
152
|
|
|
153 procedure Badfunc;
|
|
131
|
154 pragma No_Return (Badfunc);
|
|
111
|
155 -- Signal bad function in body
|
|
|
156
|
|
|
157 function Getlin return VString;
|
|
|
158 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
|
|
|
159 -- Fatal error (raises End_Error exception) if end of file encountered
|
|
|
160
|
|
|
161 procedure Must (B : Boolean);
|
|
|
162 -- Raises Err if the argument (a Match) call, returns False
|
|
|
163
|
|
|
164 procedure Sethead (Line : in out VString; Term : String);
|
|
|
165 -- Process function header into C
|
|
|
166
|
|
|
167 -------------
|
|
|
168 -- Badfunc --
|
|
|
169 -------------
|
|
|
170
|
|
|
171 procedure Badfunc is
|
|
|
172 begin
|
|
|
173 Put_Line
|
|
|
174 (Standard_Error,
|
|
|
175 "Body for function " & FN & " does not meet requirements");
|
|
|
176 raise Err;
|
|
|
177 end Badfunc;
|
|
|
178
|
|
|
179 -------------
|
|
|
180 -- Getlin --
|
|
|
181 -------------
|
|
|
182
|
|
|
183 function Getlin return VString is
|
|
|
184 Lin : VString;
|
|
|
185
|
|
|
186 begin
|
|
|
187 loop
|
|
|
188 Lin := Get_Line (InF);
|
|
|
189 Lineno := Lineno + 1;
|
|
|
190
|
|
|
191 if Lin /= ""
|
|
|
192 and then not Match (Lin, Comment)
|
|
|
193 and then not Match (Lin, For_Rep)
|
|
|
194 then
|
|
|
195 return Lin;
|
|
|
196 end if;
|
|
|
197 end loop;
|
|
|
198 end Getlin;
|
|
|
199
|
|
|
200 ----------
|
|
|
201 -- Must --
|
|
|
202 ----------
|
|
|
203
|
|
|
204 procedure Must (B : Boolean) is
|
|
|
205 begin
|
|
|
206 if not B then
|
|
|
207 raise Err;
|
|
|
208 end if;
|
|
|
209 end Must;
|
|
|
210
|
|
|
211 -------------
|
|
|
212 -- Sethead --
|
|
|
213 -------------
|
|
|
214
|
|
|
215 procedure Sethead (Line : in out VString; Term : String) is
|
|
|
216 Args : VString;
|
|
|
217
|
|
|
218 begin
|
|
|
219 Must (Match (Line, Get_Func, ""));
|
|
|
220 Args := Nul;
|
|
|
221
|
|
|
222 if Match (Line, To_Paren, "") then
|
|
|
223 Args := Filler & '(';
|
|
|
224
|
|
|
225 loop
|
|
|
226 Must (Match (Line, Get_Fml, ""));
|
|
|
227 Append (Args, Formaltyp & ' ' & Formal);
|
|
|
228 exit when not Match (Line, Nxt_Fml);
|
|
|
229 Append (Args, ",");
|
|
|
230 end loop;
|
|
|
231
|
|
|
232 Match (Line, Rem_Prn, "");
|
|
|
233 Append (Args, ')');
|
|
|
234 end if;
|
|
|
235
|
|
|
236 Must (Match (Line, Get_Rtn));
|
|
|
237
|
|
|
238 if Present (Inlined, Name) then
|
|
|
239 Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
|
|
|
240 else
|
|
|
241 Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
|
|
|
242 end if;
|
|
|
243 end Sethead;
|
|
|
244
|
|
|
245 -- Start of processing for XEinfo
|
|
|
246
|
|
|
247 begin
|
|
|
248 -- First run CEinfo to check for errors. Note that CEinfo is also a
|
|
|
249 -- stand-alone program that can be run separately.
|
|
|
250
|
|
|
251 CEinfo;
|
|
|
252
|
|
|
253 Anchored_Mode := True;
|
|
|
254
|
|
|
255 if Argument_Count > 0 then
|
|
|
256 Create (Ofile, Out_File, Argument (1));
|
|
|
257 else
|
|
|
258 Create (Ofile, Out_File, "einfo.h");
|
|
|
259 end if;
|
|
|
260
|
|
|
261 Open (InB, In_File, "einfo.adb");
|
|
|
262 Open (InF, In_File, "einfo.ads");
|
|
|
263
|
|
|
264 Lineno := 0;
|
|
|
265 loop
|
|
|
266 Line := Get_Line (InF);
|
|
|
267 Lineno := Lineno + 1;
|
|
|
268 exit when Line = "";
|
|
|
269
|
|
|
270 Match (Line,
|
|
|
271 "-- S p e c ",
|
|
|
272 "-- C Header File ");
|
|
|
273 Match (Line, "--", "/*");
|
|
|
274 Match (Line, Rtab (2) * A & "--", M);
|
|
|
275 Replace (M, A & "*/");
|
|
|
276 Put_Line (Ofile, Line);
|
|
|
277 end loop;
|
|
|
278
|
|
|
279 Put_Line (Ofile, "");
|
|
|
280
|
|
|
281 Put_Line (Ofile, "#ifdef __cplusplus");
|
|
|
282 Put_Line (Ofile, "extern ""C"" {");
|
|
|
283 Put_Line (Ofile, "#endif");
|
|
|
284
|
|
|
285 -- Find and record pragma Inlines
|
|
|
286
|
|
|
287 loop
|
|
|
288 Line := Get_Line (InF);
|
|
|
289 exit when Match (Line, " -- END XEINFO INLINES");
|
|
|
290
|
|
|
291 if Match (Line, Inline) then
|
|
|
292 Set (Inlined, Name, True);
|
|
|
293 end if;
|
|
|
294 end loop;
|
|
|
295
|
|
|
296 -- Skip to package line
|
|
|
297
|
|
|
298 Reset (InF, In_File);
|
|
|
299 Lineno := 0;
|
|
|
300
|
|
|
301 loop
|
|
|
302 Line := Getlin;
|
|
|
303 exit when Match (Line, Get_Pack);
|
|
|
304 end loop;
|
|
|
305
|
|
|
306 V := 0;
|
|
|
307 Line := Getlin;
|
|
|
308 Must (Match (Line, wsp & "type Entity_Kind"));
|
|
|
309
|
|
|
310 -- Process entity kind code definitions
|
|
|
311
|
|
|
312 loop
|
|
|
313 Line := Getlin;
|
|
|
314 exit when not Match (Line, Get_Enam);
|
|
|
315 Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
|
|
|
316 V := V + 1;
|
|
|
317 end loop;
|
|
|
318
|
|
|
319 Must (Match (Line, wsp & Rest * N));
|
|
|
320 Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
|
|
|
321 Line := Getlin;
|
|
|
322
|
|
|
323 Must (Match (Line, wsp & ");"));
|
|
|
324 Put_Line (Ofile, "");
|
|
|
325
|
|
|
326 -- Loop through subtype and type declarations
|
|
|
327
|
|
|
328 loop
|
|
|
329 Line := Getlin;
|
|
|
330 exit when Match (Line, Find_Fun);
|
|
|
331
|
|
|
332 -- Case of a subtype declaration
|
|
|
333
|
|
|
334 if Match (Line, F_Subtyp) then
|
|
|
335
|
|
|
336 -- Case of a subtype declaration that is an abbreviation of the
|
|
|
337 -- form subtype x is y, and if so generate the appropriate typedef
|
|
|
338
|
|
|
339 if Match (Line, G_Subtyp) then
|
|
|
340 Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
|
|
|
341
|
|
|
342 -- Otherwise the subtype must be declaring a subrange of Entity_Id
|
|
|
343
|
|
|
344 else
|
|
|
345 Must (Match (Line, Get_Styp));
|
|
|
346 Line := Getlin;
|
|
|
347 Must (Match (Line, Get_N1));
|
|
|
348
|
|
|
349 loop
|
|
|
350 Line := Get_Line (InF);
|
|
|
351 Lineno := Lineno + 1;
|
|
|
352 exit when not Match (Line, Get_N2);
|
|
|
353 end loop;
|
|
|
354
|
|
|
355 Must (Match (Line, Get_N3));
|
|
|
356 Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
|
|
|
357 Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
|
|
|
358 Put_Line (Ofile, "");
|
|
|
359 end if;
|
|
|
360
|
|
|
361 -- Case of type declaration
|
|
|
362
|
|
|
363 elsif Match (Line, F_Typ) then
|
|
|
364
|
|
|
365 -- Process type declaration (must be enumeration type)
|
|
|
366
|
|
|
367 Ctr := 0;
|
|
|
368 Put_Line (Ofile, A & "typedef char " & N & ';');
|
|
|
369
|
|
|
370 loop
|
|
|
371 Line := Getlin;
|
|
|
372 Must (Match (Line, Get_Nam));
|
|
|
373 Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
|
|
|
374 Ctr := Ctr + 1;
|
|
|
375 exit when Term /= ",";
|
|
|
376 end loop;
|
|
|
377
|
|
|
378 Put_Line (Ofile, "");
|
|
|
379
|
|
|
380 -- Neither subtype nor type declaration
|
|
|
381
|
|
|
382 else
|
|
|
383 raise Err;
|
|
|
384 end if;
|
|
|
385 end loop;
|
|
|
386
|
|
|
387 -- Process function declarations
|
|
|
388
|
|
|
389 -- Note: Lastinlined used to control blank lines
|
|
|
390
|
|
|
391 Put_Line (Ofile, "");
|
|
|
392 Lastinlined := True;
|
|
|
393
|
|
|
394 -- Loop through function declarations
|
|
|
395
|
|
|
396 while Match (Line, Get_FN) loop
|
|
|
397
|
|
|
398 -- Non-inlined function
|
|
|
399
|
|
|
400 if not Present (Inlined, FN) then
|
|
|
401 Put_Line (Ofile, "");
|
|
|
402 Put_Line
|
|
|
403 (Ofile,
|
|
|
404 " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
|
|
|
405
|
|
|
406 -- Inlined function
|
|
|
407
|
|
|
408 else
|
|
|
409 if not Lastinlined then
|
|
|
410 Put_Line (Ofile, "");
|
|
|
411 end if;
|
|
|
412 end if;
|
|
|
413
|
|
|
414 -- Merge here to output spec
|
|
|
415
|
|
|
416 Sethead (Line, ";");
|
|
|
417 Lastinlined := Get (Inlined, FN);
|
|
|
418 Line := Getlin;
|
|
|
419 end loop;
|
|
|
420
|
|
|
421 Put_Line (Ofile, "");
|
|
|
422
|
|
|
423 -- Read body to find inlined functions
|
|
|
424
|
|
|
425 Close (InB);
|
|
|
426 Close (InF);
|
|
|
427 Open (InF, In_File, "einfo.adb");
|
|
|
428 Lineno := 0;
|
|
|
429
|
|
|
430 -- Loop through input lines to find bodies of inlined functions
|
|
|
431
|
|
|
432 while not End_Of_File (InF) loop
|
|
|
433 Fline := Get_Line (InF);
|
|
|
434
|
|
|
435 if Match (Fline, Get_FN)
|
|
|
436 and then Get (Inlined, FN)
|
|
|
437 then
|
|
|
438 -- Here we have an inlined function
|
|
|
439
|
|
|
440 if not Match (Fline, Is_Rturn) then
|
|
|
441 Line := Fline;
|
|
|
442 Badfunc;
|
|
|
443 end if;
|
|
|
444
|
|
|
445 Line := Getlin;
|
|
|
446
|
|
|
447 if not Match (Line, Is_Begin) then
|
|
|
448 Badfunc;
|
|
|
449 end if;
|
|
|
450
|
|
|
451 -- Skip past pragma Asserts
|
|
|
452
|
|
|
453 loop
|
|
|
454 Line := Getlin;
|
|
|
455 exit when not Match (Line, Get_Asrt);
|
|
|
456
|
|
|
457 -- Pragma assert found, get its continuation lines
|
|
|
458
|
|
|
459 loop
|
|
|
460 exit when Match (Line, Semicoln);
|
|
|
461 Line := Getlin;
|
|
|
462 end loop;
|
|
|
463 end loop;
|
|
|
464
|
|
|
465 -- Process return statement
|
|
|
466
|
|
|
467 Match (Line, Get_Cmnt, M);
|
|
|
468 Replace (M, A);
|
|
|
469
|
|
|
470 -- Get continuations of return statement
|
|
|
471
|
|
|
472 while not Match (Line, Semicoln) loop
|
|
|
473 Nextlin := Getlin;
|
|
|
474 Match (Nextlin, wsp, " ");
|
|
|
475 Append (Line, Nextlin);
|
|
|
476 end loop;
|
|
|
477
|
|
|
478 if not Match (Line, Get_Expr) then
|
|
|
479 Badfunc;
|
|
|
480 end if;
|
|
|
481
|
|
|
482 Line := Getlin;
|
|
|
483
|
|
|
484 if not Match (Line, Chek_End) then
|
|
|
485 Badfunc;
|
|
|
486 end if;
|
|
|
487
|
|
|
488 Match (Expr, Get_B1, M);
|
|
|
489 Replace (M, "IN (" & A & ", " & B & ')');
|
|
|
490 Match (Expr, Get_B2, M);
|
|
|
491 Replace (M, A & " == " & B);
|
|
|
492 Match (Expr, Get_B3, M);
|
|
|
493 Replace (M, A & " != " & B);
|
|
|
494 Match (Expr, Get_B4, M);
|
|
|
495 Replace (M, A & " || " & B);
|
|
|
496 Put_Line (Ofile, "");
|
|
|
497 Sethead (Fline, "");
|
|
|
498 Put_Line (Ofile, C & " { return " & Expr & "; }");
|
|
|
499 end if;
|
|
|
500 end loop;
|
|
|
501
|
|
|
502 Put_Line (Ofile, "");
|
|
|
503
|
|
|
504 Put_Line (Ofile, "#ifdef __cplusplus");
|
|
|
505 Put_Line (Ofile, "}");
|
|
|
506 Put_Line (Ofile, "#endif");
|
|
|
507
|
|
|
508 Put_Line
|
|
|
509 (Ofile,
|
|
|
510 "/* End of einfo.h (C version of Einfo package specification) */");
|
|
|
511
|
|
|
512 Close (InF);
|
|
|
513 Close (Ofile);
|
|
|
514
|
|
|
515 exception
|
|
|
516 when Err =>
|
|
|
517 Put_Line (Standard_Error, Lineno & ". " & Line);
|
|
|
518 Put_Line (Standard_Error, "**** fatal error ****");
|
|
|
519 Set_Exit_Status (1);
|
|
|
520
|
|
|
521 when End_Error =>
|
|
|
522 Put_Line (Standard_Error, "unexpected end of file");
|
|
|
523 Put_Line (Standard_Error, "**** fatal error ****");
|
|
|
524
|
|
|
525 end XEinfo;
|
