+2015-05-22 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Incomplete_Actuals): New attribute of
+ package instantiations. Holds the list of actuals in the instance
+ that are incomplete types, to determine where the corresponding
+ instance body must be placed.
+ * sem_ch6.adb (Conforming_Types): An incomplete type used as an
+ actual in an instance matches an incomplete formal.
+ * sem_disp.adb (Check_Dispatching_Call): Handle missing case of
+ explicit dereference.
+ (Inherited_Subprograms): In the presence of a limited view there
+ are no subprograms to inherit.
+ * sem_ch12.adb (Preanalyze_Actuals): Build list of incomplete
+ actuals of instance, for later placement of instance body and
+ freeze nodes for actuals.
+ (Install_Body): In the presence of actuals that incomplete types
+ from a limited view, the instance body cannot be placed after
+ the declaration because full views have not been seen yet. Any
+ use of the non-limited views in the instance body requires
+ the presence of a regular with_clause in the enclosing unit,
+ and will fail if this with_clause is missing. We place the
+ instance body at the beginning of the enclosing body, which is
+ the unit being compiled, and ensure that freeze nodes for the
+ full views of the incomplete types appear before the instance.
+
+2015-05-22 Pascal Obry <obry@adacore.com>
+
+ * makeutl.ads, prj-conf.adb, prj-nmsc.adb, prj.ads
+ (In_Place_Option): Removed.
+ (Relocate_Build_Tree_Option): New constant.
+ (Root_Dir_Option): New constant.
+ (Obj_Root_Dir): Removed.
+ (Build_Tree_Dir): New variable.
+ (Root_Src_Tree): Removed.
+ (Root_Dir): New variable.
+ * prj-conf.adb (Get_Or_Create_Configuration_File): Add check
+ for improper relocation.
+ * prj-nmsc.adb (Locate_Directory): Add check for improper
+ relocation.
+
2015-05-22 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb (Default_Init_Cond_Procedure): Code cleanup. The
-- Protection_Object Node23
-- Stored_Constraint Elist23
+ -- Incomplete_Actuals Elist24
-- Related_Expression Node24
-- Subps_Index Uint24
return Node35 (Id);
end Import_Pragma;
+ function Incomplete_Actuals (Id : E) return L is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ return Elist24 (Id);
+ end Incomplete_Actuals;
+
function Interface_Alias (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id));
Set_Node4 (Id, V);
end Set_Homonym;
+ procedure Set_Incomplete_Actuals (Id : E; V : L) is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ Set_Elist24 (Id, V);
+ end Set_Incomplete_Actuals;
+
procedure Set_Import_Pragma (Id : E; V : E) is
begin
pragma Assert (Is_Subprogram (Id));
E_Procedure =>
Write_Str ("Subps_Index");
+ when E_Package =>
+ Write_Str ("Incomplete_Actuals");
+
when others =>
Write_Str ("Field24???");
end case;
-- Rep_Item chain mechanism, because a single pragma Import can apply
-- to multiple subprogram entities).
+-- Incomplete_Actuals (Elist24)
+-- Defined on package entities that are instances. Indicates the actusl
+-- types in the instantiation that are limited views. IF this list is
+-- not empty, the instantiation, which appears in a package declaration,
+-- is relocated to the corresponding package body, which must have a
+-- corresponding non-limited with_clause.
+
-- In_Package_Body (Flag48)
-- Defined in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
-- length objects). It is set conservatively (i.e. if it is True, the
-- size is certainly known at compile time, if it is False, then the
-- size may or may not be known at compile time, but the code will
--- assume that it is not known).
+-- assume that it is not known). Note that the value may be known only
+-- to the back end, so the fact that this flag is set does not mean that
+-- the front end can access the value.
-- Small_Value (Ureal21)
-- Defined in fixed point types. Points to the universal real for the
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
-- Limited_View (Node23) (non-generic/instance)
+ -- Incomplete_Actuals (Elist24) (for an instance)
-- Abstract_States (Elist25)
-- Package_Instantiation (Node26)
-- Current_Use_Clause (Node27)
function Hiding_Loop_Variable (Id : E) return E;
function Homonym (Id : E) return E;
function Import_Pragma (Id : E) return E;
+ function Incomplete_Actuals (Id : E) return L;
function In_Package_Body (Id : E) return B;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
procedure Set_Import_Pragma (Id : E; V : E);
+ procedure Set_Incomplete_Actuals (Id : E; V : L);
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
pragma Inline (Import_Pragma);
+ pragma Inline (Incomplete_Actuals);
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
pragma Inline (Set_Import_Pragma);
+ pragma Inline (Set_Incomplete_Actuals);
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
-- Switch used to indicate that the real directories (object, exec,
-- library, ...) are subdirectories of those in the project file.
- In_Place_Option : constant String := "--in-place";
+ Relocate_Build_Tree_Option : constant String := "--relocate-build-tree";
-- Switch to build out-of-tree. In this context the object, exec and
- -- library directories are relocated to the current working directory.
+ -- library directories are relocated to the current working directory
+ -- or the directory specified as parameter to this option.
+
+ Root_Dir_Option : constant String := "--root-dir";
+ -- The root directory under which all artifacts (objects, library, ali)
+ -- directory are to be found for the current compilation. This directory
+ -- will be use to relocate artifacts based on this directory. If this
+ -- option is not specificed the default value is the directory of the
+ -- main project.
Unchecked_Shared_Lib_Imports : constant String :=
"--unchecked-shared-lib-imports";
-- First, find the object directory of the Conf_Project
- -- If the object directory is a relative one and Obj_Root_Dir is set,
- -- first add it.
+ -- If the object directory is a relative one and Build_Tree_Dir is
+ -- set, first add it.
Name_Len := 0;
if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
- if Obj_Root_Dir /= null then
- Add_Str_To_Name_Buffer (Obj_Root_Dir.all);
+ if Build_Tree_Dir /= null then
+ Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
+
+ if Get_Name_String (Conf_Project.Directory.Display_Name)'Length
+ < Root_Dir'Length
+ then
+ Raise_Invalid_Config
+ ("cannot relocate deeper than object directory");
+ end if;
+
Add_Str_To_Name_Buffer
(Relative_Path
(Get_Name_String (Conf_Project.Directory.Display_Name),
- Root_Src_Tree.all));
+ Root_Dir.all));
else
Get_Name_String (Conf_Project.Directory.Display_Name);
end if;
Get_Name_String (Obj_Dir.Value);
else
- if Obj_Root_Dir /= null then
- Add_Str_To_Name_Buffer (Obj_Root_Dir.all);
+ if Build_Tree_Dir /= null then
+ if Get_Name_String
+ (Conf_Project.Directory.Display_Name)'Length
+ < Root_Dir'Length
+ then
+ Raise_Invalid_Config
+ ("cannot relocate deeper than object directory");
+ end if;
+
+ Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
Add_Str_To_Name_Buffer
(Relative_Path
(Get_Name_String (Conf_Project.Directory.Display_Name),
- Root_Src_Tree.all));
+ Root_Dir.all));
else
Add_Str_To_Name_Buffer
(Get_Name_String (Conf_Project.Directory.Display_Name));
end if;
end if;
- elsif not No_Sources
- and then (Subdirs /= null or else Obj_Root_Dir /= null)
+ elsif not No_Sources and then
+ (Subdirs /= null or else Build_Tree_Dir /= null)
then
Name_Len := 1;
Name_Buffer (1) := '.';
-- Check if we have a root-object dir specified, if so relocate all
-- artefact directories to it.
- if Obj_Root_Dir /= null
+ if Build_Tree_Dir /= null
and then Create /= ""
and then not Is_Absolute_Path (Get_Name_String (Name))
then
Name_Len := 0;
- Add_Str_To_Name_Buffer (Obj_Root_Dir.all);
+ Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
+
+ if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then
+ Err_Vars.Error_Msg_File_1 := Name;
+ Error_Or_Warning
+ (Data.Flags, Error,
+ "{ cannot relocate deeper than " & Create & " directory",
+ No_Location, Project);
+ end if;
+
Add_Str_To_Name_Buffer
(Relative_Path
(The_Parent (The_Parent'First .. The_Parent_Last),
- Root_Src_Tree.all));
+ Root_Dir.all));
Add_Str_To_Name_Buffer (Get_Name_String (Name));
else
- if Obj_Root_Dir /= null and then Create /= "" then
-
+ if Build_Tree_Dir /= null and then Create /= "" then
-- Issue a warning that we cannot relocate absolute obj dir
Err_Vars.Error_Msg_File_1 := Name;
-- The value after the equal sign in switch --subdirs=...
-- Contains the relative subdirectory.
- Obj_Root_Dir : String_Ptr := null;
+ Build_Tree_Dir : String_Ptr := null;
-- A root directory for building out-of-tree projects. All relative object
- -- directories will be rooted at this location. If Subdirs is also set it
- -- will be added at the end too.
+ -- directories will be rooted at this location.
- Root_Src_Tree : String_Ptr := null;
+ Root_Dir : String_Ptr := null;
-- When using out-of-tree build we need to keep information about the root
- -- directory source tree to properly relocate all projects to this root
- -- directory. Note that the root source directory is not necessary the
- -- directory of the main project.
+ -- directory of artifacts to properly relocate them. Note that the root
+ -- directory is not necessary the directory of the main project.
type Library_Support is (None, Static_Only, Full);
-- Support for Library Project File.
-- at the end of the enclosing generic package, which is semantically
-- neutral.
- procedure Preanalyze_Actuals (N : Node_Id);
+ procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty);
-- Analyze actuals to perform name resolution. Full resolution is done
-- later, when the expected types are known, but names have to be captured
-- before installing parents of generics, that are not visible for the
-- actuals themselves.
+ -- If Inst is present, it is the entity of the package instance. This
+ -- entity is marked as having a limited_view actual when some actual is
+ -- a limited view. This is used to place the instance body properly..
procedure Remove_Parent (In_Body : Boolean := False);
-- Reverse effect after instantiation of child is complete
end if;
Generate_Definition (Act_Decl_Id);
- Preanalyze_Actuals (N);
+ Set_Ekind (Act_Decl_Id, E_Package);
+
+ -- Initialize list of incomplete actuals before analysis.
+ Set_Incomplete_Actuals (Act_Decl_Id, New_Elmt_List);
+
+ Preanalyze_Actuals (N, Act_Decl_Id);
Init_Env;
Env_Installed := True;
-- Start of processing for Install_Body
begin
+ -- Handle first the case of an instance with incomplete actual types.
+ -- The instance body cannot be placed after the declaration because
+ -- full views have not been seen yet. Any use of the non-limited views
+ -- in the instance body requires the presence of a regular with_clause
+ -- in the enclosing unit, and will fail if this with_clause is missing.
+ -- We place the instance body at the beginning of the enclosing body,
+ -- which is the unit being compiled, and ensure that freeze nodes for
+ -- the full views of the incomplete types appear before the instance.
+
+ if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id))
+ and then Expander_Active
+ and then Ekind (Scope (Act_Id)) = E_Package
+ then
+ declare
+ Scop : constant Entity_Id := Scope (Act_Id);
+ Body_Id : constant Node_Id :=
+ Corresponding_Body (Unit_Declaration_Node (Scop));
+
+ begin
+ Ensure_Freeze_Node (Act_Id);
+ F_Node := Freeze_Node (Act_Id);
+ if Present (Body_Id) then
+ Set_Is_Frozen (Act_Id);
+ Prepend (Act_Body, Declarations (Parent (Body_Id)));
+ end if;
+
+ -- Add freeze nodes of formerly incomplete types ahead of
+ -- the instance body.
+
+ declare
+ Elmt : Elmt_Id;
+ F_T : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ Elmt := First_Elmt (Incomplete_Actuals (Act_Id));
+ while Present (Elmt) loop
+ Typ := Node (Elmt);
+ if From_Limited_With (Typ) then
+ Typ := Non_Limited_View (Typ);
+ end if;
+ Ensure_Freeze_Node (Typ);
+ F_T := Freeze_Node (Typ);
+
+ -- If freeze node is already in the tree, remove it
+ -- and place ahead of instance body.
+
+ if Is_List_Member (F_T) then
+ Remove (F_T);
+ end if;
+
+ Prepend (F_T, Declarations (Parent (Body_Id)));
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end;
+
+ return;
+ end if;
+
-- If the body is a subunit, the freeze point is the corresponding stub
-- in the current compilation, not the subunit itself.
-- Preanalyze_Actuals --
------------------------
- procedure Preanalyze_Actuals (N : Node_Id) is
+ procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is
Assoc : Node_Id;
Act : Node_Id;
Errs : constant Int := Serious_Errors_Detected;
elsif Nkind (Act) /= N_Operator_Symbol then
Analyze (Act);
+
+ if Is_Entity_Name (Act)
+ and then Is_Type (Entity (Act))
+ and then From_Limited_With (Entity (Act))
+ then
+ Append_Elmt (Entity (Act), Incomplete_Actuals (Inst));
+ end if;
end if;
if Errs /= Serious_Errors_Detected then
procedure Detect_And_Exchange (Id : Entity_Id);
-- Determine whether Id's type denotes an incomplete type associated
-- with a limited with clause and exchange the limited view with the
- -- non-limited one.
+ -- non-limited one when available.
-------------------------
-- Detect_And_Exchange --
procedure Detect_And_Exchange (Id : Entity_Id) is
Typ : constant Entity_Id := Etype (Id);
begin
- if From_Limited_With (Typ) and then Has_Non_Limited_View (Typ) then
+ if From_Limited_With (Typ)
+ and then Has_Non_Limited_View (Typ)
+ then
Set_Etype (Id, Non_Limited_View (Typ));
end if;
end Detect_And_Exchange;
then
return Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+
+ -- In Ada2012, incomplete types (including limited views) can appear
+ -- as actuals in instantiations.
+
+ elsif Is_Incomplete_Type (Type_1)
+ and then Is_Incomplete_Type (Type_2)
+ and then (Used_As_Generic_Actual (Type_1)
+ or else Used_As_Generic_Actual (Type_2))
+ then
+ return True;
end if;
-- Ada 2005 (AI-254): Anonymous access-to-subprogram types must be
end;
end if;
+ -- A limited view of an actual matches the corresponding
+ -- incomplete formal.
+
+ elsif Ekind (Desig_2) = E_Incomplete_Subtype
+ and then From_Limited_With (Desig_2)
+ and then Used_As_Generic_Actual (Etype (Desig_2))
+ then
+ return True;
+
else
return Base_Type (Desig_1) = Base_Type (Desig_2)
and then (Ctype = Type_Conformant
then
Func := Empty;
+ -- Ditto if it is an explicit dereference.
+
+ elsif
+ Nkind (Original_Node (Actual)) = N_Explicit_Dereference
+ then
+ Func := Empty;
+
-- Only other possibility is a qualified expression whose
-- constituent expression is itself a call.
begin
Tag_Typ := Find_Dispatching_Type (S);
+ -- In the presence of limited views there may be no visible
+ -- dispatching type. Primitives will be inherited when non-
+ -- limited view is frozen.
+
+ if No (Tag_Typ) then
+ return Result (1 .. 0);
+ end if;
+
if Is_Concurrent_Type (Tag_Typ) then
Tag_Typ := Corresponding_Record_Type (Tag_Typ);
end if;
projects / gcc.git / commitdiff