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