1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- Program to construct C header file a-einfo.h (C version of einfo.ads spec)
28 -- for use by Gigi. This header file contaInF all definitions and access
29 -- functions, but does not contain set procedures, since Gigi is not allowed
30 -- to modify the GNAT tree)
34 -- einfo.ads spec of Einfo package
35 -- einfo.adb body of Einfo package
39 -- a-einfo.h Corresponding c header file
41 -- Note: It is assumed that the input files have been compiled without errors
43 -- An optional argument allows the specification of an output file name to
44 -- override the default a-einfo.h file name for the generated output file.
46 -- Most, but not all of the functions in Einfo can be inlined in the C header.
47 -- They are the functions identified by pragma Inline in the spec. Functions
48 -- that cannot be inlined are simply defined in the header.
50 with Ada
.Command_Line
; use Ada
.Command_Line
;
51 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
52 with Ada
.Strings
.Unbounded
.Text_IO
; use Ada
.Strings
.Unbounded
.Text_IO
;
53 with Ada
.Strings
.Maps
; use Ada
.Strings
.Maps
;
54 with Ada
.Strings
.Maps
.Constants
; use Ada
.Strings
.Maps
.Constants
;
55 with Ada
.Text_IO
; use Ada
.Text_IO
;
57 with GNAT
.Spitbol
; use GNAT
.Spitbol
;
58 with GNAT
.Spitbol
.Patterns
; use GNAT
.Spitbol
.Patterns
;
59 with GNAT
.Spitbol
.Table_Boolean
; use GNAT
.Spitbol
.Table_Boolean
;
63 package TB
renames GNAT
.Spitbol
.Table_Boolean
;
70 Expr
: VString
:= Nul
;
71 Filler
: VString
:= Nul
;
72 Fline
: VString
:= Nul
;
73 Formal
: VString
:= Nul
;
74 Formaltyp
: VString
:= Nul
;
76 Line
: VString
:= Nul
;
82 Name
: VString
:= Nul
;
83 NewS
: VString
:= Nul
;
84 Nextlin
: VString
:= Nul
;
85 OldS
: VString
:= Nul
;
87 Term
: VString
:= Nul
;
90 -- Used to read full text of both spec and body
93 -- Used to write output file
95 wsp
: Pattern
:= NSpan
(' ' & ASCII
.HT
);
96 Comment
: Pattern
:= wsp
& "--";
97 For_Rep
: Pattern
:= wsp
& "for";
98 Get_Func
: Pattern
:= wsp
* A
& "function" & wsp
& Break
(' ') * Name
;
99 Inline
: Pattern
:= wsp
& "pragma Inline (" & Break
(')') * Name
;
100 Get_Pack
: Pattern
:= wsp
& "package ";
101 Get_Enam
: Pattern
:= wsp
& Break
(',') * N
& ',';
102 Find_Fun
: Pattern
:= wsp
& "function";
103 F_Subtyp
: Pattern
:= wsp
* A
& "subtype " & Break
(' ') * N
;
104 G_Subtyp
: Pattern
:= wsp
& "subtype" & wsp
& Break
(' ') * NewS
105 & wsp
& "is" & wsp
& Break
(" ;") * OldS
106 & wsp
& ';' & wsp
& Rtab
(0);
107 F_Typ
: Pattern
:= wsp
* A
& "type " & Break
(' ') * N
& " is (";
108 Get_Nam
: Pattern
:= wsp
* A
& Break
(",)") * Nam
& Len
(1) * Term
;
109 Get_Styp
: Pattern
:= wsp
* A
& "subtype " & Break
(' ') * N
;
110 Get_N1
: Pattern
:= wsp
& Break
(' ') * N1
;
111 Get_N2
: Pattern
:= wsp
& "-- " & Rest
* N2
;
112 Get_N3
: Pattern
:= wsp
& Break
(';') * N3
;
113 Get_FN
: Pattern
:= wsp
* C
& "function" & wsp
& Break
(" (") * FN
;
114 Is_Rturn
: Pattern
:= BreakX
('r') & "return";
115 Is_Begin
: Pattern
:= wsp
& "begin";
116 Get_Asrt
: Pattern
:= wsp
& "pragma Assert";
117 Semicoln
: Pattern
:= BreakX
(';');
118 Get_Cmnt
: Pattern
:= BreakX
('-') * A
& "--";
119 Get_Expr
: Pattern
:= wsp
& "return " & Break
(';') * Expr
;
120 Chek_End
: Pattern
:= wsp
& "end" & BreakX
(';') & ';';
121 Get_B1
: Pattern
:= BreakX
(' ') * A
& " in " & Rest
* B
;
122 Get_B2
: Pattern
:= BreakX
(' ') * A
& " = " & Rest
* B
;
123 Get_B3
: Pattern
:= BreakX
(' ') * A
& " /= " & Rest
* B
;
124 To_Paren
: Pattern
:= wsp
* Filler
& '(';
125 Get_Fml
: Pattern
:= Break
(" :") * Formal
& wsp
& ':' & wsp
126 & BreakX
(" );") * Formaltyp
;
127 Nxt_Fml
: Pattern
:= wsp
& "; ";
128 Get_Rtn
: Pattern
:= wsp
& "return" & wsp
& BreakX
(" ;") * Rtn
;
129 Rem_Prn
: Pattern
:= wsp
& ')';
133 Lineno
: Natural := 0;
134 -- Line number in spec
139 Inlined
: TB
.Table
(200);
140 -- Inlined<N> = True for inlined function, False otherwise
142 Lastinlined
: Boolean;
145 -- Signal bad function in body
147 function Getlin
return VString
;
148 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
149 -- Fatal error (raises End_Error exception) if end of file encountered
151 procedure Must
(B
: Boolean);
152 -- Raises Err if the argument (a Match) call, returns False
154 procedure Sethead
(Line
: in out VString
; Term
: String);
155 -- Process function header into C
165 "Body for function " & FN
& " does not meet requirements");
173 function Getlin
return VString
is
178 Lin
:= Get_Line
(InF
);
179 Lineno
:= Lineno
+ 1;
182 and then not Match
(Lin
, Comment
)
183 and then not Match
(Lin
, For_Rep
)
194 procedure Must
(B
: Boolean) is
205 procedure Sethead
(Line
: in out VString
; Term
: String) is
209 Must
(Match
(Line
, Get_Func
, ""));
212 if Match
(Line
, To_Paren
, "") then
213 Args
:= Filler
& '(';
216 Must
(Match
(Line
, Get_Fml
, ""));
217 Append
(Args
, Formaltyp
& ' ' & Formal
);
218 exit when not Match
(Line
, Nxt_Fml
);
222 Match
(Line
, Rem_Prn
, "");
226 Must
(Match
(Line
, Get_Rtn
));
228 if Present
(Inlined
, Name
) then
229 Put_Line
(Ofile
, A
& "INLINE " & Rtn
& ' ' & Name
& Args
& Term
);
231 Put_Line
(Ofile
, A
& Rtn
& ' ' & Name
& Args
& Term
);
235 -- Start of processing for XEinfo
238 Anchored_Mode
:= True;
240 if Argument_Count
> 0 then
241 Create
(Ofile
, Out_File
, Argument
(1));
243 Create
(Ofile
, Out_File
, "a-einfo.h");
246 Open
(InF
, In_File
, "einfo.ads");
250 -- Write header to output file
253 Line
:= Get_Line
(InF
);
254 Lineno
:= Lineno
+ 1;
259 "-- C Header File ");
261 Match
(Line
, "--", "/*");
262 Match
(Line
, Rtab
(2) * A
& "--", M
);
263 Replace
(M
, A
& "*/");
264 Put_Line
(Ofile
, Line
);
267 Put_Line
(Ofile
, "");
269 -- Find and record pragma Inlines
272 Line
:= Get_Line
(InF
);
273 exit when Match
(Line
, " -- END XEINFO INLINES");
275 if Match
(Line
, Inline
) then
276 Set
(Inlined
, Name
, True);
280 -- Skip to package line
282 Reset
(InF
, In_File
);
287 exit when Match
(Line
, Get_Pack
);
292 Must
(Match
(Line
, wsp
& "type Entity_Kind"));
294 -- Process entity kind code definitions
298 exit when not Match
(Line
, Get_Enam
);
299 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & " " & V
);
303 Must
(Match
(Line
, wsp
& Rest
* N
));
304 Put_Line
(Ofile
, " #define " & Rpad
(N
, 32) & ' ' & V
);
307 Must
(Match
(Line
, wsp
& ");"));
308 Put_Line
(Ofile
, "");
310 -- Loop through subtype and type declarations
314 exit when Match
(Line
, Find_Fun
);
316 -- Case of a subtype declaration
318 if Match
(Line
, F_Subtyp
) then
320 -- Case of a subtype declaration that is an abbreviation of the
321 -- form subtype x is y, and if so generate the appropriate typedef
323 if Match
(Line
, G_Subtyp
) then
324 Put_Line
(Ofile
, A
& "typedef " & OldS
& ' ' & NewS
& ';');
326 -- Otherwise the subtype must be declaring a subrange of Entity_Id
329 Must
(Match
(Line
, Get_Styp
));
331 Must
(Match
(Line
, Get_N1
));
334 Line
:= Get_Line
(InF
);
335 Lineno
:= Lineno
+ 1;
336 exit when not Match
(Line
, Get_N2
);
339 Must
(Match
(Line
, Get_N3
));
340 Put_Line
(Ofile
, A
& "SUBTYPE (" & N
& ", Entity_Kind, ");
341 Put_Line
(Ofile
, A
& " " & N1
& ", " & N3
& ')');
342 Put_Line
(Ofile
, "");
345 -- Case of type declaration
347 elsif Match
(Line
, F_Typ
) then
348 -- Process type declaration (must be enumeration type)
351 Put_Line
(Ofile
, A
& "typedef char " & N
& ';');
355 Must
(Match
(Line
, Get_Nam
));
356 Put_Line
(Ofile
, A
& "#define " & Rpad
(Nam
, 25) & Ctr
);
358 exit when Term
/= ",";
361 Put_Line
(Ofile
, "");
363 -- Neither subtype nor type declaration
370 -- Process function declarations
371 -- Note: Lastinlined used to control blank lines
373 Put_Line
(Ofile
, "");
376 -- Loop through function declarations
378 while Match
(Line
, Get_FN
) loop
380 -- Non-inlined function
382 if not Present
(Inlined
, FN
) then
383 Put_Line
(Ofile
, "");
386 " #define " & FN
& " einfo__" & Translate
(FN
, Lower_Case_Map
));
391 if not Lastinlined
then
392 Put_Line
(Ofile
, "");
396 -- Merge here to output spec
399 Lastinlined
:= Get
(Inlined
, FN
);
403 Put_Line
(Ofile
, "");
405 -- 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 ****");