File : xeinfo.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- X E I N F O --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, 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 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;
154 -- Signal bad function in body
155
156 function Getlin return VString;
157 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
158 -- Fatal error (raises End_Error exception) if end of file encountered
159
160 procedure Must (B : Boolean);
161 -- Raises Err if the argument (a Match) call, returns False
162
163 procedure Sethead (Line : in out VString; Term : String);
164 -- Process function header into C
165
166 -------------
167 -- Badfunc --
168 -------------
169
170 procedure Badfunc is
171 begin
172 Put_Line
173 (Standard_Error,
174 "Body for function " & FN & " does not meet requirements");
175 raise Err;
176 end Badfunc;
177
178 -------------
179 -- Getlin --
180 -------------
181
182 function Getlin return VString is
183 Lin : VString;
184
185 begin
186 loop
187 Lin := Get_Line (InF);
188 Lineno := Lineno + 1;
189
190 if Lin /= ""
191 and then not Match (Lin, Comment)
192 and then not Match (Lin, For_Rep)
193 then
194 return Lin;
195 end if;
196 end loop;
197 end Getlin;
198
199 ----------
200 -- Must --
201 ----------
202
203 procedure Must (B : Boolean) is
204 begin
205 if not B then
206 raise Err;
207 end if;
208 end Must;
209
210 -------------
211 -- Sethead --
212 -------------
213
214 procedure Sethead (Line : in out VString; Term : String) is
215 Args : VString;
216
217 begin
218 Must (Match (Line, Get_Func, ""));
219 Args := Nul;
220
221 if Match (Line, To_Paren, "") then
222 Args := Filler & '(';
223
224 loop
225 Must (Match (Line, Get_Fml, ""));
226 Append (Args, Formaltyp & ' ' & Formal);
227 exit when not Match (Line, Nxt_Fml);
228 Append (Args, ",");
229 end loop;
230
231 Match (Line, Rem_Prn, "");
232 Append (Args, ')');
233 end if;
234
235 Must (Match (Line, Get_Rtn));
236
237 if Present (Inlined, Name) then
238 Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
239 else
240 Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
241 end if;
242 end Sethead;
243
244 -- Start of processing for XEinfo
245
246 begin
247 -- First run CEinfo to check for errors. Note that CEinfo is also a
248 -- stand-alone program that can be run separately.
249
250 CEinfo;
251
252 Anchored_Mode := True;
253
254 if Argument_Count > 0 then
255 Create (Ofile, Out_File, Argument (1));
256 else
257 Create (Ofile, Out_File, "einfo.h");
258 end if;
259
260 Open (InB, In_File, "einfo.adb");
261 Open (InF, In_File, "einfo.ads");
262
263 Lineno := 0;
264 loop
265 Line := Get_Line (InF);
266 Lineno := Lineno + 1;
267 exit when Line = "";
268
269 Match (Line,
270 "-- S p e c ",
271 "-- C Header File ");
272 Match (Line, "--", "/*");
273 Match (Line, Rtab (2) * A & "--", M);
274 Replace (M, A & "*/");
275 Put_Line (Ofile, Line);
276 end loop;
277
278 Put_Line (Ofile, "");
279
280 Put_Line (Ofile, "#ifdef __cplusplus");
281 Put_Line (Ofile, "extern ""C"" {");
282 Put_Line (Ofile, "#endif");
283
284 -- Find and record pragma Inlines
285
286 loop
287 Line := Get_Line (InF);
288 exit when Match (Line, " -- END XEINFO INLINES");
289
290 if Match (Line, Inline) then
291 Set (Inlined, Name, True);
292 end if;
293 end loop;
294
295 -- Skip to package line
296
297 Reset (InF, In_File);
298 Lineno := 0;
299
300 loop
301 Line := Getlin;
302 exit when Match (Line, Get_Pack);
303 end loop;
304
305 V := 0;
306 Line := Getlin;
307 Must (Match (Line, wsp & "type Entity_Kind"));
308
309 -- Process entity kind code definitions
310
311 loop
312 Line := Getlin;
313 exit when not Match (Line, Get_Enam);
314 Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
315 V := V + 1;
316 end loop;
317
318 Must (Match (Line, wsp & Rest * N));
319 Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
320 Line := Getlin;
321
322 Must (Match (Line, wsp & ");"));
323 Put_Line (Ofile, "");
324
325 -- Loop through subtype and type declarations
326
327 loop
328 Line := Getlin;
329 exit when Match (Line, Find_Fun);
330
331 -- Case of a subtype declaration
332
333 if Match (Line, F_Subtyp) then
334
335 -- Case of a subtype declaration that is an abbreviation of the
336 -- form subtype x is y, and if so generate the appropriate typedef
337
338 if Match (Line, G_Subtyp) then
339 Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
340
341 -- Otherwise the subtype must be declaring a subrange of Entity_Id
342
343 else
344 Must (Match (Line, Get_Styp));
345 Line := Getlin;
346 Must (Match (Line, Get_N1));
347
348 loop
349 Line := Get_Line (InF);
350 Lineno := Lineno + 1;
351 exit when not Match (Line, Get_N2);
352 end loop;
353
354 Must (Match (Line, Get_N3));
355 Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
356 Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
357 Put_Line (Ofile, "");
358 end if;
359
360 -- Case of type declaration
361
362 elsif Match (Line, F_Typ) then
363
364 -- Process type declaration (must be enumeration type)
365
366 Ctr := 0;
367 Put_Line (Ofile, A & "typedef char " & N & ';');
368
369 loop
370 Line := Getlin;
371 Must (Match (Line, Get_Nam));
372 Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
373 Ctr := Ctr + 1;
374 exit when Term /= ",";
375 end loop;
376
377 Put_Line (Ofile, "");
378
379 -- Neither subtype nor type declaration
380
381 else
382 raise Err;
383 end if;
384 end loop;
385
386 -- Process function declarations
387
388 -- Note: Lastinlined used to control blank lines
389
390 Put_Line (Ofile, "");
391 Lastinlined := True;
392
393 -- Loop through function declarations
394
395 while Match (Line, Get_FN) loop
396
397 -- Non-inlined function
398
399 if not Present (Inlined, FN) then
400 Put_Line (Ofile, "");
401 Put_Line
402 (Ofile,
403 " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
404
405 -- Inlined function
406
407 else
408 if not Lastinlined then
409 Put_Line (Ofile, "");
410 end if;
411 end if;
412
413 -- Merge here to output spec
414
415 Sethead (Line, ";");
416 Lastinlined := Get (Inlined, FN);
417 Line := Getlin;
418 end loop;
419
420 Put_Line (Ofile, "");
421
422 -- Read body to find inlined functions
423
424 Close (InB);
425 Close (InF);
426 Open (InF, In_File, "einfo.adb");
427 Lineno := 0;
428
429 -- Loop through input lines to find bodies of inlined functions
430
431 while not End_Of_File (InF) loop
432 Fline := Get_Line (InF);
433
434 if Match (Fline, Get_FN)
435 and then Get (Inlined, FN)
436 then
437 -- Here we have an inlined function
438
439 if not Match (Fline, Is_Rturn) then
440 Line := Fline;
441 Badfunc;
442 end if;
443
444 Line := Getlin;
445
446 if not Match (Line, Is_Begin) then
447 Badfunc;
448 end if;
449
450 -- Skip past pragma Asserts
451
452 loop
453 Line := Getlin;
454 exit when not Match (Line, Get_Asrt);
455
456 -- Pragma assert found, get its continuation lines
457
458 loop
459 exit when Match (Line, Semicoln);
460 Line := Getlin;
461 end loop;
462 end loop;
463
464 -- Process return statement
465
466 Match (Line, Get_Cmnt, M);
467 Replace (M, A);
468
469 -- Get continuations of return statement
470
471 while not Match (Line, Semicoln) loop
472 Nextlin := Getlin;
473 Match (Nextlin, wsp, " ");
474 Append (Line, Nextlin);
475 end loop;
476
477 if not Match (Line, Get_Expr) then
478 Badfunc;
479 end if;
480
481 Line := Getlin;
482
483 if not Match (Line, Chek_End) then
484 Badfunc;
485 end if;
486
487 Match (Expr, Get_B1, M);
488 Replace (M, "IN (" & A & ", " & B & ')');
489 Match (Expr, Get_B2, M);
490 Replace (M, A & " == " & B);
491 Match (Expr, Get_B3, M);
492 Replace (M, A & " != " & B);
493 Match (Expr, Get_B4, M);
494 Replace (M, A & " || " & B);
495 Put_Line (Ofile, "");
496 Sethead (Fline, "");
497 Put_Line (Ofile, C & " { return " & Expr & "; }");
498 end if;
499 end loop;
500
501 Put_Line (Ofile, "");
502
503 Put_Line (Ofile, "#ifdef __cplusplus");
504 Put_Line (Ofile, "}");
505 Put_Line (Ofile, "#endif");
506
507 Put_Line
508 (Ofile,
509 "/* End of einfo.h (C version of Einfo package specification) */");
510
511 Close (InF);
512 Close (Ofile);
513
514 exception
515 when Err =>
516 Put_Line (Standard_Error, Lineno & ". " & Line);
517 Put_Line (Standard_Error, "**** fatal error ****");
518 Set_Exit_Status (1);
519
520 when End_Error =>
521 Put_Line (Standard_Error, "unexpected end of file");
522 Put_Line (Standard_Error, "**** fatal error ****");
523
524 end XEinfo;