aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/xeinfo.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/xeinfo.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/xeinfo.adb505
1 files changed, 505 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/xeinfo.adb b/gcc-4.3.1/gcc/ada/xeinfo.adb
new file mode 100644
index 000000000..120bf397b
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/xeinfo.adb
@@ -0,0 +1,505 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT SYSTEM UTILITIES --
+-- --
+-- X E I N F O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- --
+-- 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- --
+-- 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- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- 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 --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- 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
+-- functions, but does not contain set procedures, since Gigi is not allowed
+-- to modify the GNAT tree)
+
+-- Input files:
+
+-- einfo.ads spec of Einfo package
+-- einfo.adb body of Einfo package
+
+-- Output files:
+
+-- a-einfo.h Corresponding c header file
+
+-- 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
+-- 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.
+-- They are the functions identified by pragma Inline in the spec. Functions
+-- that cannot be inlined are simply defined in the header.
+
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
+with Ada.Strings.Maps; use Ada.Strings.Maps;
+with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with GNAT.Spitbol; use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
+with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
+
+procedure XEinfo is
+
+ package TB renames GNAT.Spitbol.Table_Boolean;
+
+ Err : exception;
+
+ pragma Warnings (Off);
+ -- These seem not to be referenced, but they are (by * operator)
+
+ A : VString := Nul;
+ B : VString := Nul;
+ C : VString := Nul;
+ Expr : VString := Nul;
+ Filler : VString := Nul;
+ Fline : VString := Nul;
+ Formal : VString := Nul;
+ Formaltyp : VString := Nul;
+ FN : VString := Nul;
+ Line : VString := Nul;
+ N : VString := Nul;
+ N1 : VString := Nul;
+ N2 : VString := Nul;
+ N3 : VString := Nul;
+ Nam : VString := Nul;
+ Name : VString := Nul;
+ NewS : VString := Nul;
+ Nextlin : VString := Nul;
+ OldS : VString := Nul;
+ Rtn : VString := Nul;
+ Term : VString := Nul;
+
+ pragma Warnings (On);
+
+ InB : File_Type;
+ -- Used to read initial header from body
+
+ InF : File_Type;
+ -- Used to read full text of both spec and body
+
+ Ofile : File_Type;
+ -- Used to write output file
+
+ wsp : constant Pattern := NSpan (' ' & ASCII.HT);
+ Comment : constant Pattern := wsp & "--";
+ For_Rep : constant Pattern := wsp & "for";
+ Get_Func : constant Pattern := wsp * A & "function" & wsp
+ & Break (' ') * Name;
+ Inline : constant Pattern := wsp & "pragma Inline (" & Break (')') * Name;
+ Get_Pack : constant Pattern := wsp & "package ";
+ Get_Enam : constant Pattern := wsp & Break (',') * N & ',';
+ Find_Fun : constant Pattern := wsp & "function";
+ F_Subtyp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
+ G_Subtyp : constant Pattern := wsp & "subtype" & wsp & Break (' ') * NewS
+ & wsp & "is" & wsp & Break (" ;") * OldS
+ & wsp & ';' & wsp & Rtab (0);
+ F_Typ : constant Pattern := wsp * A & "type " & Break (' ') * N &
+ " is (";
+ Get_Nam : constant Pattern := wsp * A & Break (",)") * Nam
+ & Len (1) * Term;
+ Get_Styp : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
+ Get_N1 : constant Pattern := wsp & Break (' ') * N1;
+ Get_N2 : constant Pattern := wsp & "-- " & Rest * N2;
+ Get_N3 : constant Pattern := wsp & Break (';') * N3;
+ Get_FN : constant Pattern := wsp * C & "function" & wsp
+ & Break (" (") * FN;
+ Is_Rturn : constant Pattern := BreakX ('r') & "return";
+ Is_Begin : constant Pattern := wsp & "begin";
+ Get_Asrt : constant Pattern := wsp & "pragma Assert";
+ Semicoln : constant Pattern := BreakX (';');
+ Get_Cmnt : constant Pattern := BreakX ('-') * A & "--";
+ Get_Expr : constant Pattern := wsp & "return " & Break (';') * Expr;
+ Chek_End : constant Pattern := wsp & "end" & BreakX (';') & ';';
+ Get_B1 : constant Pattern := BreakX (' ') * A & " in " & Rest * B;
+ Get_B2 : constant Pattern := BreakX (' ') * A & " = " & Rest * B;
+ Get_B3 : constant Pattern := BreakX (' ') * A & " /= " & Rest * B;
+ To_Paren : constant Pattern := wsp * Filler & '(';
+ Get_Fml : constant Pattern := Break (" :") * Formal & wsp & ':' & wsp
+ & BreakX (" );") * Formaltyp;
+ Nxt_Fml : constant Pattern := wsp & "; ";
+ Get_Rtn : constant Pattern := wsp & "return" & wsp & BreakX (" ;") * Rtn;
+ Rem_Prn : constant Pattern := wsp & ')';
+
+ M : Match_Result;
+
+ Lineno : Natural := 0;
+ -- Line number in spec
+
+ V : Natural;
+ Ctr : Natural;
+
+ Inlined : TB.Table (200);
+ -- Inlined<N> = True for inlined function, False otherwise
+
+ Lastinlined : Boolean;
+
+ procedure Badfunc;
+ -- Signal bad function in body
+
+ function Getlin return VString;
+ -- Get non-comment line (comment lines skipped, also skips FOR rep clauses)
+ -- Fatal error (raises End_Error exception) if end of file encountered
+
+ procedure Must (B : Boolean);
+ -- Raises Err if the argument (a Match) call, returns False
+
+ procedure Sethead (Line : in out VString; Term : String);
+ -- Process function header into C
+
+ -------------
+ -- Badfunc --
+ -------------
+
+ procedure Badfunc is
+ begin
+ Put_Line
+ (Standard_Error,
+ "Body for function " & FN & " does not meet requirements");
+ raise Err;
+ end Badfunc;
+
+ -------------
+ -- Getlin --
+ -------------
+
+ function Getlin return VString is
+ Lin : VString;
+
+ begin
+ loop
+ Lin := Get_Line (InF);
+ Lineno := Lineno + 1;
+
+ if Lin /= ""
+ and then not Match (Lin, Comment)
+ and then not Match (Lin, For_Rep)
+ then
+ return Lin;
+ end if;
+ end loop;
+ end Getlin;
+
+ ----------
+ -- Must --
+ ----------
+
+ procedure Must (B : Boolean) is
+ begin
+ if not B then
+ raise Err;
+ end if;
+ end Must;
+
+ -------------
+ -- Sethead --
+ -------------
+
+ procedure Sethead (Line : in out VString; Term : String) is
+ Args : VString;
+
+ begin
+ Must (Match (Line, Get_Func, ""));
+ Args := Nul;
+
+ if Match (Line, To_Paren, "") then
+ Args := Filler & '(';
+
+ loop
+ Must (Match (Line, Get_Fml, ""));
+ Append (Args, Formaltyp & ' ' & Formal);
+ exit when not Match (Line, Nxt_Fml);
+ Append (Args, ",");
+ end loop;
+
+ Match (Line, Rem_Prn, "");
+ Append (Args, ')');
+ end if;
+
+ Must (Match (Line, Get_Rtn));
+
+ if Present (Inlined, Name) then
+ Put_Line (Ofile, A & "INLINE " & Rtn & ' ' & Name & Args & Term);
+ else
+ Put_Line (Ofile, A & Rtn & ' ' & Name & Args & Term);
+ end if;
+ end Sethead;
+
+-- Start of processing for XEinfo
+
+begin
+ Anchored_Mode := True;
+
+ if Argument_Count > 0 then
+ Create (Ofile, Out_File, Argument (1));
+ else
+ Create (Ofile, Out_File, "a-einfo.h");
+ end if;
+
+ Open (InB, In_File, "einfo.adb");
+ Open (InF, In_File, "einfo.ads");
+
+ Lineno := 0;
+ loop
+ Line := Get_Line (InF);
+ Lineno := Lineno + 1;
+ exit when Line = "";
+
+ Match (Line,
+ "-- S p e c ",
+ "-- C Header File ");
+ Match (Line, "--", "/*");
+ Match (Line, Rtab (2) * A & "--", M);
+ Replace (M, A & "*/");
+ Put_Line (Ofile, Line);
+ end loop;
+
+ Put_Line (Ofile, "");
+
+ -- Find and record pragma Inlines
+
+ loop
+ Line := Get_Line (InF);
+ exit when Match (Line, " -- END XEINFO INLINES");
+
+ if Match (Line, Inline) then
+ Set (Inlined, Name, True);
+ end if;
+ end loop;
+
+ -- Skip to package line
+
+ Reset (InF, In_File);
+ Lineno := 0;
+
+ loop
+ Line := Getlin;
+ exit when Match (Line, Get_Pack);
+ end loop;
+
+ V := 0;
+ Line := Getlin;
+ Must (Match (Line, wsp & "type Entity_Kind"));
+
+ -- Process entity kind code definitions
+
+ loop
+ Line := Getlin;
+ exit when not Match (Line, Get_Enam);
+ Put_Line (Ofile, " #define " & Rpad (N, 32) & " " & V);
+ V := V + 1;
+ end loop;
+
+ Must (Match (Line, wsp & Rest * N));
+ Put_Line (Ofile, " #define " & Rpad (N, 32) & ' ' & V);
+ Line := Getlin;
+
+ Must (Match (Line, wsp & ");"));
+ Put_Line (Ofile, "");
+
+ -- Loop through subtype and type declarations
+
+ loop
+ Line := Getlin;
+ exit when Match (Line, Find_Fun);
+
+ -- Case of a subtype declaration
+
+ if Match (Line, F_Subtyp) then
+
+ -- Case of a subtype declaration that is an abbreviation of the
+ -- form subtype x is y, and if so generate the appropriate typedef
+
+ if Match (Line, G_Subtyp) then
+ Put_Line (Ofile, A & "typedef " & OldS & ' ' & NewS & ';');
+
+ -- Otherwise the subtype must be declaring a subrange of Entity_Id
+
+ else
+ Must (Match (Line, Get_Styp));
+ Line := Getlin;
+ Must (Match (Line, Get_N1));
+
+ loop
+ Line := Get_Line (InF);
+ Lineno := Lineno + 1;
+ exit when not Match (Line, Get_N2);
+ end loop;
+
+ Must (Match (Line, Get_N3));
+ Put_Line (Ofile, A & "SUBTYPE (" & N & ", Entity_Kind, ");
+ Put_Line (Ofile, A & " " & N1 & ", " & N3 & ')');
+ Put_Line (Ofile, "");
+ end if;
+
+ -- Case of type declaration
+
+ elsif Match (Line, F_Typ) then
+ -- Process type declaration (must be enumeration type)
+
+ Ctr := 0;
+ Put_Line (Ofile, A & "typedef char " & N & ';');
+
+ loop
+ Line := Getlin;
+ Must (Match (Line, Get_Nam));
+ Put_Line (Ofile, A & "#define " & Rpad (Nam, 25) & Ctr);
+ Ctr := Ctr + 1;
+ exit when Term /= ",";
+ end loop;
+
+ Put_Line (Ofile, "");
+
+ -- Neither subtype nor type declaration
+
+ else
+ raise Err;
+ end if;
+ end loop;
+
+ -- Process function declarations
+ -- Note: Lastinlined used to control blank lines
+
+ Put_Line (Ofile, "");
+ Lastinlined := True;
+
+ -- Loop through function declarations
+
+ while Match (Line, Get_FN) loop
+
+ -- Non-inlined funcion
+
+ if not Present (Inlined, FN) then
+ Put_Line (Ofile, "");
+ Put_Line
+ (Ofile,
+ " #define " & FN & " einfo__" & Translate (FN, Lower_Case_Map));
+
+ -- Inlined function
+
+ else
+ if not Lastinlined then
+ Put_Line (Ofile, "");
+ end if;
+ end if;
+
+ -- Merge here to output spec
+
+ Sethead (Line, ";");
+ Lastinlined := Get (Inlined, FN);
+ Line := Getlin;
+ end loop;
+
+ Put_Line (Ofile, "");
+
+ -- Read body to find inlined functions
+
+ Close (InB);
+ Close (InF);
+ Open (InF, In_File, "einfo.adb");
+ Lineno := 0;
+
+ -- Loop through input lines to find bodies of inlined functions
+
+ while not End_Of_File (InF) loop
+ Fline := Get_Line (InF);
+
+ if Match (Fline, Get_FN)
+ and then Get (Inlined, FN)
+ then
+ -- Here we have an inlined function
+
+ if not Match (Fline, Is_Rturn) then
+ Line := Fline;
+ Badfunc;
+ end if;
+
+ Line := Getlin;
+
+ if not Match (Line, Is_Begin) then
+ Badfunc;
+ end if;
+
+ -- Skip past pragma Asserts
+
+ loop
+ Line := Getlin;
+ exit when not Match (Line, Get_Asrt);
+
+ -- Pragma asser found, get its continuation lines
+
+ loop
+ exit when Match (Line, Semicoln);
+ Line := Getlin;
+ end loop;
+ end loop;
+
+ -- Process return statement
+
+ Match (Line, Get_Cmnt, M);
+ Replace (M, A);
+
+ -- Get continuations of return statemnt
+
+ while not Match (Line, Semicoln) loop
+ Nextlin := Getlin;
+ Match (Nextlin, wsp, " ");
+ Append (Line, Nextlin);
+ end loop;
+
+ if not Match (Line, Get_Expr) then
+ Badfunc;
+ end if;
+
+ Line := Getlin;
+
+ if not Match (Line, Chek_End) then
+ Badfunc;
+ end if;
+
+ Match (Expr, Get_B1, M);
+ Replace (M, "IN (" & A & ", " & B & ')');
+ Match (Expr, Get_B2, M);
+ Replace (M, A & " == " & B);
+ Match (Expr, Get_B3, M);
+ Replace (M, A & " != " & B);
+ Put_Line (Ofile, "");
+ Sethead (Fline, "");
+ Put_Line (Ofile, C & " { return " & Expr & "; }");
+ end if;
+ end loop;
+
+ Put_Line (Ofile, "");
+ Put_Line
+ (Ofile,
+ "/* End of einfo.h (C version of Einfo package specification) */");
+
+exception
+ when Err =>
+ Put_Line (Standard_Error, Lineno & ". " & Line);
+ Put_Line (Standard_Error, "**** fatal error ****");
+ Set_Exit_Status (1);
+
+ when End_Error =>
+ Put_Line (Standard_Error, "unexpected end of file");
+ Put_Line (Standard_Error, "**** fatal error ****");
+
+end XEinfo;