------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT SYSTEM UTILITIES --
|
-- GNAT SYSTEM UTILITIES --
|
-- --
|
-- --
|
-- X E I N F O --
|
-- X E I N F O --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- for more details. You should have received a copy of the GNU General --
|
-- for more details. You should have received a copy of the GNU General --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
-- Program to construct C header file a-einfo.h (C version of einfo.ads spec)
|
-- Program to construct C header file a-einfo.h (C version of einfo.ads spec)
|
-- for use by Gigi. This header file contains all definitions and access
|
-- for use by Gigi. This header file contains all definitions and access
|
-- functions, but does not contain set procedures, since Gigi is not allowed
|
-- functions, but does not contain set procedures, since Gigi is not allowed
|
-- to modify the GNAT tree)
|
-- to modify the GNAT tree)
|
|
|
-- Input files:
|
-- Input files:
|
|
|
-- einfo.ads spec of Einfo package
|
-- einfo.ads spec of Einfo package
|
-- einfo.adb body of Einfo package
|
-- einfo.adb body of Einfo package
|
|
|
-- Output files:
|
-- Output files:
|
|
|
-- a-einfo.h Corresponding c header file
|
-- a-einfo.h Corresponding c header file
|
|
|
-- Note: It is assumed that the input files have been compiled without errors
|
-- Note: It is assumed that the input files have been compiled without errors
|
|
|
-- An optional argument allows the specification of an output file name to
|
-- An optional argument allows the specification of an output file name to
|
-- override the default a-einfo.h file name for the generated output file.
|
-- override the default a-einfo.h file name for the generated output file.
|
|
|
-- Most, but not all of the functions in Einfo can be inlined in the C header.
|
-- Most, but not all of the functions in Einfo can be inlined in the C header.
|
-- They are the functions identified by pragma Inline in the spec. Functions
|
-- They are the functions identified by pragma Inline in the spec. Functions
|
-- that cannot be inlined are simply defined in the header.
|
-- that cannot be inlined are simply defined in the header.
|
|
|
with Ada.Command_Line; use Ada.Command_Line;
|
with Ada.Command_Line; use Ada.Command_Line;
|
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
|
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
|
with Ada.Text_IO; use Ada.Text_IO;
|
with Ada.Text_IO; use Ada.Text_IO;
|
|
|
with GNAT.Spitbol; use GNAT.Spitbol;
|
with GNAT.Spitbol; use GNAT.Spitbol;
|
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
|
|
procedure XEinfo is
|
procedure XEinfo is
|
|
|
package TB renames GNAT.Spitbol.Table_Boolean;
|
package TB renames GNAT.Spitbol.Table_Boolean;
|
|
|
Err : exception;
|
Err : exception;
|
|
|
A : VString := Nul;
|
A : VString := Nul;
|
B : VString := Nul;
|
B : VString := Nul;
|
C : VString := Nul;
|
C : VString := Nul;
|
Expr : VString := Nul;
|
Expr : VString := Nul;
|
Filler : VString := Nul;
|
Filler : VString := Nul;
|
Fline : VString := Nul;
|
Fline : VString := Nul;
|
Formal : VString := Nul;
|
Formal : VString := Nul;
|
Formaltyp : VString := Nul;
|
Formaltyp : VString := Nul;
|
FN : VString := Nul;
|
FN : VString := Nul;
|
Line : VString := Nul;
|
Line : VString := Nul;
|
N : VString := Nul;
|
N : VString := Nul;
|
N1 : VString := Nul;
|
N1 : VString := Nul;
|
N2 : VString := Nul;
|
N2 : VString := Nul;
|
N3 : VString := Nul;
|
N3 : VString := Nul;
|
Nam : VString := Nul;
|
Nam : VString := Nul;
|
Name : VString := Nul;
|
Name : VString := Nul;
|
NewS : VString := Nul;
|
NewS : VString := Nul;
|
Nextlin : VString := Nul;
|
Nextlin : VString := Nul;
|
OldS : VString := Nul;
|
OldS : VString := Nul;
|
Rtn : VString := Nul;
|
Rtn : VString := Nul;
|
Term : VString := Nul;
|
Term : VString := Nul;
|
|
|
InB : File_Type;
|
InB : File_Type;
|
-- Used to read initial header from body
|
-- Used to read initial header from body
|
|
|
InF : File_Type;
|
InF : File_Type;
|
-- Used to read full text of both spec and body
|
-- Used to read full text of both spec and body
|
|
|
Ofile : File_Type;
|
Ofile : File_Type;
|
-- Used to write output file
|
-- Used to write output file
|
|
|
wsp : constant Pattern := NSpan (' ' & ASCII.HT);
|
wsp : constant Pattern := NSpan (' ' & ASCII.HT);
|
Comment : constant Pattern := wsp & "--";
|
Comment : constant Pattern := wsp & "--";
|
For_Rep : constant Pattern := wsp & "for";
|
For_Rep : constant Pattern := wsp & "for";
|
Get_Func : constant Pattern := wsp * A & "function" & wsp
|
Get_Func : constant Pattern := wsp * A & "function" & wsp
|
& Break (' ') * Name;
|
& Break (' ') * Name;
|
Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
|
Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
|
Get_Pack : constant Pattern := wsp & "package ";
|
Get_Pack : constant Pattern := wsp & "package ";
|
Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
|
Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
|
Find_Fun : constant Pattern := wsp & "function";
|
Find_Fun : constant Pattern := wsp & "function";
|
F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
|
G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
|
& wsp & "is" & wsp & Break (" ;") * OldS
|
& wsp & "is" & wsp & Break (" ;") * OldS
|
& wsp & ';' & wsp & Rtab (0);
|
& wsp & ';' & wsp & Rtab (0);
|
F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
|
F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
|
" is (";
|
" is (";
|
Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
|
Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
|
& Len (1) * Term;
|
& Len (1) * Term;
|
Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
|
Get_N1 : constant Pattern := wsp & Break (' ') * N1;
|
Get_N1 : constant Pattern := wsp & Break (' ') * N1;
|
Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
|
Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
|
Get_N3 : constant Pattern := wsp & Break (';') * N3;
|
Get_N3 : constant Pattern := wsp & Break (';') * N3;
|
Get_FN : constant Pattern := wsp * C & "function" & wsp
|
Get_FN : constant Pattern := wsp * C & "function" & wsp
|
& Break (" (") * FN;
|
& Break (" (") * FN;
|
Is_Rturn : constant Pattern := BreakX ('r') & "return";
|
Is_Rturn : constant Pattern := BreakX ('r') & "return";
|
Is_Begin : constant Pattern := wsp & "begin";
|
Is_Begin : constant Pattern := wsp & "begin";
|
Get_Asrt : constant Pattern := wsp & "pragma Assert";
|
Get_Asrt : constant Pattern := wsp & "pragma Assert";
|
Semicoln : constant Pattern := BreakX (';');
|
Semicoln : constant Pattern := BreakX (';');
|
Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
|
Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
|
Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
|
Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
|
Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
|
Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
|
Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
|
Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
|
Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
|
Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
|
Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
|
Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
|
To_Paren : constant Pattern := wsp * Filler & '(';
|
To_Paren : constant Pattern := wsp * Filler & '(';
|
Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
|
Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
|
& BreakX (" );") * Formaltyp;
|
& BreakX (" );") * Formaltyp;
|
Nxt_Fml : constant Pattern := wsp & "; ";
|
Nxt_Fml : constant Pattern := wsp & "; ";
|
Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
|
Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
|
Rem_Prn : constant Pattern := wsp & ')';
|
Rem_Prn : constant Pattern := wsp & ')';
|
|
|
M : Match_Result;
|
M : Match_Result;
|
|
|
Lineno : Natural := 0;
|
Lineno : Natural := 0;
|
-- Line number in spec
|
-- Line number in spec
|
|
|
V : Natural;
|
V : Natural;
|
Ctr : Natural;
|
Ctr : Natural;
|
|
|
Inlined : TB.Table (200);
|
Inlined : TB.Table (200);
|
-- Inlined<N> = True for inlined function, False otherwise
|
-- Inlined<N> = True for inlined function, False otherwise
|
|
|
Lastinlined : Boolean;
|
Lastinlined : Boolean;
|
|
|
procedure Badfunc;
|
procedure Badfunc;
|
-- Signal bad function in body
|
-- Signal bad function in body
|
|
|
function Getlin return VString;
|
function Getlin return VString;
|
-- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
|
-- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
|
-- Fatal error (raises End_Error exception) if end of file encountered
|
-- Fatal error (raises End_Error exception) if end of file encountered
|
|
|
procedure Must (B : Boolean);
|
procedure Must (B : Boolean);
|
-- Raises Err if the argument (a Match) call, returns False
|
-- Raises Err if the argument (a Match) call, returns False
|
|
|
procedure Sethead (Line : in out VString; Term : String);
|
procedure Sethead (Line : in out VString; Term : String);
|
-- Process function header into C
|
-- Process function header into C
|
|
|
-------------
|
-------------
|
-- Badfunc --
|
-- Badfunc --
|
-------------
|
-------------
|
|
|
procedure Badfunc is
|
procedure Badfunc is
|
begin
|
begin
|
Put_Line
|
Put_Line
|
(Standard_Error,
|
(Standard_Error,
|
"Body for function " & FN & " does not meet requirements");
|
"Body for function " & FN & " does not meet requirements");
|
raise Err;
|
raise Err;
|
end Badfunc;
|
end Badfunc;
|
|
|
-------------
|
-------------
|
-- Getlin --
|
-- Getlin --
|
-------------
|
-------------
|
|
|
function Getlin return VString is
|
function Getlin return VString is
|
Lin : VString;
|
Lin : VString;
|
|
|
begin
|
begin
|
loop
|
loop
|
Lin := Get_Line (InF);
|
Lin := Get_Line (InF);
|
Lineno := Lineno + 1;
|
Lineno := Lineno + 1;
|
|
|
if Lin /= ""
|
if Lin /= ""
|
and then not Match (Lin, Comment)
|
and then not Match (Lin, Comment)
|
and then not Match (Lin, For_Rep)
|
and then not Match (Lin, For_Rep)
|
then
|
then
|
return Lin;
|
return Lin;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Getlin;
|
end Getlin;
|
|
|
----------
|
----------
|
-- Must --
|
-- Must --
|
----------
|
----------
|
|
|
procedure Must (B : Boolean) is
|
procedure Must (B : Boolean) is
|
begin
|
begin
|
if not B then
|
if not B then
|
raise Err;
|
raise Err;
|
end if;
|
end if;
|
end Must;
|
end Must;
|
|
|
-------------
|
-------------
|
-- Sethead --
|
-- Sethead --
|
-------------
|
-------------
|
|
|
procedure Sethead (Line : in out VString; Term : String) is
|
procedure Sethead (Line : in out VString; Term : String) is
|
Args : VString;
|
Args : VString;
|
|
|
begin
|
begin
|
Must (Match (Line, Get_Func, ""));
|
Must (Match (Line, Get_Func, ""));
|
Args := Nul;
|
Args := Nul;
|
|
|
if Match (Line, To_Paren, "") then
|
if Match (Line, To_Paren, "") then
|
Args := Filler & '(';
|
Args := Filler & '(';
|
|
|
loop
|
loop
|
Must (Match (Line, Get_Fml, ""));
|
Must (Match (Line, Get_Fml, ""));
|
Append (Args, Formaltyp & ' ' & Formal);
|
Append (Args, Formaltyp & ' ' & Formal);
|
exit when not Match (Line, Nxt_Fml);
|
exit when not Match (Line, Nxt_Fml);
|
Append (Args, ",");
|
Append (Args, ",");
|
end loop;
|
end loop;
|
|
|
Match (Line, Rem_Prn, "");
|
Match (Line, Rem_Prn, "");
|
Append (Args, ')');
|
Append (Args, ')');
|
end if;
|
end if;
|
|
|
Must (Match (Line, Get_Rtn));
|
Must (Match (Line, Get_Rtn));
|
|
|
if Present (Inlined, Name) then
|
if Present (Inlined, Name) then
|
Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
|
Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
|
else
|
else
|
Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
|
Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
|
end if;
|
end if;
|
end Sethead;
|
end Sethead;
|
|
|
-- Start of processing for XEinfo
|
-- Start of processing for XEinfo
|
|
|
begin
|
begin
|
Anchored_Mode := True;
|
Anchored_Mode := True;
|
|
|
if Argument_Count > 0 then
|
if Argument_Count > 0 then
|
Create (Ofile, Out_File, Argument (1));
|
Create (Ofile, Out_File, Argument (1));
|
else
|
else
|
Create (Ofile, Out_File, "a-einfo.h");
|
Create (Ofile, Out_File, "a-einfo.h");
|
end if;
|
end if;
|
|
|
Open (InB, In_File, "einfo.adb");
|
Open (InB, In_File, "einfo.adb");
|
Open (InF, In_File, "einfo.ads");
|
Open (InF, In_File, "einfo.ads");
|
|
|
Lineno := 0;
|
Lineno := 0;
|
loop
|
loop
|
Line := Get_Line (InF);
|
Line := Get_Line (InF);
|
Lineno := Lineno + 1;
|
Lineno := Lineno + 1;
|
exit when Line = "";
|
exit when Line = "";
|
|
|
Match (Line,
|
Match (Line,
|
"-- S p e c ",
|
"-- S p e c ",
|
"-- C Header File ");
|
"-- C Header File ");
|
Match (Line, "--", "/*");
|
Match (Line, "--", "/*");
|
Match (Line, Rtab (2) * A & "--", M);
|
Match (Line, Rtab (2) * A & "--", M);
|
Replace (M, A & "*/");
|
Replace (M, A & "*/");
|
Put_Line (Ofile, Line);
|
Put_Line (Ofile, Line);
|
end loop;
|
end loop;
|
|
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
|
|
-- Find and record pragma Inlines
|
-- Find and record pragma Inlines
|
|
|
loop
|
loop
|
Line := Get_Line (InF);
|
Line := Get_Line (InF);
|
exit when Match (Line, " -- END XEINFO INLINES");
|
exit when Match (Line, " -- END XEINFO INLINES");
|
|
|
if Match (Line, Inline) then
|
if Match (Line, Inline) then
|
Set (Inlined, Name, True);
|
Set (Inlined, Name, True);
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Skip to package line
|
-- Skip to package line
|
|
|
Reset (InF, In_File);
|
Reset (InF, In_File);
|
Lineno := 0;
|
Lineno := 0;
|
|
|
loop
|
loop
|
Line := Getlin;
|
Line := Getlin;
|
exit when Match (Line, Get_Pack);
|
exit when Match (Line, Get_Pack);
|
end loop;
|
end loop;
|
|
|
V := 0;
|
V := 0;
|
Line := Getlin;
|
Line := Getlin;
|
Must (Match (Line, wsp & "type Entity_Kind"));
|
Must (Match (Line, wsp & "type Entity_Kind"));
|
|
|
-- Process entity kind code definitions
|
-- Process entity kind code definitions
|
|
|
loop
|
loop
|
Line := Getlin;
|
Line := Getlin;
|
exit when not Match (Line, Get_Enam);
|
exit when not Match (Line, Get_Enam);
|
Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
|
Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
|
V := V + 1;
|
V := V + 1;
|
end loop;
|
end loop;
|
|
|
Must (Match (Line, wsp & Rest * N));
|
Must (Match (Line, wsp & Rest * N));
|
Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
|
Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
|
Line := Getlin;
|
Line := Getlin;
|
|
|
Must (Match (Line, wsp & ");"));
|
Must (Match (Line, wsp & ");"));
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
|
|
-- Loop through subtype and type declarations
|
-- Loop through subtype and type declarations
|
|
|
loop
|
loop
|
Line := Getlin;
|
Line := Getlin;
|
exit when Match (Line, Find_Fun);
|
exit when Match (Line, Find_Fun);
|
|
|
-- Case of a subtype declaration
|
-- Case of a subtype declaration
|
|
|
if Match (Line, F_Subtyp) then
|
if Match (Line, F_Subtyp) then
|
|
|
-- Case of a subtype declaration that is an abbreviation of the
|
-- Case of a subtype declaration that is an abbreviation of the
|
-- form subtype x is y, and if so generate the appropriate typedef
|
-- form subtype x is y, and if so generate the appropriate typedef
|
|
|
if Match (Line, G_Subtyp) then
|
if Match (Line, G_Subtyp) then
|
Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
|
Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
|
|
|
-- Otherwise the subtype must be declaring a subrange of Entity_Id
|
-- Otherwise the subtype must be declaring a subrange of Entity_Id
|
|
|
else
|
else
|
Must (Match (Line, Get_Styp));
|
Must (Match (Line, Get_Styp));
|
Line := Getlin;
|
Line := Getlin;
|
Must (Match (Line, Get_N1));
|
Must (Match (Line, Get_N1));
|
|
|
loop
|
loop
|
Line := Get_Line (InF);
|
Line := Get_Line (InF);
|
Lineno := Lineno + 1;
|
Lineno := Lineno + 1;
|
exit when not Match (Line, Get_N2);
|
exit when not Match (Line, Get_N2);
|
end loop;
|
end loop;
|
|
|
Must (Match (Line, Get_N3));
|
Must (Match (Line, Get_N3));
|
Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
|
Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
|
Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
|
Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
end if;
|
end if;
|
|
|
-- Case of type declaration
|
-- Case of type declaration
|
|
|
elsif Match (Line, F_Typ) then
|
elsif Match (Line, F_Typ) then
|
-- Process type declaration (must be enumeration type)
|
-- Process type declaration (must be enumeration type)
|
|
|
Ctr := 0;
|
Ctr := 0;
|
Put_Line (Ofile, A & "typedef char " & N & ';');
|
Put_Line (Ofile, A & "typedef char " & N & ';');
|
|
|
loop
|
loop
|
Line := Getlin;
|
Line := Getlin;
|
Must (Match (Line, Get_Nam));
|
Must (Match (Line, Get_Nam));
|
Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
|
Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
|
Ctr := Ctr + 1;
|
Ctr := Ctr + 1;
|
exit when Term /= ",";
|
exit when Term /= ",";
|
end loop;
|
end loop;
|
|
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
|
|
-- Neither subtype nor type declaration
|
-- Neither subtype nor type declaration
|
|
|
else
|
else
|
raise Err;
|
raise Err;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Process function declarations
|
-- Process function declarations
|
-- Note: Lastinlined used to control blank lines
|
-- Note: Lastinlined used to control blank lines
|
|
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
Lastinlined := True;
|
Lastinlined := True;
|
|
|
-- Loop through function declarations
|
-- Loop through function declarations
|
|
|
while Match (Line, Get_FN) loop
|
while Match (Line, Get_FN) loop
|
|
|
-- Non-inlined function
|
-- Non-inlined function
|
|
|
if not Present (Inlined, FN) then
|
if not Present (Inlined, FN) then
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
Put_Line
|
Put_Line
|
(Ofile,
|
(Ofile,
|
" #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
|
" #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
|
|
|
-- Inlined function
|
-- Inlined function
|
|
|
else
|
else
|
if not Lastinlined then
|
if not Lastinlined then
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Merge here to output spec
|
-- Merge here to output spec
|
|
|
Sethead (Line, ";");
|
Sethead (Line, ";");
|
Lastinlined := Get (Inlined, FN);
|
Lastinlined := Get (Inlined, FN);
|
Line := Getlin;
|
Line := Getlin;
|
end loop;
|
end loop;
|
|
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
|
|
-- Read body to find inlined functions
|
-- Read body to find inlined functions
|
|
|
Close (InB);
|
Close (InB);
|
Close (InF);
|
Close (InF);
|
Open (InF, In_File, "einfo.adb");
|
Open (InF, In_File, "einfo.adb");
|
Lineno := 0;
|
Lineno := 0;
|
|
|
-- Loop through input lines to find bodies of inlined functions
|
-- Loop through input lines to find bodies of inlined functions
|
|
|
while not End_Of_File (InF) loop
|
while not End_Of_File (InF) loop
|
Fline := Get_Line (InF);
|
Fline := Get_Line (InF);
|
|
|
if Match (Fline, Get_FN)
|
if Match (Fline, Get_FN)
|
and then Get (Inlined, FN)
|
and then Get (Inlined, FN)
|
then
|
then
|
-- Here we have an inlined function
|
-- Here we have an inlined function
|
|
|
if not Match (Fline, Is_Rturn) then
|
if not Match (Fline, Is_Rturn) then
|
Line := Fline;
|
Line := Fline;
|
Badfunc;
|
Badfunc;
|
end if;
|
end if;
|
|
|
Line := Getlin;
|
Line := Getlin;
|
|
|
if not Match (Line, Is_Begin) then
|
if not Match (Line, Is_Begin) then
|
Badfunc;
|
Badfunc;
|
end if;
|
end if;
|
|
|
-- Skip past pragma Asserts
|
-- Skip past pragma Asserts
|
|
|
loop
|
loop
|
Line := Getlin;
|
Line := Getlin;
|
exit when not Match (Line, Get_Asrt);
|
exit when not Match (Line, Get_Asrt);
|
|
|
-- Pragma assert found, get its continuation lines
|
-- Pragma assert found, get its continuation lines
|
|
|
loop
|
loop
|
exit when Match (Line, Semicoln);
|
exit when Match (Line, Semicoln);
|
Line := Getlin;
|
Line := Getlin;
|
end loop;
|
end loop;
|
end loop;
|
end loop;
|
|
|
-- Process return statement
|
-- Process return statement
|
|
|
Match (Line, Get_Cmnt, M);
|
Match (Line, Get_Cmnt, M);
|
Replace (M, A);
|
Replace (M, A);
|
|
|
-- Get continuations of return statement
|
-- Get continuations of return statement
|
|
|
while not Match (Line, Semicoln) loop
|
while not Match (Line, Semicoln) loop
|
Nextlin := Getlin;
|
Nextlin := Getlin;
|
Match (Nextlin, wsp, " ");
|
Match (Nextlin, wsp, " ");
|
Append (Line, Nextlin);
|
Append (Line, Nextlin);
|
end loop;
|
end loop;
|
|
|
if not Match (Line, Get_Expr) then
|
if not Match (Line, Get_Expr) then
|
Badfunc;
|
Badfunc;
|
end if;
|
end if;
|
|
|
Line := Getlin;
|
Line := Getlin;
|
|
|
if not Match (Line, Chek_End) then
|
if not Match (Line, Chek_End) then
|
Badfunc;
|
Badfunc;
|
end if;
|
end if;
|
|
|
Match (Expr, Get_B1, M);
|
Match (Expr, Get_B1, M);
|
Replace (M, "IN (" & A & ", " & B & ')');
|
Replace (M, "IN (" & A & ", " & B & ')');
|
Match (Expr, Get_B2, M);
|
Match (Expr, Get_B2, M);
|
Replace (M, A & " == " & B);
|
Replace (M, A & " == " & B);
|
Match (Expr, Get_B3, M);
|
Match (Expr, Get_B3, M);
|
Replace (M, A & " != " & B);
|
Replace (M, A & " != " & B);
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
Sethead (Fline, "");
|
Sethead (Fline, "");
|
Put_Line (Ofile, C & " { return " & Expr & "; }");
|
Put_Line (Ofile, C & " { return " & Expr & "; }");
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Put_Line (Ofile, "");
|
Put_Line (Ofile, "");
|
Put_Line
|
Put_Line
|
(Ofile,
|
(Ofile,
|
"/* End of einfo.h (C version of Einfo package specification) */");
|
"/* End of einfo.h (C version of Einfo package specification) */");
|
|
|
exception
|
exception
|
when Err =>
|
when Err =>
|
Put_Line (Standard_Error, Lineno & ". " & Line);
|
Put_Line (Standard_Error, Lineno & ". " & Line);
|
Put_Line (Standard_Error, "**** fatal error ****");
|
Put_Line (Standard_Error, "**** fatal error ****");
|
Set_Exit_Status (1);
|
Set_Exit_Status (1);
|
|
|
when End_Error =>
|
when End_Error =>
|
Put_Line (Standard_Error, "unexpected end of file");
|
Put_Line (Standard_Error, "unexpected end of file");
|
Put_Line (Standard_Error, "**** fatal error ****");
|
Put_Line (Standard_Error, "**** fatal error ****");
|
|
|
end XEinfo;
|
end XEinfo;
|
|
|