------------------------------------------------------------------------------
-- --
-- GNATELIM COMPONENTS --
-- --
-- G N A T E L I M . P R O C E S S _ B I N D _ F I L E --
-- --
-- B o d y --
-- --
-- $Revision: 1.24 $
-- --
-- Copyright (c) 1997-2002, Free Software Foundation, Inc. --
-- --
-- Gnatelim is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. Gnatelim is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY 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 COPYING. If --
-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- Gnatelim is distributed as a part of the ASIS implementation for GNAT --
-- (ASIS-for-GNAT). --
-- --
-- Gnatelim was originally developed by Alain Le Guennec --
-- --
-- Gnatelim is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
------------------------------------------------------------------------------
with GNATELIM.Errors;
with GNATELIM.Options; use GNATELIM.Options;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
with Asis.Compilation_Units; use Asis.Compilation_Units;
with Hostparm;
package body GNATELIM.Process_Bind_File is
------------------------------
-- Get_Units_From_Bind_File --
------------------------------
function Get_Units_From_Bind_File
(C : Context; Main, Bindname : String)
return Compilation_Unit_List
is
Bind_File_Descr : File_Type;
Elab_Proc_Name : String (1 .. 256);
Unit_Name : String (1 .. 256);
-- 256 should be enough
-- ??? names used for local variables are not really good
Elab_Proc_NLen : Natural range 0 .. 256;
Elab_Proc_NInd : Positive range 1 .. 256;
Unit_Name_Len : Natural range 0 .. 256;
Spec : Boolean;
Next_CU : Compilation_Unit;
Result_List : Compilation_Unit_List
:= Asis.Compilation_Units.Compilation_Units (C);
Result_Len : Natural := 0;
function Ada_Bind_File_Name return String;
function C_Bind_File_Name return String;
-- Returns the name of the Ada or C bind file. If Bindname is not empty,
-- it is simply checked what language is it written in, otherwise the
-- name is computed based on Main. In the later case it is assumed that
-- unit name is not redefined by Source_File_Name pragma, it is not
-- any predefined/gnat-specific unit, and neither it is an empty string
------------------------
-- Ada_Bind_File_Name --
------------------------
function Ada_Bind_File_Name return String is
Res_Str_Len : Natural := Main'Length + 6;
Res_String : String (1 .. Res_Str_Len);
-- that is b~unit_name.adb
begin
if Bindname /= "" then
if To_Lower (Bindname (Bindname'Last)) /= 'b' then
raise Name_Error;
else
return Bindname;
end if;
end if;
Res_String (1) := 'b';
if Hostparm.OpenVMS then
Res_String (2) := '$';
else
Res_String (2) := '~';
end if;
for I in Main'Range loop
if Main (I) = '.' then
Res_String (I + 2) := '-';
else
Res_String (I + 2) := To_Lower (Main (I));
end if;
end loop;
Res_String (Res_Str_Len - 3) := '.';
Res_String (Res_Str_Len - 2) := 'a';
Res_String (Res_Str_Len - 1) := 'd';
Res_String (Res_Str_Len) := 's';
return Res_String;
end Ada_Bind_File_Name;
----------------------
-- C_Bind_File_Name --
----------------------
function C_Bind_File_Name return String is
Res_Str_Len : Natural := Main'Length + 4;
Res_String : String (1 .. Res_Str_Len);
-- that is b_unit_name.c
begin
if Bindname /= "" then
if To_Lower (Bindname (Bindname'Last)) /= 'c' then
raise Name_Error;
else
return Bindname;
end if;
end if;
Res_String (1) := 'b';
Res_String (2) := '_';
for I in Main'Range loop
if Main (I) = '.' then
Res_String (I + 2) := '-';
else
Res_String (I + 2) := To_Lower (Main (I));
end if;
end loop;
Res_String (Res_Str_Len) := 'c';
Res_String (Res_Str_Len - 1) := '.';
return Res_String;
end C_Bind_File_Name;
procedure Get_Bind_File_Line;
-- Simple bindfile line processing routine
------------------------
-- Get_Bind_File_Line --
------------------------
procedure Get_Bind_File_Line is
-- Reads next line from bind file and discards leading and trailing
-- spaces and trailing '('
begin
Elab_Proc_NInd := 1;
Get_Line (Bind_File_Descr, Elab_Proc_Name, Elab_Proc_NLen);
while Elab_Proc_NInd < Elab_Proc_NLen and then
Elab_Proc_Name (Elab_Proc_NInd) = ' '
loop
Elab_Proc_NInd := Elab_Proc_NInd + 1;
end loop;
while Elab_Proc_NLen > 1 and then
(Elab_Proc_Name (Elab_Proc_NLen) = ' ' or else
Elab_Proc_Name (Elab_Proc_NLen) = '(')
loop
Elab_Proc_NLen := Elab_Proc_NLen - 1;
end loop;
end Get_Bind_File_Line;
procedure Skip_Ada_Starting_Part;
procedure Skip_C_Starting_Part;
-- Skips the first lines of an Ada or C bind file; stops when the next
-- line to read is the line containing the first call to an elaboration
-- procedure;
type Access_Skip_Starting_Part is access procedure;
Skip_Starting_Part : Access_Skip_Starting_Part;
function Get_Unit_From_Ada_Elab_Procedure return Compilation_Unit;
function Get_Unit_From_C_Elab_Procedure return Compilation_Unit;
-- takes the call to an elaboration procedure (in Ada or C bind file
-- respectively) as the value of Elab_Proc_Name (1 .. Elab_Proc_NLen)
-- and returns the corresponding ASIS Compilation_Unit.
-- Also sets Spec for it. Stores the full expanded Ada name of the unit
-- to get in Unit_Name and sets Unit_Name_Len accordingly
type Access_Get_Unit_From_Elab_Procedure is
access function return Compilation_Unit;
Get_Unit_From_Elab_Procedure : Access_Get_Unit_From_Elab_Procedure;
function End_Of_Ada_Elab_Procedures return Boolean;
function End_Of_C_Elab_Procedures return Boolean;
-- Checks if the latest line read from a bind file does not already
-- contain a call to an elaboration procedure
type Access_End_Of_Elab_Procedures is access function return Boolean;
End_Of_Elab_Procedures : Access_End_Of_Elab_Procedures;
function May_Be_Internal return Boolean;
-- using the current settings of Unit_Name and Unit_Name_Len,
-- tries to guess, if the corresponding unit can be from RTL
function Is_Instance_Body return Boolean;
-- using the current settings of Unit_Name, Unit_Name_Len, and Spec,
-- checks if the given Unit Name corresponds to the body, implicitly
-- created by the compiler for library-level generic instantiation
function Should_Never_Be_Touched return Boolean;
-- using the current settings of Unit_Name and Unit_Name_Len, defines
-- if a given unit is an RTL component for which no Eliminate pragmas
-- could be generated because the frontend may generate implicit calls
-- to subprograms defined in the corresponding unit.
--------------------------------
-- End_Of_Ada_Elab_Procedures --
--------------------------------
function End_Of_Ada_Elab_Procedures return Boolean is
Result : Boolean := True;
begin
Result := Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen) =
"-- END ELABORATION ORDER";
return Result;
end End_Of_Ada_Elab_Procedures;
------------------------------
-- End_Of_C_Elab_Procedures --
------------------------------
function End_Of_C_Elab_Procedures return Boolean is
Result : Boolean := True;
begin
Result := Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen) =
"END ELABORATION ORDER */";
return Result;
end End_Of_C_Elab_Procedures;
--------------------------------------
-- Get_Unit_From_Ada_Elab_Procedure --
--------------------------------------
function Get_Unit_From_Ada_Elab_Procedure return Compilation_Unit is
begin
Elab_Proc_NInd := Elab_Proc_NInd + 3;
-- Skip "-- "
return Get_Unit_From_C_Elab_Procedure;
end Get_Unit_From_Ada_Elab_Procedure;
------------------------------------
-- Get_Unit_From_C_Elab_Procedure --
------------------------------------
function Get_Unit_From_C_Elab_Procedure return Compilation_Unit is
begin
while Elab_Proc_Name (Elab_Proc_NLen) /= ' ' loop
Elab_Proc_NLen := Elab_Proc_NLen - 1;
end loop;
-- Skip "(spec)" or "(body")
if Elab_Proc_Name (Elab_Proc_NLen + 2) = 's' then
Spec := True;
else
Spec := False;
end if;
Elab_Proc_NLen := Elab_Proc_NLen - 1;
-- Skip ' ' between the unit name and "(spec|body)"
Unit_Name_Len := Elab_Proc_NLen - Elab_Proc_NInd + 1;
Unit_Name (1 .. Unit_Name_Len) :=
To_Lower (Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen));
-- here we have a unit name as Unit_Name (1 .. Unit_Name_Len);
if Spec then
return Library_Unit_Declaration
(To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);
else
return Compilation_Unit_Body
(To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);
end if;
end Get_Unit_From_C_Elab_Procedure;
----------------------
-- Is_Instance_Body --
----------------------
function Is_Instance_Body return Boolean is
Result : Boolean := False;
Spec_CU : Compilation_Unit;
begin
if not Spec then
Spec_CU := Library_Unit_Declaration
(To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);
if Exists (Spec_CU) and then
Unit_Kind (Spec_CU) in A_Generic_Unit_Instance
then
Result := True;
end if;
end if;
return Result;
end Is_Instance_Body;
---------------------
-- May_Be_Internal --
---------------------
function May_Be_Internal return Boolean is
Result : Boolean := False;
begin
-- roots of predefined/GNAT-specific hierarchies:
if Unit_Name_Len = 6 and then
Unit_Name (1 .. Unit_Name_Len) = "system"
then
Result := True;
elsif Unit_Name_Len = 3 and then
Unit_Name (1 .. Unit_Name_Len) = "ada"
then
Result := True;
elsif Unit_Name_Len = 4 and then
Unit_Name (1 .. Unit_Name_Len) = "gnat"
then
Result := True;
elsif Unit_Name_Len = 10 and then
Unit_Name (1 .. Unit_Name_Len) = "interfaces"
then
Result := True;
end if;
-- and their children:
if Unit_Name_Len >= 5 and then
Unit_Name (1 .. 4) = "ada."
then
Result := True;
elsif Unit_Name_Len >= 8 and then
Unit_Name (1 .. 7) = "system."
then
Result := True;
elsif Unit_Name_Len >= 6 and then
Unit_Name (1 .. 5) = "gnat."
then
Result := True;
elsif Unit_Name_Len >= 12 and then
Unit_Name (1 .. 11) = "interfaces."
then
Result := True;
end if;
-- And, finally, checking obsolescent library unit renamings
if (Unit_Name_Len = 20 and then
Unit_Name (1 .. Unit_Name_Len) = "unchecked_conversion")
or else
(Unit_Name_Len = 22 and then
Unit_Name (1 .. Unit_Name_Len) = "unchecked_deallocation")
or else
(Unit_Name_Len = 13 and then
Unit_Name (1 .. Unit_Name_Len) = "sequential_io")
or else
(Unit_Name_Len = 9 and then
Unit_Name (1 .. Unit_Name_Len) = "direct_io")
or else
(Unit_Name_Len = 7 and then
Unit_Name (1 .. Unit_Name_Len) = "text_io")
or else
(Unit_Name_Len = 13 and then
Unit_Name (1 .. Unit_Name_Len) = "io_exceptions")
or else
(Unit_Name_Len = 8 and then
Unit_Name (1 .. Unit_Name_Len) = "calendar")
or else
(Unit_Name_Len = 12 and then
Unit_Name (1 .. Unit_Name_Len) = "machine_code")
then
Result := True;
end if;
return Result;
end May_Be_Internal;
-----------------------------
-- Should_Never_Be_Touched --
-----------------------------
function Should_Never_Be_Touched return Boolean is
Result : Boolean := False;
Max_Non_Touchecd_Name_Len : constant Positive := 32;
subtype Non_Touched_Name is String (1 .. Max_Non_Touchecd_Name_Len);
type Non_Touched_Name_List is array (Positive range <>)
of Non_Touched_Name;
-- This is the list of units which should never been touched.
-- The original list was suggested by Robert Dewar in the
-- gnatelim-related discussion on asis-report (23.02.98).
-- Some more elements were added to this list later, as the
-- results of gnatelim testing, they are marked by '-- ???'
-- comments on the right.
Non_Touched_Names : Non_Touched_Name_List := (
"ada.calendar ",
"ada.exceptions ",
"ada.finalization ",
"ada.interrupts ",
"ada.real_time ",
"ada.streams ",
"ada.tags ",
"ada.task_identification ",
"ada.calendar.delays ",
"ada.calendar.delay_objects ",
"ada.finalization.list_controller",
"ada.real_time.delays ",
"interfaces ",
"interfaces.cpp ",
"interfaces.packed_decimal ",
"interfaces.c_streams ", -- ???
"gnat.heap_sort_a "); -- ???
begin
-- nothing in the System hierarchy should be touched
if (Unit_Name_Len = 6 and then
Unit_Name (1 .. Unit_Name_Len) = "system")
or else
(Unit_Name_Len >= 8 and then
Unit_Name (1 .. 7) = "system.")
then
Result := True;
end if;
-- The predefined Interfaces package should not be touched
if Result = False and then
(Unit_Name_Len = 10 and then
Unit_Name (1 .. 10) = "interfaces")
then
Result := True;
end if;
-- Checking Ada, Gnat and Interfaces hierarchies:
if Result = False and then
((Unit_Name_Len > 4 and then
Unit_Name (1 .. 4) = "ada.")
or else
(Unit_Name_Len > 11 and then
Unit_Name (1 .. 11) = "interfaces.")
or else -- ???
(Unit_Name_Len > 5 and then
Unit_Name (1 .. 5) = "gnat."))
then
for J in Unit_Name_Len + 1 .. Max_Non_Touchecd_Name_Len loop
Unit_Name (J) := ' ';
end loop;
for J in Non_Touched_Names'Range loop
if Unit_Name (1 .. Max_Non_Touchecd_Name_Len) =
Non_Touched_Names (J)
then
Result := True;
exit;
end if;
end loop;
end if;
return Result;
end Should_Never_Be_Touched;
----------------------------
-- Skip_Ada_Starting_Part --
----------------------------
procedure Skip_Ada_Starting_Part is
begin
-- looking for the call to Set_Globals:
loop
Get_Bind_File_Line;
exit when
Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen)
= "-- BEGIN ELABORATION ORDER";
end loop;
end Skip_Ada_Starting_Part;
--------------------------
-- Skip_C_Starting_Part --
--------------------------
procedure Skip_C_Starting_Part is
begin
-- looking for /* BEGIN ELABORATION ORDER
loop
Get_Bind_File_Line;
exit when
Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen) =
"/* BEGIN ELABORATION ORDER";
end loop;
end Skip_C_Starting_Part;
begin -- Get_Units_From_Bind_File
-- we assume, that a bind file is in the current directory. If there
-- is neither Ada nor C bind file, we'll be in the exception handler
-- just after this block statement (the default preference is an Ada
-- bind file):
Opening_A_Bind_File :
begin
Open (Bind_File_Descr, In_File, Ada_Bind_File_Name);
-- if we are here, we will process an Ada bind file:
Skip_Starting_Part := Skip_Ada_Starting_Part'Access;
Get_Unit_From_Elab_Procedure :=
Get_Unit_From_Ada_Elab_Procedure'Access;
End_Of_Elab_Procedures := End_Of_Ada_Elab_Procedures'Access;
exception
when Name_Error =>
Open (Bind_File_Descr, In_File, C_Bind_File_Name);
-- if we are here, we will process a C bind file:
Skip_Starting_Part := Skip_C_Starting_Part'Access;
Get_Unit_From_Elab_Procedure :=
Get_Unit_From_C_Elab_Procedure'Access;
End_Of_Elab_Procedures := End_Of_C_Elab_Procedures'Access;
end Opening_A_Bind_File;
-- and if we are here, we have some bind file to process
Skip_Starting_Part.all;
-- We assume that there is at least one unit in the elaboration
-- sequence (that is, at least one call to an elaboration procedure
-- in the body of adainit). We also assume that
-- the sequence of the calls to elaboration procedures in the body of
-- adainit is separated from the line containing "end adainit" by an
-- empty line in an Ada bind file or by a line containing '}' in its
-- first postilion in a C bind file:
Get_Bind_File_Line;
while not End_Of_Elab_Procedures.all loop
Next_CU := Get_Unit_From_Elab_Procedure.all;
if Is_Nil (Next_CU) and then (not Skip_Missed_Units) then
-- here we have to check if a given unit may really be nil
-- (the problem is that a bind file may contain some units for
-- which tree files are not created when running gnatmake to
-- prepare the data for gnatelim
if not (
(May_Be_Internal
and then
(Dont_Eliminate_In_RTS or else Should_Never_Be_Touched))
or else
Is_Instance_Body)
then
GNATELIM.Errors.Error
("gnatelim: library item corresponding to "
& To_Wide_String (Unit_Name (1 .. Unit_Name_Len))
& " not found.");
end if;
end if;
if not Is_Nil (Next_CU) then
-- In some cases we should not include a unit in a set of units
-- to be analyzed by gnatelim
if Unit_Origin (Next_CU) /= An_Application_Unit then
if Dont_Eliminate_In_RTS or else Should_Never_Be_Touched then
Next_CU := Nil_Compilation_Unit;
end if;
elsif Unit_Kind (Next_CU) in A_Procedure .. A_Generic_Package
and then
Is_Body_Required (Next_CU)
and then
not Exists (Corresponding_Body (Next_CU))
then
-- This condition is a kind of guessing, that Next_CU is
-- a spec of a component of some precompiled Ada library.
-- Such component should be turned into Nil_Unit to avoid
-- registering subprograms declared within it. There is no
-- reason to raise an exception here - if an exception has
-- to be raised, it should be raised by the previous check
-- (for Next_CU being Nil Compilation Unit)
--
-- This guessing is not very smart...
Next_CU := Nil_Compilation_Unit;
end if;
end if;
if not Is_Nil (Next_CU) then
Result_Len := Result_Len + 1;
Result_List (Result_Len) := Next_CU;
end if;
Get_Bind_File_Line;
end loop;
return Result_List (1 .. Result_Len);
exception
when Name_Error =>
GNATELIM.Errors.Error
("gnatelim: cannot find a bind file for " & To_Wide_String (Main));
when Constraint_Error =>
GNATELIM.Errors.Error
("gnatelim: there are probably not enough "
& "tree files in you environment.");
end Get_Units_From_Bind_File;
end GNATELIM.Process_Bind_File;
syntax highlighted by Code2HTML, v. 0.9.1