1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2007, 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 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)
33 -- einfo.ads spec of Einfo package
34 -- einfo.adb body of Einfo package
38 -- a-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 a-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
;
62 package TB
renames GNAT
.Spitbol
.Table_Boolean
;
69 Expr
: VString
:= Nul
;
70 Filler
: VString
:= Nul
;
71 Fline
: VString
:= Nul
;
72 Formal
: VString
:= Nul
;
73 Formaltyp
: VString
:= Nul
;
75 Line
: VString
:= Nul
;
81 Name
: VString
:= Nul
;
82 NewS
: VString
:= Nul
;
83 Nextlin
: VString
:= Nul
;
84 OldS
: VString
:= Nul
;
86 Term
: VString
:= Nul
;
89 -- Used to read initial header from body
92 -- Used to read full text of both spec and body
95 -- Used to write output file
97 wsp
: Pattern
:= NSpan
(' ' & ASCII
.HT
);
98 Comment
: Pattern
:= wsp
& "--";
99 For_Rep
: Pattern
:= wsp
& "for";
100 Get_Func
: Pattern
:= wsp
* A
& "function" & wsp
& Break
(' ') * Name
;
101 Inline
: Pattern
:= wsp
& "pragma Inline (" & Break
(')') * Name
;
102 Get_Pack
: Pattern
:= wsp
& "package ";
103 Get_Enam
: Pattern
:= wsp
& Break
(',') * N
& ',';
104 Find_Fun
: Pattern
:= wsp
& "function";
105 F_Subtyp
: Pattern
:= wsp
* A
& "subtype " & Break
(' ') * N
;
106 G_Subtyp
: Pattern
:= wsp
& "subtype" & wsp
& Break
(' ') * NewS
107 & wsp
& "is" & wsp
& Break
(" ;") * OldS
108 & wsp
& ';' & wsp
& Rtab
(0);
109 F_Typ
: Pattern
:= wsp
* A
& "type " & Break
(' ') * N
& " is (";
110 Get_Nam
: Pattern
:= wsp
* A
& Break
(",)") * Nam
& Len
(1) * Term
;
111 Get_Styp
: Pattern
:= wsp
* A
& "subtype " & Break
(' ') * N
;
112 Get_N1
: Pattern
:= wsp
& Break
(' ') * N1
;
113 Get_N2
: Pattern
:= wsp
& "-- " & Rest
* N2
;
114 Get_N3
: Pattern
:= wsp
& Break
(';') * N3
;
115 Get_FN
: Pattern
:= wsp
* C
& "function" & wsp
& Break
(" (") * FN
;
116 Is_Rturn
: Pattern
:= BreakX
('r') & "return";
117 Is_Begin
: Pattern
:= wsp
& "begin";
118 Get_Asrt
: Pattern
:= wsp
& "pragma Assert";
119 Semicoln
: Pattern
:= BreakX
(';');
120 Get_Cmnt
: Pattern
:= BreakX
('-') * A
& "--";
121 Get_Expr
: Pattern
:= wsp
& "return " & Break
(';') * Expr
;
122 Chek_End
: Pattern
:= wsp
& "end" & BreakX
(';') & ';';
123 Get_B1
: Pattern
:= BreakX
(' ') * A
& " in " & Rest
* B
;
124 Get_B2
: Pattern
:= BreakX
(' ') * A
& " = " & Rest
* B
;
125 Get_B3
: Pattern
:= BreakX
(' ') * A
& " /= " & Rest
* B
;
126 To_Paren
: Pattern
:= wsp
* Filler
& '(';
127 Get_Fml
: Pattern
:= Break
(" :") * Formal
& wsp
& ':' & wsp
128 & BreakX
(" );") * Formaltyp
;
129 Nxt_Fml
: Pattern
:= wsp
& "; ";
130 Get_Rtn
: Pattern
:= wsp
& "return" & wsp
& BreakX
(" ;") * Rtn
;
131 Rem_Prn
: Pattern
:= wsp
& ')';
135 Lineno
: Natural := 0;
136 -- Line number in spec
141 Inlined
: TB
.Table
(200);
142 -- Inlined<N> = True for inlined function, False otherwise
144 Lastinlined
: Boolean;
147 -- Signal bad function in body
149 function Getlin
return VString
;
150 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
151 -- Fatal error (raises End_Error exception) if end of file encountered
153 procedure Must
(B
: Boolean);
154 -- Raises Err if the argument (a Match) call, returns False
156 procedure Sethead
(Line
: in out VString
; Term
: String);
157 -- Process function header into C
167 "Body for function " & FN
& " does not meet requirements");
175 function Getlin
return VString
is
180 Lin
:= Get_Line
(InF
);
181 Lineno
:= Lineno
+ 1;
184 and then not Match
(Lin
, Comment
)
185 and then not Match
(Lin
, For_Rep
)
196 procedure Must
(B
: Boolean) is
207 procedure Sethead
(Line
: in out VString
; Term
: String) is
211 Must
(Match
(Line
, Get_Func
, ""));
214 if Match
(Line
, To_Paren
, "") then
215 Args
:= Filler
& '(';
218 Must
(Match
(Line
, Get_Fml
, ""));
219 Append
(Args
, Formaltyp
& ' ' & Formal
);
220 exit when not Match
(Line
, Nxt_Fml
);
224 Match
(Line
, Rem_Prn
, "");
228 Must
(Match
(Line
, Get_Rtn
));
230 if Present
(Inlined
, Name
) then
231 Put_Line
(Ofile
, A
& "INLINE " & Rtn
& ' ' & Name
& Args
& Term
);
233 Put_Line
(Ofile
, A
& Rtn
& ' ' & Name
& Args
& Term
);
237 -- Start of processing for XEinfo
240 Anchored_Mode
:= True;
242 if Argument_Count
> 0 then
243 Create
(Ofile
, Out_File
, Argument
(1));
245 Create
(Ofile
, Out_File
, "a-einfo.h");
248 Open
(InB
, In_File
, "einfo.adb");
249 Open
(InF
, In_File
, "einfo.ads");
253 Line
:= Get_Line
(InF
);
254 Lineno
:= Lineno
+ 1;
259 "-- C Header File ");
260 Match
(Line
, "--", "/*");
261 Match
(Line
, Rtab
(2) * A
& "--", M
);
262 Replace
(M
, A
& "*/");
263 Put_Line
(Ofile
, Line
);
266 Put_Line
(Ofile
, "");
268 -- Find and record pragma Inlines
271 Line
:= Get_Line
(InF
);
272 exit when Match
(Line
, " -- END XEINFO INLINES");
274 if Match
(Line
, Inline
) then
275 Set
(Inlined
, Name
, True);
279 -- Skip to package line
281 Reset
(InF
, In_File
);
286 exit when Match
(Line
, Get_Pack
);
291 Must
(Match
(Line
, wsp
& "type Entity_Kind"));
293 -- Process entity kind code definitions
297 exit when not Match
(Line
, Get_Enam
);
298 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & " " & V
);
302 Must
(Match
(Line
, wsp
& Rest
* N
));
303 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & ' ' & V
);
306 Must
(Match
(Line
, wsp
& ");"));
307 Put_Line
(Ofile
, "");
309 -- Loop through subtype and type declarations
313 exit when Match
(Line
, Find_Fun
);
315 -- Case of a subtype declaration
317 if Match
(Line
, F_Subtyp
) then
319 -- Case of a subtype declaration that is an abbreviation of the
320 -- form subtype x is y, and if so generate the appropriate typedef
322 if Match
(Line
, G_Subtyp
) then
323 Put_Line
(Ofile
, A
& "typedef " & OldS
& ' ' & NewS
& ';');
325 -- Otherwise the subtype must be declaring a subrange of Entity_Id
328 Must
(Match
(Line
, Get_Styp
));
330 Must
(Match
(Line
, Get_N1
));
333 Line
:= Get_Line
(InF
);
334 Lineno
:= Lineno
+ 1;
335 exit when not Match
(Line
, Get_N2
);
338 Must
(Match
(Line
, Get_N3
));
339 Put_Line
(Ofile
, A
& "SUBTYPE (" & N
& ", Entity_Kind, ");
340 Put_Line
(Ofile
, A
& " " & N1
& ", " & N3
& ')');
341 Put_Line
(Ofile
, "");
344 -- Case of type declaration
346 elsif Match
(Line
, F_Typ
) then
347 -- Process type declaration (must be enumeration type)
350 Put_Line
(Ofile
, A
& "typedef char " & N
& ';');
354 Must
(Match
(Line
, Get_Nam
));
355 Put_Line
(Ofile
, A
& "#define " & Rpad
(Nam
, 25) & Ctr
);
357 exit when Term
/= ",";
360 Put_Line
(Ofile
, "");
362 -- Neither subtype nor type declaration
369 -- Process function declarations
370 -- Note: Lastinlined used to control blank lines
372 Put_Line
(Ofile
, "");
375 -- Loop through function declarations
377 while Match
(Line
, Get_FN
) loop
379 -- Non-inlined funcion
381 if not Present
(Inlined
, FN
) then
382 Put_Line
(Ofile
, "");
385 " #define " & FN
& " einfo__" & Translate
(FN
, Lower_Case_Map
));
390 if not Lastinlined
then
391 Put_Line
(Ofile
, "");
395 -- Merge here to output spec
398 Lastinlined
:= Get
(Inlined
, FN
);
402 Put_Line
(Ofile
, "");
404 -- Read body to find inlined functions
408 Open
(InF
, In_File
, "einfo.adb");
411 -- Loop through input lines to find bodies of inlined functions
413 while not End_Of_File
(InF
) loop
414 Fline
:= Get_Line
(InF
);
416 if Match
(Fline
, Get_FN
)
417 and then Get
(Inlined
, FN
)
419 -- Here we have an inlined function
421 if not Match
(Fline
, Is_Rturn
) then
428 if not Match
(Line
, Is_Begin
) then
432 -- Skip past pragma Asserts
436 exit when not Match
(Line
, Get_Asrt
);
438 -- Pragma asser found, get its continuation lines
441 exit when Match
(Line
, Semicoln
);
446 -- Process return statement
448 Match
(Line
, Get_Cmnt
, M
);
451 -- Get continuations of return statemnt
453 while not Match
(Line
, Semicoln
) loop
455 Match
(Nextlin
, wsp
, " ");
456 Append
(Line
, Nextlin
);
459 if not Match
(Line
, Get_Expr
) then
465 if not Match
(Line
, Chek_End
) then
469 Match
(Expr
, Get_B1
, M
);
470 Replace
(M
, "IN (" & A
& ", " & B
& ')');
471 Match
(Expr
, Get_B2
, M
);
472 Replace
(M
, A
& " == " & B
);
473 Match
(Expr
, Get_B3
, M
);
474 Replace
(M
, A
& " != " & B
);
475 Put_Line
(Ofile
, "");
477 Put_Line
(Ofile
, C
& " { return " & Expr
& "; }");
481 Put_Line
(Ofile
, "");
484 "/* End of einfo.h (C version of Einfo package specification) */");
488 Put_Line
(Standard_Error
, Lineno
& ". " & Line
);
489 Put_Line
(Standard_Error
, "**** fatal error ****");
493 Put_Line
(Standard_Error
, "unexpected end of file");
494 Put_Line
(Standard_Error
, "**** fatal error ****");