File : asis-compilation_units.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . C O M P I L A T I O N _ U N I T S --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-1999, Free Software Foundation, Inc. --
-- --
-- ASIS-for-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 --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be use- --
-- ful, 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 ASIS-for-GNAT; see file --
-- COPYING. If not, write to the Free Software Foundation, 59 Temple Place --
-- - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the --
-- Software Engineering Laboratory of the Swiss Federal Institute of --
-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the --
-- Scientific Research Computer Center of Moscow State University (SRCC --
-- MSU), Russia, with funding partially provided by grants from the Swiss --
-- National Science Foundation and the Swiss Academy of Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Asis.Errors; use Asis.Errors;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Extensions; use Asis.Extensions;
with Asis.Set_Get; use Asis.Set_Get;
with A4G.A_Opt; use A4G.A_Opt;
with A4G.A_Output; use A4G.A_Output;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.Get_Unit; use A4G.Get_Unit;
with A4G.Contt; use A4G.Contt;
with A4G.Contt.UT; use A4G.Contt.UT;
with Atree; use Atree;
with Types; use Types;
with Lib; use Lib;
package body Asis.Compilation_Units is
-- !!!??? This file is '-gnatg-compilable', but both its content and its
-- !!!??? documentation need revising
function "=" (Left, Right : Compilation_Unit) return Boolean
renames Asis.Set_Get."=";
------------------------------------------------------------------------------
function Unit_Kind (Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Unit_Kinds is
begin
Check_Validity (Compilation_Unit, "Asis.Compilation_Units.Unit_Kind");
return Kind (Compilation_Unit);
end Unit_Kind;
-----------------------------------------------------------------------------
function Unit_Class (Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Unit_Classes is
begin
Check_Validity (Compilation_Unit, "Asis.Compilation_Units.Unit_Class");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
return Class (Compilation_Unit);
end Unit_Class;
-----------------------------------------------------------------------------
function Unit_Origin (Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Unit_Origins is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Unit_Origin");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
return Origin (Compilation_Unit);
end Unit_Origin;
-----------------------------------------------------------------------------
function Enclosing_Context (Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Context is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Enclosing_Context");
if Is_Nil (Compilation_Unit) then
Raise_ASIS_Inappropriate_Compilation_Unit
(Diagnosis => "Asis.Compilation_Units.Enclosing_Context");
else
return Encl_Cont (Compilation_Unit);
end if;
end Enclosing_Context;
------------------------------------------------------------------------------
function Enclosing_Container
(Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Ada_Environments.Containers .Container is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Enclosing_Container");
if Is_Nil (Compilation_Unit) then
Raise_ASIS_Inappropriate_Compilation_Unit
(Diagnosis => "Asis.Compilation_Units.Enclosing_Container");
else
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Enclosing_Container");
return Asis.Ada_Environments.Containers.Nil_Container;
-- to make the code syntactically correct
end if;
end Enclosing_Container;
------------------------------------------------------------------------------
function Library_Unit_Declaration
(Name : in Wide_String;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Result_Id : Unit_Id;
Result_Cont : Context_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Library_Unit_Declaration");
Result_Cont := Get_Cont_Id (The_Context);
Reset_Context (Result_Cont);
Result_Id := Get_One_Unit (To_String (Name), Result_Cont, Spec => True);
return Get_Comp_Unit (Result_Id, Result_Cont);
exception
when Program_Error =>
raise;
when ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Library_Unit_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
"Asis.Compilation_Units.Library_Unit_Declaration");
end Library_Unit_Declaration;
-----------------------------------------------------------------------------
function Compilation_Unit_Body
(Name : in Wide_String;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Result_Id : Unit_Id;
Result_Cont : Context_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Library_Unit_Body");
Result_Cont := Get_Cont_Id (The_Context);
Reset_Context (Result_Cont);
Result_Id := Get_One_Unit (To_String (Name), Result_Cont, Spec => False);
return Get_Comp_Unit (Result_Id, Result_Cont);
exception
when Program_Error =>
raise;
when ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Library_Unit_Body");
raise;
when others =>
Raise_ASIS_Failed (
"Asis.Compilation_Units.Library_Unit_Body");
end Compilation_Unit_Body;
------------------------------------------------------------------------------
function Library_Unit_Declarations
(The_Context : in Asis.Context)
return Asis.Compilation_Unit_List
is
Res_Cont_Id : Context_Id := Get_Cont_Id (The_Context);
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Library_Unit_Declarations");
Cont_Tree_Mode := Tree_Processing_Mode (Res_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Library_Unit_Declarations");
end if;
Reset_Context (Res_Cont_Id);
declare
Result_Len : Natural := Lib_Unit_Decls (Res_Cont_Id);
Result : Compilation_Unit_List (1 .. Result_Len);
L_U_Decl : Unit_Id := First_Unit_Id; -- Standard
begin
for I in 1 .. Result_Len loop
Result (I) := Get_Comp_Unit (L_U_Decl, Res_Cont_Id);
L_U_Decl := Next_Decl (Res_Cont_Id, L_U_Decl);
end loop;
return Result;
end;
exception
when ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Library_Unit_Declarations");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Library_Unit_Declarations");
end Library_Unit_Declarations;
------------------------------------------------------------------------------
function Compilation_Unit_Bodies
(The_Context : in Asis.Context)
return Asis.Compilation_Unit_List
is
Res_Cont_Id : Context_Id := Get_Cont_Id (The_Context);
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Compilation_Unit_Bodies");
Cont_Tree_Mode := Tree_Processing_Mode (Res_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Compilation_Unit_Bodies");
end if;
Reset_Context (Res_Cont_Id);
declare
Result_Len : Natural := Comp_Unit_Bodies (Res_Cont_Id);
Result : Compilation_Unit_List (1 .. Result_Len);
L_U_Body : Unit_Id := First_Body (Res_Cont_Id);
begin
for I in 1 .. Result_Len loop
Result (I) := Get_Comp_Unit (L_U_Body, Res_Cont_Id);
L_U_Body := Next_Body (Res_Cont_Id, L_U_Body);
end loop;
return Result;
end;
exception
when ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Compilation_Unit_Bodies");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Compilation_Unit_Bodies");
end Compilation_Unit_Bodies;
------------------------------------------------------------------------------
function Compilation_Units
(The_Context : in Asis.Context)
return Asis.Compilation_Unit_List
is
Res_Cont_Id : Context_Id := Get_Cont_Id (The_Context);
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Compilation_Units");
Cont_Tree_Mode := Tree_Processing_Mode (Res_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Compilation_Units");
end if;
Reset_Context (Res_Cont_Id);
declare
Result_Len : Natural := Lib_Unit_Decls (Res_Cont_Id) +
Comp_Unit_Bodies (Res_Cont_Id);
Result : Compilation_Unit_List (1 .. Result_Len);
begin
for I in 1 .. Result_Len loop
Result (I) := Get_Comp_Unit
(First_Unit_Id + Unit_Id (I) - 1, Res_Cont_Id);
end loop;
return Result;
end;
exception
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Compilation_Units");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Compilation_Units");
end Compilation_Units;
------------------------------------------------------------------------------
function Corresponding_Children (Library_Unit : in Asis.Compilation_Unit)
return Asis.Compilation_Unit_List
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Res_Cont_Id : Context_Id;
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (Library_Unit,
"Asis.Compilation_Units.Corresponding_Children");
Res_Cont_Id := Encl_Cont_Id (Library_Unit);
Reset_Context (Res_Cont_Id);
Arg_Kind := Kind (Library_Unit);
if not (Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Package_Instance)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end if;
Cont_Tree_Mode := Tree_Processing_Mode (Res_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Unit);
declare
Result_Id_List : Unit_Id_List renames
Children (Res_Cont_Id, Arg_Unit_Id);
Result_List : Compilation_Unit_List renames
Get_Comp_Unit_List (Result_Id_List, Res_Cont_Id);
begin
return Result_List;
end;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Children");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end Corresponding_Children;
function Corresponding_Children
(Library_Unit : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit_List
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Corresponding_Children");
Check_Validity (Library_Unit,
"Asis.Compilation_Units.Corresponding_Children");
Arg_Cont_Id := Encl_Cont_Id (Library_Unit);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Library_Unit);
if not (Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Package_Instance)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end if;
Result_Cont_Id := Get_Cont_Id (The_Context);
Cont_Tree_Mode := Tree_Processing_Mode (Result_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Unit);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Corresponding_Children
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit_List;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Children");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Children");
end Corresponding_Children;
------------------------------------------------------------------------------
function Corresponding_Parent_Declaration
(Library_Unit : in Asis.Compilation_Unit)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Res_Cont_Id : Context_Id;
Result_Id : Unit_Id;
begin
Check_Validity (Library_Unit,
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
Res_Cont_Id := Encl_Cont_Id (Library_Unit);
Reset_Context (Res_Cont_Id);
Arg_Kind := Kind (Library_Unit);
if not (Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Unit);
Result_Id := Get_Parent_Unit (Res_Cont_Id, Arg_Unit_Id);
-- Result_Id cannot be Nil_Unit here
-- if not Is_Consistent (Res_Cont_Id, Result_Id, Arg_Unit_Id) then
-- -- the corresponding nonexistent declaration should be returned
-- Result_Id := Get_Nonexistent_Unit (Res_Cont_Id);
-- end if;
return Get_Comp_Unit (Result_Id, Res_Cont_Id);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end Corresponding_Parent_Declaration;
function Corresponding_Parent_Declaration
(Library_Unit : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
Check_Validity (Library_Unit,
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
Arg_Cont_Id := Encl_Cont_Id (Library_Unit);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Library_Unit);
if not (Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Unit);
Result_Cont_Id := Get_Cont_Id (The_Context);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Corresponding_Parent_Declaration
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Parent_Declaration");
end Corresponding_Parent_Declaration;
-----------------------------------------------------------------------------
function Corresponding_Declaration
(Library_Item : in Asis.Compilation_Unit)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Result_Unit_Id : Unit_Id;
Result_Cont_Id : Context_Id;
begin
Check_Validity (Library_Item,
"Asis.Compilation_Units.Corresponding_Declaration");
Result_Cont_Id := Encl_Cont_Id (Library_Item);
Reset_Context (Result_Cont_Id);
Arg_Kind := Kind (Library_Item);
if not (Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = An_Unknown_Unit or else
Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit or else
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Declaration");
end if;
if Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else -- ???
Arg_Kind = A_Function_Body_Subunit or else -- ???
Arg_Kind = A_Package_Body_Subunit or else -- ???
Arg_Kind = A_Task_Body_Subunit or else -- ???
Arg_Kind = A_Protected_Body_Subunit or else -- ???
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body -- ???
then
return Library_Item;
end if;
if ((Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body)
and then
Class (Library_Item) = A_Public_Declaration_And_Body)
then
return Nil_Compilation_Unit;
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Item);
Result_Unit_Id := Get_Declaration (Result_Cont_Id, Arg_Unit_Id);
-- if not Is_Consistent (Result_Cont_Id, Result_Unit_Id, Arg_Unit_Id) then
-- -- the corresponding nonexistent declaration should be returned
-- -- this should cover the crazy situation, when a Context contains
-- -- the body of the procedure P and the declaration of the package
-- -- P in the same time. (??? it's not quite clear at the moment...)
-- Result_Unit_Id := Get_Nonexistent_Unit (Result_Cont_Id);
-- end if;
return Get_Comp_Unit (Result_Unit_Id, Result_Cont_Id);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Declaration");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Declaration");
end Corresponding_Declaration;
function Corresponding_Declaration
(Library_Item : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Corresponding_Declaration");
Check_Validity (Library_Item,
"Asis.Compilation_Units.Corresponding_Declaration");
Arg_Cont_Id := Encl_Cont_Id (Library_Item);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Library_Item);
if not (Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = An_Unknown_Unit or else
Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit or else
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Declaration");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Item);
Result_Cont_Id := Get_Cont_Id (The_Context);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Corresponding_Declaration
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Declaration");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Declaration");
end Corresponding_Declaration;
-----------------------------------------------------------------------------
function Corresponding_Body
(Library_Item : in Asis.Compilation_Unit)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Result_Unit_Id : Unit_Id;
Result_Cont_Id : Context_Id;
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (Library_Item,
"Asis.Compilation_Units.Body");
Result_Cont_Id := Encl_Cont_Id (Library_Item);
Reset_Context (Result_Cont_Id);
Arg_Kind := Kind (Library_Item);
if not (Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = An_Unknown_Unit or else
Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit or else
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Body");
end if;
if Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit or else
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body
then
return Library_Item;
end if;
if (Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Package)
and then
not Asis.Set_Get.Is_Body_Required (Library_Item)
then
return Nil_Compilation_Unit;
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Item);
Cont_Tree_Mode := Tree_Processing_Mode (Result_Cont_Id);
Result_Unit_Id := Get_Body (Result_Cont_Id, Arg_Unit_Id);
if No (Result_Unit_Id) and then
(Cont_Tree_Mode = On_The_Fly or else Cont_Tree_Mode = Mixed)
then
-- as a last escape, we try to create the result body by
-- compiling on the fly:
Result_Unit_Id :=
Get_One_Unit (Name => Unit_Name (Library_Item),
Context => Result_Cont_Id,
Spec => False);
end if;
if No (Result_Unit_Id)
-- or else
-- (not Is_Consistent (Result_Cont_Id, Arg_Unit_Id, Result_Unit_Id))
then
Result_Unit_Id := Get_Nonexistent_Unit (Result_Cont_Id);
end if;
return Get_Comp_Unit (Result_Unit_Id, Result_Cont_Id);
exception
when Program_Error =>
raise;
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Body");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Body");
end Corresponding_Body;
------------------------------------------------------------------------------
function Corresponding_Body
(Library_Item : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Corresponding_Body");
Check_Validity (Library_Item,
"Asis.Compilation_Units.Corresponding_Body");
Arg_Cont_Id := Encl_Cont_Id (Library_Item);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Library_Item);
if not (Arg_Kind = A_Procedure or else
Arg_Kind = A_Function or else
Arg_Kind = A_Package or else
Arg_Kind = A_Generic_Procedure or else
Arg_Kind = A_Generic_Function or else
Arg_Kind = A_Generic_Package or else
Arg_Kind = An_Unknown_Unit or else
Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = A_Procedure_Instance or else
Arg_Kind = A_Function_Instance or else
Arg_Kind = A_Package_Instance or else
Arg_Kind = A_Procedure_Renaming or else
Arg_Kind = A_Function_Renaming or else
Arg_Kind = A_Package_Renaming or else
Arg_Kind = A_Generic_Procedure_Renaming or else
Arg_Kind = A_Generic_Function_Renaming or else
Arg_Kind = A_Generic_Package_Renaming or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit or else
Arg_Kind = A_Nonexistent_Declaration or else
Arg_Kind = A_Nonexistent_Body)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Body");
end if;
Arg_Unit_Id := Get_Unit_Id (Library_Item);
Result_Cont_Id := Get_Cont_Id (The_Context);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Corresponding_Body
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Body");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Body");
end Corresponding_Body;
------------------------------------------------------------------------------
function Is_Nil (Right : in Asis.Compilation_Unit) return Boolean is
begin
Check_Validity (Right, "Asis.Compilation_Units.Is_Nil");
return Right = Nil_Compilation_Unit;
end Is_Nil;
-----------------------------------------------------------------------------
function Is_Nil (Right : in Asis.Compilation_Unit_List) return Boolean is
begin
return Right = Nil_Compilation_Unit_List;
end Is_Nil;
-----------------------------------------------------------------------------
function Is_Equal
(Left : in Asis.Compilation_Unit;
Right : in Asis.Compilation_Unit)
return Boolean
is
Left_Unit_Id : Unit_Id;
Right_Unit_Id : Unit_Id;
Left_Cont_Id : Context_Id;
Right_Cont_Id : Context_Id;
-- Left_Kind : Asis.Unit_Kinds;
-- Right_Kind : Asis.Unit_Kinds;
begin
Check_Validity (Left, "Asis.Compilation_Units.Is_Equal");
Check_Validity (Right, "Asis.Compilation_Units.Is_Equal");
Left_Unit_Id := Get_Unit_Id (Left);
Right_Unit_Id := Get_Unit_Id (Right);
if Left_Unit_Id = Nil_Unit and then Right_Unit_Id = Nil_Unit then
return True;
elsif (Right_Unit_Id = Nil_Unit and then Right_Unit_Id /= Nil_Unit)
or else
(Right_Unit_Id /= Nil_Unit and then Right_Unit_Id = Nil_Unit)
then
return False;
end if;
Left_Cont_Id := Encl_Cont_Id (Left);
Right_Cont_Id := Encl_Cont_Id (Right);
if Left_Cont_Id = Right_Cont_Id then
return Left_Unit_Id = Right_Unit_Id;
else
-- if Unit_Name (Left) /= Unit_Name (Right) then
-- -- Unit_Name should reset context!
-- return False;
-- else
-- Left_Kind := Kind (Left);
-- Right_Kind := Kind (Right);
-- if Left_Kind /= Right_Kind then
-- return False;
-- elsif Left_Kind = A_Nonexistent_Declaration or else
-- Left_Kind = A_Nonexistent_Body
-- then
-- return True;
-- else
return Right_Unit_Id = Get_Same_Unit
(Left_Cont_Id, Left_Unit_Id, Right_Cont_Id);
-- end if;
-- end if;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Is_Equal");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Is_Equal");
end Is_Equal;
-----------------------------------------------------------------------------
function Is_Identical
(Left : in Asis.Compilation_Unit;
Right : in Asis.Compilation_Unit)
return Boolean
is
Left_Cont_Id : Context_Id;
Right_Cont_Id : Context_Id;
begin
Check_Validity (Left, "Asis.Compilation_Units.Is_Identical");
Check_Validity (Right, "Asis.Compilation_Units.Is_Identical");
Left_Cont_Id := Encl_Cont_Id (Left);
Right_Cont_Id := Encl_Cont_Id (Right);
return Left_Cont_Id = Right_Cont_Id and then Is_Equal (Left, Right);
end Is_Identical;
-----------------------------------------------------------------------------
function Unit_Full_Name
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Unit_Full_Name");
if Is_Nil (Compilation_Unit) then
return Nil_Asis_Wide_String;
else
Reset_Context (Encl_Cont_Id (Compilation_Unit));
return To_Wide_String (Unit_Name (Compilation_Unit));
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Unit_Full_Name");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Unit_Full_Name");
end Unit_Full_Name;
-----------------------------------------------------------------------------
function Unique_Name
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
Arg_Kind : Unit_Kinds;
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Unique_Name");
if Is_Nil (Compilation_Unit) then
return Nil_Asis_Wide_String;
else
Reset_Context (Encl_Cont_Id (Compilation_Unit));
Arg_Kind := Unit_Kind (Compilation_Unit);
-- ???!!! Diagnosis_Buffer and Diagnosis_Len should noy be used here!
Diagnosis_Len := 0;
A4G.Vcheck.Add (Context_Info (Compilation_Unit));
A4G.Vcheck.Add (": ");
A4G.Vcheck.Add (Unit_Name (Compilation_Unit));
case Arg_Kind is
when Asis.A_Library_Unit_Body =>
A4G.Vcheck.Add (" (body)");
when Asis.A_Subunit =>
A4G.Vcheck.Add (" (subunit)");
when others =>
A4G.Vcheck.Add (" (spec)");
end case;
return To_Wide_String (Diagnosis_Buffer (1 .. Diagnosis_Len));
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Unique_Name");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Unique_Name");
end Unique_Name;
-----------------------------------------------------------------------------
function Exists
(Compilation_Unit : in Asis.Compilation_Unit)
return Boolean
is
Unit_Kind : Asis.Unit_Kinds;
begin
Check_Validity (Compilation_Unit, "Asis.Compilation_Units.Exists");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
Unit_Kind := Kind (Compilation_Unit);
return not (Unit_Kind = Not_A_Unit or else
Unit_Kind = A_Nonexistent_Declaration or else
Unit_Kind = A_Nonexistent_Body);
end Exists;
-----------------------------------------------------------------------------
function Can_Be_Main_Program
(Compilation_Unit : in Asis.Compilation_Unit)
return Boolean
is
Unit_Kind : Asis.Unit_Kinds;
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Can_Be_Main_Program");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
Unit_Kind := Kind (Compilation_Unit);
if not (Unit_Kind = A_Procedure or else
Unit_Kind = A_Function or else
Unit_Kind = A_Procedure_Body or else
Unit_Kind = A_Function_Body)
then
return False;
else
return Is_Main_Unit (Compilation_Unit);
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Can_Be_Main_Program");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Can_Be_Main_Program");
end Can_Be_Main_Program;
-----------------------------------------------------------------------------
function Is_Body_Required
(Compilation_Unit : in Asis.Compilation_Unit)
return Boolean
is
Unit_Kind : Asis.Unit_Kinds;
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Is_Body_Required");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
Unit_Kind := Kind (Compilation_Unit);
if not (Unit_Kind = A_Package or else
Unit_Kind = A_Generic_Package)
then
return False;
else
return Asis.Set_Get.Is_Body_Required (Compilation_Unit);
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Is_Body_Required");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Is_Body_Required");
end Is_Body_Required;
-----------------------------------------------------------------------------
function Text_Name
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Text_Name");
if not Exists (Compilation_Unit) then
return Nil_Asis_Wide_String;
else
-- Exists resets the Context!
return To_Wide_String (Ref_File (Compilation_Unit));
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Text_Name");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Text_Name");
end Text_Name;
-----------------------------------------------------------------------------
function Text_Form
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Text_Form");
return Nil_Asis_Wide_String;
-- exception
-- when ASIS_Inappropriate_Compilation_Unit =>
-- raise;
-- when ASIS_Failed =>
-- Add_Call_Information (Outer_Call =>
-- "Asis.Compilation_Units.Text_Form");
-- raise;
-- when others =>
-- Raise_ASIS_Failed (Diagnosis =>
-- "Asis.Compilation_Units.Text_Form");
end Text_Form;
-----------------------------------------------------------------------------
function Object_Name
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Object_Name");
if not Exists (Compilation_Unit) then
return Nil_Asis_Wide_String;
else
return Nil_Asis_Wide_String;
-- chould be changed to real implementation
end if;
-- exception
-- when ASIS_Inappropriate_Compilation_Unit =>
-- raise;
-- when ASIS_Failed =>
-- Add_Call_Information (Outer_Call =>
-- "Asis.Compilation_Units.Object_Name");
-- raise;
-- when others =>
-- Raise_ASIS_Failed (Diagnosis =>
-- "Asis.Compilation_Units.Object_Name");
end Object_Name;
-----------------------------------------------------------------------------
function Object_Form
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Object_Form");
if not Exists (Compilation_Unit) then
return Nil_Asis_Wide_String;
else
return Nil_Asis_Wide_String;
-- chould be changed to real implementation
end if;
-- exception
-- when ASIS_Inappropriate_Compilation_Unit =>
-- raise;
-- when ASIS_Failed =>
-- Add_Call_Information (Outer_Call =>
-- "Asis.Compilation_Units.Object_Form");
-- raise;
-- when others =>
-- Raise_ASIS_Failed (Diagnosis =>
-- "Asis.Compilation_Units.Object_Form");
end Object_Form;
-----------------------------------------------------------------------------
function Compilation_Command_Line_Options
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
use Lib.Compilation_Arguments;
Arg_Len : Natural := 0;
Corr_Main_Unit_Id : Unit_Id := Nil_Unit;
Corresponding_Main_Unit : Asis.Compilation_Unit := Nil_Compilation_Unit;
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Compilation_Command_Line_Options");
Arg_Kind := Kind (Compilation_Unit);
if Arg_Kind not in A_Procedure .. A_Protected_Body_Subunit then
return Nil_Asis_Wide_String;
end if;
Arg_Cont_Id := Encl_Cont_Id (Compilation_Unit);
Reset_Context (Arg_Cont_Id);
if Is_Main_Unit_In_Tree (Compilation_Unit) then
Corresponding_Main_Unit := Compilation_Unit;
else
Arg_Unit_Id := Get_Unit_Id (Compilation_Unit);
-- Here we have to check if the argument unit should to
-- inherit command line options from some main unit:
if Arg_Kind in A_Procedure .. A_Package then
-- Here we have to check if the corresponding body is a
-- main unit of some compilation:
Corr_Main_Unit_Id := Get_Body (Arg_Cont_Id, Arg_Unit_Id);
elsif Arg_Kind in A_Procedure_Body_Subunit ..
A_Protected_Body_Subunit
then
-- We have to go to ancestor body and to check it it is a main
-- unit of some compilation
Corr_Main_Unit_Id :=
Get_Subunit_Parent_Body (Arg_Cont_Id, Arg_Unit_Id);
while Class (Arg_Cont_Id, Corr_Main_Unit_Id) = A_Separate_Body
loop
Corr_Main_Unit_Id :=
Get_Subunit_Parent_Body (Arg_Cont_Id, Corr_Main_Unit_Id);
end loop;
end if;
Corresponding_Main_Unit :=
Get_Comp_Unit (Corr_Main_Unit_Id, Arg_Cont_Id);
if not Is_Main_Unit_In_Tree (Corresponding_Main_Unit) then
Corresponding_Main_Unit := Nil_Compilation_Unit;
end if;
end if;
if Is_Nil (Corresponding_Main_Unit) then
return Nil_Asis_Wide_String;
else
Reset_Main_Tree (Corresponding_Main_Unit);
-- First, declaring the length of the string to return:
for Next_Arg in 1 .. Last loop
Arg_Len := Arg_Len + Table (Next_Arg)'Length + 1;
end loop;
if Arg_Len > 0 then
Arg_Len := Arg_Len - 1;
end if;
declare
Result : String (1 .. Arg_Len);
Next_Pos : Natural := 1;
Next_Arg_Len : Natural;
begin
-- Should be rewritten on the base of ASIS string buffer???
for Next_Arg in 1 .. Last loop
Next_Arg_Len := Table (Next_Arg)'Length;
Result (Next_Pos .. Next_Pos + Next_Arg_Len - 1) :=
Table (Next_Arg).all;
Next_Pos := Next_Pos + Next_Arg_Len;
if Next_Arg < Last then
Result (Next_Pos) := ' ';
Next_Pos := Next_Pos + 1;
end if;
end loop;
return To_Wide_String (Result);
end;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Compilation_Command_Line_Options");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Compilation_Command_Line_Options");
end Compilation_Command_Line_Options;
-----------------------------------------------------------------------------
function Has_Attribute
(Compilation_Unit : in Asis.Compilation_Unit;
Attribute : in Wide_String)
return Boolean
is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Has_Attribute");
return False;
end Has_Attribute;
-----------------------------------------------------------------------------
function Attribute_Value_Delimiter return Wide_String is
begin
return Asis_Wide_Line_Terminator;
end Attribute_Value_Delimiter;
-----------------------------------------------------------------------------
function Attribute_Values
(Compilation_Unit : in Asis.Compilation_Unit;
Attribute : in Wide_String)
return Wide_String
is
begin
Check_Validity (Compilation_Unit,
"Asis.Compilation_Units.Attribute_Values");
return Nil_Asis_Wide_String;
end Attribute_Values;
------------------------------------------------------------------------------
function Subunits
(Parent_Body : in Asis.Compilation_Unit)
return Asis.Compilation_Unit_List
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Res_Cont_Id : Context_Id;
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (Parent_Body,
"Asis.Compilation_Units.Subunits");
Res_Cont_Id := Encl_Cont_Id (Parent_Body);
Reset_Context (Res_Cont_Id);
Arg_Kind := Kind (Parent_Body);
if not (Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Subunits");
end if;
Cont_Tree_Mode := Tree_Processing_Mode (Res_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Subunits");
end if;
Arg_Unit_Id := Get_Unit_Id (Parent_Body);
declare
Result_Id_List : Unit_Id_List renames
Subunits (Res_Cont_Id, Arg_Unit_Id);
Result_List : Compilation_Unit_List renames
Get_Comp_Unit_List (Result_Id_List, Res_Cont_Id);
begin
return Result_List;
end;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Subunits");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Subunits");
end Subunits;
function Subunits
(Parent_Body : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit_List
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
Cont_Tree_Mode : Tree_Mode;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Subunits");
Check_Validity (Parent_Body,
"Asis.Compilation_Units.Subunits");
Arg_Cont_Id := Encl_Cont_Id (Parent_Body);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Parent_Body);
if not (Arg_Kind = A_Procedure_Body or else
Arg_Kind = A_Function_Body or else
Arg_Kind = A_Package_Body or else
Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Subunits");
end if;
Result_Cont_Id := Get_Cont_Id (The_Context);
Cont_Tree_Mode := Tree_Processing_Mode (Result_Cont_Id);
if Cont_Tree_Mode /= Pre_Created then
Not_Implemented_Yet (Diagnosis =>
"Asis.Compilation_Units.Subunits");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
end if;
Arg_Unit_Id := Get_Unit_Id (Parent_Body);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Subunits
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit_List;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Subunits");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Subunits");
end Subunits;
-----------------------------------------------------------------------------
function Corresponding_Subunit_Parent_Body
(Subunit : in Asis.Compilation_Unit)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Result_Unit_Id : Unit_Id;
Result_Cont_Id : Context_Id;
begin
Check_Validity
(Subunit,
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
Result_Cont_Id := Encl_Cont_Id (Subunit);
Reset_Context (Result_Cont_Id);
Arg_Kind := Kind (Subunit);
if not (Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end if;
Arg_Unit_Id := Get_Unit_Id (Subunit);
Result_Unit_Id := Get_Subunit_Parent_Body (Result_Cont_Id, Arg_Unit_Id);
-- if not Is_Consistent (Result_Cont_Id, Result_Unit_Id, Arg_Unit_Id) then
-- Result_Unit_Id := Get_Nonexistent_Unit (Result_Cont_Id);
-- end if;
return Get_Comp_Unit (Result_Unit_Id, Result_Cont_Id);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end Corresponding_Subunit_Parent_Body;
function Corresponding_Subunit_Parent_Body
(Subunit : in Asis.Compilation_Unit;
The_Context : in Asis.Context)
return Asis.Compilation_Unit
is
Arg_Kind : Asis.Unit_Kinds;
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
Result_Cont_Id : Context_Id;
New_Arg_Unit_Id : Unit_Id;
begin
Check_Validity (The_Context,
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
Check_Validity (Subunit,
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
Arg_Cont_Id := Encl_Cont_Id (Subunit);
Reset_Context (Arg_Cont_Id);
Arg_Kind := Kind (Subunit);
if not (Arg_Kind = A_Procedure_Body_Subunit or else
Arg_Kind = A_Function_Body_Subunit or else
Arg_Kind = A_Package_Body_Subunit or else
Arg_Kind = A_Task_Body_Subunit or else
Arg_Kind = A_Protected_Body_Subunit)
then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end if;
Arg_Unit_Id := Get_Unit_Id (Subunit);
Result_Cont_Id := Get_Cont_Id (The_Context);
New_Arg_Unit_Id := Get_Same_Unit
(Arg_Cont_Id, Arg_Unit_Id, Result_Cont_Id);
if Present (New_Arg_Unit_Id) then
return Corresponding_Subunit_Parent_Body
(Get_Comp_Unit (New_Arg_Unit_Id, Result_Cont_Id));
else
return Nil_Compilation_Unit;
end if;
exception
when ASIS_Inappropriate_Compilation_Unit
| ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
if Status_Indicator /= Obsolete_Reference_Error then
Add_Call_Information (Outer_Call =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end if;
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Compilation_Units.Corresponding_Subunit_Parent_Body");
end Corresponding_Subunit_Parent_Body;
-----------------------------------------------------------------------------
function Debug_Image
(Compilation_Unit : in Asis.Compilation_Unit)
return Wide_String
is
LT : String renames A4G.A_Types.ASIS_Line_Terminator;
begin
return To_Wide_String (LT & "Compilation Unit Debug_Image: "
& Debug_String (Compilation_Unit));
end Debug_Image;
end Asis.Compilation_Units