+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>
* sem_ch3.adb, exp_util.adb, sem_dim.adb, sem_elab.adb, sem_ch8.adb,
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
- -- Initialize warnings table. As an optimization, if all warnings are
- -- 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.
+ -- Initialize warnings table
Warnings.Init;
Specific_Warnings.Init;
- if not GNATprove_Mode
- and then Warning_Mode = Suppress
- then
+ -- As an optimization, if all warnings are 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 use of the warning
+ -- mechanism for gnatprove itself.
+
+ if not GNATprove_Mode and then Warning_Mode = Suppress then
Warnings.Append
((Start => Source_Ptr'First, Stop => Source_Ptr'Last));
end if;
return;
end if;
- -- Nothing to do unless command line switch to suppress all warnings is
- -- off or we are in GNATprove_Mode, and the last entry in the warnings
- -- table covers this pragma Warnings (On), in which case adjust the end
- -- point.
-
- if (Warnings.Last >= Warnings.First
- and then Warnings.Table (Warnings.Last).Start <= Loc
- and then Loc <= Warnings.Table (Warnings.Last).Stop)
- and then
- (Warning_Mode /= Suppress
- or else
- GNATprove_Mode)
+ -- If the last entry in the warnings table covers this pragma, then
+ -- we adjust the end point appropriately.
+
+ if Warnings.Last >= Warnings.First
+ and then Warnings.Table (Warnings.Last).Start <= Loc
+ and then Loc <= Warnings.Table (Warnings.Last).Stop
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 Set_Warnings_Mode_On;
-- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
-- 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);
-- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
-- to generate appropriate semantic checks that are delayed until this
end if;
-- If the type is private, indicate that its completion
- -- has a freeze node, because that is the one that will be
- -- visible at freeze time.
+ -- has a freeze node, because that is the one that will
+ -- be visible at freeze time.
if Is_Private_Type (E) and then Present (Full_View (E)) then
Set_Has_Predicates (Full_View (E));
return;
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
Analyze_And_Resolve
(Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
Analyze_And_Resolve (Expr, Any_Integer);
if Is_Access_Type (U_Ent) then
- if Present (Associated_Storage_Pool (U_Ent)) then
- Error_Msg_N ("storage pool already given for &", Nam);
- return;
- end if;
+
+ -- Check for Storage_Pool previously given
+
+ 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)
and then Expr_Value (Expr) = 0
end if;
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 --
----------------------------------------
-------------------------------------
procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is
-
function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Rep_Item : Node_Id) return Boolean;
-- This routine checks if Rep_Item is either a pragma or an aspect
return Empty;
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.
-- If the access definition is the return type of another access to
Set_Has_Delayed_Freeze (Current_Scope);
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
-- before expansion of the full declaration, because the declaration may
-- include an expression that is an allocator, whose expansion needs the
-- 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
-- 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.
if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
if No (E) then
Act_T := Build_Default_Subtype (T, N);
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
-- unconstrained nominal type, Its actual subtype will be obtained
-- from the aggregate, and not from the default discriminants.
-- from a private type) has no discriminants. (Defect Report
-- 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
-- can be declared. Furthermore, the rule applies to all access
-- types, unlike the rule concerning default discriminants (see
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.
if Nkind (Parent (Def)) = N_Derived_Type_Definition
projects / gcc.git / commitdiff