Mark ChangeLog
[official-gcc.git] / gcc / ada / xeinfo.adb
blob272112d77b44f123895c17f3c64ea64c129eb8a2
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-2002 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 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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
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)
32 -- Input files:
34 -- einfo.ads spec of Einfo package
35 -- einfo.adb body of Einfo package
37 -- Output files:
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;
61 procedure XEinfo is
63 package TB renames GNAT.Spitbol.Table_Boolean;
65 Err : exception;
67 A : VString := Nul;
68 B : VString := Nul;
69 C : VString := Nul;
70 Expr : VString := Nul;
71 Filler : VString := Nul;
72 Fline : VString := Nul;
73 Formal : VString := Nul;
74 Formaltyp : VString := Nul;
75 FN : VString := Nul;
76 Line : VString := Nul;
77 N : VString := Nul;
78 N1 : VString := Nul;
79 N2 : VString := Nul;
80 N3 : VString := Nul;
81 Nam : VString := Nul;
82 Name : VString := Nul;
83 NewS : VString := Nul;
84 Nextlin : VString := Nul;
85 OldS : VString := Nul;
86 Rtn : VString := Nul;
87 Term : VString := Nul;
89 InB : File_Type;
90 -- Used to read initial header from body
92 InF : File_Type;
93 -- Used to read full text of both spec and body
95 Ofile : File_Type;
96 -- Used to write output file
98 wsp : Pattern := NSpan (' ' & ASCII.HT);
99 Comment : Pattern := wsp & "--";
100 For_Rep : Pattern := wsp & "for";
101 Get_Func : Pattern := wsp * A & "function" & wsp & Break (' ') * Name;
102 Inline : Pattern := wsp & "pragma Inline (" & Break (')') * Name;
103 Get_Pack : Pattern := wsp & "package ";
104 Get_Enam : Pattern := wsp & Break (',') * N & ',';
105 Find_Fun : Pattern := wsp & "function";
106 F_Subtyp : Pattern := wsp * A & "subtype " & Break (' ') * N;
107 G_Subtyp : Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
108 & wsp & "is" & wsp & Break (" ;") * OldS
109 & wsp & ';' & wsp & Rtab (0);
110 F_Typ : Pattern := wsp * A & "type " & Break (' ') * N & " is (";
111 Get_Nam : Pattern := wsp * A & Break (",)") * Nam & Len (1) * Term;
112 Get_Styp : Pattern := wsp * A & "subtype " & Break (' ') * N;
113 Get_N1 : Pattern := wsp & Break (' ') * N1;
114 Get_N2 : Pattern := wsp & "-- " & Rest * N2;
115 Get_N3 : Pattern := wsp & Break (';') * N3;
116 Get_FN : Pattern := wsp * C & "function" & wsp & Break (" (") * FN;
117 Is_Rturn : Pattern := BreakX ('r') & "return";
118 Is_Begin : Pattern := wsp & "begin";
119 Get_Asrt : Pattern := wsp & "pragma Assert";
120 Semicoln : Pattern := BreakX (';');
121 Get_Cmnt : Pattern := BreakX ('-') * A & "--";
122 Get_Expr : Pattern := wsp & "return " & Break (';') * Expr;
123 Chek_End : Pattern := wsp & "end" & BreakX (';') & ';';
124 Get_B1 : Pattern := BreakX (' ') * A & " in " & Rest * B;
125 Get_B2 : Pattern := BreakX (' ') * A & " = " & Rest * B;
126 Get_B3 : Pattern := BreakX (' ') * A & " /= " & Rest * B;
127 To_Paren : Pattern := wsp * Filler & '(';
128 Get_Fml : Pattern := Break (" :") * Formal & wsp & ':' & wsp
129 & BreakX (" );") * Formaltyp;
130 Nxt_Fml : Pattern := wsp & "; ";
131 Get_Rtn : Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
132 Rem_Prn : Pattern := wsp & ')';
134 M : Match_Result;
136 Lineno : Natural := 0;
137 -- Line number in spec
139 V : Natural;
140 Ctr : Natural;
142 Inlined : TB.Table (200);
143 -- Inlined<N> = True for inlined function, False otherwise
145 Lastinlined : Boolean;
147 procedure Badfunc;
148 -- Signal bad function in body
150 function Getlin return VString;
151 -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
152 -- Fatal error (raises End_Error exception) if end of file encountered
154 procedure Must (B : Boolean);
155 -- Raises Err if the argument (a Match) call, returns False
157 procedure Sethead (Line : in out VString; Term : String);
158 -- Process function header into C
160 -------------
161 -- Badfunc --
162 -------------
164 procedure Badfunc is
165 begin
166 Put_Line
167 (Standard_Error,
168 "Body for function " & FN & " does not meet requirements");
169 raise Err;
170 end Badfunc;
172 -------------
173 -- Getlin --
174 -------------
176 function Getlin return VString is
177 Lin : VString;
179 begin
180 loop
181 Lin := Get_Line (InF);
182 Lineno := Lineno + 1;
184 if Lin /= ""
185 and then not Match (Lin, Comment)
186 and then not Match (Lin, For_Rep)
187 then
188 return Lin;
189 end if;
190 end loop;
191 end Getlin;
193 ----------
194 -- Must --
195 ----------
197 procedure Must (B : Boolean) is
198 begin
199 if not B then
200 raise Err;
201 end if;
202 end Must;
204 -------------
205 -- Sethead --
206 -------------
208 procedure Sethead (Line : in out VString; Term : String) is
209 Args : VString;
211 begin
212 Must (Match (Line, Get_Func, ""));
213 Args := Nul;
215 if Match (Line, To_Paren, "") then
216 Args := Filler & '(';
218 loop
219 Must (Match (Line, Get_Fml, ""));
220 Append (Args, Formaltyp & ' ' & Formal);
221 exit when not Match (Line, Nxt_Fml);
222 Append (Args, ",");
223 end loop;
225 Match (Line, Rem_Prn, "");
226 Append (Args, ')');
227 end if;
229 Must (Match (Line, Get_Rtn));
231 if Present (Inlined, Name) then
232 Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
233 else
234 Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
235 end if;
236 end Sethead;
238 -- Start of processing for XEinfo
240 begin
241 Anchored_Mode := True;
243 if Argument_Count > 0 then
244 Create (Ofile, Out_File, Argument (1));
245 else
246 Create (Ofile, Out_File, "a-einfo.h");
247 end if;
249 Open (InB, In_File, "einfo.adb");
250 Open (InF, In_File, "einfo.ads");
252 Lineno := 0;
253 loop
254 Line := Get_Line (InF);
255 Lineno := Lineno + 1;
256 exit when Line = "";
258 Match (Line,
259 "-- S p e c ",
260 "-- C Header File ");
261 Match (Line, "--", "/*");
262 Match (Line, Rtab (2) * A & "--", M);
263 Replace (M, A & "*/");
264 Put_Line (Ofile, Line);
265 end loop;
267 Put_Line (Ofile, "");
269 -- Find and record pragma Inlines
271 loop
272 Line := Get_Line (InF);
273 exit when Match (Line, " -- END XEINFO INLINES");
275 if Match (Line, Inline) then
276 Set (Inlined, Name, True);
277 end if;
278 end loop;
280 -- Skip to package line
282 Reset (InF, In_File);
283 Lineno := 0;
285 loop
286 Line := Getlin;
287 exit when Match (Line, Get_Pack);
288 end loop;
290 V := 0;
291 Line := Getlin;
292 Must (Match (Line, wsp & "type Entity_Kind"));
294 -- Process entity kind code definitions
296 loop
297 Line := Getlin;
298 exit when not Match (Line, Get_Enam);
299 Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
300 V := V + 1;
301 end loop;
303 Must (Match (Line, wsp & Rest * N));
304 Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
305 Line := Getlin;
307 Must (Match (Line, wsp & ");"));
308 Put_Line (Ofile, "");
310 -- Loop through subtype and type declarations
312 loop
313 Line := Getlin;
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
328 else
329 Must (Match (Line, Get_Styp));
330 Line := Getlin;
331 Must (Match (Line, Get_N1));
333 loop
334 Line := Get_Line (InF);
335 Lineno := Lineno + 1;
336 exit when not Match (Line, Get_N2);
337 end loop;
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, "");
343 end if;
345 -- Case of type declaration
347 elsif Match (Line, F_Typ) then
348 -- Process type declaration (must be enumeration type)
350 Ctr := 0;
351 Put_Line (Ofile, A & "typedef char " & N & ';');
353 loop
354 Line := Getlin;
355 Must (Match (Line, Get_Nam));
356 Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
357 Ctr := Ctr + 1;
358 exit when Term /= ",";
359 end loop;
361 Put_Line (Ofile, "");
363 -- Neither subtype nor type declaration
365 else
366 raise Err;
367 end if;
368 end loop;
370 -- Process function declarations
371 -- Note: Lastinlined used to control blank lines
373 Put_Line (Ofile, "");
374 Lastinlined := True;
376 -- Loop through function declarations
378 while Match (Line, Get_FN) loop
380 -- Non-inlined funcion
382 if not Present (Inlined, FN) then
383 Put_Line (Ofile, "");
384 Put_Line
385 (Ofile,
386 " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
388 -- Inlined function
390 else
391 if not Lastinlined then
392 Put_Line (Ofile, "");
393 end if;
394 end if;
396 -- Merge here to output spec
398 Sethead (Line, ";");
399 Lastinlined := Get (Inlined, FN);
400 Line := Getlin;
401 end loop;
403 Put_Line (Ofile, "");
405 -- Read body to find inlined functions
407 Close (InB);
408 Close (InF);
409 Open (InF, In_File, "einfo.adb");
410 Lineno := 0;
412 -- Loop through input lines to find bodies of inlined functions
414 while not End_Of_File (InF) loop
415 Fline := Get_Line (InF);
417 if Match (Fline, Get_FN)
418 and then Get (Inlined, FN)
419 then
420 -- Here we have an inlined function
422 if not Match (Fline, Is_Rturn) then
423 Line := Fline;
424 Badfunc;
425 end if;
427 Line := Getlin;
429 if not Match (Line, Is_Begin) then
430 Badfunc;
431 end if;
433 -- Skip past pragma Asserts
435 loop
436 Line := Getlin;
437 exit when not Match (Line, Get_Asrt);
439 -- Pragma asser found, get its continuation lines
441 loop
442 exit when Match (Line, Semicoln);
443 Line := Getlin;
444 end loop;
445 end loop;
447 -- Process return statement
449 Match (Line, Get_Cmnt, M);
450 Replace (M, A);
452 -- Get continuations of return statemnt
454 while not Match (Line, Semicoln) loop
455 Nextlin := Getlin;
456 Match (Nextlin, wsp, " ");
457 Append (Line, Nextlin);
458 end loop;
460 if not Match (Line, Get_Expr) then
461 Badfunc;
462 end if;
464 Line := Getlin;
466 if not Match (Line, Chek_End) then
467 Badfunc;
468 end if;
470 Match (Expr, Get_B1, M);
471 Replace (M, "IN (" & A & ", " & B & ')');
472 Match (Expr, Get_B2, M);
473 Replace (M, A & " == " & B);
474 Match (Expr, Get_B3, M);
475 Replace (M, A & " != " & B);
476 Put_Line (Ofile, "");
477 Sethead (Fline, "");
478 Put_Line (Ofile, C & " { return " & Expr & "; }");
479 end if;
480 end loop;
482 Put_Line (Ofile, "");
483 Put_Line
484 (Ofile,
485 "/* End of einfo.h (C version of Einfo package specification) */");
487 exception
488 when Err =>
489 Put_Line (Standard_Error, Lineno & ". " & Line);
490 Put_Line (Standard_Error, "**** fatal error ****");
491 Set_Exit_Status (1);
493 when End_Error =>
494 Put_Line (Standard_Error, "unexpected end of file");
495 Put_Line (Standard_Error, "**** fatal error ****");
497 end XEinfo;