+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.
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
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');
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
-- 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);
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
-- 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 --
--------------------------
end if;
end if;
+ Check_Aliased_Parameter;
+
Eval_Actual (A);
-- If it is a named association, treat the selector_name as a
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.
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 --
-------------------
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
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. ???)
-- 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.
projects / platform / upstream / gcc.git / commitdiff