Skip to content

R
riscv-gcc-1
Commit dedac3eb by Robert Dewar Committed by Arnaud Charlet
Options

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