+2017-05-22 Ed Schonberg <schonberg@adacore.com>
+ Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Analyze_Call): In Ada2012 an incomplete type from a
+ limited view may appear in the profile of a function, and a call to
+ that function in another unit in which the full view is available must
+ use this full view to spurious type errors at the point of call.
+ * inline.adb (Analyze_Inlined_Bodies): Remove restriction on loading
+ of parent body with a with clause for the main unit.
+ * gcc-interface/decl.c (defer_limited_with_list): Document new usage.
+ (gnat_to_gnu_entity) <E_Access_Type>: Handle completed Taft Amendment
+ types declared in external units like types from limited with clauses.
+ Adjust final processing of defer_limited_with_list accordingly.
+ * gcc-interface/trans.c (gnat_to_gnu) < N_Selected_Component>: Try
+ again to translate the prefix after the field if it is incomplete.
+
2017-05-22 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (gnat_to_gnu_field): Do not enforce strict
static int defer_incomplete_level = 0;
static struct incomplete *defer_incomplete_list;
-/* This variable is used to delay expanding From_Limited_With types until the
- end of the spec. */
+/* This variable is used to delay expanding types coming from a limited with
+ clause and completed Taft Amendment types until the end of the spec. */
static struct incomplete *defer_limited_with_list;
typedef struct subst_pair_d {
const bool is_from_limited_with
= (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
&& From_Limited_With (gnat_desig_equiv));
+ /* Whether it is a completed Taft Amendment type. Such a type is to
+ be treated as coming from a limited with clause if it is not in
+ the main unit, i.e. we break potential circularities here in case
+ the body of an external unit is loaded for inter-unit inlining. */
+ const bool is_completed_taft_type
+ = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
+ && Has_Completion_In_Body (gnat_desig_equiv)
+ && Present (Full_View (gnat_desig_equiv)));
/* The "full view" of the designated type. If this is an incomplete
entity from a limited with, treat its non-limited view as the full
view. Otherwise, if this is an incomplete or private type, use the
/* Get the type of the thing we are to point to and build a pointer to
it. If it is a reference to an incomplete or private type with a
- full view that is a record or an array, make a dummy type node and
- get the actual type later when we have verified it is safe. */
+ full view that is a record, an array or an access, make a dummy type
+ and get the actual type later when we have verified it is safe. */
else if ((!in_main_unit
&& !present_gnu_tree (gnat_desig_equiv)
&& Present (gnat_desig_full)
&& (Is_Record_Type (gnat_desig_full)
- || Is_Array_Type (gnat_desig_full)))
+ || Is_Array_Type (gnat_desig_full)
+ || Is_Access_Type (gnat_desig_full)))
/* Likewise if this is a reference to a record, an array or a
subprogram type and we are to defer elaborating incomplete
types. We do this because this access type may be the full
save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true;
- if (defer_incomplete_level == 0 && !is_from_limited_with)
+ if (defer_incomplete_level == 0
+ && !is_from_limited_with
+ && !is_completed_taft_type)
{
update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
gnat_to_gnu_type (gnat_desig_equiv));
{
struct incomplete *p = XNEW (struct incomplete);
struct incomplete **head
- = (is_from_limited_with
+ = (is_from_limited_with || is_completed_taft_type
? &defer_limited_with_list : &defer_incomplete_list);
p->old_type = gnu_desig_type;
}
for (p = defer_limited_with_list; p; p = p->next)
- if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
+ if (p->old_type
+ && (Non_Limited_View (p->full_type) == gnat_entity
+ || Full_View (p->full_type) == gnat_entity))
{
update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
TREE_TYPE (gnu_decl));
Entity_Id gnat_prefix = Prefix (gnat_node);
Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
tree gnu_prefix = gnat_to_gnu (gnat_prefix);
- tree gnu_field;
gnu_prefix = maybe_implicit_deref (gnu_prefix);
NULL_TREE, gnu_prefix);
else
{
- gnu_field = gnat_to_gnu_field_decl (gnat_field);
-
+ tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
+
+ /* If the prefix has incomplete type, try again to translate it.
+ The idea is that the translation of the field just above may
+ have completed it through gnat_to_gnu_entity, in case it is
+ the dereference of an access to Taft Amendment type used in
+ the instantiation of a generic body from an external unit. */
+ if (!COMPLETE_TYPE_P (TREE_TYPE (gnu_prefix)))
+ {
+ gnu_prefix = gnat_to_gnu (gnat_prefix);
+ gnu_prefix = maybe_implicit_deref (gnu_prefix);
+ }
+
gnu_result
= build_component_ref (gnu_prefix, gnu_field,
(Nkind (Parent (gnat_node))
Table_Name => "Pending_Inlined");
-- The workpile used to compute the transitive closure
- function Is_Ancestor_Of_Main
- (U_Name : Entity_Id;
- Nam : Node_Id) return Boolean;
- -- Determine whether the unit whose body is loaded is an ancestor of
- -- the main unit, and has a with_clause on it. The body is not
- -- analyzed yet, so the check is purely lexical: the name of the with
- -- clause is a selected component, and names of ancestors must match.
-
- -------------------------
- -- Is_Ancestor_Of_Main --
- -------------------------
-
- function Is_Ancestor_Of_Main
- (U_Name : Entity_Id;
- Nam : Node_Id) return Boolean
- is
- Pref : Node_Id;
-
- begin
- if Nkind (Nam) /= N_Selected_Component then
- return False;
-
- else
- if Chars (Selector_Name (Nam)) /=
- Chars (Cunit_Entity (Main_Unit))
- then
- return False;
- end if;
-
- Pref := Prefix (Nam);
- if Nkind (Pref) = N_Identifier then
-
- -- Par is an ancestor of Par.Child.
-
- return Chars (Pref) = Chars (U_Name);
-
- elsif Nkind (Pref) = N_Selected_Component
- and then Chars (Selector_Name (Pref)) = Chars (U_Name)
- then
- -- Par.Child is an ancestor of Par.Child.Grand.
-
- return True; -- should check that ancestor match
-
- else
- -- A is an ancestor of A.B.C if it is an ancestor of A.B
-
- return Is_Ancestor_Of_Main (U_Name, Pref);
- end if;
- end if;
- end Is_Ancestor_Of_Main;
-
-- Start of processing for Analyze_Inlined_Bodies
begin
begin
if not Is_Loaded (Bname) then
Style_Check := False;
- Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
+ Load_Needed_Body (Comp_Unit, OK);
if not OK then
Error_Msg_File_1 :=
Get_File_Name (Bname, Subunit => False);
Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
-
- else
- -- If the package to be inlined is an ancestor unit of
- -- the main unit, and it has a semantic dependence on
- -- it, the inlining cannot take place to prevent an
- -- elaboration circularity. The desired body is not
- -- analyzed yet, to prevent the completion of Taft
- -- amendment types that would lead to elaboration
- -- circularities in gigi.
-
- declare
- U_Id : constant Entity_Id :=
- Defining_Entity (Unit (Comp_Unit));
- Body_Unit : constant Node_Id :=
- Library_Unit (Comp_Unit);
- Item : Node_Id;
-
- begin
- Item := First (Context_Items (Body_Unit));
- while Present (Item) loop
- if Nkind (Item) = N_With_Clause
- and then
- Is_Ancestor_Of_Main (U_Id, Name (Item))
- then
- Set_Is_Inlined (U_Id, False);
- exit;
- end if;
-
- Next (Item);
- end loop;
-
- -- If no suspicious with_clauses, analyze the body
-
- if Is_Inlined (U_Id) then
- Semantics (Body_Unit);
- end if;
- end;
end if;
end if;
end;
-- can also happen when the function declaration appears before the
-- full view of the type (which is legal in Ada 2012) and the call
-- appears in a different unit, in which case the incomplete view
- -- must be replaced with the full view to prevent subsequent type
- -- errors.
+ -- must be replaced with the full view (or the non-limited view)
+ -- to prevent subsequent type errors. Note that the usual install/
+ -- removal of limited_with clauses is not sufficient to handle this
+ -- case, because the limited view may have been captured is another
+ -- compilation unit that defines the current function.
+
+ if Is_Incomplete_Type (Etype (N)) then
+ if Present (Full_View (Etype (N))) then
+ if Is_Entity_Name (Nam) then
+ Set_Etype (Nam, Full_View (Etype (N)));
+ Set_Etype (Entity (Nam), Full_View (Etype (N)));
+ end if;
- if Is_Incomplete_Type (Etype (N))
- and then Present (Full_View (Etype (N)))
- then
- if Is_Entity_Name (Nam) then
- Set_Etype (Nam, Full_View (Etype (N)));
- Set_Etype (Entity (Nam), Full_View (Etype (N)));
- end if;
+ Set_Etype (N, Full_View (Etype (N)));
- Set_Etype (N, Full_View (Etype (N)));
+ elsif From_Limited_With (Etype (N))
+ and then Present (Non_Limited_View (Etype (N)))
+ then
+ Set_Etype (N, Non_Limited_View (Etype (N)));
+ end if;
end if;
end if;
end Analyze_Call;
+2017-05-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnat.dg/limited_with5.ad[sb]: New test.
+ * gnat.dg/limited_with5_pkg.ad[sb]: New helper.
+ * gnat.dg/limited_with6.ad[sb]: New test.
+ * gnat.dg/limited_with6_pkg.ad[sb]: New helper.
+
2017-05-22 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/specs/volatile1.ads: Remove obsolete errors.
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+package body Limited_With5 is
+ procedure Doit (Obj : Limited_With5_Pkg.T) is
+ begin
+ if Limited_With5_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then
+ raise Program_Error;
+ end if;
+ end Doit;
+end Limited_With5;
--- /dev/null
+with Limited_With5_Pkg;
+
+package Limited_With5 is
+ type Sup_T is new Integer;
+ procedure Doit (Obj : Limited_With5_Pkg.T);
+end Limited_With5;
--- /dev/null
+with Limited_With5;
+
+package body Limited_With5_Pkg is
+ function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T is
+ begin
+ return Limited_With5.Sup_T (Obj + 1);
+ end Get_Expression_Support;
+end Limited_With5_Pkg;
--- /dev/null
+limited with Limited_With5;
+
+package Limited_With5_Pkg is
+ type T is limited private;
+ function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T with Inline;
+private
+ type T is new Integer;
+end Limited_With5_Pkg;
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+package body Limited_With6 is
+ procedure Doit (Obj : Limited_With6_Pkg.T) is
+ begin
+ if Limited_With6_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then
+ raise Program_Error;
+ end if;
+ end Doit;
+end Limited_With6;
--- /dev/null
+with Limited_With6_Pkg;
+
+package Limited_With6 is
+ type Sup_T is new Integer;
+ procedure Doit (Obj : Limited_With6_Pkg.T);
+
+ type Rec is record
+ A : Limited_With6_Pkg.Taft_Ptr;
+ end record;
+end Limited_With6;
--- /dev/null
+with Limited_With6;
+
+package body Limited_With6_Pkg is
+ function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T is
+ begin
+ return Limited_With6.Sup_T (Obj + 1);
+ end Get_Expression_Support;
+
+ type TT is access all Limited_With6.Rec;
+end Limited_With6_Pkg;
--- /dev/null
+limited with Limited_With6;
+
+package Limited_With6_Pkg is
+ type T is limited private;
+ function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T with Inline;
+
+ type Taft_Ptr is private;
+
+private
+ type T is new Integer;
+
+ type TT;
+ type Taft_Ptr is access TT;
+end Limited_With6_Pkg;
projects / gcc.git / commitdiff