Commit dedac3eb by Robert Dewar Committed by Arnaud Charlet

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

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* par_sco.adb, sem_ch3.adb, scos.ads, a-iteint.ads, sem_ch12.adb,
	a-cimutr.adb, a-cimutr.ads, sem_util.ads, sem_res.adb, a-fihema.adb,
	sem_ch4.adb, lib-xref-alfa.adb, exp_disp.adb, a-comutr.adb,
	a-comutr.ads, lib-xref.adb: Minor reformatting.

2011-08-05  Robert Dewar  <dewar@adacore.com>

	* sem_ch11.adb (Analyze_Raise_Statement): Kill assignment to formal
	warning if there is an exception handler present.

From-SVN: r177451
parent 7c62a85a
2011-08-05 Robert Dewar <dewar@adacore.com>
* par_sco.adb, sem_ch3.adb, scos.ads, a-iteint.ads, sem_ch12.adb,
a-cimutr.adb, a-cimutr.ads, sem_util.ads, sem_res.adb, a-fihema.adb,
sem_ch4.adb, lib-xref-alfa.adb, exp_disp.adb, a-comutr.adb,
a-comutr.ads, lib-xref.adb: Minor reformatting.
2011-08-05 Robert Dewar <dewar@adacore.com>
* sem_ch11.adb (Analyze_Raise_Statement): Kill assignment to formal
warning if there is an exception handler present.
2011-08-05 Pascal Obry <obry@adacore.com>
* a-iteint.ads: Fix copyright year.
......
......@@ -231,8 +231,8 @@ package Ada.Containers.Indefinite_Multiway_Trees is
-- Parent : Cursor;
-- Process : not null access procedure (Position : Cursor));
--
-- It seems that the Container parameter is there by mistake, but
-- we need an official ruling from the ARG. ???
-- It seems that the Container parameter is there by mistake, but we need
-- an official ruling from the ARG. ???
procedure Iterate_Children
(Parent : Cursor;
......@@ -264,19 +264,17 @@ private
use Ada.Finalization;
-- The Count component of type Tree represents the number of
-- nodes that have been (dynamically) allocated. It does not
-- include the root node itself. As implementors, we decide
-- to cache this value, so that the selector function Node_Count
-- can execute in O(1) time, in order to be consistent with
-- the behavior of the Length selector function for other
-- standard container library units. This does mean, however,
-- that the two-container forms for Splice_XXX (that move subtrees
-- across tree containers) will execute in O(n) time, because
-- we must count the number of nodes in the subtree(s) that
-- get moved. (We resolve the tension between Node_Count
-- and Splice_XXX in favor of Node_Count, under the assumption
-- that Node_Count is the more common operation).
-- The Count component of type Tree represents the number of nodes that
-- have been (dynamically) allocated. It does not include the root node
-- itself. As implementors, we decide to cache this value, so that the
-- selector function Node_Count can execute in O(1) time, in order to be
-- consistent with the behavior of the Length selector function for other
-- standard container library units. This does mean, however, that the
-- two-container forms for Splice_XXX (that move subtrees across tree
-- containers) will execute in O(n) time, because we must count the number
-- of nodes in the subtree(s) that get moved. (We resolve the tension
-- between Node_Count and Splice_XXX in favor of Node_Count, under the
-- assumption that Node_Count is the more common operation).
type Tree is new Controlled with record
Root : aliased Tree_Node_Type;
......
......@@ -238,8 +238,8 @@ package Ada.Containers.Multiway_Trees is
-- Parent : Cursor;
-- Process : not null access procedure (Position : Cursor));
--
-- It seems that the Container parameter is there by mistake, but
-- we need an official ruling from the ARG. ???
-- It seems that the Container parameter is there by mistake, but we need
-- an official ruling from the ARG. ???
procedure Iterate_Children
(Parent : Cursor;
......@@ -251,29 +251,29 @@ package Ada.Containers.Multiway_Trees is
private
-- A node of this multiway tree comprises an element and a list of
-- children (that are themselves trees). The root node is distinguished
-- because it contains only children: it does not have an element itself.
-- A node of this multiway tree comprises an element and a list of children
-- (that are themselves trees). The root node is distinguished because it
-- contains only children: it does not have an element itself.
--
-- This design feature puts two design goals in tension:
-- (1) treat the root node the same as any other node
-- (2) not declare any objects of type Element_Type unnecessarily
--
-- To satisfy (1), we could simply declare the Root node of the tree
-- using the normal Tree_Node_Type, but that would mean that (2) is not
-- To satisfy (1), we could simply declare the Root node of the tree using
-- the normal Tree_Node_Type, but that would mean that (2) is not
-- satisfied. To resolve the tension (in favor of (2)), we declare the
-- component Root as having a different node type, without an Element
-- component (thus satisfying goal (2)) but otherwise identical to a
-- normal node, and then use Unchecked_Conversion to convert an access
-- object designating the Root node component to the access type
-- designating a normal, non-root node (thus satisfying goal (1)). We make
-- an explicit check for Root when there is any attempt to manipulate the
-- Element component of the node (a check required by the RM anyway).
-- component (thus satisfying goal (2)) but otherwise identical to a normal
-- node, and then use Unchecked_Conversion to convert an access object
-- designating the Root node component to the access type designating a
-- normal, non-root node (thus satisfying goal (1)). We make an explicit
-- check for Root when there is any attempt to manipulate the Element
-- component of the node (a check required by the RM anyway).
--
-- In order to be explicit about node (and pointer) representation, we
-- specify that the respective node types have convention C, to ensure
-- that the layout of the components of the node records is the same,
-- thus guaranteeing that (unchecked) conversions between access types
-- specify that the respective node types have convention C, to ensure that
-- the layout of the components of the node records is the same, thus
-- guaranteeing that (unchecked) conversions between access types
-- designating each kind of node type is a meaningful conversion.
type Tree_Node_Type;
......@@ -285,9 +285,8 @@ private
Last : Tree_Node_Access;
end record;
-- See the comment above. This declaration must exactly
-- match the declaration of Root_Node_Type (except for
-- the Element component).
-- See the comment above. This declaration must exactly match the
-- declaration of Root_Node_Type (except for the Element component).
type Tree_Node_Type is record
Parent : Tree_Node_Access;
......@@ -298,9 +297,8 @@ private
end record;
pragma Convention (C, Tree_Node_Type);
-- See the comment above. This declaration must match
-- the declaration of Tree_Node_Type (except for the
-- Element component).
-- See the comment above. This declaration must match the declaration of
-- Tree_Node_Type (except for the Element component).
type Root_Node_Type is record
Parent : Tree_Node_Access;
......@@ -312,19 +310,17 @@ private
use Ada.Finalization;
-- The Count component of type Tree represents the number of
-- nodes that have been (dynamically) allocated. It does not
-- include the root node itself. As implementors, we decide
-- to cache this value, so that the selector function Node_Count
-- can execute in O(1) time, in order to be consistent with
-- the behavior of the Length selector function for other
-- standard container library units. This does mean, however,
-- that the two-container forms for Splice_XXX (that move subtrees
-- across tree containers) will execute in O(n) time, because
-- we must count the number of nodes in the subtree(s) that
-- get moved. (We resolve the tension between Node_Count
-- and Splice_XXX in favor of Node_Count, under the assumption
-- that Node_Count is the more common operation).
-- The Count component of type Tree represents the number of nodes that
-- have been (dynamically) allocated. It does not include the root node
-- itself. As implementors, we decide to cache this value, so that the
-- selector function Node_Count can execute in O(1) time, in order to be
-- consistent with the behavior of the Length selector function for other
-- standard container library units. This does mean, however, that the
-- two-container forms for Splice_XXX (that move subtrees across tree
-- containers) will execute in O(n) time, because we must count the number
-- of nodes in the subtree(s) that get moved. (We resolve the tension
-- between Node_Count and Splice_XXX in favor of Node_Count, under the
-- assumption that Node_Count is the more common operation).
type Tree is new Controlled with record
Root : aliased Root_Node_Type;
......
......@@ -67,11 +67,10 @@ package body Ada.Finalization.Heap_Management is
procedure Fin_Assert (Condition : Boolean; Message : String);
-- Asserts that the condition is True. Used instead of pragma Assert in
-- delicate places where raising an exception would cause re-invocation of
-- finalization. Instead of raising an exception, aborts the whole
-- process.
-- finalization. Instead of raising an exception, aborts the whole process.
function Is_Empty (Objects : Node_Ptr) return Boolean;
-- True if the Objects list is empty.
-- True if the Objects list is empty
----------------
-- Fin_Assert --
......@@ -194,6 +193,7 @@ package body Ada.Finalization.Heap_Management is
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Attach;
---------------
......@@ -279,8 +279,10 @@ package body Ada.Finalization.Heap_Management is
end if;
Unlock_Task.all;
-- Note: no need to unlock in case of exceptions; the above code cannot
-- raise any.
end Detach;
--------------
......@@ -305,9 +307,12 @@ package body Ada.Finalization.Heap_Management is
-- modified.
if Collection.Finalization_Started then
-- ???Needed for shared libraries.
-- ???Needed for shared libraries
return;
end if;
pragma Debug (Fin_Assert (not Collection.Finalization_Started,
"Finalize: already started"));
Collection.Finalization_Started := True;
......@@ -340,7 +345,6 @@ package body Ada.Finalization.Heap_Management is
begin
Collection.Finalize_Address (Object_Address);
exception
when Fin_Except : others =>
if not Raised then
......@@ -403,7 +407,7 @@ package body Ada.Finalization.Heap_Management is
procedure pcol (Collection : Finalization_Collection) is
Head : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
-- "Unrestricted", because we are getting access-to-variable of a
-- constant! Normally worrisome, this is OK for debugging code.
-- constant! Normally worrisome, this is OK for debugging code.
Head_Seen : Boolean := False;
N_Ptr : Node_Ptr;
......
......@@ -6,27 +6,10 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
......@@ -34,13 +17,21 @@ generic
type Cursor is private;
No_Element : Cursor;
pragma Unreferenced (No_Element);
package Ada.Iterator_Interfaces is
type Forward_Iterator is limited interface;
function First (Object : Forward_Iterator) return Cursor is abstract;
function Next (Object : Forward_Iterator; Position : Cursor) return Cursor
is abstract;
function Next
(Object : Forward_Iterator;
Position : Cursor) return Cursor is abstract;
type Reversible_Iterator is limited interface and Forward_Iterator;
function Last (Object : Reversible_Iterator) return Cursor is abstract;
function Previous (Object : Reversible_Iterator; Position : Cursor)
return Cursor is abstract;
function Previous
(Object : Reversible_Iterator;
Position : Cursor) return Cursor is abstract;
end Ada.Iterator_Interfaces;
......@@ -7870,8 +7870,8 @@ package body Exp_Disp is
First_Prim : constant Elmt_Id := First_Elmt (Primitive_Operations (Typ));
The_Tag : constant Entity_Id := First_Tag_Component (Typ);
Adjusted : Boolean := False;
Finalized : Boolean := False;
Adjusted : Boolean := False;
Finalized : Boolean := False;
Count_Prim : Nat;
DT_Length : Nat;
......
......@@ -877,12 +877,11 @@ package body ALFA is
procedure Detect_And_Add_ALFA_Scope (N : Node_Id) is
begin
if Nkind_In (N,
N_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Package_Declaration,
N_Package_Body)
if Nkind_In (N, N_Subprogram_Declaration,
N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Package_Declaration,
N_Package_Body)
then
Add_ALFA_Scope (N);
end if;
......
......@@ -174,7 +174,8 @@ package body Lib.Xref is
when N_Pragma =>
if Get_Pragma_Id (Result) = Pragma_Precondition
or else Get_Pragma_Id (Result) = Pragma_Postcondition
or else
Get_Pragma_Id (Result) = Pragma_Postcondition
then
return Empty;
else
......
......@@ -893,6 +893,7 @@ package body Par_SCO is
if Index /= 0 then
declare
T : SCO_Table_Entry renames SCO_Table.Table (Index);
begin
-- Called multiple times for the same sloc (need to allow for
-- C2 = 'P') ???
......@@ -1080,7 +1081,7 @@ package body Par_SCO is
SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location;
begin
-- For the statement SCO for a pragma controlled by
-- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enable, set Pragma_Sloc so that the SCO (and
-- those of any nested decision) is emitted only if the pragma
-- is enabled.
......@@ -1506,10 +1507,9 @@ package body Par_SCO is
when N_Generic_Instantiation =>
Typ := 'i';
when
N_Representation_Clause |
N_Use_Package_Clause |
N_Use_Type_Clause =>
when N_Representation_Clause |
N_Use_Package_Clause |
N_Use_Type_Clause =>
Typ := ASCII.NUL;
when others =>
......
......@@ -339,7 +339,7 @@ package SCOs is
-- Disabled pragmas
-- No SCO is generated for disabled pragmas.
-- No SCO is generated for disabled pragmas
---------------------------------------------------------------------
-- Internal table used to store Source Coverage Obligations (SCOs) --
......
......@@ -432,6 +432,7 @@ package body Sem_Ch11 is
Exception_Id : constant Node_Id := Name (N);
Exception_Name : Entity_Id := Empty;
P : Node_Id;
Par : Node_Id;
begin
Check_SPARK_Restriction ("raise statement is not allowed", N);
......@@ -443,9 +444,9 @@ package body Sem_Ch11 is
Check_Restriction (No_Exceptions, N);
end if;
-- Check for useless assignment to OUT or IN OUT scalar immediately
-- preceding the raise. Right now we only look at assignment statements,
-- we could do more.
-- Check for useless assignment to OUT or IN OUT scalar preceding the
-- raise. Right now we only look at assignment statements, we could do
-- more.
if Is_List_Member (N) then
declare
......@@ -455,21 +456,49 @@ package body Sem_Ch11 is
begin
P := Prev (N);
-- Skip past null statements and pragmas
while Present (P)
and then Nkind_In (P, N_Null_Statement, N_Pragma)
loop
P := Prev (P);
end loop;
-- See if preceding statement is an assignment
if Present (P)
and then Nkind (P) = N_Assignment_Statement
then
L := Name (P);
-- Give warning for assignment to scalar formal
if Is_Scalar_Type (Etype (L))
and then Is_Entity_Name (L)
and then Is_Formal (Entity (L))
then
Error_Msg_N
("?assignment to pass-by-copy formal may have no effect",
P);
Error_Msg_N
("\?RAISE statement may result in abnormal return" &
" (RM 6.4.1(17))", P);
-- Don't give warning if we are covered by an exception
-- handler, since this may result in false positives, since
-- the handler may handle the exception and return normally.
-- First find enclosing sequence of statements
Par := N;
loop
Par := Parent (Par);
exit when Nkind (Par) = N_Handled_Sequence_Of_Statements;
end loop;
-- See if there is a handler, give message if not
if No (Exception_Handlers (Par)) then
Error_Msg_N
("?assignment to pass-by-copy formal " &
"may have no effect", P);
Error_Msg_N
("\?RAISE statement may result in abnormal return" &
" (RM 6.4.1(17))", P);
end if;
end if;
end if;
end;
......
......@@ -3402,14 +3402,14 @@ package body Sem_Ch12 is
and then not Inline_Now
and then not ALFA_Mode
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate body if
-- within a generic context.
if (Front_End_Inlining
and then not Expander_Active)
and then not Expander_Active)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
then
Needs_Body := False;
......@@ -3430,10 +3430,10 @@ package body Sem_Ch12 is
begin
if Nkind (Decl) = N_Formal_Package_Declaration
or else (Nkind (Decl) = N_Package_Declaration
and then Is_List_Member (Decl)
and then Present (Next (Decl))
and then
Nkind (Next (Decl)) =
and then Is_List_Member (Decl)
and then Present (Next (Decl))
and then
Nkind (Next (Decl)) =
N_Formal_Package_Declaration)
then
Needs_Body := False;
......@@ -4014,12 +4014,12 @@ package body Sem_Ch12 is
is
begin
if (Is_In_Main_Unit (N)
or else Is_Inlined (Subp)
or else Is_Inlined (Alias (Subp)))
or else Is_Inlined (Subp)
or else Is_Inlined (Alias (Subp)))
and then not ALFA_Mode
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode))
or else (Operating_Mode = Check_Semantics
and then ASIS_Mode))
and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Subp)
......@@ -4033,6 +4033,7 @@ package body Sem_Ch12 is
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
Version => Ada_Version));
return True;
else
return False;
end if;
......@@ -11892,14 +11893,13 @@ package body Sem_Ch12 is
if Present (E) then
-- If the node is an entry call to an entry in an enclosing task,
-- it is rewritten as a selected component. No global entity
-- to preserve in this case, the expansion will be redone in the
-- instance.
if not Nkind_In (E,
N_Defining_Identifier,
N_Defining_Character_Literal,
N_Defining_Operator_Symbol)
-- it is rewritten as a selected component. No global entity to
-- preserve in this case, since the expansion will be redone in
-- the instance.
if not Nkind_In (E, N_Defining_Identifier,
N_Defining_Character_Literal,
N_Defining_Operator_Symbol)
then
Set_Associated_Node (N, Empty);
Set_Etype (N, Empty);
......
......@@ -4243,24 +4243,24 @@ package body Sem_Ch3 is
end if;
when Private_Kind =>
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Ekind (Id, Subtype_Kind (Ekind (T)));
Set_Has_Discriminants (Id, Has_Discriminants (T));
Set_Is_Constrained (Id, Is_Constrained (T));
Set_First_Entity (Id, First_Entity (T));
Set_Last_Entity (Id, Last_Entity (T));
Set_Private_Dependents (Id, New_Elmt_List);
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Is_Limited_Record (Id, Is_Limited_Record (T));
Set_Has_Implicit_Dereference
(Id, Has_Implicit_Dereference (T));
(Id, Has_Implicit_Dereference (T));
Set_Has_Unknown_Discriminants
(Id, Has_Unknown_Discriminants (T));
(Id, Has_Unknown_Discriminants (T));
Set_Known_To_Have_Preelab_Init
(Id, Known_To_Have_Preelab_Init (T));
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract_Type (Id, Is_Abstract_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
Set_Direct_Primitive_Operations (Id,
Direct_Primitive_Operations (T));
end if;
......@@ -4273,14 +4273,14 @@ package body Sem_Ch3 is
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
(Id, Discriminant_Constraint (T));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
elsif Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (Full_View (T)));
(Id, Discriminant_Constraint (Full_View (T)));
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
-- This would seem semantically correct, but apparently
......
......@@ -6303,26 +6303,27 @@ package body Sem_Ch4 is
Func_Name := Empty;
Is_Var := False;
Ritem := First_Rep_Item (Etype (Prefix));
Ritem := First_Rep_Item (Etype (Prefix));
while Present (Ritem) loop
if Nkind (Ritem) = N_Aspect_Specification then
-- Prefer Variable_Indexing, but will settle for Constant.
if Get_Aspect_Id (Chars (Identifier (Ritem))) =
Aspect_Constant_Indexing
Aspect_Constant_Indexing
then
Func_Name := Expression (Ritem);
elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
Aspect_Variable_Indexing
Aspect_Variable_Indexing
then
Func_Name := Expression (Ritem);
Is_Var := True;
exit;
end if;
end if;
Next_Rep_Item (Ritem);
end loop;
......
......@@ -1756,7 +1756,7 @@ package body Sem_Res is
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
-- AI05-139 : names with implicit dereference. If the expression N is a
-- AI05-139: Names with implicit dereference. If the expression N is a
-- reference type and the context imposes the corresponding designated
-- type, convert N into N.Disc.all. Such expressions are always over-
-- loaded with both interpretations, and the dereference interpretation
......@@ -2312,9 +2312,9 @@ package body Sem_Res is
elsif Nkind (N) = N_Conditional_Expression then
Set_Etype (N, Expr_Type);
-- AI05-0139-2 : expression is overloaded because
-- type has implicit dereference. If type matches
-- context, no implicit dereference is involved.
-- AI05-0139-2: Expression is overloaded because type has
-- implicit dereference. If type matches context, no implicit
-- dereference is involved.
elsif Has_Implicit_Dereference (Expr_Type) then
Set_Etype (N, Expr_Type);
......
......@@ -148,7 +148,7 @@ package Sem_Util is
-- means that for sure CE cannot be raised.
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
-- AI05-139-2 : accessors and iterators for containers. This procedure
-- AI05-139-2: Accessors and iterators for containers. This procedure
-- checks whether T is a reference type, and if so it adds an interprettion
-- to Expr whose type is the designated type of the reference_discriminant.
......
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