1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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.
33 -- einfo.ads spec of Einfo package
34 -- einfo.adb body of Einfo package
38 -- einfo.h corresponding C header file
40 -- Note: It is assumed that the input files have been compiled without errors
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.
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.
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
;
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
;
64 package TB
renames GNAT
.Spitbol
.Table_Boolean
;
71 Expr
: VString
:= Nul
;
72 Filler
: VString
:= Nul
;
73 Fline
: VString
:= Nul
;
74 Formal
: VString
:= Nul
;
75 Formaltyp
: VString
:= Nul
;
77 Line
: VString
:= Nul
;
83 Name
: VString
:= Nul
;
84 NewS
: VString
:= Nul
;
85 Nextlin
: VString
:= Nul
;
86 OldS
: VString
:= Nul
;
88 Term
: VString
:= Nul
;
91 -- Used to read initial header from body
94 -- Used to read full text of both spec and body
97 -- Used to write output file
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
&
114 Get_Nam
: constant Pattern
:= wsp
* A
& Break
(",)") * Nam
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
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
& ')';
142 Lineno
: Natural := 0;
143 -- Line number in spec
148 Inlined
: TB
.Table
(200);
149 -- Inlined<N> = True for inlined function, False otherwise
151 Lastinlined
: Boolean;
154 pragma No_Return
(Badfunc
);
155 -- Signal bad function in body
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
161 procedure Must
(B
: Boolean);
162 -- Raises Err if the argument (a Match) call, returns False
164 procedure Sethead
(Line
: in out VString
; Term
: String);
165 -- Process function header into C
175 "Body for function " & FN
& " does not meet requirements");
183 function Getlin
return VString
is
188 Lin
:= Get_Line
(InF
);
189 Lineno
:= Lineno
+ 1;
192 and then not Match
(Lin
, Comment
)
193 and then not Match
(Lin
, For_Rep
)
204 procedure Must
(B
: Boolean) is
215 procedure Sethead
(Line
: in out VString
; Term
: String) is
219 Must
(Match
(Line
, Get_Func
, ""));
222 if Match
(Line
, To_Paren
, "") then
223 Args
:= Filler
& '(';
226 Must
(Match
(Line
, Get_Fml
, ""));
227 Append
(Args
, Formaltyp
& ' ' & Formal
);
228 exit when not Match
(Line
, Nxt_Fml
);
232 Match
(Line
, Rem_Prn
, "");
236 Must
(Match
(Line
, Get_Rtn
));
238 if Present
(Inlined
, Name
) then
239 Put_Line
(Ofile
, A
& "INLINE " & Rtn
& ' ' & Name
& Args
& Term
);
241 Put_Line
(Ofile
, A
& Rtn
& ' ' & Name
& Args
& Term
);
245 -- Start of processing for XEinfo
248 -- First run CEinfo to check for errors. Note that CEinfo is also a
249 -- stand-alone program that can be run separately.
253 Anchored_Mode
:= True;
255 if Argument_Count
> 0 then
256 Create
(Ofile
, Out_File
, Argument
(1));
258 Create
(Ofile
, Out_File
, "einfo.h");
261 Open
(InB
, In_File
, "einfo.adb");
262 Open
(InF
, In_File
, "einfo.ads");
266 Line
:= Get_Line
(InF
);
267 Lineno
:= Lineno
+ 1;
272 "-- C Header File ");
273 Match
(Line
, "--", "/*");
274 Match
(Line
, Rtab
(2) * A
& "--", M
);
275 Replace
(M
, A
& "*/");
276 Put_Line
(Ofile
, Line
);
279 Put_Line
(Ofile
, "");
281 Put_Line
(Ofile
, "#ifdef __cplusplus");
282 Put_Line
(Ofile
, "extern ""C"" {");
283 Put_Line
(Ofile
, "#endif");
285 -- Find and record pragma Inlines
288 Line
:= Get_Line
(InF
);
289 exit when Match
(Line
, " -- END XEINFO INLINES");
291 if Match
(Line
, Inline
) then
292 Set
(Inlined
, Name
, True);
296 -- Skip to package line
298 Reset
(InF
, In_File
);
303 exit when Match
(Line
, Get_Pack
);
308 Must
(Match
(Line
, wsp
& "type Entity_Kind"));
310 -- Process entity kind code definitions
314 exit when not Match
(Line
, Get_Enam
);
315 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & " " & V
);
319 Must
(Match
(Line
, wsp
& Rest
* N
));
320 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & ' ' & V
);
323 Must
(Match
(Line
, wsp
& ");"));
324 Put_Line
(Ofile
, "");
326 -- Loop through subtype and type declarations
330 exit when Match
(Line
, Find_Fun
);
332 -- Case of a subtype declaration
334 if Match
(Line
, F_Subtyp
) then
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
339 if Match
(Line
, G_Subtyp
) then
340 Put_Line
(Ofile
, A
& "typedef " & OldS
& ' ' & NewS
& ';');
342 -- Otherwise the subtype must be declaring a subrange of Entity_Id
345 Must
(Match
(Line
, Get_Styp
));
347 Must
(Match
(Line
, Get_N1
));
350 Line
:= Get_Line
(InF
);
351 Lineno
:= Lineno
+ 1;
352 exit when not Match
(Line
, Get_N2
);
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
, "");
361 -- Case of type declaration
363 elsif Match
(Line
, F_Typ
) then
365 -- Process type declaration (must be enumeration type)
368 Put_Line
(Ofile
, A
& "typedef char " & N
& ';');
372 Must
(Match
(Line
, Get_Nam
));
373 Put_Line
(Ofile
, A
& "#define " & Rpad
(Nam
, 25) & Ctr
);
375 exit when Term
/= ",";
378 Put_Line
(Ofile
, "");
380 -- Neither subtype nor type declaration
387 -- Process function declarations
389 -- Note: Lastinlined used to control blank lines
391 Put_Line
(Ofile
, "");
394 -- Loop through function declarations
396 while Match
(Line
, Get_FN
) loop
398 -- Non-inlined function
400 if not Present
(Inlined
, FN
) then
401 Put_Line
(Ofile
, "");
404 " #define " & FN
& " einfo__" & Translate
(FN
, Lower_Case_Map
));
409 if not Lastinlined
then
410 Put_Line
(Ofile
, "");
414 -- Merge here to output spec
417 Lastinlined
:= Get
(Inlined
, FN
);
421 Put_Line
(Ofile
, "");
423 -- Read body to find inlined functions
427 Open
(InF
, In_File
, "einfo.adb");
430 -- Loop through input lines to find bodies of inlined functions
432 while not End_Of_File
(InF
) loop
433 Fline
:= Get_Line
(InF
);
435 if Match
(Fline
, Get_FN
)
436 and then Get
(Inlined
, FN
)
438 -- Here we have an inlined function
440 if not Match
(Fline
, Is_Rturn
) then
447 if not Match
(Line
, Is_Begin
) then
451 -- Skip past pragma Asserts
455 exit when not Match
(Line
, Get_Asrt
);
457 -- Pragma assert found, get its continuation lines
460 exit when Match
(Line
, Semicoln
);
465 -- Process return statement
467 Match
(Line
, Get_Cmnt
, M
);
470 -- Get continuations of return statement
472 while not Match
(Line
, Semicoln
) loop
474 Match
(Nextlin
, wsp
, " ");
475 Append
(Line
, Nextlin
);
478 if not Match
(Line
, Get_Expr
) then
484 if not Match
(Line
, Chek_End
) then
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
, "");
498 Put_Line
(Ofile
, C
& " { return " & Expr
& "; }");
502 Put_Line
(Ofile
, "");
504 Put_Line
(Ofile
, "#ifdef __cplusplus");
505 Put_Line
(Ofile
, "}");
506 Put_Line
(Ofile
, "#endif");
510 "/* End of einfo.h (C version of Einfo package specification) */");
517 Put_Line
(Standard_Error
, Lineno
& ". " & Line
);
518 Put_Line
(Standard_Error
, "**** fatal error ****");
522 Put_Line
(Standard_Error
, "unexpected end of file");
523 Put_Line
(Standard_Error
, "**** fatal error ****");