sem_ch3.adb, [...]: Minor reformatting.
2014-01-22 Robert Dewar <dewar@adacore.com> * sem_ch3.adb, errout.adb, erroutc.adb: Minor reformatting. 2014-01-22 Robert Dewar <dewar@adacore.com> * sem_ch13.adb (Check_Pool_Size_Clash): New procedure (Analyze_Attribute_Definition_Clause, case Storage_Pool): call Check_Pool_Size_Clash (Analyze_Attribute_Definition_Clause, case Storage_Size): call Check_Pool_Size_Clash. From-SVN: r206923
This commit is contained in:
parent
f5f6d8d705
commit
113a62d92e
|
@ -1,3 +1,14 @@
|
||||||
|
2014-01-22 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch3.adb, errout.adb, erroutc.adb: Minor reformatting.
|
||||||
|
|
||||||
|
2014-01-22 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch13.adb (Check_Pool_Size_Clash): New procedure
|
||||||
|
(Analyze_Attribute_Definition_Clause, case Storage_Pool): call
|
||||||
|
Check_Pool_Size_Clash (Analyze_Attribute_Definition_Clause,
|
||||||
|
case Storage_Size): call Check_Pool_Size_Clash.
|
||||||
|
|
||||||
2014-01-22 Robert Dewar <dewar@adacore.com>
|
2014-01-22 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* sem_ch3.adb, exp_util.adb, sem_dim.adb, sem_elab.adb, sem_ch8.adb,
|
* sem_ch3.adb, exp_util.adb, sem_dim.adb, sem_elab.adb, sem_ch8.adb,
|
||||||
|
|
|
@ -1499,19 +1499,19 @@ package body Errout is
|
||||||
Cur_Msg := No_Error_Msg;
|
Cur_Msg := No_Error_Msg;
|
||||||
List_Pragmas.Init;
|
List_Pragmas.Init;
|
||||||
|
|
||||||
-- Initialize warnings table. As an optimization, if all warnings are
|
-- Initialize warnings table
|
||||||
-- suppressed, we supply an initial dummy entry covering all possible
|
|
||||||
-- source locations, which avoids taking into account pragma Warnings
|
|
||||||
-- in the source. In GNATprove_Mode, this optimization is disabled, as
|
|
||||||
-- we rely on the Warnings table to be correctly filled for back-end
|
|
||||||
-- warnings.
|
|
||||||
|
|
||||||
Warnings.Init;
|
Warnings.Init;
|
||||||
Specific_Warnings.Init;
|
Specific_Warnings.Init;
|
||||||
|
|
||||||
if not GNATprove_Mode
|
-- As an optimization, if all warnings are suppressed, we supply an
|
||||||
and then Warning_Mode = Suppress
|
-- initial dummy entry covering all possible source locations, which
|
||||||
then
|
-- avoids taking into account pragma Warnings in the source. In
|
||||||
|
-- GNATprove_Mode, this optimization is disabled, as we rely on
|
||||||
|
-- the Warnings table to be correctly filled for use of the warning
|
||||||
|
-- mechanism for gnatprove itself.
|
||||||
|
|
||||||
|
if not GNATprove_Mode and then Warning_Mode = Suppress then
|
||||||
Warnings.Append
|
Warnings.Append
|
||||||
((Start => Source_Ptr'First, Stop => Source_Ptr'Last));
|
((Start => Source_Ptr'First, Stop => Source_Ptr'Last));
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -1207,20 +1207,20 @@ package body Erroutc is
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Nothing to do unless command line switch to suppress all warnings is
|
-- If the last entry in the warnings table covers this pragma, then
|
||||||
-- off or we are in GNATprove_Mode, and the last entry in the warnings
|
-- we adjust the end point appropriately.
|
||||||
-- table covers this pragma Warnings (On), in which case adjust the end
|
|
||||||
-- point.
|
|
||||||
|
|
||||||
if (Warnings.Last >= Warnings.First
|
if Warnings.Last >= Warnings.First
|
||||||
and then Warnings.Table (Warnings.Last).Start <= Loc
|
and then Warnings.Table (Warnings.Last).Start <= Loc
|
||||||
and then Loc <= Warnings.Table (Warnings.Last).Stop)
|
and then Loc <= Warnings.Table (Warnings.Last).Stop
|
||||||
and then
|
|
||||||
(Warning_Mode /= Suppress
|
|
||||||
or else
|
|
||||||
GNATprove_Mode)
|
|
||||||
then
|
then
|
||||||
Warnings.Table (Warnings.Last).Stop := Loc;
|
-- We can normally skip this adjustment if we are suppressing all
|
||||||
|
-- warnings, but we do want to do it in gnatprove mode even then,
|
||||||
|
-- since we use the warning mechanism in gnatprove itself.
|
||||||
|
|
||||||
|
if Warning_Mode /= Suppress or else GNATprove_Mode then
|
||||||
|
Warnings.Table (Warnings.Last).Stop := Loc;
|
||||||
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end Set_Warnings_Mode_On;
|
end Set_Warnings_Mode_On;
|
||||||
|
|
||||||
|
|
|
@ -112,6 +112,10 @@ package body Sem_Ch13 is
|
||||||
-- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
|
-- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
|
||||||
-- a canonicalized membership operation.
|
-- a canonicalized membership operation.
|
||||||
|
|
||||||
|
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
|
||||||
|
-- Called if both Storage_Pool and Storage_Size attribute definition
|
||||||
|
-- clauses (SP and SS) are present for entity Ent. Issue error message.
|
||||||
|
|
||||||
procedure Freeze_Entity_Checks (N : Node_Id);
|
procedure Freeze_Entity_Checks (N : Node_Id);
|
||||||
-- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
|
-- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
|
||||||
-- to generate appropriate semantic checks that are delayed until this
|
-- to generate appropriate semantic checks that are delayed until this
|
||||||
|
@ -1698,8 +1702,8 @@ package body Sem_Ch13 is
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If the type is private, indicate that its completion
|
-- If the type is private, indicate that its completion
|
||||||
-- has a freeze node, because that is the one that will be
|
-- has a freeze node, because that is the one that will
|
||||||
-- visible at freeze time.
|
-- be visible at freeze time.
|
||||||
|
|
||||||
if Is_Private_Type (E) and then Present (Full_View (E)) then
|
if Is_Private_Type (E) and then Present (Full_View (E)) then
|
||||||
Set_Has_Predicates (Full_View (E));
|
Set_Has_Predicates (Full_View (E));
|
||||||
|
@ -4629,6 +4633,20 @@ package body Sem_Ch13 is
|
||||||
return;
|
return;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- Check for Storage_Size previously given
|
||||||
|
|
||||||
|
declare
|
||||||
|
SS : constant Node_Id :=
|
||||||
|
Get_Attribute_Definition_Clause
|
||||||
|
(U_Ent, Attribute_Storage_Size);
|
||||||
|
begin
|
||||||
|
if Present (SS) then
|
||||||
|
Check_Pool_Size_Clash (U_Ent, N, SS);
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
|
||||||
|
-- Storage_Pool case
|
||||||
|
|
||||||
if Id = Attribute_Storage_Pool then
|
if Id = Attribute_Storage_Pool then
|
||||||
Analyze_And_Resolve
|
Analyze_And_Resolve
|
||||||
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
|
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
|
||||||
|
@ -4788,10 +4806,21 @@ package body Sem_Ch13 is
|
||||||
Analyze_And_Resolve (Expr, Any_Integer);
|
Analyze_And_Resolve (Expr, Any_Integer);
|
||||||
|
|
||||||
if Is_Access_Type (U_Ent) then
|
if Is_Access_Type (U_Ent) then
|
||||||
if Present (Associated_Storage_Pool (U_Ent)) then
|
|
||||||
Error_Msg_N ("storage pool already given for &", Nam);
|
-- Check for Storage_Pool previously given
|
||||||
return;
|
|
||||||
end if;
|
declare
|
||||||
|
SP : constant Node_Id :=
|
||||||
|
Get_Attribute_Definition_Clause
|
||||||
|
(U_Ent, Attribute_Storage_Pool);
|
||||||
|
|
||||||
|
begin
|
||||||
|
if Present (SP) then
|
||||||
|
Check_Pool_Size_Clash (U_Ent, SP, N);
|
||||||
|
end if;
|
||||||
|
end;
|
||||||
|
|
||||||
|
-- Special case of for x'Storage_Size use 0
|
||||||
|
|
||||||
if Is_OK_Static_Expression (Expr)
|
if Is_OK_Static_Expression (Expr)
|
||||||
and then Expr_Value (Expr) = 0
|
and then Expr_Value (Expr) = 0
|
||||||
|
@ -8307,6 +8336,33 @@ package body Sem_Ch13 is
|
||||||
end if;
|
end if;
|
||||||
end Check_Constant_Address_Clause;
|
end Check_Constant_Address_Clause;
|
||||||
|
|
||||||
|
---------------------------
|
||||||
|
-- Check_Pool_Size_Clash --
|
||||||
|
---------------------------
|
||||||
|
|
||||||
|
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id) is
|
||||||
|
Post : Node_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
-- We need to find out which one came first. Note that in the case of
|
||||||
|
-- aspects mixed with pragmas there are cases where the processing order
|
||||||
|
-- is reversed, which is why we do the check here.
|
||||||
|
|
||||||
|
if Sloc (SP) < Sloc (SS) then
|
||||||
|
Error_Msg_Sloc := Sloc (SP);
|
||||||
|
Post := SS;
|
||||||
|
Error_Msg_NE ("Storage_Pool previously given for&#", Post, Ent);
|
||||||
|
|
||||||
|
else
|
||||||
|
Error_Msg_Sloc := Sloc (SS);
|
||||||
|
Post := SP;
|
||||||
|
Error_Msg_NE ("Storage_Size previously given for&#", Post, Ent);
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Error_Msg_N
|
||||||
|
("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post);
|
||||||
|
end Check_Pool_Size_Clash;
|
||||||
|
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
-- Check_Record_Representation_Clause --
|
-- Check_Record_Representation_Clause --
|
||||||
----------------------------------------
|
----------------------------------------
|
||||||
|
@ -9580,7 +9636,6 @@ package body Sem_Ch13 is
|
||||||
-------------------------------------
|
-------------------------------------
|
||||||
|
|
||||||
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
|
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
|
||||||
|
|
||||||
function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
|
function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
|
||||||
(Rep_Item : Node_Id) return Boolean;
|
(Rep_Item : Node_Id) return Boolean;
|
||||||
-- This routine checks if Rep_Item is either a pragma or an aspect
|
-- This routine checks if Rep_Item is either a pragma or an aspect
|
||||||
|
|
|
@ -733,7 +733,7 @@ package body Sem_Ch3 is
|
||||||
return Empty;
|
return Empty;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Ada 2005: for an object declaration the corresponding anonymous
|
-- Ada 2005: For an object declaration the corresponding anonymous
|
||||||
-- type is declared in the current scope.
|
-- type is declared in the current scope.
|
||||||
|
|
||||||
-- If the access definition is the return type of another access to
|
-- If the access definition is the return type of another access to
|
||||||
|
@ -912,7 +912,7 @@ package body Sem_Ch3 is
|
||||||
Set_Has_Delayed_Freeze (Current_Scope);
|
Set_Has_Delayed_Freeze (Current_Scope);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Ada 2005: if the designated type is an interface that may contain
|
-- Ada 2005: If the designated type is an interface that may contain
|
||||||
-- tasks, create a Master entity for the declaration. This must be done
|
-- tasks, create a Master entity for the declaration. This must be done
|
||||||
-- before expansion of the full declaration, because the declaration may
|
-- before expansion of the full declaration, because the declaration may
|
||||||
-- include an expression that is an allocator, whose expansion needs the
|
-- include an expression that is an allocator, whose expansion needs the
|
||||||
|
@ -3241,11 +3241,11 @@ package body Sem_Ch3 is
|
||||||
|
|
||||||
-- Protected objects with interrupt handlers must be at library level
|
-- Protected objects with interrupt handlers must be at library level
|
||||||
|
|
||||||
-- Ada 2005: this test is not needed (and the corresponding clause
|
-- Ada 2005: This test is not needed (and the corresponding clause
|
||||||
-- in the RM is removed) because accessibility checks are sufficient
|
-- in the RM is removed) because accessibility checks are sufficient
|
||||||
-- to make handlers not at the library level illegal.
|
-- to make handlers not at the library level illegal.
|
||||||
|
|
||||||
-- AI05-0303: the AI is in fact a binding interpretation, and thus
|
-- AI05-0303: The AI is in fact a binding interpretation, and thus
|
||||||
-- applies to the '95 version of the language as well.
|
-- applies to the '95 version of the language as well.
|
||||||
|
|
||||||
if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
|
if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
|
||||||
|
@ -3637,7 +3637,7 @@ package body Sem_Ch3 is
|
||||||
if No (E) then
|
if No (E) then
|
||||||
Act_T := Build_Default_Subtype (T, N);
|
Act_T := Build_Default_Subtype (T, N);
|
||||||
else
|
else
|
||||||
-- Ada 2005: a limited object may be initialized by means of an
|
-- Ada 2005: A limited object may be initialized by means of an
|
||||||
-- aggregate. If the type has default discriminants it has an
|
-- aggregate. If the type has default discriminants it has an
|
||||||
-- unconstrained nominal type, Its actual subtype will be obtained
|
-- unconstrained nominal type, Its actual subtype will be obtained
|
||||||
-- from the aggregate, and not from the default discriminants.
|
-- from the aggregate, and not from the default discriminants.
|
||||||
|
@ -11173,7 +11173,7 @@ package body Sem_Ch3 is
|
||||||
-- from a private type) has no discriminants. (Defect Report
|
-- from a private type) has no discriminants. (Defect Report
|
||||||
-- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
|
-- 8652/0008, Technical Corrigendum 1, checked by ACATS B371001).
|
||||||
|
|
||||||
-- Rule updated for Ada 2005: the private type is said to have
|
-- Rule updated for Ada 2005: The private type is said to have
|
||||||
-- a constrained partial view, given that objects of the type
|
-- a constrained partial view, given that objects of the type
|
||||||
-- can be declared. Furthermore, the rule applies to all access
|
-- can be declared. Furthermore, the rule applies to all access
|
||||||
-- types, unlike the rule concerning default discriminants (see
|
-- types, unlike the rule concerning default discriminants (see
|
||||||
|
@ -20127,7 +20127,7 @@ package body Sem_Ch3 is
|
||||||
|
|
||||||
Final_Storage_Only := not Is_Controlled (T);
|
Final_Storage_Only := not Is_Controlled (T);
|
||||||
|
|
||||||
-- Ada 2005: check whether an explicit Limited is present in a derived
|
-- Ada 2005: Check whether an explicit Limited is present in a derived
|
||||||
-- type declaration.
|
-- type declaration.
|
||||||
|
|
||||||
if Nkind (Parent (Def)) = N_Derived_Type_Definition
|
if Nkind (Parent (Def)) = N_Derived_Type_Definition
|
||||||
|
|
Loading…
Reference in New Issue