From: Eric Botcazou Date: Mon, 22 May 2017 09:24:24 +0000 (+0000) Subject: sem_ch4.adb (Analyze_Call): In Ada2012 an incomplete type from a limited view may... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d327113612c1b089eee87f04cd517b7f7103c1ea;p=gcc.git sem_ch4.adb (Analyze_Call): In Ada2012 an incomplete type from a limited view may appear in the profile of... * 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) : 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. From-SVN: r248321 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e7d5692a286..945218bae91 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2017-05-22 Ed Schonberg + Eric Botcazou + + * 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) : 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 * gcc-interface/decl.c (gnat_to_gnu_field): Do not enforce strict diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 4bf14649d97..91a03cd631b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -101,8 +101,8 @@ struct incomplete 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 { @@ -3580,6 +3580,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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 @@ -3646,13 +3654,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* 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 @@ -3763,7 +3772,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) 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)); @@ -3772,7 +3783,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { 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; @@ -4766,7 +4777,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } 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)); diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index dc1b43ad6c4..2542626d0ca 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -6413,7 +6413,6 @@ gnat_to_gnu (Node_Id gnat_node) 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); @@ -6442,8 +6441,19 @@ gnat_to_gnu (Node_Id gnat_node) 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)) diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index ac19c9d2c45..9f2539a6b62 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -667,57 +667,6 @@ package body Inline is 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 @@ -766,7 +715,7 @@ package body Inline is 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 @@ -780,43 +729,6 @@ package body Inline is 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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 9de32782dbc..3b0717cf86a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1469,18 +1469,26 @@ package body Sem_Ch4 is -- 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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 575ed96c46a..b058621f0e4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2017-05-22 Eric Botcazou + + * 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 * gnat.dg/specs/volatile1.ads: Remove obsolete errors. diff --git a/gcc/testsuite/gnat.dg/limited_with5.adb b/gcc/testsuite/gnat.dg/limited_with5.adb new file mode 100644 index 00000000000..c3bf270b35e --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with5.adb @@ -0,0 +1,11 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/limited_with5.ads b/gcc/testsuite/gnat.dg/limited_with5.ads new file mode 100644 index 00000000000..4a242a04e11 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with5.ads @@ -0,0 +1,6 @@ +with Limited_With5_Pkg; + +package Limited_With5 is + type Sup_T is new Integer; + procedure Doit (Obj : Limited_With5_Pkg.T); +end Limited_With5; diff --git a/gcc/testsuite/gnat.dg/limited_with5_pkg.adb b/gcc/testsuite/gnat.dg/limited_with5_pkg.adb new file mode 100644 index 00000000000..785f84e91fd --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with5_pkg.adb @@ -0,0 +1,8 @@ +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; diff --git a/gcc/testsuite/gnat.dg/limited_with5_pkg.ads b/gcc/testsuite/gnat.dg/limited_with5_pkg.ads new file mode 100644 index 00000000000..e048653a873 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with5_pkg.ads @@ -0,0 +1,8 @@ +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; diff --git a/gcc/testsuite/gnat.dg/limited_with6.adb b/gcc/testsuite/gnat.dg/limited_with6.adb new file mode 100644 index 00000000000..972b47231e8 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with6.adb @@ -0,0 +1,11 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/limited_with6.ads b/gcc/testsuite/gnat.dg/limited_with6.ads new file mode 100644 index 00000000000..05b9cc9fa40 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with6.ads @@ -0,0 +1,10 @@ +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; diff --git a/gcc/testsuite/gnat.dg/limited_with6_pkg.adb b/gcc/testsuite/gnat.dg/limited_with6_pkg.adb new file mode 100644 index 00000000000..46db471446b --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with6_pkg.adb @@ -0,0 +1,10 @@ +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; diff --git a/gcc/testsuite/gnat.dg/limited_with6_pkg.ads b/gcc/testsuite/gnat.dg/limited_with6_pkg.ads new file mode 100644 index 00000000000..4eab8682635 --- /dev/null +++ b/gcc/testsuite/gnat.dg/limited_with6_pkg.ads @@ -0,0 +1,14 @@ +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;