sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util.
2014-07-29 Ed Schonberg <schonberg@adacore.com> * 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
This commit is contained in:
Ed Schonberg
Arnaud Charlet
parent
2d180af122
commit
f3691f465e
|
|
@ -1,3 +1,22 @@
|
|||
2014-07-29 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* 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 <moy@adacore.com>
|
||||
|
||||
* debug.adb Enable GNATprove inlining under debug flag -gnatdQ for now.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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');
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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. ???)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue