Skip to content

R
riscv-gcc-1
Commit 243cae0a by Arnaud Charlet
Options

[multiple changes] 

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

	* a-cfdlli.adb, bindgen.adb, exp_ch4.adb, exp_ch13.adb, sem_warn.adb,
	exp_ch3.adb, exp_ch3.ads: Minor reformatting.

2011-08-03  Pascal Obry  <obry@adacore.com>

	* g-awk.ads: Minor comment fix.

2011-08-03  Sergey Rybin  <rybin@adacore.com>

	* tree_io.ads (ASIS_Version_Number): Update because of the changes in
	the tree structure related to discriminant constraints.
	Original_Discriminant cannot be used any more for computing the
	defining name for the reference to a discriminant.

2011-08-03  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Is_Tag_Indeterminate): If the return type of the
	function is not visibly tagged, this is not a dispatching call and
	therfore is not Tag_Indeterminate, even if the function is marked as
	dispatching on result.

From-SVN: r177281
parent f553e7bc
Showing with 158 additions and 110 deletions
gcc/ada/ChangeLog
2011-08-03 Robert Dewar <dewar@adacore.com>
* a-cfdlli.adb, bindgen.adb, exp_ch4.adb, exp_ch13.adb, sem_warn.adb,
exp_ch3.adb, exp_ch3.ads: Minor reformatting.
2011-08-03 Pascal Obry <obry@adacore.com>
* g-awk.ads: Minor comment fix.
2011-08-03 Sergey Rybin <rybin@adacore.com>
* tree_io.ads (ASIS_Version_Number): Update because of the changes in
the tree structure related to discriminant constraints.
Original_Discriminant cannot be used any more for computing the
defining name for the reference to a discriminant.
2011-08-03 Ed Schonberg <schonberg@adacore.com>
* sem_disp.adb (Is_Tag_Indeterminate): If the return type of the
function is not visibly tagged, this is not a dispatching call and
therfore is not Tag_Indeterminate, even if the function is marked as
dispatching on result.
2011-08-03 Hristian Kirtchev <kirtchev@adacore.com> 2011-08-03 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch13.adb: Add with and use clauses for Restrict and Rident. * exp_ch13.adb: Add with and use clauses for Restrict and Rident.
......
gcc/ada/a-cfdlli.adb
...@@ -234,6 +234,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -234,6 +234,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
N : Count_Type := 1; N : Count_Type := 1;
P : List (C); P : List (C);
begin begin
while N <= Source.Capacity loop while N <= Source.Capacity loop
P.Nodes (N).Prev := Source.Nodes (N).Prev; P.Nodes (N).Prev := Source.Nodes (N).Prev;
...@@ -241,10 +242,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -241,10 +242,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
P.Nodes (N).Element := Source.Nodes (N).Element; P.Nodes (N).Element := Source.Nodes (N).Element;
N := N + 1; N := N + 1;
end loop; end loop;
P.Free := Source.Free; P.Free := Source.Free;
P.Length := Source.Length; P.Length := Source.Length;
P.First := Source.First; P.First := Source.First;
P.Last := Source.Last; P.Last := Source.Last;
if P.Free >= 0 then if P.Free >= 0 then
N := Source.Capacity + 1; N := Source.Capacity + 1;
while N <= C loop while N <= C loop
...@@ -252,6 +255,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -252,6 +255,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
N := N + 1; N := N + 1;
end loop; end loop;
end if; end if;
return P; return P;
end Copy; end Copy;
...@@ -269,7 +273,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -269,7 +273,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
begin begin
if not Has_Element (Container => Container, if not Has_Element (Container => Container,
Position => Position) then Position => Position)
then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if; end if;
...@@ -349,7 +354,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -349,7 +354,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
"attempt to tamper with elements (list is busy)"; "attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.First; X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First); pragma Assert (N (N (X).Next).Prev = Container.First);
...@@ -388,7 +393,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -388,7 +393,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
"attempt to tamper with elements (list is busy)"; "attempt to tamper with elements (list is busy)";
end if; end if;
for I in 1 .. Count loop for J in 1 .. Count loop
X := Container.Last; X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last); pragma Assert (N (N (X).Prev).Next = Container.Last);
...@@ -407,7 +412,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -407,7 +412,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Element function Element
(Container : List; (Container : List;
Position : Cursor) return Element_Type is Position : Cursor) return Element_Type
is
begin begin
if not Has_Element (Container => Container, Position => Position) then if not Has_Element (Container => Container, Position => Position) then
raise Constraint_Error with raise Constraint_Error with
...@@ -427,15 +433,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -427,15 +433,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Position : Cursor := No_Element) return Cursor Position : Cursor := No_Element) return Cursor
is is
From : Count_Type := Position.Node; From : Count_Type := Position.Node;
begin begin
if From = 0 and Container.Length = 0 then if From = 0 and Container.Length = 0 then
return No_Element; return No_Element;
end if; end if;
if From = 0 then if From = 0 then
From := Container.First; From := Container.First;
end if; end if;
if Position.Node /= 0 and then if Position.Node /= 0 and then
not Has_Element (Container, Position) then not Has_Element (Container, Position)
then
raise Constraint_Error with raise Constraint_Error with
"Position cursor has no element"; "Position cursor has no element";
end if; end if;
...@@ -444,6 +454,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -444,6 +454,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Container.Nodes (From).Element = Item then if Container.Nodes (From).Element = Item then
return (Node => From); return (Node => From);
end if; end if;
From := Container.Nodes (From).Next; From := Container.Nodes (From).Next;
end loop; end loop;
...@@ -459,6 +470,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -459,6 +470,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Container.First = 0 then if Container.First = 0 then
return No_Element; return No_Element;
end if; end if;
return (Node => Container.First); return (Node => Container.First);
end First; end First;
...@@ -507,8 +519,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -507,8 +519,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Container.Free := 0; Container.Free := 0;
else else
for I in Container.Free .. Container.Capacity - 1 loop for J in Container.Free .. Container.Capacity - 1 loop
N (I).Next := I + 1; N (J).Next := J + 1;
end loop; end loop;
N (Container.Capacity).Next := 0; N (Container.Capacity).Next := 0;
...@@ -532,6 +544,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -532,6 +544,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Is_Sorted (Container : List) return Boolean is function Is_Sorted (Container : List) return Boolean is
Nodes : Node_Array renames Container.Nodes; Nodes : Node_Array renames Container.Nodes;
Node : Count_Type := Container.First; Node : Count_Type := Container.First;
begin begin
for I in 2 .. Container.Length loop for I in 2 .. Container.Length loop
if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
...@@ -618,9 +631,10 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -618,9 +631,10 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
--------------- ---------------
procedure Partition (Pivot, Back : Count_Type) is procedure Partition (Pivot, Back : Count_Type) is
Node : Count_Type := N (Pivot).Next; Node : Count_Type;
begin begin
Node := N (Pivot).Next;
while Node /= Back loop while Node /= Back loop
if N (Node).Element < N (Pivot).Element then if N (Node).Element < N (Pivot).Element then
declare declare
...@@ -709,6 +723,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -709,6 +723,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Position.Node = 0 then if Position.Node = 0 then
return False; return False;
end if; end if;
return Container.Nodes (Position.Node).Prev /= -1; return Container.Nodes (Position.Node).Prev /= -1;
end Has_Element; end Has_Element;
...@@ -763,7 +778,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -763,7 +778,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
Position : Cursor; Position : Cursor;
begin begin
Insert (Container, Before, New_Item, Position, Count); Insert (Container, Before, New_Item, Position, Count);
end Insert; end Insert;
...@@ -893,6 +907,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -893,6 +907,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Process (Container, (Node => Node)); Process (Container, (Node => Node));
Node := Container.Nodes (Node).Next; Node := Container.Nodes (Node).Next;
end loop; end loop;
exception exception
when others => when others =>
B := B - 1; B := B - 1;
...@@ -934,12 +949,14 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -934,12 +949,14 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Left (Container : List; Position : Cursor) return List is function Left (Container : List; Position : Cursor) return List is
Curs : Cursor := Position; Curs : Cursor := Position;
C : List (Container.Capacity) := Copy (Container, Container.Capacity); C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type; Node : Count_Type;
begin begin
if Curs = No_Element then if Curs = No_Element then
return C; return C;
end if; end if;
if not Has_Element (Container, Curs) then if not Has_Element (Container, Curs) then
raise Constraint_Error; raise Constraint_Error;
end if; end if;
...@@ -949,6 +966,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -949,6 +966,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Delete (C, Curs); Delete (C, Curs);
Curs := Next (Container, (Node => Node)); Curs := Next (Container, (Node => Node));
end loop; end loop;
return C; return C;
end Left; end Left;
...@@ -1015,9 +1033,11 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1015,9 +1033,11 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Position.Node = 0 then if Position.Node = 0 then
return No_Element; return No_Element;
end if; end if;
if not Has_Element (Container, Position) then if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element"; raise Program_Error with "Position cursor has no element";
end if; end if;
return (Node => Container.Nodes (Position.Node).Next); return (Node => Container.Nodes (Position.Node).Next);
end Next; end Next;
...@@ -1052,6 +1072,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1052,6 +1072,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if not Has_Element (Container, Position) then if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element"; raise Program_Error with "Position cursor has no element";
end if; end if;
return (Node => Container.Nodes (Position.Node).Prev); return (Node => Container.Nodes (Position.Node).Prev);
end Previous; end Previous;
...@@ -1316,13 +1337,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1316,13 +1337,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Right (Container : List; Position : Cursor) return List is function Right (Container : List; Position : Cursor) return List is
Curs : Cursor := First (Container); Curs : Cursor := First (Container);
C : List (Container.Capacity) := Copy (Container, Container.Capacity); C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type; Node : Count_Type;
begin begin
if Curs = No_Element then if Curs = No_Element then
Clear (C); Clear (C);
return C; return C;
end if; end if;
if Position /= No_Element and not Has_Element (Container, Position) then if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error; raise Constraint_Error;
end if; end if;
...@@ -1332,6 +1355,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1332,6 +1355,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Delete (C, Curs); Delete (C, Curs);
Curs := Next (Container, (Node => Node)); Curs := Next (Container, (Node => Node));
end loop; end loop;
return C; return C;
end Right; end Right;
...@@ -1537,15 +1561,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1537,15 +1561,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Strict_Equal (Left, Right : List) return Boolean is function Strict_Equal (Left, Right : List) return Boolean is
CL : Count_Type := Left.First; CL : Count_Type := Left.First;
CR : Count_Type := Right.First; CR : Count_Type := Right.First;
begin begin
while CL /= 0 or CR /= 0 loop while CL /= 0 or CR /= 0 loop
if CL /= CR or else if CL /= CR or else
Left.Nodes (CL).Element /= Right.Nodes (CL).Element then Left.Nodes (CL).Element /= Right.Nodes (CL).Element
then
return False; return False;
end if; end if;
CL := Left.Nodes (CL).Next; CL := Left.Nodes (CL).Next;
CR := Right.Nodes (CR).Next; CR := Right.Nodes (CR).Next;
end loop; end loop;
return True; return True;
end Strict_Equal; end Strict_Equal;
...@@ -1558,7 +1586,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1558,7 +1586,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
I, J : Cursor) I, J : Cursor)
is is
begin begin
if I.Node = 0 then if I.Node = 0 then
raise Constraint_Error with "I cursor has no element"; raise Constraint_Error with "I cursor has no element";
end if; end if;
...@@ -1603,7 +1630,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1603,7 +1630,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
I_Next, J_Next : Cursor; I_Next, J_Next : Cursor;
begin begin
if I.Node = 0 then if I.Node = 0 then
raise Constraint_Error with "I cursor has no element"; raise Constraint_Error with "I cursor has no element";
end if; end if;
...@@ -1653,7 +1679,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is ...@@ -1653,7 +1679,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Process : not null access procedure (Element : in out Element_Type)) Process : not null access procedure (Element : in out Element_Type))
is is
begin begin
if Position.Node = 0 then if Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if; end if;
......
gcc/ada/bindgen.adb
...@@ -2125,7 +2125,8 @@ package body Bindgen is ...@@ -2125,7 +2125,8 @@ package body Bindgen is
procedure Gen_Main_C is procedure Gen_Main_C is
Needs_Library_Finalization : constant Boolean := Needs_Library_Finalization : constant Boolean :=
not Configurable_Run_Time_On_Target and then Has_Finalizer; not Configurable_Run_Time_On_Target
and then Has_Finalizer;
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want library-level finalization. -- non-terminating, so we do not want library-level finalization.
...@@ -2649,7 +2650,8 @@ package body Bindgen is ...@@ -2649,7 +2650,8 @@ package body Bindgen is
-- function Get_Ada_Main_Name for details on the form of the name. -- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean := Needs_Library_Finalization : constant Boolean :=
not Configurable_Run_Time_On_Target and then Has_Finalizer; not Configurable_Run_Time_On_Target
and then Has_Finalizer;
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization. -- non-terminating, so we do not want finalization.
...@@ -3004,7 +3006,9 @@ package body Bindgen is ...@@ -3004,7 +3006,9 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String) is procedure Gen_Output_File_C (Filename : String) is
Needs_Library_Finalization : constant Boolean := Needs_Library_Finalization : constant Boolean :=
not Configurable_Run_Time_On_Target and then Has_Finalizer; not Configurable_Run_Time_On_Target
and then Has_Finalizer;
-- ??? seems like we repeat this cantation often, should it be global?
Bfile : Name_Id; Bfile : Name_Id;
pragma Warnings (Off, Bfile); pragma Warnings (Off, Bfile);
......
gcc/ada/exp_ch13.adb
...@@ -214,7 +214,7 @@ package body Exp_Ch13 is ...@@ -214,7 +214,7 @@ package body Exp_Ch13 is
procedure Expand_N_Free_Statement (N : Node_Id) is procedure Expand_N_Free_Statement (N : Node_Id) is
Expr : constant Node_Id := Expression (N); Expr : constant Node_Id := Expression (N);
Typ : Entity_Id := Etype (Expr); Typ : Entity_Id;
begin begin
-- Certain run-time configurations and targets do not provide support -- Certain run-time configurations and targets do not provide support
...@@ -232,6 +232,8 @@ package body Exp_Ch13 is ...@@ -232,6 +232,8 @@ package body Exp_Ch13 is
-- Use the base type to perform the collection check -- Use the base type to perform the collection check
Typ := Etype (Expr);
if Ekind (Typ) = E_Access_Subtype then if Ekind (Typ) = E_Access_Subtype then
Typ := Etype (Typ); Typ := Etype (Typ);
end if; end if;
......
gcc/ada/exp_ch3.ads
...@@ -113,22 +113,6 @@ package Exp_Ch3 is ...@@ -113,22 +113,6 @@ package Exp_Ch3 is
-- want Gigi to see the node. This function can't delete the node itself -- want Gigi to see the node. This function can't delete the node itself
-- since it would confuse any remaining processing of the freeze node. -- since it would confuse any remaining processing of the freeze node.
function Get_Simple_Init_Val
(T : Entity_Id;
N : Node_Id;
Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. N is a
-- node whose source location used in constructing this tree which is
-- returned as the result of the call. The Size parameter indicates the
-- target size of the object if it is known (indicated by a value that is
-- not No_Uint and is greater than zero). If Size is not given (Size set to
-- No_Uint, or non-positive), then the Esize of T is used as an estimate of
-- the Size. The object size is needed to prepare a known invalid value for
-- use by Normalize_Scalars. A call to this routine where T is a scalar
-- type is only valid if we are in Normalize_Scalars or Initialize_Scalars
-- mode, or if N is the node for a 'Invalid_Value attribute node.
procedure Init_Secondary_Tags procedure Init_Secondary_Tags
(Typ : Entity_Id; (Typ : Entity_Id;
Target : Node_Id; Target : Node_Id;
...@@ -155,4 +139,20 @@ package Exp_Ch3 is ...@@ -155,4 +139,20 @@ package Exp_Ch3 is
-- set to False, but if Consider_IS is set to True, then the cases above -- set to False, but if Consider_IS is set to True, then the cases above
-- mentioning Normalize_Scalars also apply for Initialize_Scalars mode. -- mentioning Normalize_Scalars also apply for Initialize_Scalars mode.
function Get_Simple_Init_Val
(T : Entity_Id;
N : Node_Id;
Size : Uint := No_Uint) return Node_Id;
-- For a type which Needs_Simple_Initialization (see above), prepares the
-- tree for an expression representing the required initial value. N is a
-- node whose source location used in constructing this tree which is
-- returned as the result of the call. The Size parameter indicates the
-- target size of the object if it is known (indicated by a value that is
-- not No_Uint and is greater than zero). If Size is not given (Size set to
-- No_Uint, or non-positive), then the Esize of T is used as an estimate of
-- the Size. The object size is needed to prepare a known invalid value for
-- use by Normalize_Scalars. A call to this routine where T is a scalar
-- type is only valid if we are in Normalize_Scalars or Initialize_Scalars
-- mode, or if N is the node for a 'Invalid_Value attribute node.
end Exp_Ch3; end Exp_Ch3;
gcc/ada/g-awk.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2000-2010, AdaCore -- -- Copyright (C) 2000-2011, AdaCore --
-- -- -- --
-- 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- --
...@@ -215,7 +215,7 @@ package GNAT.AWK is ...@@ -215,7 +215,7 @@ package GNAT.AWK is
-- a full AWK run. The state comprises a list of files, the current file, -- a full AWK run. The state comprises a list of files, the current file,
-- the number of line processed, the current line, the number of fields in -- the number of line processed, the current line, the number of fields in
-- the current line... A default session is provided (see Set_Current, -- the current line... A default session is provided (see Set_Current,
-- Current_Session and Default_Session above). -- Current_Session and Default_Session below).
---------------------------- ----------------------------
-- Package initialization -- -- Package initialization --
......
gcc/ada/sem_disp.adb
...@@ -1500,17 +1500,16 @@ package body Sem_Disp is ...@@ -1500,17 +1500,16 @@ package body Sem_Disp is
if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
-- If Old_Subp isn't already marked as dispatching then -- If Old_Subp isn't already marked as dispatching then this is
-- this is the case of an operation of an untagged private -- the case of an operation of an untagged private type fulfilled
-- type fulfilled by a tagged type that overrides an -- by a tagged type that overrides an inherited dispatching
-- inherited dispatching operation, so we set the necessary -- operation, so we set the necessary dispatching attributes here.
-- dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then if not Is_Dispatching_Operation (Old_Subp) then
-- If the untagged type has no discriminants, and the full -- If the untagged type has no discriminants, and the full
-- view is constrained, there will be a spurious mismatch -- view is constrained, there will be a spurious mismatch of
-- of subtypes on the controlling arguments, because the tagged -- subtypes on the controlling arguments, because the tagged
-- type is the internal base type introduced in the derivation. -- type is the internal base type introduced in the derivation.
-- Use the original type to verify conformance, rather than the -- Use the original type to verify conformance, rather than the
-- base type. -- base type.
...@@ -1758,9 +1757,9 @@ package body Sem_Disp is ...@@ -1758,9 +1757,9 @@ package body Sem_Disp is
begin begin
-- The original corresponding operation of Prim must be an -- The original corresponding operation of Prim must be an
-- operation of a visible ancestor of the dispatching type -- operation of a visible ancestor of the dispatching type S,
-- S, and the original corresponding operation of S2 must -- and the original corresponding operation of S2 must be
-- be visible. -- visible.
Orig_Prim := Original_Corresponding_Operation (Prim); Orig_Prim := Original_Corresponding_Operation (Prim);
...@@ -2026,6 +2025,14 @@ package body Sem_Disp is ...@@ -2026,6 +2025,14 @@ package body Sem_Disp is
if not Has_Controlling_Result (Nam) then if not Has_Controlling_Result (Nam) then
return False; return False;
-- The function may have a controlling result, but if the return type
-- is not visibly tagged, then this is not tag-indeterminate.
elsif Is_Access_Type (Etype (Nam))
and then not Is_Tagged_Type (Designated_Type (Etype (Nam)))
then
return False;
-- An explicit dereference means that the call has already been -- An explicit dereference means that the call has already been
-- expanded and there is no tag to propagate. -- expanded and there is no tag to propagate.
...@@ -2043,7 +2050,9 @@ package body Sem_Disp is ...@@ -2043,7 +2050,9 @@ package body Sem_Disp is
if Is_Controlling_Actual (Actual) if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual) and then not Is_Tag_Indeterminate (Actual)
then then
return False; -- one operand is dispatching -- One operand is dispatching
return False;
end if; end if;
Next_Actual (Actual); Next_Actual (Actual);
...@@ -2066,9 +2075,9 @@ package body Sem_Disp is ...@@ -2066,9 +2075,9 @@ package body Sem_Disp is
then then
return True; return True;
-- In Ada 2005 a function that returns an anonymous access type can -- In Ada 2005, a function that returns an anonymous access type can be
-- dispatching, and the dereference of a call to such a function -- dispatching, and the dereference of a call to such a function can
-- is also tag-indeterminate. -- also be tag-indeterminate if the call itself is.
elsif Nkind (Orig_Node) = N_Explicit_Dereference elsif Nkind (Orig_Node) = N_Explicit_Dereference
and then Ada_Version >= Ada_2005 and then Ada_Version >= Ada_2005
......
gcc/ada/sem_warn.adb
...@@ -3379,7 +3379,6 @@ package body Sem_Warn is ...@@ -3379,7 +3379,6 @@ package body Sem_Warn is
Act1, Form); Act1, Form);
else else
-- For greater clarity, give name of formal. -- For greater clarity, give name of formal.
Error_Msg_Node_2 := Form; Error_Msg_Node_2 := Form;
......
gcc/ada/tree_io.ads
...@@ -47,7 +47,7 @@ package Tree_IO is ...@@ -47,7 +47,7 @@ package Tree_IO is
Tree_Format_Error : exception; Tree_Format_Error : exception;
-- Raised if a format error is detected in the input file -- Raised if a format error is detected in the input file
ASIS_Version_Number : constant := 24; ASIS_Version_Number : constant := 25;
-- ASIS Version. This is used to check for consistency between the compiler -- ASIS Version. This is used to check for consistency between the compiler
-- used to generate trees and an ASIS application that is reading the -- used to generate trees and an ASIS application that is reading the
-- trees. It must be incremented whenever a change is made to the tree -- trees. It must be incremented whenever a change is made to the tree
......
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