+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_spark.adb, exp_attr.adb, sem_ch9.adb, sem_prag.adb,
+ sem_util.adb, sem_warn.adb, exp_ch3.adb: Minor reformatting.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_Subprogram): Ensure that all anonymous
+ access-to-subprogram types inherit the convention of the
+ associated subprogram. (Set_Profile_Convention): New routine.
+ * sem_ch6.adb (Check_Conformance): Do not compare the conventions
+ of the two entities directly, use Conventions_Match to account
+ for anonymous access-to-subprogram and subprogram types.
+ (Conventions_Match): New routine.
+
2017-01-23 Claire Dross <dross@adacore.com>
* exp_spark.adb (Expand_SPARK_Attribute_Reference): For attributes
Res := True;
end if;
end if;
- else
+ else
-- For access type, apply access check as needed
if Is_Access_Type (Ptyp) then
if not Is_Variable (Pref)
or else Present (Formal_Ent)
or else (Ada_Version < Ada_2005
- and then Is_Aliased_View (Pref))
+ and then Is_Aliased_View (Pref))
or else (Ada_Version >= Ada_2005
- and then Is_Constrained_Aliased_View (Pref))
+ and then Is_Constrained_Aliased_View (Pref))
then
Res := True;
if Is_Array_Type (Typ)
and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
then
- -- To prevent arithmetic overflow with large values, we
- -- raise Storage_Error under the following guard:
- --
- -- (Arr'Last / 2 - Arr'First / 2) > (Typ'Last - 1) / 2
-
- -- This takes care of the boundary case, but it is preferable
- -- to use a smaller limit, because even on 64-bit architectures
- -- an array of more than 2 ** 30 bytes is likely to raise
+ -- To prevent arithmetic overflow with large values, we raise
+ -- Storage_Error under the following guard:
+
+ -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
+
+ -- This takes care of the boundary case, but it is preferable to
+ -- use a smaller limit, because even on 64-bit architectures an
+ -- array of more than 2 ** 30 bytes is likely to raise
-- Storage_Error.
Index_Typ := Etype (First_Index (Typ));
+
if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
Insert_Action (N,
- Make_Raise_Storage_Error (Loc,
+ Make_Raise_Storage_Error (Loc,
Condition =>
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Op_Subtract (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Divide (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Last),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_2)),
+ Prefix =>
+ New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Last),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Uint_2)),
Right_Opnd =>
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix =>
+ New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_First),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_2))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Uint_2))),
Right_Opnd =>
- Make_Integer_Literal (Loc, (Uint_2 ** 30))),
+ Make_Integer_Literal (Loc, (Uint_2 ** 30))),
Reason => SE_Object_Too_Large));
end if;
end if;
or else Attr_Id = Attribute_Aft
or else Attr_Id = Attribute_Max_Alignment_For_Allocation
then
-
-- If the expected type is Long_Long_Integer, there will be no check
-- flag as the compiler assumes attributes always fit in this type.
-- Since in SPARK_Mode we do not take Storage_Error into account, we
begin
if Attr_Id = Attribute_Range_Length then
Typ := Etype (Prefix (N));
+
elsif Attr_Id = Attribute_Length then
Typ := Etype (Prefix (N));
declare
- Indx : Node_Id;
- J : Int;
+ Indx : Node_Id;
+ J : Int;
+
begin
if Is_Access_Type (Typ) then
Typ := Designated_Type (Typ);
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
- Retype : Entity_Id;
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id);
+ -- Set the conventions of all anonymous access-to-subprogram formals and
+ -- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+
+ ----------------------------
+ -- Set_Profile_Convention --
+ ----------------------------
+
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id) is
+ Conv : constant Convention_Id := Convention (Subp_Id);
+
+ procedure Set_Type_Convention (Typ : Entity_Id);
+ -- Set the convention of anonymous access-to-subprogram type Typ and
+ -- its designated type to Conv.
+
+ -------------------------
+ -- Set_Type_Convention --
+ -------------------------
+
+ procedure Set_Type_Convention (Typ : Entity_Id) is
+ begin
+ -- Set the convention on both the anonymous access-to-subprogram
+ -- type and the subprogram type it points to because both types
+ -- participate in conformance-related checks.
+
+ if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+ Set_Convention (Typ, Conv);
+ Set_Convention (Designated_Type (Typ), Conv);
+ end if;
+ end Set_Type_Convention;
+
+ -- Local variables
+
+ Formal : Entity_Id;
+
+ -- Start of processing for Set_Profile_Convention
+
+ begin
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Set_Type_Convention (Etype (Formal));
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (Subp_Id) = E_Function then
+ Set_Type_Convention (Etype (Subp_Id));
+ end if;
+ end Set_Profile_Convention;
+
+ -- Local variables
+
F : Entity_Id;
+ Retype : Entity_Id;
+
+ -- Start of processing for Freeze_Subprogram
begin
-- Subprogram may not have an address clause unless it is imported
if Present (Address_Clause (E)) then
if not Is_Imported (E) then
Error_Msg_N
- ("address clause can only be given " &
- "for imported subprogram",
+ ("address clause can only be given for imported subprogram",
Name (Address_Clause (E)));
end if;
end if;
-- referenced data may change even if the address value does not.
-- Note that if the programmer gave an explicit Pure_Function pragma,
- -- then we believe the programmer, and leave the subprogram Pure.
- -- We also suppress this check on run-time files.
+ -- then we believe the programmer, and leave the subprogram Pure. We
+ -- also suppress this check on run-time files.
if Is_Pure (E)
and then Is_Subprogram (E)
Check_Function_With_Address_Parameter (E);
end if;
+ -- Ensure that all anonymous access-to-subprogram types inherit the
+ -- covention of their related subprogram (RM 6.3.1 13.1/3). This is
+ -- not done for a defaulted convention Ada because those types also
+ -- default to Ada. Convention Protected must not be propagated when
+ -- the subprogram is an entry because this would be illegal. The only
+ -- way to force convention Protected on these kinds of types is to
+ -- include keyword "protected" in the access definition.
+
+ if Convention (E) /= Convention_Ada
+ and then Convention (E) /= Convention_Protected
+ then
+ Set_Profile_Convention (E);
+ end if;
+
-- For non-foreign convention subprograms, this is where we create
-- the extra formals (for accessibility level and constrained bit
-- information). We delay this till the freeze point precisely so
else
Set_Has_Delayed_Freeze (Full,
Has_Delayed_Freeze (Full_Base)
- and then (not Is_Frozen (Full_Base)));
+ and then not Is_Frozen (Full_Base));
end if;
end if;
-- in the message, and also provides the location for posting the
-- message in the absence of a specified Err_Loc location.
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean;
+ -- Determine whether the conventions of arbitrary entities Id1 and Id2
+ -- match.
+
-----------------------
-- Conformance_Error --
-----------------------
end if;
end Conformance_Error;
+ -----------------------
+ -- Conventions_Match --
+ -----------------------
+
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean
+ is
+ begin
+ -- Ignore the conventions of anonymous access-to-subprogram types
+ -- and subprogram types because these are internally generated and
+ -- the only way these may receive a convention is if they inherit
+ -- the convention of a related subprogram.
+
+ if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ or else
+ Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ then
+ return True;
+
+ -- Otherwise compare the conventions directly
+
+ else
+ return Convention (Id1) = Convention (Id2);
+ end if;
+ end Conventions_Match;
+
-- Local Variables
Old_Type : constant Entity_Id := Etype (Old_Id);
-- entity is inherited.
if Ctype >= Subtype_Conformant then
- if Convention (Old_Id) /= Convention (New_Id) then
+ if not Conventions_Match (Old_Id, New_Id) then
if not Is_Frozen (New_Id) then
null;
procedure Analyze_Delay_Relative (N : Node_Id) is
E : constant Node_Id := Expression (N);
+
begin
Tasking_Used := True;
Check_SPARK_05_Restriction ("delay statement is not allowed", N);
-- Attribute 'Result matches attribute 'Result
- elsif Is_Attribute_Result (Dep_Item)
- and then Is_Attribute_Result (Ref_Item)
- then
+ -- ??? this is incorrect, Ref_Item should be checked as well
+
+ elsif Is_Attribute_Result (Dep_Item) then
Matched := True;
-- Abstract states, current instances of concurrent types,
and then not ASIS_Mode
then
if Chars (N) = Name_Precondition
- or else Chars (N) = Name_Postcondition
+ or else Chars (N) = Name_Postcondition
then
- Error_Msg_N (" Check_Policy is a non-standard pragma??", N);
+ Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
Error_Msg_N
- (" \use Assertion_Policy and aspect names Pre/Post"
- & " for Ada2012 conformance?", N);
+ ("\use Assertion_Policy and aspect names Pre/Post for "
+ & "Ada2012 conformance?", N);
end if;
+
return;
end if;
procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
pragma Assert (not Has_Aspects (To));
Asp : Node_Id;
+
begin
if Has_Aspects (From) then
Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
-- Give appropriate message, distinguishing between
-- assignment statements and out parameters.
- if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
- N_Parameter_Association)
+ if Nkind_In (Parent (LA), N_Parameter_Association,
+ N_Procedure_Call_Statement)
then
Error_Msg_NE
- ("?m?& modified by call, but value might not "
- & "be referenced", LA, Ent);
+ ("?m?& modified by call, but value might not be "
+ & "referenced", LA, Ent);
else
Error_Msg_NE -- CODEFIX
projects / gcc.git / commitdiff