From 58009744b53fa118a5caac4e20135cd5dd41f4aa Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 4 Mar 2015 15:56:45 +0100 Subject: [PATCH] [multiple changes] 2015-03-04 Robert Dewar * einfo.adb (Is_ARECnF_Entity): Removed. (Last_Formal): Remove special handling of Is_ARECnF_Entity. (Next_Formal): Remove special handling of Is_ARECnF_Entity. (Next_Formal_With_Extras): Remove special handling of Is_ARECnF_Entity. (Number_Entries): Minor reformatting. * einfo.ads (Is_ARECnF_Entity): Removed. * exp_unst.adb (Unnest_Subprogram): Remove setting of Is_ARECnF_Entity. (Add_Extra_Formal): Use normal Extra_Formal circuit. * sprint.adb (Write_Param_Specs): Properly handle case where there are no source formals, but we have at least one Extra_Formal present. 2015-03-04 Ed Schonberg * sem_aggr.adb (Resolve_Record_Aggregate, Add_Discriminant_Values): If the value is a reference to the current instance of an enclosing type, use its base type to check against prefix of attribute reference, because the target type may be otherwise constrained. From-SVN: r221187 --- gcc/ada/ChangeLog | 23 +++++++ gcc/ada/einfo.adb | 59 +++------------- gcc/ada/einfo.ads | 20 ++---- gcc/ada/exp_unst.adb | 62 +++++++---------- gcc/ada/sem_aggr.adb | 157 ++++++++++++++++++++----------------------- gcc/ada/sprint.adb | 62 +++++++++++++---- 6 files changed, 178 insertions(+), 205 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5c3816b4099..7b1f0f4d771 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2015-03-04 Robert Dewar + + * einfo.adb (Is_ARECnF_Entity): Removed. + (Last_Formal): Remove special handling of Is_ARECnF_Entity. + (Next_Formal): Remove special handling of Is_ARECnF_Entity. + (Next_Formal_With_Extras): Remove special handling of Is_ARECnF_Entity. + (Number_Entries): Minor reformatting. + * einfo.ads (Is_ARECnF_Entity): Removed. + * exp_unst.adb (Unnest_Subprogram): Remove setting of + Is_ARECnF_Entity. + (Add_Extra_Formal): Use normal Extra_Formal circuit. + * sprint.adb (Write_Param_Specs): Properly handle case where + there are no source formals, but we have at least one Extra_Formal + present. + +2015-03-04 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate, + Add_Discriminant_Values): If the value is a reference to the + current instance of an enclosing type, use its base type to check + against prefix of attribute reference, because the target type + may be otherwise constrained. + 2015-03-04 Robert Dewar * atree.h: Add entries for Flag287-Flag309. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0961b2d708e..70dc46fc17a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -584,8 +584,8 @@ package body Einfo is -- Is_Static_Type Flag281 -- Has_Nested_Subprogram Flag282 -- Uplevel_Reference_Noted Flag283 - -- Is_ARECnF_Entity Flag284 + -- (unused) Flag284 -- (unused) Flag285 -- (unused) Flag286 -- (unused) Flag287 @@ -1915,11 +1915,6 @@ package body Einfo is return Flag146 (Id); end Is_Abstract_Type; - function Is_ARECnF_Entity (Id : E) return B is - begin - return Flag284 (Id); - end Is_ARECnF_Entity; - function Is_Local_Anonymous_Access (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); @@ -4802,11 +4797,6 @@ package body Einfo is Set_Flag146 (Id, V); end Set_Is_Abstract_Type; - procedure Set_Is_ARECnF_Entity (Id : E; V : B := True) is - begin - Set_Flag284 (Id, V); - end Set_Is_ARECnF_Entity; - procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id)); @@ -7586,7 +7576,7 @@ package body Einfo is function Last_Formal (Id : E) return E is Formal : E; - NForm : E; + begin pragma Assert (Is_Overloadable (Id) @@ -7601,10 +7591,8 @@ package body Einfo is Formal := First_Formal (Id); if Present (Formal) then - loop - NForm := Next_Formal (Formal); - exit when No (NForm) or else Is_ARECnF_Entity (NForm); - Formal := NForm; + while Present (Next_Formal (Formal)) loop + Formal := Next_Formal (Formal); end loop; end if; @@ -7812,19 +7800,8 @@ package body Einfo is loop Next_Entity (P); - -- Return Empty if no next entity, or its an ARECnF entity (since - -- the latter is the last extra formal, not to be returned here). - - if No (P) or else Is_ARECnF_Entity (P) then - return Empty; - - -- If next entity is a formal, return it - - elsif Is_Formal (P) then + if No (P) or else Is_Formal (P) then return P; - - -- Else one, unless we have an internal entity, which we skip - elsif not Is_Internal (P) then return Empty; end if; @@ -7836,30 +7813,11 @@ package body Einfo is ----------------------------- function Next_Formal_With_Extras (Id : E) return E is - NForm : Entity_Id; - Next : Entity_Id; - begin if Present (Extra_Formal (Id)) then return Extra_Formal (Id); - else - NForm := Next_Formal (Id); - - if Present (NForm) then - return NForm; - - -- Deal with ARECnF entity as last extra formal - - else - Next := Next_Entity (Id); - - if Present (Next) and then Is_ARECnF_Entity (Next) then - return Next; - else - return Empty; - end if; - end if; + return Next_Formal (Id); end if; end Next_Formal_With_Extras; @@ -7922,8 +7880,8 @@ package body Einfo is -------------------- function Number_Entries (Id : E) return Nat is - N : Int; - Ent : Entity_Id; + N : Int; + Ent : Entity_Id; begin pragma Assert (Is_Concurrent_Type (Id)); @@ -8708,7 +8666,6 @@ package body Einfo is W ("In_Use", Flag8 (Id)); W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Type", Flag146 (Id)); - W ("Is_ARECnF_Entity", Flag284 (Id)); W ("Is_Access_Constant", Flag69 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3b6f5be7abb..cd92063e3f4 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1214,10 +1214,12 @@ package Einfo is -- Extra_Formal field (i.e. the Extra_Formal field of the last "real" -- formal points to the first extra formal, and the Extra_Formal field of -- each extra formal points to the next one, with Empty indicating the --- end of the list of extra formals). +-- end of the list of extra formals). Another case of Extra_Formal arises +-- in connection with unnesting of subprograms, where the ARECnF formal +-- that represents an activation record pointer is an extra formal. -- Extra_Formals (Node28) --- Applies to subprograms and subprogram types, and also in entries +-- Applies to subprograms and subprogram types, and also to entries -- and entry families. Returns first extra formal of the subprogram -- or entry. Returns Empty if there are no extra formals. @@ -2176,15 +2178,6 @@ package Einfo is -- carry the keyword aliased, and on record components that have the -- keyword. For Ada 2012, also applies to formal parameters. --- Is_ARECnF_Entity (Flag284) --- Defined in all entities. Set for the ARECnF E_In_Parameter entity that --- is generated for nested subprograms that require an activation record. --- Logically this is an extra formal, and must be treated that way, but --- we can't use the normal Extra_Formal mechanism since it is designed --- to handle only cases where an extra formal is associated with one of --- the source formals, which is not the case for ARECnF entities. Hence --- we use this special flag to deal with this special extra formal. - -- Is_Atomic (Flag85) -- Defined in all type entities, and also in constants, components and -- variables. Set if a pragma Atomic or Shared applies to the entity. @@ -5257,7 +5250,6 @@ package Einfo is -- In_Private_Part (Flag45) -- Is_Ada_2005_Only (Flag185) -- Is_Ada_2012_Only (Flag199) - -- Is_ARECnF_Entity (Flag284) -- Is_Bit_Packed_Array (Flag122) (base type only) -- Is_Aliased (Flag15) -- Is_Character_Type (Flag63) @@ -6811,7 +6803,6 @@ package Einfo is function Is_Ada_2005_Only (Id : E) return B; function Is_Ada_2012_Only (Id : E) return B; function Is_Aliased (Id : E) return B; - function Is_ARECnF_Entity (Id : E) return B; function Is_Asynchronous (Id : E) return B; function Is_Atomic (Id : E) return B; function Is_Bit_Packed_Array (Id : E) return B; @@ -7460,7 +7451,6 @@ package Einfo is procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); procedure Set_Is_Ada_2012_Only (Id : E; V : B := True); procedure Set_Is_Aliased (Id : E; V : B := True); - procedure Set_Is_ARECnF_Entity (Id : E; V : B := True); procedure Set_Is_Asynchronous (Id : E; V : B := True); procedure Set_Is_Atomic (Id : E; V : B := True); procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True); @@ -8228,7 +8218,6 @@ package Einfo is pragma Inline (Is_Ada_2012_Only); pragma Inline (Is_Aggregate_Type); pragma Inline (Is_Aliased); - pragma Inline (Is_ARECnF_Entity); pragma Inline (Is_Array_Type); pragma Inline (Is_Assignable); pragma Inline (Is_Asynchronous); @@ -8721,7 +8710,6 @@ package Einfo is pragma Inline (Set_Is_Ada_2005_Only); pragma Inline (Set_Is_Ada_2012_Only); pragma Inline (Set_Is_Aliased); - pragma Inline (Set_Is_ARECnF_Entity); pragma Inline (Set_Is_Asynchronous); pragma Inline (Set_Is_Atomic); pragma Inline (Set_Is_Bit_Packed_Array); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index a850e7816fa..b7bcf5c6e51 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -611,7 +611,6 @@ package body Exp_Unst is STJ.ARECnF := Make_Defining_Identifier (Loc, Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); - Set_Is_ARECnF_Entity (STJ.ARECnF, True); else STJ.ARECnF := Empty; end if; @@ -679,7 +678,7 @@ package body Exp_Unst is -- and it is not obvious how we can get what we want if we -- try to use the normal Analyze circuit. - Extra_Formal : declare + Add_Extra_Formal : declare Encl : constant SI_Type := Enclosing_Subp (J); STJE : Subp_Entry renames Subps.Table (Encl); -- Index and Subp_Entry for enclosing routine @@ -688,12 +687,10 @@ package body Exp_Unst is -- The formal to be added. Note that n here is one less -- than the level of the subprogram itself (STJ.Ent). - Formb : Entity_Id; - -- If needed, this is the formal added to the body - procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); -- S is an N_Function/Procedure_Specification node, and F - -- is the new entity to add to this subprogramn spec. + -- is the new entity to add to this subprogramn spec as + -- the last Extra_Formal. ---------------------- -- Add_Form_To_Spec -- @@ -701,43 +698,33 @@ package body Exp_Unst is procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is Sub : constant Entity_Id := Defining_Unit_Name (S); + Ent : Entity_Id; begin - if No (First_Entity (Sub)) then - Set_First_Entity (Sub, F); - Set_Last_Entity (Sub, F); + -- Case of at least one Extra_Formal is present, set + -- ARECnF as the new last entry in the list. + + if Present (Extra_Formals (Sub)) then + Ent := Extra_Formals (Sub); + while Present (Extra_Formal (Ent)) loop + Ent := Extra_Formal (Ent); + end loop; + + Set_Extra_Formal (Ent, F); + + -- No Extra formals present else - declare - LastF : constant Entity_Id := Last_Formal (Sub); - begin - if No (LastF) then - Set_Next_Entity (F, First_Entity (Sub)); - Set_First_Entity (Sub, F); - - else - Set_Next_Entity (F, Next_Entity (LastF)); - Set_Next_Entity (LastF, F); - - if Last_Entity (Sub) = LastF then - Set_Last_Entity (Sub, F); - end if; - end if; - end; - end if; + Set_Extra_Formals (Sub, F); + Ent := Last_Formal (Sub); - if No (Parameter_Specifications (S)) then - Set_Parameter_Specifications (S, Empty_List); + if Present (Ent) then + Set_Extra_Formal (Ent, F); + end if; end if; - - Append_To (Parameter_Specifications (S), - Make_Parameter_Specification (Sloc (F), - Defining_Identifier => F, - Parameter_Type => - New_Occurrence_Of (STJE.ARECnPT, Sloc (F)))); end Add_Form_To_Spec; - -- Start of processing for Extra_Formal + -- Start of processing for Add_Extra_Formal begin -- Decorate the new formal entity @@ -758,12 +745,9 @@ package body Exp_Unst is -- Case of separate spec else - Formb := New_Entity (Nkind (Form), Sloc (Form)); - Copy_Node (Form, Formb); Add_Form_To_Spec (Form, Parent (STJ.Ent)); - Add_Form_To_Spec (Formb, Specification (STJ.Bod)); end if; - end Extra_Formal; + end Add_Extra_Formal; end if; -- Processing for subprograms that have at least one nested diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index f14381b2cea..dce37c887fe 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -430,8 +430,8 @@ package body Sem_Aggr is Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); -- Constrained N_Range of each index dimension in our aggregate itype - Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); - Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); + Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); + Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); -- Low and High bounds for each index dimension in our aggregate itype Is_Fully_Positional : Boolean := True; @@ -607,7 +607,8 @@ package body Sem_Aggr is -- regardless of the staticness of the bounds themselves. Subsequent -- checks in exp_aggr verify that type is not packed, etc. - Set_Size_Known_At_Compile_Time (Itype, + Set_Size_Known_At_Compile_Time + (Itype, Is_Fully_Positional and then Comes_From_Source (N) and then Size_Known_At_Compile_Time (Component_Type (Typ))); @@ -778,7 +779,7 @@ package body Sem_Aggr is Ind := First_Index (Etype (Comp)); while Present (Ind) loop if Nkind (Ind) /= N_Range - or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal + or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal or else Nkind (High_Bound (Ind)) /= N_Integer_Literal then return; @@ -807,8 +808,8 @@ package body Sem_Aggr is begin return No (Expressions (Aggr)) and then - Nkind (First (Choices (First (Component_Associations (Aggr))))) - = N_Others_Choice; + Nkind (First (Choices (First (Component_Associations (Aggr))))) = + N_Others_Choice; end Is_Others_Aggregate; ---------------------------- @@ -1294,8 +1295,8 @@ package body Sem_Aggr is Expr_Pos := Make_Op_Add (Loc, - Left_Opnd => To_Pos, - Right_Opnd => Make_Integer_Literal (Loc, Val)); + Left_Opnd => To_Pos, + Right_Opnd => Make_Integer_Literal (Loc, Val)); Expr := Make_Attribute_Reference @@ -1488,7 +1489,6 @@ package body Sem_Aggr is and then Compile_Time_Known_Value (First (Expressions (From))) then Value := Expr_Value (First (Expressions (From))); - else Value := Uint_0; OK := False; @@ -1553,8 +1553,8 @@ package body Sem_Aggr is if Paren_Count (Expr) > 0 then Error_Msg_N - ("\if single-component aggregate is intended," - & " write e.g. (1 ='> ...)", Expr); + ("\if single-component aggregate is intended, " + & "write e.g. (1 ='> ...)", Expr); end if; return Failure; @@ -1636,12 +1636,10 @@ package body Sem_Aggr is -- Variables local to Resolve_Array_Aggregate - Assoc : Node_Id; - Choice : Node_Id; - Expr : Node_Id; - + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; Discard : Node_Id; - pragma Warnings (Off, Discard); Delete_Choice : Boolean; -- Used when replacing a subtype choice with predicate by a list @@ -1687,7 +1685,6 @@ package body Sem_Aggr is while Present (Assoc) loop Choice := First (Choices (Assoc)); Delete_Choice := False; - while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then Others_Present := True; @@ -1897,9 +1894,10 @@ package body Sem_Aggr is if Has_Dynamic_Predicate_Aspect (Entity (Subtype_Mark (Choice))) then - Error_Msg_NE ("subtype& has dynamic predicate, " - & "not allowed in aggregate choice", - Choice, Entity (Subtype_Mark (Choice))); + Error_Msg_NE + ("subtype& has dynamic predicate, " + & "not allowed in aggregate choice", + Choice, Entity (Subtype_Mark (Choice))); end if; -- Does the subtype indication evaluation raise CE? @@ -1964,8 +1962,8 @@ package body Sem_Aggr is and then Nb_Choices /= 1 then Error_Msg_N - ("dynamic or empty choice in aggregate " & - "must be the only choice", Choice); + ("dynamic or empty choice in aggregate " + & "must be the only choice", Choice); return Failure; end if; @@ -2332,11 +2330,11 @@ package body Sem_Aggr is -- any of the bounds have values that are not known at -- compile time. - -- Another case warranting a warning is when the length is - -- right, but as above we have an index type that is an - -- enumeration, and the bounds do not match. This is a - -- case where dubious sliding is allowed and we generate - -- a warning that the bounds do not match. + -- Another case warranting a warning is when the length + -- is right, but as above we have an index type that is + -- an enumeration, and the bounds do not match. This is a + -- case where dubious sliding is allowed and we generate a + -- warning that the bounds do not match. if No (Expressions (N)) and then Nkind (Index) = N_Range @@ -2444,9 +2442,7 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_2005 - and then Known_Null (Expr) - then + if Ada_Version >= Ada_2005 and then Known_Null (Expr) then Check_Can_Never_Be_Null (Etype (N), Expr); end if; @@ -2471,9 +2467,7 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_2005 - and then Known_Null (Assoc) - then + if Ada_Version >= Ada_2005 and then Known_Null (Assoc) then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); end if; @@ -2517,8 +2511,8 @@ package body Sem_Aggr is if Is_Tagged_Type (Etype (Expr)) then Check_Dynamically_Tagged_Expression - (Expr => Expr, - Typ => Component_Type (Etype (N)), + (Expr => Expr, + Typ => Component_Type (Etype (N)), Related_Nod => N); end if; end; @@ -2749,9 +2743,7 @@ package body Sem_Aggr is -- In SPARK, the ancestor part cannot be a type mark - if Is_Entity_Name (A) - and then Is_Type (Entity (A)) - then + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A); -- AI05-0115: if the ancestor part is a subtype mark, the ancestor @@ -2790,9 +2782,7 @@ package body Sem_Aggr is return; end if; - if Is_Entity_Name (A) - and then Is_Type (Entity (A)) - then + if Is_Entity_Name (A) and then Is_Type (Entity (A)) then A_Type := Get_Full_View (Entity (A)); if Valid_Ancestor_Type then @@ -2809,6 +2799,7 @@ package body Sem_Aggr is Get_First_Interp (A, I, It); while Present (It.Typ) loop + -- Only consider limited interpretations in the Ada 2005 case if Is_Tagged_Type (It.Typ) @@ -2828,7 +2819,8 @@ package body Sem_Aggr is if A_Type = Any_Type then if Ada_Version >= Ada_2005 then - Error_Msg_N ("ancestor part must be of a tagged type", A); + Error_Msg_N + ("ancestor part must be of a tagged type", A); else Error_Msg_N ("ancestor part must be of a nonlimited tagged type", A); @@ -3184,12 +3176,11 @@ package body Sem_Aggr is begin Is_Box_Present := False; - if Present (From) then - Assoc := First (From); - else + if No (From) then return Empty; end if; + Assoc := First (From); while Present (Assoc) loop Selector_Name := First (Choices (Assoc)); while Present (Selector_Name) loop @@ -3331,9 +3322,8 @@ package body Sem_Aggr is if Is_Generic_Type (Base_Type (Typ)) then Error_Msg_NE - ("\instance should provide actual " - & "type with initialization for&", - Assoc, Typ); + ("\instance should provide actual type with " + & "initialization for&", Assoc, Typ); end if; end if; @@ -3381,6 +3371,7 @@ package body Sem_Aggr is is New_Copy : constant Node_Id := New_Copy_Tree (Source, Map, New_Sloc, New_Scope); + begin -- Move the dimensions of Source to New_Copy @@ -3727,7 +3718,7 @@ package body Sem_Aggr is then Error_Msg_NE ("aggregate not available for type& whose ancestor " - & "has unknown discriminants ", N, Typ); + & "has unknown discriminants ", N, Typ); end if; if Has_Unknown_Discriminants (Typ) @@ -3774,7 +3765,7 @@ package body Sem_Aggr is if not Discr_Present (Discrim) then if Present (Expr) then Error_Msg_NE - ("more than one value supplied for discriminant&", + ("more than one value supplied for discriminant &", N, Discrim); end if; @@ -3816,7 +3807,7 @@ package body Sem_Aggr is if Has_Discriminants (Typ) or else (Has_Unknown_Discriminants (Typ) - and then Present (Underlying_Record_View (Typ))) + and then Present (Underlying_Record_View (Typ))) then Build_Constrained_Itype : declare Loc : constant Source_Ptr := Sloc (N); @@ -3840,14 +3831,14 @@ package body Sem_Aggr is Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Underlying_Record_View (Typ), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); else Indic := Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); end if; @@ -3895,6 +3886,7 @@ package body Sem_Aggr is function Find_Private_Ancestor return Entity_Id is Par : Entity_Id; + begin Par := Typ; loop @@ -3941,8 +3933,7 @@ package body Sem_Aggr is Cunit_Entity (Get_Source_Unit (Base_Type (Etype (Ancestor)))); begin - - -- check whether we are in a scope that has full view + -- Check whether we are in a scope that has full view -- over the private ancestor and its parent. This can -- only happen if the derivation takes place in a child -- unit of the unit that declares the parent, and we are @@ -3954,14 +3945,14 @@ package body Sem_Aggr is and then In_Open_Scopes (Scope (Ancestor)) and then (In_Private_Part (Scope (Ancestor)) - or else In_Package_Body (Scope (Ancestor))) + or else In_Package_Body (Scope (Ancestor))) then null; else Error_Msg_NE ("type of aggregate has private ancestor&!", - N, Root_Typ); + N, Root_Typ); Error_Msg_N ("must use extension aggregate!", N); return; end if; @@ -4102,9 +4093,7 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_2005 - and then Known_Null (Positional_Expr) - then + if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then Check_Can_Never_Be_Null (Component, Positional_Expr); end if; @@ -4306,31 +4295,33 @@ package body Sem_Aggr is Assoc := First (Assoc_List); while Present (Assoc) loop if Present - (Entity (First (Choices (Assoc)))) + (Entity (First (Choices (Assoc)))) and then - Entity (First (Choices (Assoc))) - = Val + Entity (First (Choices (Assoc))) = Val then Discr_Val := Expression (Assoc); exit; end if; + Next (Assoc); end loop; end if; Add_Association (Discr, New_Copy_Tree (Discr_Val), - Component_Associations (New_Aggr)); + Component_Associations (New_Aggr)); -- If the discriminant constraint is a current -- instance, mark the current aggregate so that -- the self-reference can be expanded later. + -- The constraint may refer to the subtype of + -- aggregate, so use base type for comparison. if Nkind (Discr_Val) = N_Attribute_Reference and then Is_Entity_Name (Prefix (Discr_Val)) and then Is_Type (Entity (Prefix (Discr_Val))) - and then Etype (N) = - Entity (Prefix (Discr_Val)) + and then Base_Type (Etype (N)) = + Entity (Prefix (Discr_Val)) then Set_Has_Self_Reference (N); end if; @@ -4340,9 +4331,9 @@ package body Sem_Aggr is end loop; end Add_Discriminant_Values; - ------------------------------ - -- Propagate_Discriminants -- - ------------------------------ + ----------------------------- + -- Propagate_Discriminants -- + ----------------------------- procedure Propagate_Discriminants (Aggr : Node_Id; @@ -4365,13 +4356,13 @@ package body Sem_Aggr is -- inner aggregate, and recurse if component is -- itself composite. - ------------------------ - -- Process_Component -- - ------------------------ + ----------------------- + -- Process_Component -- + ----------------------- procedure Process_Component (Comp : Entity_Id) is - T : constant Entity_Id := Etype (Comp); - New_Aggr : Node_Id; + T : constant Entity_Id := Etype (Comp); + New_Aggr : Node_Id; begin if Is_Record_Type (T) @@ -4406,8 +4397,7 @@ package body Sem_Aggr is -- list of the current aggregate. if Nkind (Def_Node) = N_Record_Definition - and then - Present (Component_List (Def_Node)) + and then Present (Component_List (Def_Node)) and then Present (Variant_Part (Component_List (Def_Node))) @@ -4420,8 +4410,7 @@ package body Sem_Aggr is Comp_Elmt := First_Elmt (Components); while Present (Comp_Elmt) loop - if - Ekind (Node (Comp_Elmt)) /= E_Discriminant + if Ekind (Node (Comp_Elmt)) /= E_Discriminant then Process_Component (Node (Comp_Elmt)); end if; @@ -4488,10 +4477,10 @@ package body Sem_Aggr is (Component_Associations (Expr), Make_Component_Association (Loc, Choices => - New_List - (Make_Others_Choice (Loc)), + New_List ( + Make_Others_Choice (Loc)), Expression => Empty, - Box_Present => True)); + Box_Present => True)); end if; exit; end if; @@ -4567,9 +4556,7 @@ package body Sem_Aggr is -- Ada 2005 (AI-287): others choice may have expression or box - if No (Others_Etype) - and then not Others_Box - then + if No (Others_Etype) and then not Others_Box then Error_Msg_N ("OTHERS must represent at least one component", Selectr); end if; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 670e5341664..bd772f3ab35 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -309,8 +309,9 @@ package body Sprint is -- characters {} if the Do_Overflow flag is set on the node N. procedure Write_Param_Specs (N : Node_Id); - -- Output parameter specifications for node (which is either a function - -- or procedure specification with a Parameter_Specifications field) + -- Output parameter specifications for node N (which is a subprogram, or + -- entry or entry family or access-subprogram-definition, all of which + -- have a Parameter_Specificatioons field). procedure Write_Rewrite_Str (S : String); -- Writes out a string (typically containing <<< or >>>}) for a node @@ -4554,17 +4555,25 @@ package body Sprint is ----------------------- procedure Write_Param_Specs (N : Node_Id) is - Specs : List_Id; + Specs : constant List_Id := Parameter_Specifications (N); + Specs_Present : constant Boolean := Is_Non_Empty_List (Specs); + + Ent : Entity_Id; + Extras : Node_Id; Spec : Node_Id; Formal : Node_Id; + Output : Boolean := False; + -- Set true if we output at least one parameter + begin - Specs := Parameter_Specifications (N); + -- Write out explicit specs from Parameter_Speficiations list - if Is_Non_Empty_List (Specs) then + if Specs_Present then Write_Str_With_Col_Check (" ("); - Spec := First (Specs); + Output := True; + Spec := First (Specs); loop Sprint_Node (Spec); Formal := Defining_Identifier (Spec); @@ -4579,17 +4588,42 @@ package body Sprint is Write_Str ("; "); end if; end loop; + end if; - -- Write out any extra formals + -- See if we have extra formals - while Present (Extra_Formal (Formal)) loop - Formal := Extra_Formal (Formal); - Write_Str ("; "); - Write_Name_With_Col_Check (Chars (Formal)); - Write_Str (" : "); - Write_Name_With_Col_Check (Chars (Etype (Formal))); - end loop; + if Nkind_In (N, N_Function_Specification, + N_Procedure_Specification) + then + Ent := Defining_Entity (N); + + -- Loop to write extra formals (if any) + + if Present (Ent) and then Is_Subprogram (Ent) then + Extras := Extra_Formals (Ent); + + if Present (Extras) then + if not Specs_Present then + Write_Str_With_Col_Check (" ("); + Output := True; + end if; + + Formal := Extras; + while Present (Formal) loop + if Specs_Present or else Formal /= Extras then + Write_Str ("; "); + end if; + + Write_Name_With_Col_Check (Chars (Formal)); + Write_Str (" : "); + Write_Name_With_Col_Check (Chars (Etype (Formal))); + Formal := Extra_Formal (Formal); + end loop; + end if; + end if; + end if; + if Output then Write_Char (')'); end if; end Write_Param_Specs; -- 2.30.2