1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 -- Program to construct C header file a-einfo.h (C version of einfo.ads spec)
30 -- for use by Gigi. This header file contaInF all definitions and access
31 -- functions, but does not contain set procedures, since Gigi is not allowed
32 -- to modify the GNAT tree)
36 -- einfo.ads spec of Einfo package
37 -- einfo.adb body of Einfo package
41 -- a-einfo.h Corresponding c header file
43 -- Note: It is assumed that the input files have been compiled without errors
45 -- An optional argument allows the specification of an output file name to
46 -- override the default a-einfo.h file name for the generated output file.
48 -- Most, but not all of the functions in Einfo can be inlined in the C header.
49 -- They are the functions identified by pragma Inline in the spec. Functions
50 -- that cannot be inlined are simply defined in the header.
52 with Ada.Command_Line; use Ada.Command_Line;
53 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
54 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
55 with Ada.Strings.Maps; use Ada.Strings.Maps;
56 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
57 with Ada.Text_IO; use Ada.Text_IO;
59 with GNAT.Spitbol; use GNAT.Spitbol;
60 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
61 with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
65 package TB renames GNAT.Spitbol.Table_Boolean;
72 Einfobrev : VString := Nul;
73 Einfosrev : VString := Nul;
74 Expr : VString := Nul;
75 Filler : VString := Nul;
76 Fline : VString := Nul;
77 Formal : VString := Nul;
78 Formaltyp : VString := Nul;
80 Line : VString := Nul;
86 Name : VString := Nul;
87 NewS : VString := Nul;
88 Nextlin : VString := Nul;
89 OldS : VString := Nul;
91 Term : VString := Nul;
92 XEinforev : VString := Nul;
95 -- Used to read initial header from body
98 -- Used to read full text of both spec and body
101 -- Used to write output file
103 wsp : Pattern := NSpan (' ' & ASCII.HT);
104 Get_BRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
105 & Break (' ') * Einfobrev;
106 Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
107 & Break (' ') * Einfosrev;
108 Comment : Pattern := wsp & "--";
109 For_Rep : Pattern := wsp & "for";
110 Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name;
111 Inline : Pattern := wsp & "pragma Inline (" & Break (')') * Name;
112 Get_Pack : Pattern := wsp & "package ";
113 Get_Enam : Pattern := wsp & Break (',') * N & ',';
114 Find_Fun : Pattern := wsp & "function";
115 F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N;
116 G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
117 & wsp & "is" & wsp & Break (" ;") * OldS
118 & wsp & ';' & wsp & Rtab (0);
119 F_Typ : Pattern := wsp * A & "type " & Break (' ') * N & " is (";
120 Get_Nam : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term;
121 Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N;
122 Get_N1 : Pattern := wsp & Break (' ') * N1;
123 Get_N2 : Pattern := wsp & "-- " & Rest * N2;
124 Get_N3 : Pattern := wsp & Break (';') * N3;
125 Get_FN : Pattern := wsp * C & "function" & wsp & Break (" (") * FN;
126 Is_Rturn : Pattern := BreakX ('r') & "return";
127 Is_Begin : Pattern := wsp & "begin";
128 Get_Asrt : Pattern := wsp & "pragma Assert";
129 Semicoln : Pattern := BreakX (';');
130 Get_Cmnt : Pattern := BreakX ('-') * A & "--";
131 Get_Expr : Pattern := wsp & "return " & Break (';') * Expr;
132 Chek_End : Pattern := wsp & "end" & BreakX (';') & ';';
133 Get_B1 : Pattern := BreakX (' ') * A & " in " & Rest * B;
134 Get_B2 : Pattern := BreakX (' ') * A & " = " & Rest * B;
135 Get_B3 : Pattern := BreakX (' ') * A & " /= " & Rest * B;
136 To_Paren : Pattern := wsp * Filler & '(';
137 Get_Fml : Pattern := Break (" :") * Formal & wsp & ':' & wsp
138 & BreakX (" );") * Formaltyp;
139 Nxt_Fml : Pattern := wsp & "; ";
140 Get_Rtn : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
141 Rem_Prn : Pattern := wsp & ')';
145 Lineno : Natural := 0;
146 -- Line number in spec
151 Inlined : TB.Table (200);
152 -- Inlined<N> = True for inlined function, False otherwise
154 Lastinlined : Boolean;
157 -- Signal bad function in body
159 function Getlin return VString;
160 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
161 -- Fatal error (raises End_Error exception) if end of file encountered
163 procedure Must (B : Boolean);
164 -- Raises Err if the argument (a Match) call, returns False
166 procedure Sethead (Line : in out VString; Term : String);
167 -- Process function header into C
177 "Body for function " & FN & " does not meet requirements");
185 function Getlin return VString is
190 Lin := Get_Line (InF);
191 Lineno := Lineno + 1;
194 and then not Match (Lin, Comment)
195 and then not Match (Lin, For_Rep)
206 procedure Must (B : Boolean) is
217 procedure Sethead (Line : in out VString; Term : String) is
221 Must (Match (Line, Get_Func, ""));
224 if Match (Line, To_Paren, "") then
225 Args := Filler & '(';
228 Must (Match (Line, Get_Fml, ""));
229 Append (Args, Formaltyp & ' ' & Formal);
230 exit when not Match (Line, Nxt_Fml);
234 Match (Line, Rem_Prn, "");
238 Must (Match (Line, Get_Rtn));
240 if Present (Inlined, Name) then
241 Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
243 Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
247 -- Start of processing for XEinfo
250 Anchored_Mode := True;
252 Match ("$Revision$", "$Rev" & "ision: " & Break (' ') * XEinforev);
254 if Argument_Count > 0 then
255 Create (Ofile, Out_File, Argument (1));
257 Create (Ofile, Out_File, "a-einfo.h");
260 Open (InB, In_File, "einfo.adb");
261 Open (InF, In_File, "einfo.ads");
265 -- Get einfo revs and write header to output file
268 Line := Get_Line (InB);
274 exit when Match (Line, Get_BRev);
278 Line := Get_Line (InF);
279 Lineno := Lineno + 1;
282 if Match (Line, Get_SRev) then
285 "/* Generated by xeinfo revision " & XEinforev &
289 "/* einfo.ads revision " & Einfosrev &
293 "/* einfo.adb revision " & Einfobrev &
298 "-- C Header File ");
300 Match (Line, "--", "/*");
301 Match (Line, Rtab (2) * A & "--", M);
302 Replace (M, A & "*/");
303 Put_Line (Ofile, Line);
307 Put_Line (Ofile, "");
309 -- Find and record pragma Inlines
312 Line := Get_Line (InF);
313 exit when Match (Line, " -- END XEINFO INLINES");
315 if Match (Line, Inline) then
316 Set (Inlined, Name, True);
320 -- Skip to package line
322 Reset (InF, In_File);
327 exit when Match (Line, Get_Pack);
332 Must (Match (Line, wsp & "type Entity_Kind"));
334 -- Process entity kind code definitions
338 exit when not Match (Line, Get_Enam);
339 Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
343 Must (Match (Line, wsp & Rest * N));
344 Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
347 Must (Match (Line, wsp & ");"));
348 Put_Line (Ofile, "");
350 -- Loop through subtype and type declarations
354 exit when Match (Line, Find_Fun);
356 -- Case of a subtype declaration
358 if Match (Line, F_Subtyp) then
360 -- Case of a subtype declaration that is an abbreviation of the
361 -- form subtype x is y, and if so generate the appropriate typedef
363 if Match (Line, G_Subtyp) then
364 Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
366 -- Otherwise the subtype must be declaring a subrange of Entity_Id
369 Must (Match (Line, Get_Styp));
371 Must (Match (Line, Get_N1));
374 Line := Get_Line (InF);
375 Lineno := Lineno + 1;
376 exit when not Match (Line, Get_N2);
379 Must (Match (Line, Get_N3));
380 Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
381 Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
382 Put_Line (Ofile, "");
385 -- Case of type declaration
387 elsif Match (Line, F_Typ) then
388 -- Process type declaration (must be enumeration type)
391 Put_Line (Ofile, A & "typedef char " & N & ';');
395 Must (Match (Line, Get_Nam));
396 Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
398 exit when Term /= ",";
401 Put_Line (Ofile, "");
403 -- Neither subtype nor type declaration
410 -- Process function declarations
411 -- Note: Lastinlined used to control blank lines
413 Put_Line (Ofile, "");
416 -- Loop through function declarations
418 while Match (Line, Get_FN) loop
420 -- Non-inlined funcion
422 if not Present (Inlined, FN) then
423 Put_Line (Ofile, "");
426 " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
431 if not Lastinlined then
432 Put_Line (Ofile, "");
436 -- Merge here to output spec
439 Lastinlined := Get (Inlined, FN);
443 Put_Line (Ofile, "");
445 -- Read body to find inlined functions
449 Open (InF, In_File, "einfo.adb");
452 -- Loop through input lines to find bodies of inlined functions
454 while not End_Of_File (InF) loop
455 Fline := Get_Line (InF);
457 if Match (Fline, Get_FN)
458 and then Get (Inlined, FN)
460 -- Here we have an inlined function
462 if not Match (Fline, Is_Rturn) then
469 if not Match (Line, Is_Begin) then
473 -- Skip past pragma Asserts
477 exit when not Match (Line, Get_Asrt);
479 -- Pragma asser found, get its continuation lines
482 exit when Match (Line, Semicoln);
487 -- Process return statement
489 Match (Line, Get_Cmnt, M);
492 -- Get continuations of return statemnt
494 while not Match (Line, Semicoln) loop
496 Match (Nextlin, wsp, " ");
497 Append (Line, Nextlin);
500 if not Match (Line, Get_Expr) then
506 if not Match (Line, Chek_End) then
510 Match (Expr, Get_B1, M);
511 Replace (M, "IN (" & A & ", " & B & ')');
512 Match (Expr, Get_B2, M);
513 Replace (M, A & " == " & B);
514 Match (Expr, Get_B3, M);
515 Replace (M, A & " != " & B);
516 Put_Line (Ofile, "");
518 Put_Line (Ofile, C & " { return " & Expr & "; }");
522 Put_Line (Ofile, "");
525 "/* End of einfo.h (C version of Einfo package specification) */");
529 Put_Line (Standard_Error, Lineno & ". " & Line);
530 Put_Line (Standard_Error, "**** fatal error ****");
534 Put_Line (Standard_Error, "unexpected end of file");
535 Put_Line (Standard_Error, "**** fatal error ****");