From: Ed Schonberg Date: Tue, 29 Jul 2014 14:56:34 +0000 (+0000) Subject: sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=f3691f465e062f2380c0d9a6018951030fc8a2a3;p=gcc.git sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util. 2014-07-29 Ed Schonberg * sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util. * sem_ch4.adb (Analyze_Allocator): Defer resolution of expression until context type is available. * sem_res.adb (Resolve_Allocator): In the case of a qualified expression, complete resolution of expression. (Check_Aliased_Parameter): New procedure within Resolve_Actuals, to apply Ada2012 checks on aliased formals, as well as accesibility checks when the context of the call is an allocator or a qualified expression. * sem_util.ads, sem_util.adb (Has_Defaulted_Discriminants): Moved here from sem_ch3. (Object_Access_Level): Handle properly aliased formals and aggregates. * exp_ch6.adb (Expand_Call): Remove check on aliased parameters, now properly performed in sem_res (Resolve_Actuals, Check_Aliased_Parameter). From-SVN: r213206 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index aaf8a145394..9f1ccb7f1bf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,22 @@ +2014-07-29 Ed Schonberg + + * sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util. + * sem_ch4.adb (Analyze_Allocator): Defer resolution of expression + until context type is available. + * sem_res.adb (Resolve_Allocator): In the case of a qualified + expression, complete resolution of expression. + (Check_Aliased_Parameter): New procedure within Resolve_Actuals, + to apply Ada2012 checks on aliased formals, as well as + accesibility checks when the context of the call is an allocator + or a qualified expression. + * sem_util.ads, sem_util.adb (Has_Defaulted_Discriminants): + Moved here from sem_ch3. + (Object_Access_Level): Handle properly aliased formals and + aggregates. + * exp_ch6.adb (Expand_Call): Remove check on aliased parameters, + now properly performed in sem_res (Resolve_Actuals, + Check_Aliased_Parameter). + 2014-07-29 Yannick Moy * debug.adb Enable GNATprove inlining under debug flag -gnatdQ for now. diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c69136d4315..de2ded83fd6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3138,18 +3138,6 @@ package body Exp_Ch6 is end if; end if; - -- For Ada 2012, if a parameter is aliased, the actual must be a - -- tagged type or an aliased view of an object. - - if Is_Aliased (Formal) - and then not Is_Aliased_View (Actual) - and then not Is_Tagged_Type (Etype (Formal)) - then - Error_Msg_NE - ("actual for aliased formal& must be aliased object", - Actual, Formal); - end if; - -- For IN OUT and OUT parameters, ensure that subscripts are valid -- since this is a left side reference. We only do this for calls -- from the source program since we assume that compiler generated diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 84858793540..0a75c5cad24 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11252,24 +11252,6 @@ package body Sem_Ch3 is Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); Constraint_OK : Boolean := True; - function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; - -- Simple predicate to test for defaulted discriminants - -- Shouldn't this be in sem_util??? - - --------------------------------- - -- Has_Defaulted_Discriminants -- - --------------------------------- - - function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is - begin - return Has_Discriminants (Typ) - and then Present (First_Discriminant (Typ)) - and then Present - (Discriminant_Default_Value (First_Discriminant (Typ))); - end Has_Defaulted_Discriminants; - - -- Start of processing for Constrain_Access - begin if Is_Array_Type (Desig_Type) then Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 313f6f87d29..968619762d8 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -501,8 +501,6 @@ package body Sem_Ch4 is Type_Id := Etype (E); Set_Directly_Designated_Type (Acc_Type, Type_Id); - Resolve (Expression (E), Type_Id); - -- Allocators generated by the build-in-place expansion mechanism -- are explicitly marked as coming from source but do not need to be -- checked for limited initialization. To exclude this case, ensure @@ -529,10 +527,9 @@ package body Sem_Ch4 is -- Wrong_Type (Expression (E), Type_Id); -- end if; - Check_Non_Static_Context (Expression (E)); - -- We don't analyze the qualified expression itself because it's - -- part of the allocator + -- part of the allocator. It is fully analyzed and resolved when + -- the allocator is resolved with the context type. Set_Etype (E, Type_Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0e73216971f..c0ae52d11bf 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2976,6 +2976,10 @@ package body Sem_Res is Prev : Node_Id := Empty; Orig_A : Node_Id; + procedure Check_Aliased_Parameter; + -- Check rules on aliased parameters and related accessibility rules + -- in (3.10.2 (10.2-10.4)). + procedure Check_Argument_Order; -- Performs a check for the case where the actuals are all simple -- identifiers that correspond to the formal names, but in the wrong @@ -3012,6 +3016,70 @@ package body Sem_Res is -- This must be determined before the actual is resolved and expanded -- because if needed the transient scope must be introduced earlier. + ------------------------------ + -- Check_Aliased_Parameter -- + ------------------------------ + + procedure Check_Aliased_Parameter is + Nominal_Subt : Entity_Id; + + begin + if Is_Aliased (F) then + if Is_Tagged_Type (A_Typ) then + null; + + elsif Is_Aliased_View (A) then + if Is_Constr_Subt_For_U_Nominal (A_Typ) then + Nominal_Subt := Base_Type (A_Typ); + else + Nominal_Subt := A_Typ; + end if; + + if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then + null; + + -- In a generic body assume the worst for generic formals: + -- they can have a constrained partial view (AI05-041). + + elsif Has_Discriminants (F_Typ) + and then not Is_Constrained (F_Typ) + and then not Has_Constrained_Partial_View (F_Typ) + and then not Is_Generic_Type (F_Typ) + then + null; + + else + Error_Msg_NE ("untagged actual does not match " + & "aliased formal&", A, F); + end if; + + else + Error_Msg_NE ("actual for aliased formal& must be " + & "aliased object", A, F); + end if; + + if Ekind (Nam) = E_Procedure then + null; + + elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then + if Nkind (Parent (N)) = N_Type_Conversion + and then Type_Access_Level (Etype (Parent (N))) + < Object_Access_Level (A) + then + Error_Msg_N ("aliased actual has wrong accessibility", A); + end if; + + elsif Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Allocator + and then Type_Access_Level (Etype (Parent (Parent (N)))) + < Object_Access_Level (A) + then + Error_Msg_N + ("Aliased actual in allocator has wrong accessibility", A); + end if; + end if; + end Check_Aliased_Parameter; + -------------------------- -- Check_Argument_Order -- -------------------------- @@ -4213,6 +4281,8 @@ package body Sem_Res is end if; end if; + Check_Aliased_Parameter; + Eval_Actual (A); -- If it is a named association, treat the selector_name as a @@ -4426,6 +4496,7 @@ package body Sem_Res is end if; Resolve (Expression (E), Etype (E)); + Check_Non_Static_Context (Expression (E)); Check_Unset_Reference (Expression (E)); -- A qualified expression requires an exact match of the type. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 62a5bdb9743..c1d7581121c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7337,6 +7337,18 @@ package body Sem_Util is N_Package_Specification); end Has_Declarations; + --------------------------------- + -- Has_Defaulted_Discriminants -- + --------------------------------- + + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is + begin + return Has_Discriminants (Typ) + and then Present (First_Discriminant (Typ)) + and then Present + (Discriminant_Default_Value (First_Discriminant (Typ))); + end Has_Defaulted_Discriminants; + ------------------- -- Has_Denormals -- ------------------- @@ -14414,7 +14426,15 @@ package body Sem_Util is return Type_Access_Level (Scope (E)) + 1; else - return Scope_Depth (Enclosing_Dynamic_Scope (E)); + -- Aliased formals take their access level from the point of call. + -- This is smaller than the level of the subprogram itself. + + if Is_Formal (E) and then Is_Aliased (E) then + return Type_Access_Level (Etype (E)); + + else + return Scope_Depth (Enclosing_Dynamic_Scope (E)); + end if; end if; elsif Nkind (Obj) = N_Selected_Component then @@ -14586,6 +14606,12 @@ package body Sem_Util is elsif Nkind (Obj) = N_Qualified_Expression then return Object_Access_Level (Expression (Obj)); + -- Ditto for aggregates. They have the level of the temporary that + -- will hold their value. + + elsif Nkind (Obj) = N_Aggregate then + return Object_Access_Level (Current_Scope); + -- Otherwise return the scope level of Standard. (If there are cases -- that fall through to this point they will be treated as having -- global accessibility for now. ???) diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8140f61fb34..6a0e126888a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -884,6 +884,9 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; + -- Simple predicate to test for defaulted discriminants + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness.