OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2011-08-03 16:52:04 +02:00
parent f553e7bc12
commit 243cae0a51
11 changed files with 217 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/ada/ChangeLog
View File

@ -1,3 +1,26 @@
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>
* exp_ch13.adb: Add with and use clauses for Restrict and Rident.

55
gcc/ada/a-cfdlli.adb
View File

@ -234,6 +234,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity);
N : Count_Type := 1;
P : List (C);
begin
while N <= Source.Capacity loop
P.Nodes (N).Prev := Source.Nodes (N).Prev;
@ -241,10 +242,12 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
P.Nodes (N).Element := Source.Nodes (N).Element;
N := N + 1;
end loop;
P.Free := Source.Free;
P.Length := Source.Length;
P.First := Source.First;
P.Last := Source.Last;
if P.Free >= 0 then
N := Source.Capacity + 1;
while N <= C loop
@ -252,6 +255,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
N := N + 1;
end loop;
end if;
return P;
end Copy;
@ -269,7 +273,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
begin
if not Has_Element (Container => Container,
Position => Position) then
Position => Position)
then
raise Constraint_Error with
"Position cursor has no element";
end if;
@ -349,7 +354,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
for J in 1 .. Count loop
X := Container.First;
pragma Assert (N (N (X).Next).Prev = Container.First);
@ -388,7 +393,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
"attempt to tamper with elements (list is busy)";
end if;
for I in 1 .. Count loop
for J in 1 .. Count loop
X := Container.Last;
pragma Assert (N (N (X).Prev).Next = Container.Last);
@ -407,7 +412,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Element
(Container : List;
Position : Cursor) return Element_Type is
Position : Cursor) return Element_Type
is
begin
if not Has_Element (Container => Container, Position => Position) then
raise Constraint_Error with
@ -427,15 +433,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Position : Cursor := No_Element) return Cursor
is
From : Count_Type := Position.Node;
begin
if From = 0 and Container.Length = 0 then
return No_Element;
end if;
if From = 0 then
From := Container.First;
end if;
if Position.Node /= 0 and then
not Has_Element (Container, Position) then
not Has_Element (Container, Position)
then
raise Constraint_Error with
"Position cursor has no element";
end if;
@ -444,6 +454,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Container.Nodes (From).Element = Item then
return (Node => From);
end if;
From := Container.Nodes (From).Next;
end loop;
@ -459,6 +470,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Container.First = 0 then
return No_Element;
end if;
return (Node => Container.First);
end First;
@ -507,8 +519,8 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Container.Free := 0;
else
for I in Container.Free .. Container.Capacity - 1 loop
N (I).Next := I + 1;
for J in Container.Free .. Container.Capacity - 1 loop
N (J).Next := J + 1;
end loop;
N (Container.Capacity).Next := 0;
@ -532,6 +544,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Is_Sorted (Container : List) return Boolean is
Nodes : Node_Array renames Container.Nodes;
Node : Count_Type := Container.First;
begin
for I in 2 .. Container.Length loop
if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then
@ -618,9 +631,10 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
---------------
procedure Partition (Pivot, Back : Count_Type) is
Node : Count_Type := N (Pivot).Next;
Node : Count_Type;
begin
Node := N (Pivot).Next;
while Node /= Back loop
if N (Node).Element < N (Pivot).Element then
declare
@ -709,6 +723,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Position.Node = 0 then
return False;
end if;
return Container.Nodes (Position.Node).Prev /= -1;
end Has_Element;
@ -763,7 +778,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Count : Count_Type := 1)
is
Position : Cursor;
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
@ -893,6 +907,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Process (Container, (Node => Node));
Node := Container.Nodes (Node).Next;
end loop;
exception
when others =>
B := B - 1;
@ -934,12 +949,14 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Left (Container : List; Position : Cursor) return List is
Curs : Cursor := Position;
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
@ -949,6 +966,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
@ -1015,9 +1033,11 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if Position.Node = 0 then
return No_Element;
end if;
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
return (Node => Container.Nodes (Position.Node).Next);
end Next;
@ -1052,6 +1072,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
if not Has_Element (Container, Position) then
raise Program_Error with "Position cursor has no element";
end if;
return (Node => Container.Nodes (Position.Node).Prev);
end Previous;
@ -1316,13 +1337,15 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Right (Container : List; Position : Cursor) return List is
Curs : Cursor := First (Container);
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
C : List (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
@ -1332,6 +1355,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
@ -1537,15 +1561,19 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
function Strict_Equal (Left, Right : List) return Boolean is
CL : Count_Type := Left.First;
CR : Count_Type := Right.First;
begin
while CL /= 0 or CR /= 0 loop
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;
end if;
CL := Left.Nodes (CL).Next;
CR := Right.Nodes (CR).Next;
end loop;
return True;
end Strict_Equal;
@ -1558,7 +1586,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
I, J : Cursor)
is
begin
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@ -1603,7 +1630,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
I_Next, J_Next : Cursor;
begin
if I.Node = 0 then
raise Constraint_Error with "I cursor has no element";
end if;
@ -1653,7 +1679,6 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is
Process : not null access procedure (Element : in out Element_Type))
is
begin
if Position.Node = 0 then
raise Constraint_Error with "Position cursor has no element";
end if;

10
gcc/ada/bindgen.adb
View File

@ -2125,7 +2125,8 @@ package body Bindgen is
procedure Gen_Main_C is
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
-- non-terminating, so we do not want library-level finalization.
@ -2649,7 +2650,8 @@ package body Bindgen is
-- function Get_Ada_Main_Name for details on the form of the name.
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
-- non-terminating, so we do not want finalization.
@ -3004,7 +3006,9 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String) is
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;
pragma Warnings (Off, Bfile);

4
gcc/ada/exp_ch13.adb
View File

@ -214,7 +214,7 @@ package body Exp_Ch13 is
procedure Expand_N_Free_Statement (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
Typ : Entity_Id := Etype (Expr);
Typ : Entity_Id;
begin
-- Certain run-time configurations and targets do not provide support
@ -232,6 +232,8 @@ package body Exp_Ch13 is
-- Use the base type to perform the collection check
Typ := Etype (Expr);
if Ekind (Typ) = E_Access_Subtype then
Typ := Etype (Typ);
end if;

127
gcc/ada/exp_ch3.adb
View File

@ -841,10 +841,10 @@ package body Exp_Ch3 is
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uMaster),
Constant_Present => True,
Object_Definition =>
Constant_Present => True,
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
Expression =>
Make_Explicit_Dereference (Loc,
New_Reference_To (RTE (RE_Current_Master), Loc)));
@ -1659,9 +1659,9 @@ package body Exp_Ch3 is
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
Append_To (Res,
Make_Init_Call (
Obj_Ref => New_Copy_Tree (First_Arg),
Typ => Typ));
Make_Init_Call
(Obj_Ref => New_Copy_Tree (First_Arg),
Typ => Typ));
end if;
end if;
@ -1852,7 +1852,7 @@ package body Exp_Ch3 is
then
Exp :=
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Make_Identifier (Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
end if;
@ -1880,9 +1880,9 @@ package body Exp_Ch3 is
then
Append_To (Res,
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix =>
Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)),
@ -1908,9 +1908,9 @@ package body Exp_Ch3 is
and then not Is_Immutably_Limited_Type (Typ)
then
Append_To (Res,
Make_Adjust_Call (
Obj_Ref => New_Copy_Tree (Lhs),
Typ => Etype (Id)));
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Lhs),
Typ => Etype (Id)));
end if;
return Res;
@ -2069,7 +2069,7 @@ package body Exp_Ch3 is
Res :=
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
Name =>
New_Occurrence_Of (Parent_Proc, Loc),
Parameter_Associations => Args));
@ -2111,8 +2111,8 @@ package body Exp_Ch3 is
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
In_Present => True,
Parameter_Type =>
In_Present => True,
Parameter_Type =>
New_Reference_To (Rec_Type, Loc))));
Set_Result_Definition (Spec_Node,
New_Reference_To (RTE (RE_Storage_Offset), Loc));
@ -2128,7 +2128,7 @@ package body Exp_Ch3 is
Set_Declarations (Body_Node, New_List);
Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
@ -2684,14 +2684,11 @@ package body Exp_Ch3 is
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
New_Reference_To (Counter_Id, Loc),
Name => New_Reference_To (Counter_Id, Loc),
Expression =>
Make_Op_Add (Loc,
Left_Opnd =>
New_Reference_To (Counter_Id, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))));
Left_Opnd => New_Reference_To (Counter_Id, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1))));
end Increment_Counter;
------------------
@ -2716,9 +2713,9 @@ package body Exp_Ch3 is
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
Object_Definition =>
Object_Definition =>
New_Reference_To (Standard_Integer, Loc),
Expression =>
Expression =>
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
@ -2831,10 +2828,8 @@ package body Exp_Ch3 is
Build_Initialization_Call
(Loc,
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Name_uInit),
Selector_Name =>
New_Occurrence_Of (Id, Loc)),
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
@ -2896,13 +2891,13 @@ package body Exp_Ch3 is
if Restricted_Profile then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uTask_Id)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uATCB)),
@ -3245,7 +3240,6 @@ package body Exp_Ch3 is
De := First_Discriminant (Rec_Ent);
Dp := First_Discriminant (Etype (Rec_Ent));
while Present (De) loop
pragma Assert (Present (Dp));
@ -4657,9 +4651,9 @@ package body Exp_Ch3 is
or else not Comes_From_Source (N)
then
Insert_Action_After (Init_After,
Make_Init_Call (
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ)));
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ)));
-- Abort allowed
@ -4680,9 +4674,9 @@ package body Exp_Ch3 is
declare
L : constant List_Id := New_List (
Make_Init_Call (
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ)));
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
Typ => Base_Type (Typ)));
Blk : constant Node_Id :=
Make_Block_Statement (Loc,
@ -4748,11 +4742,13 @@ package body Exp_Ch3 is
declare
Init_Expr : constant Node_Id :=
Static_Initialization (Base_Init_Proc (Typ));
begin
if Present (Init_Expr) then
Set_Expression
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
return;
else
Initialization_Warning (Id_Ref);
@ -6647,11 +6643,11 @@ package body Exp_Ch3 is
null;
elsif (Needs_Finalization (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL)
and then Convention (Desig_Type) /= Convention_Java
and then Convention (Desig_Type) /= Convention_CIL)
or else
(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
-- because Ada.Tags.Tag itself is such a type and cannot
@ -6670,8 +6666,8 @@ package body Exp_Ch3 is
or else
(Is_Array_Type (Desig_Type)
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
and then not Is_Frozen (Desig_Type)
and then Needs_Finalization (Component_Type (Desig_Type)))
then
Build_Finalization_Collection (Def_Id);
end if;
@ -8533,12 +8529,10 @@ package body Exp_Ch3 is
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_V),
In_Present => True,
Out_Present => True,
Parameter_Type =>
New_Reference_To (Tag_Typ, Loc)));
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Reference_To (Tag_Typ, Loc)));
-- F : Boolean := True
@ -8547,12 +8541,9 @@ package body Exp_Ch3 is
then
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_F),
Parameter_Type =>
New_Reference_To (Standard_Boolean, Loc),
Expression =>
New_Reference_To (Standard_True, Loc)));
Defining_Identifier => Make_Defining_Identifier (Loc, Name_F),
Parameter_Type => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_True, Loc)));
end if;
return
@ -8607,8 +8598,7 @@ package body Exp_Ch3 is
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => Profile,
Result_Definition =>
New_Reference_To (Ret_Type, Loc));
Result_Definition => New_Reference_To (Ret_Type, Loc));
end if;
if Is_Interface (Tag_Typ) then
@ -8658,12 +8648,14 @@ package body Exp_Ch3 is
Ret_Type := Empty;
end if;
return Predef_Spec_Or_Body (Loc,
Name => Make_TSS_Name (Tag_Typ, Name),
Tag_Typ => Tag_Typ,
Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
Ret_Type => Ret_Type,
For_Body => For_Body);
return
Predef_Spec_Or_Body
(Loc,
Name => Make_TSS_Name (Tag_Typ, Name),
Tag_Typ => Tag_Typ,
Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
Ret_Type => Ret_Type,
For_Body => For_Body);
end Predef_Stream_Attr_Spec;
---------------------------------
@ -8931,14 +8923,13 @@ package body Exp_Ch3 is
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Final_Call (
Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
Make_Final_Call
(Obj_Ref => Make_Identifier (Loc, Name_V),
Typ => Tag_Typ))));
else
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Null_Statement (Loc))));
Statements => New_List (Make_Null_Statement (Loc))));
end if;
Append_To (Res, Decl);
@ -8954,7 +8945,7 @@ package body Exp_Ch3 is
function Predefined_Primitive_Freeze
(Tag_Typ : Entity_Id) return List_Id
is
Res : constant List_Id := New_List;
Res : constant List_Id := New_List;
Prim : Elmt_Id;
Frnodes : List_Id;

32
gcc/ada/exp_ch3.ads
View File

@ -113,22 +113,6 @@ package Exp_Ch3 is
-- 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.
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
(Typ : Entity_Id;
Target : Node_Id;
@ -155,4 +139,20 @@ package Exp_Ch3 is
-- set to False, but if Consider_IS is set to True, then the cases above
-- 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;

100
gcc/ada/exp_ch4.adb
View File

@ -660,14 +660,13 @@ package body Exp_Ch4 is
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
Left_Opnd =>
Build_Get_Access_Level (Loc,
Make_Attribute_Reference (Loc,
Prefix => Ref_Node,
Prefix => Ref_Node,
Attribute_Name => Name_Tag)),
Right_Opnd =>
Make_Integer_Literal (Loc,
Type_Access_Level (PtrT))),
Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
Reason => PE_Accessibility_Check_Failed));
end if;
end Apply_Accessibility_Check;
@ -974,11 +973,9 @@ package body Exp_Ch4 is
New_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Temporary (Loc, 'P'),
Object_Definition =>
New_Reference_To (PtrT, Loc),
Expression =>
Defining_Identifier => Make_Temporary (Loc, 'P'),
Object_Definition => New_Reference_To (PtrT, Loc),
Expression =>
Unchecked_Convert_To (PtrT,
New_Reference_To (Temp, Loc)));
@ -1085,10 +1082,10 @@ package body Exp_Ch4 is
and then Present (Associated_Collection (PtrT))
then
Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call (
Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
Make_Set_Finalize_Address_Ptr_Call
(Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
end if;
end if;
@ -1111,8 +1108,7 @@ package body Exp_Ch4 is
Object_Definition => New_Reference_To (PtrT, Loc),
Expression =>
Make_Allocator (Loc,
Expression =>
New_Reference_To (Etype (Exp), Loc)));
Expression => New_Reference_To (Etype (Exp), Loc)));
-- Copy the Comes_From_Source flag for the allocator we just built,
-- since logically this allocator is a replacement of the original
@ -1138,10 +1134,9 @@ package body Exp_Ch4 is
and then Present (Associated_Collection (PtrT))
then
Insert_Action (N,
Make_Attach_Call (
Obj_Ref =>
New_Reference_To (Temp, Loc),
Ptr_Typ => PtrT));
Make_Attach_Call
(Obj_Ref => New_Reference_To (Temp, Loc),
Ptr_Typ => PtrT));
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
@ -1215,8 +1210,7 @@ package body Exp_Ch4 is
Insert_Action (Exp,
Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT,
Subtype_Indication =>
Make_Subtype_From_Expr (Exp, T)));
Subtype_Indication => Make_Subtype_From_Expr (Exp, T)));
Freeze_Itype (ConstrT, Exp);
Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
end;
@ -3269,9 +3263,8 @@ package body Exp_Ch4 is
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (Etyp, Loc));
Aliased_Present => True,
Object_Definition => New_Occurrence_Of (Etyp, Loc));
if Nkind (Expression (N)) = N_Qualified_Expression then
Set_Expression (Temp_Decl, Expression (Expression (N)));
@ -3294,8 +3287,7 @@ package body Exp_Ch4 is
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Temp_Id, Loc),
Prefix => New_Occurrence_Of (Temp_Id, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
@ -3332,8 +3324,7 @@ package body Exp_Ch4 is
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, J)));
Expressions => New_List (Make_Integer_Literal (Loc, J)));
if J = 1 then
Res := Len;
@ -3400,8 +3391,8 @@ package body Exp_Ch4 is
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression
(Expression (N))))
and then Size_Known_At_Compile_Time
(Etype (Expression (Expression (N))))
and then not Is_Record_Type (Current_Scope)
then
-- Here we can do the optimization. For the allocator
@ -3436,7 +3427,7 @@ package body Exp_Ch4 is
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc),
Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
@ -3488,8 +3479,7 @@ package body Exp_Ch4 is
Make_Op_Gt (Loc,
Left_Opnd => Size_In_Storage_Elements (Etyp),
Right_Opnd =>
Make_Integer_Literal (Loc,
Intval => Uint_7 * (Uint_2 ** 29))),
Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
Reason => SE_Object_Too_Large));
end if;
end if;
@ -3603,8 +3593,7 @@ package body Exp_Ch4 is
-- type whose definition is a concurrent type, the first
-- argument in the Init routine has to be unchecked conversion
-- to the corresponding record type. If the designated type is
-- a derived type, we also convert the argument to its root
-- type.
-- a derived type, also convert the argument to its root type.
if Is_Concurrent_Type (T) then
Init_Arg1 :=
@ -3672,8 +3661,8 @@ package body Exp_Ch4 is
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif Nkind_In
(Nam, N_Indexed_Component, N_Selected_Component)
elsif Nkind_In (Nam, N_Indexed_Component,
N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
@ -3821,8 +3810,7 @@ package body Exp_Ch4 is
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (Init, Loc),
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
@ -3832,9 +3820,9 @@ package body Exp_Ch4 is
-- [Deep_]Initialize (Init_Arg1);
Insert_Action (N,
Make_Init_Call (
Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T));
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Typ => T));
if Present (Associated_Collection (PtrT)) then
@ -3849,9 +3837,9 @@ package body Exp_Ch4 is
if VM_Target /= No_VM then
if Is_Controlled (T) then
Insert_Action (N,
Make_Attach_Call (
Obj_Ref => New_Copy_Tree (Init_Arg1),
Ptr_Typ => PtrT));
Make_Attach_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
Ptr_Typ => PtrT));
end if;
-- Default case, generate:
@ -3861,10 +3849,10 @@ package body Exp_Ch4 is
else
Insert_Action (N,
Make_Set_Finalize_Address_Ptr_Call (
Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
Make_Set_Finalize_Address_Ptr_Call
(Loc => Loc,
Typ => T,
Ptr_Typ => PtrT));
end if;
end if;
end if;
@ -4135,9 +4123,8 @@ package body Exp_Ch4 is
Make_Temporary (Loc, 'A'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Reference_To (Typ, Loc)));
All_Present => True,
Subtype_Indication => New_Reference_To (Typ, Loc)));
Insert_Action (N, P_Decl);
@ -4153,19 +4140,19 @@ package body Exp_Ch4 is
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => Relocate_Node (Thenx)))),
Prefix => Relocate_Node (Thenx)))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => Relocate_Node (Elsex)))));
Prefix => Relocate_Node (Elsex)))));
New_N :=
Make_Explicit_Dereference (Loc,
@ -9209,7 +9196,6 @@ package body Exp_Ch4 is
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
while Present (C) loop
declare
New_Lhs : Node_Id;

4
gcc/ada/g-awk.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -215,7 +215,7 @@ package GNAT.AWK is
-- 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 current line... A default session is provided (see Set_Current,
-- Current_Session and Default_Session above).
-- Current_Session and Default_Session below).
----------------------------
-- Package initialization --

37
gcc/ada/sem_disp.adb
View File

@ -1500,17 +1500,16 @@ package body Sem_Disp is
if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then
Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type));
-- If Old_Subp isn't already marked as dispatching then
-- this is the case of an operation of an untagged private
-- type fulfilled by a tagged type that overrides an
-- inherited dispatching operation, so we set the necessary
-- dispatching attributes here.
-- If Old_Subp isn't already marked as dispatching then this is
-- the case of an operation of an untagged private type fulfilled
-- by a tagged type that overrides an inherited dispatching
-- operation, so we set the necessary dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then
-- If the untagged type has no discriminants, and the full
-- view is constrained, there will be a spurious mismatch
-- of subtypes on the controlling arguments, because the tagged
-- view is constrained, there will be a spurious mismatch of
-- subtypes on the controlling arguments, because the tagged
-- type is the internal base type introduced in the derivation.
-- Use the original type to verify conformance, rather than the
-- base type.
@ -1758,9 +1757,9 @@ package body Sem_Disp is
begin
-- The original corresponding operation of Prim must be an
-- operation of a visible ancestor of the dispatching type
-- S, and the original corresponding operation of S2 must
-- be visible.
-- operation of a visible ancestor of the dispatching type S,
-- and the original corresponding operation of S2 must be
-- visible.
Orig_Prim := Original_Corresponding_Operation (Prim);
@ -2026,6 +2025,14 @@ package body Sem_Disp is
if not Has_Controlling_Result (Nam) then
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
-- expanded and there is no tag to propagate.
@ -2043,7 +2050,9 @@ package body Sem_Disp is
if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual)
then
return False; -- one operand is dispatching
-- One operand is dispatching
return False;
end if;
Next_Actual (Actual);
@ -2066,9 +2075,9 @@ package body Sem_Disp is
then
return True;
-- In Ada 2005 a function that returns an anonymous access type can
-- dispatching, and the dereference of a call to such a function
-- is also tag-indeterminate.
-- In Ada 2005, a function that returns an anonymous access type can be
-- dispatching, and the dereference of a call to such a function can
-- also be tag-indeterminate if the call itself is.
elsif Nkind (Orig_Node) = N_Explicit_Dereference
and then Ada_Version >= Ada_2005

1
gcc/ada/sem_warn.adb
View File

@ -3379,7 +3379,6 @@ package body Sem_Warn is
Act1, Form);
else
-- For greater clarity, give name of formal.
Error_Msg_Node_2 := Form;

2
gcc/ada/tree_io.ads
View File

@ -47,7 +47,7 @@ package Tree_IO is
Tree_Format_Error : exception;
-- 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
-- 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