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 217 additions and 178 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.adb
...@@ -841,10 +841,10 @@ package body Exp_Ch3 is ...@@ -841,10 +841,10 @@ package body Exp_Ch3 is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster), Make_Defining_Identifier (Loc, Name_uMaster),
Constant_Present => True, Constant_Present => True,
Object_Definition => Object_Definition =>
New_Reference_To (Standard_Integer, Loc), New_Reference_To (Standard_Integer, Loc),
Expression => Expression =>
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc))); New_Reference_To (RTE (RE_Current_Master), Loc)));
...@@ -1659,9 +1659,9 @@ package body Exp_Ch3 is ...@@ -1659,9 +1659,9 @@ package body Exp_Ch3 is
then then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Append_To (Res, Append_To (Res,
Make_Init_Call ( Make_Init_Call
Obj_Ref => New_Copy_Tree (First_Arg), (Obj_Ref => New_Copy_Tree (First_Arg),
Typ => Typ)); Typ => Typ));
end if; end if;
end if; end if;
...@@ -1852,7 +1852,7 @@ package body Exp_Ch3 is ...@@ -1852,7 +1852,7 @@ package body Exp_Ch3 is
then then
Exp := Exp :=
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Identifier (Loc, Name_uInit), Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access); Attribute_Name => Name_Unrestricted_Access);
end if; end if;
...@@ -1880,9 +1880,9 @@ package body Exp_Ch3 is ...@@ -1880,9 +1880,9 @@ package body Exp_Ch3 is
then then
Append_To (Res, Append_To (Res,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id), New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name => Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)), New_Reference_To (First_Tag_Component (Typ), Loc)),
...@@ -1908,9 +1908,9 @@ package body Exp_Ch3 is ...@@ -1908,9 +1908,9 @@ package body Exp_Ch3 is
and then not Is_Immutably_Limited_Type (Typ) and then not Is_Immutably_Limited_Type (Typ)
then then
Append_To (Res, Append_To (Res,
Make_Adjust_Call ( Make_Adjust_Call
Obj_Ref => New_Copy_Tree (Lhs), (Obj_Ref => New_Copy_Tree (Lhs),
Typ => Etype (Id))); Typ => Etype (Id)));
end if; end if;
return Res; return Res;
...@@ -2069,7 +2069,7 @@ package body Exp_Ch3 is ...@@ -2069,7 +2069,7 @@ package body Exp_Ch3 is
Res := Res :=
New_List ( New_List (
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
New_Occurrence_Of (Parent_Proc, Loc), New_Occurrence_Of (Parent_Proc, Loc),
Parameter_Associations => Args)); Parameter_Associations => Args));
...@@ -2111,8 +2111,8 @@ package body Exp_Ch3 is ...@@ -2111,8 +2111,8 @@ package body Exp_Ch3 is
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO), Make_Defining_Identifier (Loc, Name_uO),
In_Present => True, In_Present => True,
Parameter_Type => Parameter_Type =>
New_Reference_To (Rec_Type, Loc)))); New_Reference_To (Rec_Type, Loc))));
Set_Result_Definition (Spec_Node, Set_Result_Definition (Spec_Node,
New_Reference_To (RTE (RE_Storage_Offset), Loc)); New_Reference_To (RTE (RE_Storage_Offset), Loc));
...@@ -2128,7 +2128,7 @@ package body Exp_Ch3 is ...@@ -2128,7 +2128,7 @@ package body Exp_Ch3 is
Set_Declarations (Body_Node, New_List); Set_Declarations (Body_Node, New_List);
Set_Handled_Statement_Sequence (Body_Node, Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Simple_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
...@@ -2684,14 +2684,11 @@ package body Exp_Ch3 is ...@@ -2684,14 +2684,11 @@ package body Exp_Ch3 is
Append_To (Stmts, Append_To (Stmts,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name => New_Reference_To (Counter_Id, Loc),
New_Reference_To (Counter_Id, Loc),
Expression => Expression =>
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (Counter_Id, Loc),
New_Reference_To (Counter_Id, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1))));
Right_Opnd =>
Make_Integer_Literal (Loc, 1))));
end Increment_Counter; end Increment_Counter;
------------------ ------------------
...@@ -2716,9 +2713,9 @@ package body Exp_Ch3 is ...@@ -2716,9 +2713,9 @@ package body Exp_Ch3 is
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id, Defining_Identifier => Counter_Id,
Object_Definition => Object_Definition =>
New_Reference_To (Standard_Integer, Loc), New_Reference_To (Standard_Integer, Loc),
Expression => Expression =>
Make_Integer_Literal (Loc, 0))); Make_Integer_Literal (Loc, 0)));
end Make_Counter; end Make_Counter;
...@@ -2831,10 +2828,8 @@ package body Exp_Ch3 is ...@@ -2831,10 +2828,8 @@ package body Exp_Ch3 is
Build_Initialization_Call Build_Initialization_Call
(Loc, (Loc,
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_uInit),
Make_Identifier (Loc, Name_uInit), Selector_Name => New_Occurrence_Of (Id, Loc)),
Selector_Name =>
New_Occurrence_Of (Id, Loc)),
Typ, Typ,
In_Init_Proc => True, In_Init_Proc => True,
Enclos_Type => Rec_Type, Enclos_Type => Rec_Type,
...@@ -2896,13 +2891,13 @@ package body Exp_Ch3 is ...@@ -2896,13 +2891,13 @@ package body Exp_Ch3 is
if Restricted_Profile then if Restricted_Profile then
Append_To (Stmts, Append_To (Stmts,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit), Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit), Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uATCB)), Selector_Name => Make_Identifier (Loc, Name_uATCB)),
...@@ -3245,7 +3240,6 @@ package body Exp_Ch3 is ...@@ -3245,7 +3240,6 @@ package body Exp_Ch3 is
De := First_Discriminant (Rec_Ent); De := First_Discriminant (Rec_Ent);
Dp := First_Discriminant (Etype (Rec_Ent)); Dp := First_Discriminant (Etype (Rec_Ent));
while Present (De) loop while Present (De) loop
pragma Assert (Present (Dp)); pragma Assert (Present (Dp));
...@@ -4657,9 +4651,9 @@ package body Exp_Ch3 is ...@@ -4657,9 +4651,9 @@ package body Exp_Ch3 is
or else not Comes_From_Source (N) or else not Comes_From_Source (N)
then then
Insert_Action_After (Init_After, Insert_Action_After (Init_After,
Make_Init_Call ( Make_Init_Call
Obj_Ref => New_Occurrence_Of (Def_Id, Loc), (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ))); Typ => Base_Type (Typ)));
-- Abort allowed -- Abort allowed
...@@ -4680,9 +4674,9 @@ package body Exp_Ch3 is ...@@ -4680,9 +4674,9 @@ package body Exp_Ch3 is
declare declare
L : constant List_Id := New_List ( L : constant List_Id := New_List (
Make_Init_Call ( Make_Init_Call
Obj_Ref => New_Occurrence_Of (Def_Id, Loc), (Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ))); Typ => Base_Type (Typ)));
Blk : constant Node_Id := Blk : constant Node_Id :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
...@@ -4748,11 +4742,13 @@ package body Exp_Ch3 is ...@@ -4748,11 +4742,13 @@ package body Exp_Ch3 is
declare declare
Init_Expr : constant Node_Id := Init_Expr : constant Node_Id :=
Static_Initialization (Base_Init_Proc (Typ)); Static_Initialization (Base_Init_Proc (Typ));
begin begin
if Present (Init_Expr) then if Present (Init_Expr) then
Set_Expression Set_Expression
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope)); (N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
return; return;
else else
Initialization_Warning (Id_Ref); Initialization_Warning (Id_Ref);
...@@ -6647,11 +6643,11 @@ package body Exp_Ch3 is ...@@ -6647,11 +6643,11 @@ package body Exp_Ch3 is
null; null;
elsif (Needs_Finalization (Desig_Type) elsif (Needs_Finalization (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL) and then Convention (Desig_Type) /= Convention_CIL)
or else or else
(Is_Incomplete_Or_Private_Type (Desig_Type) (Is_Incomplete_Or_Private_Type (Desig_Type)
and then No (Full_View (Desig_Type)) and then No (Full_View (Desig_Type))
-- An exception is made for types defined in the run-time -- An exception is made for types defined in the run-time
-- because Ada.Tags.Tag itself is such a type and cannot -- because Ada.Tags.Tag itself is such a type and cannot
...@@ -6670,8 +6666,8 @@ package body Exp_Ch3 is ...@@ -6670,8 +6666,8 @@ package body Exp_Ch3 is
or else or else
(Is_Array_Type (Desig_Type) (Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type) and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type))) and then Needs_Finalization (Component_Type (Desig_Type)))
then then
Build_Finalization_Collection (Def_Id); Build_Finalization_Collection (Def_Id);
end if; end if;
...@@ -8533,12 +8529,10 @@ package body Exp_Ch3 is ...@@ -8533,12 +8529,10 @@ package body Exp_Ch3 is
Formals := New_List ( Formals := New_List (
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Make_Defining_Identifier (Loc, Name_V), In_Present => True,
In_Present => True, Out_Present => True,
Out_Present => True, Parameter_Type => New_Reference_To (Tag_Typ, Loc)));
Parameter_Type =>
New_Reference_To (Tag_Typ, Loc)));
-- F : Boolean := True -- F : Boolean := True
...@@ -8547,12 +8541,9 @@ package body Exp_Ch3 is ...@@ -8547,12 +8541,9 @@ package body Exp_Ch3 is
then then
Append_To (Formals, Append_To (Formals,
Make_Parameter_Specification (Loc, Make_Parameter_Specification (Loc,
Defining_Identifier => Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
Make_Defining_Identifier (Loc, Name_F), Parameter_Type => New_Reference_To (Standard_Boolean, Loc),
Parameter_Type => Expression => New_Reference_To (Standard_True, Loc)));
New_Reference_To (Standard_Boolean, Loc),
Expression =>
New_Reference_To (Standard_True, Loc)));
end if; end if;
return return
...@@ -8607,8 +8598,7 @@ package body Exp_Ch3 is ...@@ -8607,8 +8598,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Id, Defining_Unit_Name => Id,
Parameter_Specifications => Profile, Parameter_Specifications => Profile,
Result_Definition => Result_Definition => New_Reference_To (Ret_Type, Loc));
New_Reference_To (Ret_Type, Loc));
end if; end if;
if Is_Interface (Tag_Typ) then if Is_Interface (Tag_Typ) then
...@@ -8658,12 +8648,14 @@ package body Exp_Ch3 is ...@@ -8658,12 +8648,14 @@ package body Exp_Ch3 is
Ret_Type := Empty; Ret_Type := Empty;
end if; end if;
return Predef_Spec_Or_Body (Loc, return
Name => Make_TSS_Name (Tag_Typ, Name), Predef_Spec_Or_Body
Tag_Typ => Tag_Typ, (Loc,
Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name), Name => Make_TSS_Name (Tag_Typ, Name),
Ret_Type => Ret_Type, Tag_Typ => Tag_Typ,
For_Body => For_Body); Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
Ret_Type => Ret_Type,
For_Body => For_Body);
end Predef_Stream_Attr_Spec; end Predef_Stream_Attr_Spec;
--------------------------------- ---------------------------------
...@@ -8931,14 +8923,13 @@ package body Exp_Ch3 is ...@@ -8931,14 +8923,13 @@ package body Exp_Ch3 is
Set_Handled_Statement_Sequence (Decl, Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (
Make_Final_Call ( Make_Final_Call
Obj_Ref => Make_Identifier (Loc, Name_V), (Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ)))); Typ => Tag_Typ))));
else else
Set_Handled_Statement_Sequence (Decl, Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (Make_Null_Statement (Loc))));
Make_Null_Statement (Loc))));
end if; end if;
Append_To (Res, Decl); Append_To (Res, Decl);
...@@ -8954,7 +8945,7 @@ package body Exp_Ch3 is ...@@ -8954,7 +8945,7 @@ package body Exp_Ch3 is
function Predefined_Primitive_Freeze function Predefined_Primitive_Freeze
(Tag_Typ : Entity_Id) return List_Id (Tag_Typ : Entity_Id) return List_Id
is is
Res : constant List_Id := New_List; Res : constant List_Id := New_List;
Prim : Elmt_Id; Prim : Elmt_Id;
Frnodes : List_Id; Frnodes : List_Id;
......
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/exp_ch4.adb
...@@ -660,14 +660,13 @@ package body Exp_Ch4 is ...@@ -660,14 +660,13 @@ package body Exp_Ch4 is
Make_Raise_Program_Error (Loc, Make_Raise_Program_Error (Loc,
Condition => Condition =>
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Left_Opnd =>
Build_Get_Access_Level (Loc, Build_Get_Access_Level (Loc,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Ref_Node, Prefix => Ref_Node,
Attribute_Name => Name_Tag)), Attribute_Name => Name_Tag)),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
Type_Access_Level (PtrT))),
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));
end if; end if;
end Apply_Accessibility_Check; end Apply_Accessibility_Check;
...@@ -974,11 +973,9 @@ package body Exp_Ch4 is ...@@ -974,11 +973,9 @@ package body Exp_Ch4 is
New_Decl := New_Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Defining_Identifier => Make_Temporary (Loc, 'P'),
Make_Temporary (Loc, 'P'), Object_Definition => New_Reference_To (PtrT, Loc),
Object_Definition => Expression =>
New_Reference_To (PtrT, Loc),
Expression =>
Unchecked_Convert_To (PtrT, Unchecked_Convert_To (PtrT,
New_Reference_To (Temp, Loc))); New_Reference_To (Temp, Loc)));
...@@ -1085,10 +1082,10 @@ package body Exp_Ch4 is ...@@ -1085,10 +1082,10 @@ package body Exp_Ch4 is
and then Present (Associated_Collection (PtrT)) and then Present (Associated_Collection (PtrT))
then then
Insert_Action (N, Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call ( Make_Set_Finalize_Address_Ptr_Call
Loc => Loc, (Loc => Loc,
Typ => T, Typ => T,
Ptr_Typ => PtrT)); Ptr_Typ => PtrT));
end if; end if;
end if; end if;
...@@ -1111,8 +1108,7 @@ package body Exp_Ch4 is ...@@ -1111,8 +1108,7 @@ package body Exp_Ch4 is
Object_Definition => New_Reference_To (PtrT, Loc), Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Expression =>
Make_Allocator (Loc, Make_Allocator (Loc,
Expression => Expression => New_Reference_To (Etype (Exp), Loc)));
New_Reference_To (Etype (Exp), Loc)));
-- Copy the Comes_From_Source flag for the allocator we just built, -- Copy the Comes_From_Source flag for the allocator we just built,
-- since logically this allocator is a replacement of the original -- since logically this allocator is a replacement of the original
...@@ -1138,10 +1134,9 @@ package body Exp_Ch4 is ...@@ -1138,10 +1134,9 @@ package body Exp_Ch4 is
and then Present (Associated_Collection (PtrT)) and then Present (Associated_Collection (PtrT))
then then
Insert_Action (N, Insert_Action (N,
Make_Attach_Call ( Make_Attach_Call
Obj_Ref => (Obj_Ref => New_Reference_To (Temp, Loc),
New_Reference_To (Temp, Loc), Ptr_Typ => PtrT));
Ptr_Typ => PtrT));
end if; end if;
Rewrite (N, New_Reference_To (Temp, Loc)); Rewrite (N, New_Reference_To (Temp, Loc));
...@@ -1215,8 +1210,7 @@ package body Exp_Ch4 is ...@@ -1215,8 +1210,7 @@ package body Exp_Ch4 is
Insert_Action (Exp, Insert_Action (Exp,
Make_Subtype_Declaration (Loc, Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT, Defining_Identifier => ConstrT,
Subtype_Indication => Subtype_Indication => Make_Subtype_From_Expr (Exp, T)));
Make_Subtype_From_Expr (Exp, T)));
Freeze_Itype (ConstrT, Exp); Freeze_Itype (ConstrT, Exp);
Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
end; end;
...@@ -3269,9 +3263,8 @@ package body Exp_Ch4 is ...@@ -3269,9 +3263,8 @@ package body Exp_Ch4 is
Temp_Decl := Temp_Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id, Defining_Identifier => Temp_Id,
Aliased_Present => True, Aliased_Present => True,
Object_Definition => Object_Definition => New_Occurrence_Of (Etyp, Loc));
New_Occurrence_Of (Etyp, Loc));
if Nkind (Expression (N)) = N_Qualified_Expression then if Nkind (Expression (N)) = N_Qualified_Expression then
Set_Expression (Temp_Decl, Expression (Expression (N))); Set_Expression (Temp_Decl, Expression (Expression (N)));
...@@ -3294,8 +3287,7 @@ package body Exp_Ch4 is ...@@ -3294,8 +3287,7 @@ package body Exp_Ch4 is
Rewrite (N, Rewrite (N,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => New_Occurrence_Of (Temp_Id, Loc),
New_Occurrence_Of (Temp_Id, Loc),
Attribute_Name => Name_Unrestricted_Access)); Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT); Analyze_And_Resolve (N, PtrT);
...@@ -3332,8 +3324,7 @@ package body Exp_Ch4 is ...@@ -3332,8 +3324,7 @@ package body Exp_Ch4 is
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc), Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Length, Attribute_Name => Name_Length,
Expressions => New_List ( Expressions => New_List (Make_Integer_Literal (Loc, J)));
Make_Integer_Literal (Loc, J)));
if J = 1 then if J = 1 then
Res := Len; Res := Len;
...@@ -3400,8 +3391,8 @@ package body Exp_Ch4 is ...@@ -3400,8 +3391,8 @@ package body Exp_Ch4 is
if Is_Access_Constant (PtrT) if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N))) and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression and then Size_Known_At_Compile_Time
(Expression (N)))) (Etype (Expression (Expression (N))))
and then not Is_Record_Type (Current_Scope) and then not Is_Record_Type (Current_Scope)
then then
-- Here we can do the optimization. For the allocator -- Here we can do the optimization. For the allocator
...@@ -3436,7 +3427,7 @@ package body Exp_Ch4 is ...@@ -3436,7 +3427,7 @@ package body Exp_Ch4 is
Rewrite (N, Rewrite (N,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc), Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access)); Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT); Analyze_And_Resolve (N, PtrT);
...@@ -3488,8 +3479,7 @@ package body Exp_Ch4 is ...@@ -3488,8 +3479,7 @@ package body Exp_Ch4 is
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Size_In_Storage_Elements (Etyp), Left_Opnd => Size_In_Storage_Elements (Etyp),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
Intval => Uint_7 * (Uint_2 ** 29))),
Reason => SE_Object_Too_Large)); Reason => SE_Object_Too_Large));
end if; end if;
end if; end if;
...@@ -3603,8 +3593,7 @@ package body Exp_Ch4 is ...@@ -3603,8 +3593,7 @@ package body Exp_Ch4 is
-- type whose definition is a concurrent type, the first -- type whose definition is a concurrent type, the first
-- argument in the Init routine has to be unchecked conversion -- argument in the Init routine has to be unchecked conversion
-- to the corresponding record type. If the designated type is -- to the corresponding record type. If the designated type is
-- a derived type, we also convert the argument to its root -- a derived type, also convert the argument to its root type.
-- type.
if Is_Concurrent_Type (T) then if Is_Concurrent_Type (T) then
Init_Arg1 := Init_Arg1 :=
...@@ -3672,8 +3661,8 @@ package body Exp_Ch4 is ...@@ -3672,8 +3661,8 @@ package body Exp_Ch4 is
New_Occurrence_Of New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T); (Entity (Nam), Sloc (Nam)), T);
elsif Nkind_In elsif Nkind_In (Nam, N_Indexed_Component,
(Nam, N_Indexed_Component, N_Selected_Component) N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam)) and then Is_Entity_Name (Prefix (Nam))
then then
Decls := Decls :=
...@@ -3821,8 +3810,7 @@ package body Exp_Ch4 is ...@@ -3821,8 +3810,7 @@ package body Exp_Ch4 is
else else
Insert_Action (N, Insert_Action (N,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name => New_Reference_To (Init, Loc),
New_Reference_To (Init, Loc),
Parameter_Associations => Args)); Parameter_Associations => Args));
end if; end if;
...@@ -3832,9 +3820,9 @@ package body Exp_Ch4 is ...@@ -3832,9 +3820,9 @@ package body Exp_Ch4 is
-- [Deep_]Initialize (Init_Arg1); -- [Deep_]Initialize (Init_Arg1);
Insert_Action (N, Insert_Action (N,
Make_Init_Call ( Make_Init_Call
Obj_Ref => New_Copy_Tree (Init_Arg1), (Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T)); Typ => T));
if Present (Associated_Collection (PtrT)) then if Present (Associated_Collection (PtrT)) then
...@@ -3849,9 +3837,9 @@ package body Exp_Ch4 is ...@@ -3849,9 +3837,9 @@ package body Exp_Ch4 is
if VM_Target /= No_VM then if VM_Target /= No_VM then
if Is_Controlled (T) then if Is_Controlled (T) then
Insert_Action (N, Insert_Action (N,
Make_Attach_Call ( Make_Attach_Call
Obj_Ref => New_Copy_Tree (Init_Arg1), (Obj_Ref => New_Copy_Tree (Init_Arg1),
Ptr_Typ => PtrT)); Ptr_Typ => PtrT));
end if; end if;
-- Default case, generate: -- Default case, generate:
...@@ -3861,10 +3849,10 @@ package body Exp_Ch4 is ...@@ -3861,10 +3849,10 @@ package body Exp_Ch4 is
else else
Insert_Action (N, Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call ( Make_Set_Finalize_Address_Ptr_Call
Loc => Loc, (Loc => Loc,
Typ => T, Typ => T,
Ptr_Typ => PtrT)); Ptr_Typ => PtrT));
end if; end if;
end if; end if;
end if; end if;
...@@ -4135,9 +4123,8 @@ package body Exp_Ch4 is ...@@ -4135,9 +4123,8 @@ package body Exp_Ch4 is
Make_Temporary (Loc, 'A'), Make_Temporary (Loc, 'A'),
Type_Definition => Type_Definition =>
Make_Access_To_Object_Definition (Loc, Make_Access_To_Object_Definition (Loc,
All_Present => True, All_Present => True,
Subtype_Indication => Subtype_Indication => New_Reference_To (Typ, Loc)));
New_Reference_To (Typ, Loc)));
Insert_Action (N, P_Decl); Insert_Action (N, P_Decl);
...@@ -4153,19 +4140,19 @@ package body Exp_Ch4 is ...@@ -4153,19 +4140,19 @@ package body Exp_Ch4 is
Then_Statements => New_List ( Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx), Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)), Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access, Attribute_Name => Name_Unrestricted_Access,
Prefix => Relocate_Node (Thenx)))), Prefix => Relocate_Node (Thenx)))),
Else_Statements => New_List ( Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex), Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)), Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Expression =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access, Attribute_Name => Name_Unrestricted_Access,
Prefix => Relocate_Node (Elsex))))); Prefix => Relocate_Node (Elsex)))));
New_N := New_N :=
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
...@@ -9209,7 +9196,6 @@ package body Exp_Ch4 is ...@@ -9209,7 +9196,6 @@ package body Exp_Ch4 is
Result := New_Reference_To (Standard_True, Loc); Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ)); C := Suitable_Element (First_Entity (Typ));
while Present (C) loop while Present (C) loop
declare declare
New_Lhs : Node_Id; New_Lhs : Node_Id;
......
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