FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_ch3.adb, [...]: Minor reformatting.

Browse source 
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.

From-SVN: r244778
This commit is contained in:
Hristian Kirtchev 2017-01-23 11:21:37 +00:00 • committed by Arnaud Charlet
parent d553a695b9
commit f991bd8ec9
11 changed files with 165 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
gcc/ada/ChangeLog
View file

@ -1,3 +1,18 @@
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

6
gcc/ada/exp_attr.adb
View file

@ -2682,8 +2682,8 @@ package body Exp_Attr is
Res := True;
end if;
end if;
else
else
-- For access type, apply access check as needed
if Is_Access_Type (Ptyp) then
@ -2700,9 +2700,9 @@ package body Exp_Attr is
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;

39
gcc/ada/exp_ch3.adb
View file

@ -5620,42 +5620,45 @@ package body Exp_Ch3 is
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
-- To prevent arithmetic overflow with large values, we raise
-- Storage_Error under the following guard:
-- 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
-- (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;

7
gcc/ada/exp_spark.adb
View file

@ -174,7 +174,6 @@ package body Exp_SPARK is
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
@ -187,12 +186,14 @@ package body Exp_SPARK is
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);

76
gcc/ada/freeze.adb
View file

@ -7945,8 +7945,61 @@ package body Freeze is
-----------------------
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
@ -7954,8 +8007,7 @@ package body Freeze is
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;
@ -7986,8 +8038,8 @@ package body Freeze is
-- 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)
@ -7997,6 +8049,20 @@ package body Freeze is
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

2
gcc/ada/sem_ch3.adb
View file

@ -11943,7 +11943,7 @@ package body Sem_Ch3 is
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;

37
gcc/ada/sem_ch6.adb
View file

@ -4870,6 +4870,12 @@ package body Sem_Ch6 is
-- 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 --
-----------------------
@ -4929,6 +4935,35 @@ package body Sem_Ch6 is
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);
@ -5015,7 +5050,7 @@ package body Sem_Ch6 is
-- 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;

1
gcc/ada/sem_ch9.adb
View file

@ -1154,6 +1154,7 @@ package body Sem_Ch9 is
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);

15
gcc/ada/sem_prag.adb
View file

@ -23950,9 +23950,9 @@ package body Sem_Prag is
-- 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,
@ -29491,13 +29491,14 @@ package body Sem_Prag is
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;

1
gcc/ada/sem_util.adb
View file

@ -5006,6 +5006,7 @@ package body Sem_Util is
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);

8
gcc/ada/sem_warn.adb
View file

@ -4336,12 +4336,12 @@ package body Sem_Warn is
-- 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