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