mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-13 17:11:23 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2015-03-04  Robert Dewar  <dewar@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2015-03-04 15:56:45 +01:00
parent e0601c0df9
commit 58009744b5
6 changed files with 178 additions and 205 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 @@
2015-03-04 Robert Dewar <dewar@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <dewar@adacore.com>
* atree.h: Add entries for Flag287-Flag309.

59
gcc/ada/einfo.adb
View File

@ -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));

20
gcc/ada/einfo.ads
View File

@ -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);

62
gcc/ada/exp_unst.adb
View File

@ -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);
Set_Extra_Formals (Sub, F);
Ent := Last_Formal (Sub);
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;
if Present (Ent) then
Set_Extra_Formal (Ent, F);
end if;
end if;
if No (Parameter_Specifications (S)) then
Set_Parameter_Specifications (S, Empty_List);
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

157
gcc/ada/sem_aggr.adb
View File

@ -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;

62
gcc/ada/sprint.adb
View File

@ -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;