+2011-08-04 Eric Botcazou <ebotcazou@adacore.com>
+
+ * bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate
+ the header of the finalization routine.
+ If the unit has no finalizer but is a body whose spec has one, then
+ generate the decrement of the elaboration entity only.
+ If the unit has a finalizer and is a spec, then do not generate the
+ decrement of the elaboration entity.
+ (Gen_Finalize_Library_C): Likewise.
+
+2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Alignment_Of): New subsidiary routine.
+ (Bounds_Size_Expression): Removed.
+ (Double_Alignment_Of): New subsidiary routine.
+ (Make_Finalize_Address_Stmts): New local variable Index_Typ. Account
+ for a hole in the dope vector of unconstrained arrays due to different
+ index and element alignments.
+
+2011-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Allocator): diagnose task allocator that will
+ raise program_error because body has not been seen yet.
+
+2011-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Analyze_With_Clause): Protect against child unit with
+ an unresolved name.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * makeutl.adb (Do_Complete): Check absolute paths in canonical forms
+
+2011-08-04 Yannick Moy <moy@adacore.com>
+
+ * alfa.adb, alfa.ads (Unique_Defining_Entity): move function from here
+ * sem_util.adb, sem_util.ads (Unique_Defining_Entity): ...to here
+
+2011-08-04 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for
+ instantiation in RCI.
+
+2011-08-04 Emmanuel Briot <briot@adacore.com>
+
+ * make.adb: Share more code with gprbuild
+
2011-08-04 Emmanuel Briot <briot@adacore.com>
* projects.texi: Added documentation for the IDE'Gnat project file
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
package body ALFA is
Debug_Put_ALFA;
end palfa;
- ----------------------------
- -- Unique_Defining_Entity --
- ----------------------------
-
- function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
- begin
- case Nkind (N) is
- when N_Package_Body =>
- return Corresponding_Spec (N);
-
- when N_Subprogram_Body =>
- if Acts_As_Spec (N) then
- return Defining_Entity (N);
- else
- return Corresponding_Spec (N);
- end if;
-
- when others =>
- return Defining_Entity (N);
- end case;
- end Unique_Defining_Entity;
-
end ALFA;
procedure Initialize_ALFA_Tables;
-- Reset tables for a new compilation
- function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
- -- Return the entity which represents declaration N, so that matching
- -- declaration and body have the same entity.
-
procedure dalfa;
-- Debug routine to dump internal ALFA tables. This is a raw format dump
-- showing exactly what the tables contain.
Uspec : Unit_Record;
Unum : Unit_Id;
+ procedure Gen_Header;
+ -- Generate the header of the finalization routine
+
+ procedure Gen_Header is
+ begin
+ WBI (" procedure finalize_library is");
+
+ -- The following flag is used to check for library-level
+ -- exceptions raised during finalization. The symbol comes
+ -- from System.Soft_Links. VM targets use regular Ada to
+ -- reference the entity.
+
+ if VM_Target = No_VM then
+ WBI (" LE_Set : Boolean;");
+
+ Set_String (" pragma Import (Ada, LE_Set, ");
+ Set_String ("""__gnat_library_exception_set"");");
+ Write_Statement_Buffer;
+ end if;
+
+ WBI (" begin");
+ end Gen_Header;
+
begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
U := Units.Table (Unum);
+ -- Dealing with package bodies is a little complicated. In such
+ -- cases we must retrieve the package spec since it contains the
+ -- spec of the body finalizer.
+
+ if U.Utype = Is_Body then
+ Unum := Unum + 1;
+ Uspec := Units.Table (Unum);
+ else
+ Uspec := U;
+ end if;
+
+ Get_Name_String (Uspec.Uname);
+
-- We are only interested in non-generic packages
- if U.Unit_Kind = 'p'
- and then U.Has_Finalizer
- and then not U.Is_Generic
- and then not U.SAL_Interface
- and then not U.No_Elab
- then
- if not Lib_Final_Built then
- Lib_Final_Built := True;
+ if U.Unit_Kind /= 'p' or else U.Is_Generic then
+ null;
- WBI (" procedure finalize_library is");
+ -- That aren't an interface to a stand alone library
- -- The following flag is used to check for library-level
- -- exceptions raised during finalization. The symbol comes
- -- from System.Soft_Links. VM targets use regular Ada to
- -- reference the entity.
+ elsif U.SAL_Interface then
+ null;
- if VM_Target = No_VM then
- WBI (" LE_Set : Boolean;");
+ -- Case of no finalization
- Set_String (" pragma Import (Ada, LE_Set, ");
- Set_String ("""__gnat_library_exception_set"");");
- Write_Statement_Buffer;
+ elsif not U.Has_Finalizer then
+
+ -- The only case in which we have to do something is if this
+ -- is a body, with a separate spec, where the separate spec
+ -- has a finalizer. In that case, this is where we decrement
+ -- the elaboration entity.
+
+ if U.Utype = Is_Body and then Uspec.Has_Finalizer then
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
end if;
- WBI (" begin");
+ Set_String (" E");
+ Set_Unit_Number (Unum);
+ Set_String (" := E");
+ Set_Unit_Number (Unum);
+ Set_String (" - 1;");
+ Write_Statement_Buffer;
+ end if;
+
+ else
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
end if;
-- Generate:
Set_Int (Count);
Set_String (", """);
- -- Dealing with package bodies is a little complicated. In such
- -- cases we must retrieve the package spec since it contains the
- -- spec of the body finalizer.
-
- if U.Utype = Is_Body then
- Unum := Unum + 1;
- Uspec := Units.Table (Unum);
- else
- Uspec := U;
- end if;
-
- Get_Name_String (Uspec.Uname);
-
-- Perform name construction
-- .NET xx.yy_pkg.xx__yy__finalize
-- F<Count>;
-- end;
+ -- The uname_E decrement is skipped if this is a separate spec,
+ -- since it will be done when we process the body.
+
WBI (" begin");
- Set_String (" E");
- Set_Unit_Number (Unum);
- Set_String (" := E");
- Set_Unit_Number (Unum);
- Set_String (" - 1;");
- Write_Statement_Buffer;
+
+ if U.Utype /= Is_Spec then
+ Set_String (" E");
+ Set_Unit_Number (Unum);
+ Set_String (" := E");
+ Set_Unit_Number (Unum);
+ Set_String (" - 1;");
+ Write_Statement_Buffer;
+ end if;
if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if E");
Uspec : Unit_Record;
Unum : Unit_Id;
+ procedure Gen_Header;
+ -- Generate the header of the finalization routine
+
+ procedure Gen_Header is
+ begin
+ WBI ("static void finalize_library(void) {");
+ end Gen_Header;
+
begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
U := Units.Table (Unum);
+ -- Dealing with package bodies is a little complicated. In such
+ -- cases we must retrieve the package spec since it contains the
+ -- spec of the body finalizer.
+
+ if U.Utype = Is_Body then
+ Unum := Unum + 1;
+ Uspec := Units.Table (Unum);
+ else
+ Uspec := U;
+ end if;
+
+ Get_Name_String (Uspec.Uname);
+
-- We are only interested in non-generic packages
- if U.Unit_Kind = 'p'
- and then U.Has_Finalizer
- and then not U.Is_Generic
- and then not U.SAL_Interface
- and then not U.No_Elab
- then
- if not Lib_Final_Built then
- Lib_Final_Built := True;
+ if U.Unit_Kind /= 'p' or else U.Is_Generic then
+ null;
- WBI ("static void finalize_library(void) {");
- end if;
+ -- That aren't an interface to a stand alone library
- -- Dealing with package bodies is a little complicated. In such
- -- cases we must retrieve the package spec since it contains the
- -- spec of the body finalizer.
+ elsif U.SAL_Interface then
+ null;
- if U.Utype = Is_Body then
- Unum := Unum + 1;
- Uspec := Units.Table (Unum);
- else
- Uspec := U;
+ -- Case of no finalization
+
+ elsif not U.Has_Finalizer then
+
+ -- The only case in which we have to do something is if this
+ -- is a body, with a separate spec, where the separate spec
+ -- has a finalizer. In that case, this is where we decrement
+ -- the elaboration entity.
+
+ if U.Utype = Is_Body and then Uspec.Has_Finalizer then
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
+ end if;
+
+ Set_String (" ");
+ Set_Unit_Name;
+ Set_String ("_E--;");
+ Write_Statement_Buffer;
end if;
- Get_Name_String (Uspec.Uname);
+ else
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
+ end if;
-- If binding a library or if there is a non-Ada main subprogram
-- then we generate:
-- uname_E--;
-- uname__finalize_[spec|body] ();
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("_E--;");
- Write_Statement_Buffer;
+ -- The uname_E decrement is skipped if this is a separate spec,
+ -- since it will be done when we process the body.
+
+ if U.Utype /= Is_Spec then
+ Set_String (" ");
+ Set_Unit_Name;
+ Set_String ("_E--;");
+ Write_Statement_Buffer;
+ end if;
if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if (");
Desg_Typ : Entity_Id;
Obj_Expr : Node_Id;
+ function Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
+ -- Subsidiary routine, generate the following attribute reference:
+ --
+ -- Some_Typ'Alignment
+
+ function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
+ -- Subsidiary routine, generate the following expression:
+ --
+ -- 2 * Some_Typ'Alignment
+
+ ------------------
+ -- Alignment_Of --
+ ------------------
+
+ function Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Some_Typ, Loc),
+ Attribute_Name => Name_Alignment);
+ end Alignment_Of;
+
+ -------------------------
+ -- Double_Alignment_Of --
+ -------------------------
+
+ function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Make_Integer_Literal (Loc, 2),
+ Right_Opnd => Alignment_Of (Some_Typ));
+ end Double_Alignment_Of;
+
+ -- Start of processing for Make_Finalize_Address_Stmts
+
begin
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
-- Unconstrained arrays require special processing in order to retrieve
-- the elements. To achieve this, we have to skip the dope vector which
- -- lays infront of the elements and then use a thin pointer to perform
+ -- lays in front of the elements and then use a thin pointer to perform
-- the address-to-access conversion.
if Is_Array_Type (Typ)
Dope_Id : Entity_Id;
For_First : Boolean := True;
Index : Node_Id;
-
- function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id;
- -- Given the type of an array index, create the following
- -- expression:
- --
- -- 2 * Esize (Typ) / Storage_Unit
-
- ----------------------------
- -- Bounds_Size_Expression --
- ----------------------------
-
- function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id is
- begin
- return
- Make_Op_Multiply (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, 2),
- Right_Opnd =>
- Make_Op_Divide (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit)));
- end Bounds_Size_Expression;
-
- -- Start of processing for arrays
+ Index_Typ : Entity_Id;
begin
-- Ensure that Ptr_Typ a thin pointer, generate:
Make_Integer_Literal (Loc, System_Address_Size)));
-- For unconstrained arrays, create the expression which computes
- -- the size of the dope vector. Note that in the end, all values
- -- will be constant folded.
+ -- the size of the dope vector.
Index := First_Index (Typ);
while Present (Index) loop
+ Index_Typ := Etype (Index);
- -- Generate:
- -- 2 * Esize (Index_Typ) / Storage_Unit
+ -- Each bound has two values and a potential hole added to
+ -- compensate for alignment differences.
if For_First then
For_First := False;
- Dope_Expr := Bounds_Size_Expression (Etype (Index));
- -- Generate:
- -- Dope_Expr + 2 * Esize (Index_Typ) / Storage_Unit
+ -- Generate:
+ -- 2 * Index_Typ'Alignment
+
+ Dope_Expr := Double_Alignment_Of (Index_Typ);
else
+ -- Generate:
+ -- Dope_Expr + 2 * Index_Typ'Alignment
+
Dope_Expr :=
Make_Op_Add (Loc,
Left_Opnd => Dope_Expr,
- Right_Opnd => Bounds_Size_Expression (Etype (Index)));
+ Right_Opnd => Double_Alignment_Of (Index_Typ));
end if;
Next_Index (Index);
end loop;
+ -- Round the cumulative alignment to the next higher multiple of
+ -- the array alignment. Generate:
+
+ -- ((Dope_Expr + Typ'Alignment - 1) / Typ'Alignment)
+ -- * Typ'Alignment
+
+ Dope_Expr :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Op_Add (Loc,
+ Left_Opnd => Dope_Expr,
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Alignment_Of (Typ),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))),
+ Right_Opnd => Alignment_Of (Typ)),
+ Right_Opnd => Alignment_Of (Typ));
+
-- Generate:
-- Dnn : Storage_Offset := Dope_Expr;
-----------------
procedure Check_Mains is
- Real_Main_Project : Project_Id := No_Project;
- -- The project of the first main
-
- Proj : Project_Id := No_Project;
- -- The project of the current main
-
- Real_Path : String_Access;
-
begin
- Mains.Reset;
-
- -- Check each main
-
- loop
- declare
- Main : constant String := Mains.Next_Main;
- -- The name specified on the command line may include directory
- -- information.
-
- File_Name : constant String := Base_Name (Main);
- -- The simple file name of the current main
-
- Lang : Language_Ptr;
-
- begin
- exit when Main = "";
-
- -- Get the project of the current main
-
- Proj := Prj.Env.Project_Of
- (File_Name, Main_Project, Project_Tree);
-
- -- Fail if the current main is not a source of a project
-
- if Proj = No_Project then
- Make_Failed
- ("""" & Main & """ is not a source of any project");
-
- else
- -- If there is directory information, check that the source
- -- exists and, if it does, that the path is the actual path
- -- of a source of a project.
-
- if Main /= File_Name then
- Lang := Get_Language_From_Name (Main_Project, "ada");
-
- Real_Path :=
- Locate_Regular_File
- (Main & Get_Name_String
- (Lang.Config.Naming_Data.Body_Suffix),
- "");
- if Real_Path = null then
- Real_Path :=
- Locate_Regular_File
- (Main & Get_Name_String
- (Lang.Config.Naming_Data.Spec_Suffix),
- "");
- end if;
-
- if Real_Path = null then
- Real_Path := Locate_Regular_File (Main, "");
- end if;
-
- -- Fail if the file cannot be found
-
- if Real_Path = null then
- Make_Failed ("file """ & Main & """ does not exist");
- end if;
-
- declare
- Project_Path : constant String :=
- Prj.Env.File_Name_Of_Library_Unit_Body
- (Name => File_Name,
- Project => Main_Project,
- In_Tree => Project_Tree,
- Main_Project_Only => False,
- Full_Path => True);
- Normed_Path : constant String :=
- Normalize_Pathname
- (Real_Path.all,
- Case_Sensitive => False);
- Proj_Path : constant String :=
- Normalize_Pathname
- (Project_Path,
- Case_Sensitive => False);
-
- begin
- Free (Real_Path);
-
- -- Fail if it is not the correct path
-
- if Normed_Path /= Proj_Path then
- if Verbose_Mode then
- Set_Standard_Error;
- Write_Str (Normed_Path);
- Write_Str (" /= ");
- Write_Line (Proj_Path);
- end if;
-
- Make_Failed
- ("""" & Main &
- """ is not a source of any project");
- end if;
- end;
- end if;
-
- if not Unique_Compile then
-
- -- Record the project, if it is the first main
-
- if Real_Main_Project = No_Project then
- Real_Main_Project := Proj;
-
- elsif Proj /= Real_Main_Project then
-
- -- Fail, as the current main is not a source of the
- -- same project as the first main.
-
- Make_Failed
- ("""" & Main &
- """ is not a source of project " &
- Get_Name_String (Real_Main_Project.Name));
- end if;
- end if;
- end if;
-
- -- If -u and -U are not used, we may have mains that are
- -- sources of a project that is not the one specified with
- -- switch -P.
+ if Mains.Number_Of_Mains (Project_Tree) = 0
+ and then not Unique_Compile
+ then
+ Mains.Fill_From_Project (Main_Project, Project_Tree);
+ end if;
- if not Unique_Compile then
- Main_Project := Real_Main_Project;
- end if;
- end;
- end loop;
+ Mains.Complete_Mains
+ (Root_Environment.Flags, Main_Project, Project_Tree);
+--
+--
+-- Real_Main_Project : Project_Id := No_Project;
+-- -- The project of the first main
+--
+-- Proj : Project_Id := No_Project;
+-- -- The project of the current main
+--
+-- Real_Path : String_Access;
+--
+-- begin
+-- Mains.Reset;
+--
+-- -- Check each main
+--
+-- loop
+-- declare
+-- Main : constant String := Mains.Next_Main;
+-- -- The name specified on the command line may include directory
+-- -- information.
+--
+-- File_Name : constant String := Base_Name (Main);
+-- -- The simple file name of the current main
+--
+-- Lang : Language_Ptr;
+--
+-- begin
+-- exit when Main = "";
+--
+-- -- Get the project of the current main
+--
+-- Proj := Prj.Env.Project_Of
+-- (File_Name, Main_Project, Project_Tree);
+--
+-- -- Fail if the current main is not a source of a project
+--
+-- if Proj = No_Project then
+-- Make_Failed
+-- ("""" & Main & """ is not a source of any project");
+--
+-- else
+-- -- If there is directory information, check that the source
+-- -- exists and, if it does, that the path is the actual path
+-- -- of a source of a project.
+--
+-- if Main /= File_Name then
+-- Lang := Get_Language_From_Name (Main_Project, "ada");
+--
+-- Real_Path :=
+-- Locate_Regular_File
+-- (Main & Get_Name_String
+-- (Lang.Config.Naming_Data.Body_Suffix),
+-- "");
+-- if Real_Path = null then
+-- Real_Path :=
+-- Locate_Regular_File
+-- (Main & Get_Name_String
+-- (Lang.Config.Naming_Data.Spec_Suffix),
+-- "");
+-- end if;
+--
+-- if Real_Path = null then
+-- Real_Path := Locate_Regular_File (Main, "");
+-- end if;
+--
+-- -- Fail if the file cannot be found
+--
+-- if Real_Path = null then
+-- Make_Failed ("file """ & Main & """ does not exist");
+-- end if;
+--
+-- declare
+-- Project_Path : constant String :=
+-- Prj.Env.File_Name_Of_Library_Unit_Body
+-- (Name => File_Name,
+-- Project => Main_Project,
+-- In_Tree => Project_Tree,
+-- Main_Project_Only => False,
+-- Full_Path => True);
+-- Normed_Path : constant String :=
+-- Normalize_Pathname
+-- (Real_Path.all,
+-- Case_Sensitive => False);
+-- Proj_Path : constant String :=
+-- Normalize_Pathname
+-- (Project_Path,
+-- Case_Sensitive => False);
+--
+-- begin
+-- Free (Real_Path);
+--
+-- -- Fail if it is not the correct path
+--
+-- if Normed_Path /= Proj_Path then
+-- if Verbose_Mode then
+-- Set_Standard_Error;
+-- Write_Str (Normed_Path);
+-- Write_Str (" /= ");
+-- Write_Line (Proj_Path);
+-- end if;
+--
+-- Make_Failed
+-- ("""" & Main &
+-- """ is not a source of any project");
+-- end if;
+-- end;
+-- end if;
+--
+-- if not Unique_Compile then
+--
+-- -- Record the project, if it is the first main
+--
+-- if Real_Main_Project = No_Project then
+-- Real_Main_Project := Proj;
+--
+-- elsif Proj /= Real_Main_Project then
+--
+-- -- Fail, as the current main is not a source of the
+-- -- same project as the first main.
+--
+-- Make_Failed
+-- ("""" & Main &
+-- """ is not a source of project " &
+-- Get_Name_String (Real_Main_Project.Name));
+-- end if;
+-- end if;
+-- end if;
+--
+-- -- If -u and -U are not used, we may have mains that are
+-- -- sources of a project that is not the one specified with
+-- -- switch -P.
+--
+-- if not Unique_Compile then
+-- Main_Project := Real_Main_Project;
+-- end if;
+-- end;
+-- end loop;
end Check_Mains;
-- Start of processing for Gnatmake
then
-- Traverse in reverse order, since in the case of multi-unit
-- files we will be adding extra files at the end, and there's
- -- no need to process them in tun.
+ -- no need to process them in turn.
for J in reverse Names.First .. Names.Last loop
declare
else
if Is_Absolute then
- if File_Name_Type (Source.Path.Display_Name) /=
+ if File_Name_Type (Source.Path.Name) /=
File.File
then
Debug_Output
Par_Name := Entity (Pref);
end if;
- Set_Entity_With_Style_Check (Pref, Par_Name);
- Generate_Reference (Par_Name, Pref);
+ -- Guard against missing or misspelled child units.
+
+ if Present (Par_Name) then
+ Set_Entity_With_Style_Check (Pref, Par_Name);
+ Generate_Reference (Par_Name, Pref);
+
+ else
+ Set_Name (N, Make_Null (Sloc (N)));
+ return;
+ end if;
end if;
-- If the withed unit is System, and a system extension pragma is
end if;
end;
- -- If we are generating calling stubs, we never need a body for an
- -- instantiation from source in the visible part, because in that
- -- case we'll be generating stubs for any subprogram in the instance.
- -- However normal processing occurs for instantiations in generated
- -- code or in the private part, since in those cases we do not
- -- generate stubs.
-
- if Distribution_Stub_Mode = Generate_Caller_Stub_Body
- and then Comes_From_Source (N)
- then
- Needs_Body := False;
- end if;
+ -- Note that we generate the instance body even when generating
+ -- calling stubs for an RCI unit: it may be required e.g. if it
+ -- provides stream attributes for some type used in the profile of a
+ -- remote subprogram. If the instantiation is within the visible part
+ -- of the RCI, then calling stubs for any relevant subprogram will
+ -- be inserted immediately after the subprogram declaration, and
+ -- will take precedence over the subsequent (original) body. (The
+ -- stub and original body will be complete homographs, but this is
+ -- permitted in an instance).
+
+ -- Could we do better and remove the original subprogram body in that
+ -- case???
if Needs_Body then
Set_Is_Static_Coextension (N, False);
end if;
end if;
+
+ -- Report a simple error: if the designated object is a local task,
+ -- its body has not been seen yet, and its activation will fail
+ -- an elaboration check.
+
+ if Is_Task_Type (Designated_Type (Typ))
+ and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope
+ and then Is_Compilation_Unit (Current_Scope)
+ and then Ekind (Current_Scope) = E_Package
+ and then not In_Package_Body (Current_Scope)
+ then
+ Error_Msg_N
+ ("cannot activate task before body seen?", N);
+ Error_Msg_N ("\Program_Error will be raised at run time", N);
+ end if;
end Resolve_Allocator;
---------------------------
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
+ ----------------------------
+ -- Unique_Defining_Entity --
+ ----------------------------
+
+ function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
+ begin
+ case Nkind (N) is
+ when N_Package_Body =>
+ return Corresponding_Spec (N);
+
+ when N_Subprogram_Body =>
+ if Acts_As_Spec (N) then
+ return Defining_Entity (N);
+ else
+ return Corresponding_Spec (N);
+ end if;
+
+ when others =>
+ return Defining_Entity (N);
+ end case;
+ end Unique_Defining_Entity;
+
--------------------------
-- Unit_Declaration_Node --
--------------------------
function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ
+ function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
+ -- Return the entity which represents declaration N, so that matching
+ -- declaration and body have the same entity.
+
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the
projects / gcc.git / commitdiff