From: Arnaud Charlet Date: Wed, 3 Aug 2011 14:52:04 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=243cae0a5108e18638c9c4844baaf392171130d4;p=gcc.git [multiple changes] 2011-08-03 Robert Dewar * 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 * g-awk.ads: Minor comment fix. 2011-08-03 Sergey Rybin * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6abd4106cf0..66c9f5ad8fb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2011-08-03 Robert Dewar + + * 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 + + * g-awk.ads: Minor comment fix. + +2011-08-03 Sergey Rybin + + * 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 + + * 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 * exp_ch13.adb: Add with and use clauses for Restrict and Rident. diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index d72566a03e1..93a88a725d6 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -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; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 2d9a1c1e85e..b88ed0019f7 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -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); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 761a2818ccb..9f182357ee7 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6c98ef8aed6..0e409466083 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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; diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 54aba222f9c..7b67e23a8cf 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 58516cdf36b..e340fee75a1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads index b9a7589e254..a8604a76317 100644 --- a/gcc/ada/g-awk.ads +++ b/gcc/ada/g-awk.ads @@ -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 -- diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 96f2ff830c2..369d75ef842 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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 diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 6b9dd9b4154..fe5f38b125f 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3379,7 +3379,6 @@ package body Sem_Warn is Act1, Form); else - -- For greater clarity, give name of formal. Error_Msg_Node_2 := Form; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index f2f6ad36735..fd7fa29cc06 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -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