Commit 203876fc by Arnaud Charlet

[multiple changes]

2015-03-04  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Abstract_State): Use routine
	Malformed_State_Error to issue general errors.
	(Analyze_Pragma): Diagnose a syntax error related to a state
	declaration with a simple option.
	(Malformed_State_Error): New routine.

2015-03-04  Robert Dewar  <dewar@adacore.com>

	* a-strsup.adb (Super_Slice): Deal with super flat case.
	* einfo.ads: Minor reformatting.
	* s-imgdec.adb (Set_Decimal_Digits): Add comment about possibly
	redundant code.

2015-03-04  Claire Dross  <dross@adacore.com>

	* a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads,
	a-cforse.ads, a-cofove.ads: Use Default_Initial_Condition on formal
	containers.

From-SVN: r221180
parent 5264d0df
2015-03-04 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Abstract_State): Use routine
Malformed_State_Error to issue general errors.
(Analyze_Pragma): Diagnose a syntax error related to a state
declaration with a simple option.
(Malformed_State_Error): New routine.
2015-03-04 Robert Dewar <dewar@adacore.com>
* a-strsup.adb (Super_Slice): Deal with super flat case.
* einfo.ads: Minor reformatting.
* s-imgdec.adb (Set_Decimal_Digits): Add comment about possibly
redundant code.
2015-03-04 Claire Dross <dross@adacore.com>
* a-cfdlli.ads, a-cfhase.ads, a-cforma.ads, a-cfhama.ads,
a-cforse.ads, a-cofove.ads: Use Default_Initial_Condition on formal
containers.
2015-03-04 Ed Schonberg <schonberg@adacore.com> 2015-03-04 Ed Schonberg <schonberg@adacore.com>
* sem_warn.adb (Check_References): When checking for an unused * sem_warn.adb (Check_References): When checking for an unused
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -72,7 +72,7 @@ is ...@@ -72,7 +72,7 @@ is
Next => Next, Next => Next,
Has_Element => Has_Element, Has_Element => Has_Element,
Element => Element), Element => Element),
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (List);
pragma Preelaborable_Initialization (List); pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -76,7 +76,7 @@ is ...@@ -76,7 +76,7 @@ is
Next => Next, Next => Next,
Has_Element => Has_Element, Has_Element => Has_Element,
Element => Element), Element => Element),
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (Map);
pragma Preelaborable_Initialization (Map); pragma Preelaborable_Initialization (Map);
type Cursor is private; type Cursor is private;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -78,7 +78,7 @@ is ...@@ -78,7 +78,7 @@ is
Next => Next, Next => Next,
Has_Element => Has_Element, Has_Element => Has_Element,
Element => Element), Element => Element),
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (Set);
pragma Preelaborable_Initialization (Set); pragma Preelaborable_Initialization (Set);
type Cursor is private; type Cursor is private;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -80,7 +80,7 @@ is ...@@ -80,7 +80,7 @@ is
Next => Next, Next => Next,
Has_Element => Has_Element, Has_Element => Has_Element,
Element => Element), Element => Element),
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (Map);
pragma Preelaborable_Initialization (Map); pragma Preelaborable_Initialization (Map);
type Cursor is private; type Cursor is private;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -79,7 +79,7 @@ is ...@@ -79,7 +79,7 @@ is
Next => Next, Next => Next,
Has_Element => Has_Element, Has_Element => Has_Element,
Element => Element), Element => Element),
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (Set);
pragma Preelaborable_Initialization (Set); pragma Preelaborable_Initialization (Set);
type Cursor is private; type Cursor is private;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -61,7 +61,7 @@ is ...@@ -61,7 +61,7 @@ is
Count_Type range 0 .. Count_Type (Index_Type'Last - Index_Type'First + 1); Count_Type range 0 .. Count_Type (Index_Type'Last - Index_Type'First + 1);
type Vector (Capacity : Capacity_Range) is limited private with type Vector (Capacity : Capacity_Range) is limited private with
Default_Initial_Condition; Default_Initial_Condition => Is_Empty (Vector);
-- In the bounded case, Capacity is the capacity of the container, which -- In the bounded case, Capacity is the capacity of the container, which
-- never changes. In the unbounded case, Capacity is the initial capacity -- never changes. In the unbounded case, Capacity is the initial capacity
-- of the container, and operations such as Reserve_Capacity and Append can -- of the container, and operations such as Reserve_Capacity and Append can
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2003-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1473,6 +1473,9 @@ package body Ada.Strings.Superbounded is ...@@ -1473,6 +1473,9 @@ package body Ada.Strings.Superbounded is
raise Index_Error; raise Index_Error;
end if; end if;
-- Note: in this case, superflat bounds are not a problem, we just
-- get the null string in accordance with normal Ada slice rules.
R := Source.Data (Low .. High); R := Source.Data (Low .. High);
end return; end return;
end Super_Slice; end Super_Slice;
...@@ -1490,7 +1493,9 @@ package body Ada.Strings.Superbounded is ...@@ -1490,7 +1493,9 @@ package body Ada.Strings.Superbounded is
raise Index_Error; raise Index_Error;
end if; end if;
Result.Current_Length := High - Low + 1; -- Note: the Max operation here deals with the superflat case
Result.Current_Length := Integer'Max (0, High - Low + 1);
Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High);
end return; end return;
end Super_Slice; end Super_Slice;
...@@ -1506,10 +1511,12 @@ package body Ada.Strings.Superbounded is ...@@ -1506,10 +1511,12 @@ package body Ada.Strings.Superbounded is
or else High > Source.Current_Length or else High > Source.Current_Length
then then
raise Index_Error; raise Index_Error;
else
Target.Current_Length := High - Low + 1;
Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end if; end if;
-- Note: the Max operation here deals with the superflat case
Target.Current_Length := Integer'Max (0, High - Low + 1);
Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High);
end Super_Slice; end Super_Slice;
---------------- ----------------
......
...@@ -3234,12 +3234,12 @@ package Einfo is ...@@ -3234,12 +3234,12 @@ package Einfo is
-- derived from a type with a clause present. -- derived from a type with a clause present.
-- Master_Id (Node17) -- Master_Id (Node17)
-- Defined in access types and subtypes. Empty unless Has_Task is -- Defined in access types and subtypes. Empty unless Has_Task is set for
-- set for the designated type, in which case it points to the entity -- the designated type, in which case it points to the entity for the
-- for the Master_Id for the access type master. Also set for access-to- -- Master_Id for the access type master. Also set for access-to-limited-
-- limited-class-wide types whose root may be extended with task -- class-wide types whose root may be extended with task components, and
-- components, and for access-to-limited-interfaces because they can be -- for access-to-limited-interfaces because they can be used to reference
-- used to reference tasks implementing such interface. -- tasks implementing such interface.
-- Materialize_Entity (Flag168) -- Materialize_Entity (Flag168)
-- Defined in all entities. Set only for renamed obects which should be -- Defined in all entities. Set only for renamed obects which should be
...@@ -3317,10 +3317,10 @@ package Einfo is ...@@ -3317,10 +3317,10 @@ package Einfo is
-- not all of the fields in a partially initialized record). The code -- not all of the fields in a partially initialized record). The code
-- generator should instead use the flag Is_True_Constant. -- generator should instead use the flag Is_True_Constant.
-- --
-- For the purposes of this warning, the default assignment of -- For the purposes of this warning, the default assignment of access
-- access variables to null is not considered the assignment of -- variables to null is not considered the assignment of a value (so
-- of a value (so the warning can be given for code that relies -- the warning can be given for code that relies on this initial null
-- on this initial null value, when no other value is ever set). -- value when no other value is ever set).
-- --
-- In variables and out parameters, if this flag is set after full -- In variables and out parameters, if this flag is set after full
-- processing of the corresponding declarative unit, it indicates that -- processing of the corresponding declarative unit, it indicates that
...@@ -3333,10 +3333,10 @@ package Einfo is ...@@ -3333,10 +3333,10 @@ package Einfo is
-- statement sequence, the meaning of the flag is "not set yet", and -- statement sequence, the meaning of the flag is "not set yet", and
-- once this analysis is complete the flag means "never assigned". -- once this analysis is complete the flag means "never assigned".
-- Note: for variables appearing in package declarations, this flag -- Note: for variables appearing in package declarations, this flag is
-- is never set. That is because there is no way to tell if some -- never set. That is because there is no way to tell if some client
-- client modifies the variable (or in the case of variables in the -- modifies the variable (or, in the case of variables in the private
-- private part, if some child unit modifies the variables). -- part, if some child unit modifies the variables).
-- Note: in the case of renamed objects, the flag must be set in the -- Note: in the case of renamed objects, the flag must be set in the
-- ultimate renamed object. Clients noting a possible modification -- ultimate renamed object. Clients noting a possible modification
...@@ -3358,12 +3358,12 @@ package Einfo is ...@@ -3358,12 +3358,12 @@ package Einfo is
-- discriminants in the record. -- discriminants in the record.
-- Next_Discriminant (synthesized) -- Next_Discriminant (synthesized)
-- Applies to discriminants returned by First/Next_Discriminant. -- Applies to discriminants returned by First/Next_Discriminant. Returns
-- Returns the next language-defined (ie: perhaps non-girder) -- the next language-defined (ie: perhaps non-girder) discriminant by
-- discriminant by following the chain of declared entities as long as -- following the chain of declared entities as long as the kind of the
-- the kind of the entity corresponds to a discriminant. Note that the -- entity corresponds to a discriminant. Note that the discriminants
-- discriminants might be the only components of the record. -- might be the only components of the record. Returns Empty if there
-- Returns Empty if there are no more. -- are no more discriminants.
-- Next_Entity (Node2) -- Next_Entity (Node2)
-- Defined in all entities. The entities of a scope are chained, with -- Defined in all entities. The entities of a scope are chained, with
...@@ -3374,9 +3374,9 @@ package Einfo is ...@@ -3374,9 +3374,9 @@ package Einfo is
-- field are in Sinfo. -- field are in Sinfo.
-- Next_Formal (synthesized) -- Next_Formal (synthesized)
-- Applies to the entity for a formal parameter. Returns the next -- Applies to the entity for a formal parameter. Returns the next formal
-- formal parameter of the subprogram or subprogram type. Returns -- parameter of the subprogram or subprogram type. Returns Empty if there
-- Empty if there are no more formals. -- are no more formals.
-- Next_Formal_With_Extras (synthesized) -- Next_Formal_With_Extras (synthesized)
-- Applies to the entity for a formal parameter. Returns the next -- Applies to the entity for a formal parameter. Returns the next
......
...@@ -330,6 +330,24 @@ package body System.Img_Dec is ...@@ -330,6 +330,24 @@ package body System.Img_Dec is
DA := DA - LZ; DA := DA - LZ;
if DA < ND then if DA < ND then
-- Note: it is definitely possible for the above condition
-- to be True, for example:
-- V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0
-- but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0
-- so the arguments in the call are (1, 0) meaning that no
-- digits are output.
-- No obvious example exists where the following call to
-- Set_Digits actually outputs some digits, but we lack a
-- proof that no such example exists.
-- So it is safer to retain this call, even though as a
-- result it is hard (or perhaps impossible) to create a
-- coverage test for the inlined code of the call.
Set_Digits (FD, FD + DA - 1); Set_Digits (FD, FD + DA - 1);
else else
......
...@@ -9526,6 +9526,12 @@ package body Sem_Prag is ...@@ -9526,6 +9526,12 @@ package body Sem_Prag is
-- visibility chain. Pack_Id denotes the entity or the related -- visibility chain. Pack_Id denotes the entity or the related
-- package where pragma Abstract_State appears. -- package where pragma Abstract_State appears.
procedure Malformed_State_Error (State : Node_Id);
-- Emit an error concerning the illegal declaration of abstract
-- state State. This routine diagnoses syntax errors that lead to
-- a different parse tree. The error is issued regardless of the
-- SPARK mode in effect.
---------------------------- ----------------------------
-- Analyze_Abstract_State -- -- Analyze_Abstract_State --
---------------------------- ----------------------------
...@@ -10059,11 +10065,10 @@ package body Sem_Prag is ...@@ -10059,11 +10065,10 @@ package body Sem_Prag is
Next (Opt); Next (Opt);
end loop; end loop;
-- Any other attempt to declare a state is illegal. This is a -- Any other attempt to declare a state is illegal
-- syntax error, always report.
else else
Error_Msg_N ("malformed abstract state declaration", State); Malformed_State_Error (State);
return; return;
end if; end if;
...@@ -10096,11 +10101,29 @@ package body Sem_Prag is ...@@ -10096,11 +10101,29 @@ package body Sem_Prag is
end if; end if;
end Analyze_Abstract_State; end Analyze_Abstract_State;
---------------------------
-- Malformed_State_Error --
---------------------------
procedure Malformed_State_Error (State : Node_Id) is
begin
Error_Msg_N ("malformed abstract state declaration", State);
-- An abstract state with a simple option is being declared
-- with "=>" rather than the legal "with". The state appears
-- as a component association.
if Nkind (State) = N_Component_Association then
Error_Msg_N ("\\use WITH to specify simple option", State);
end if;
end Malformed_State_Error;
-- Local variables -- Local variables
Pack_Decl : Node_Id; Pack_Decl : Node_Id;
Pack_Id : Entity_Id; Pack_Id : Entity_Id;
State : Node_Id; State : Node_Id;
States : Node_Id;
-- Start of processing for Abstract_State -- Start of processing for Abstract_State
...@@ -10137,22 +10160,34 @@ package body Sem_Prag is ...@@ -10137,22 +10160,34 @@ package body Sem_Prag is
Set_Is_Ghost_Entity (Pack_Id); Set_Is_Ghost_Entity (Pack_Id);
end if; end if;
State := Expression (Get_Argument (N)); States := Expression (Get_Argument (N));
-- Multiple non-null abstract states appear as an aggregate -- Multiple non-null abstract states appear as an aggregate
if Nkind (State) = N_Aggregate then if Nkind (States) = N_Aggregate then
State := First (Expressions (State)); State := First (Expressions (States));
while Present (State) loop while Present (State) loop
Analyze_Abstract_State (State, Pack_Id); Analyze_Abstract_State (State, Pack_Id);
Next (State); Next (State);
end loop; end loop;
-- An abstract state with a simple option is being illegaly
-- declared with "=>" rather than "with". In this case the
-- state declaration appears as a component association.
if Present (Component_Associations (States)) then
State := First (Component_Associations (States));
while Present (State) loop
Malformed_State_Error (State);
Next (State);
end loop;
end if;
-- Various forms of a single abstract state. Note that these may -- Various forms of a single abstract state. Note that these may
-- include malformed state declarations. -- include malformed state declarations.
else else
Analyze_Abstract_State (State, Pack_Id); Analyze_Abstract_State (States, Pack_Id);
end if; end if;
-- Save the pragma for retrieval by other tools -- Save the pragma for retrieval by other tools
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment