------------------------------------------------------------------------------ -- -- -- 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;