Skip to content

R
riscv-gcc-1
Commit 58009744 by Arnaud Charlet
Options

[multiple changes] 

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
parent e0601c0d
Showing with 143 additions and 170 deletions
gcc/ada/ChangeLog
2015-03-04 Robert Dewar <dewar@adacore.com> 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. * atree.h: Add entries for Flag287-Flag309.
* einfo.adb: Add (unused) flags Flag287-Flag309. * einfo.adb: Add (unused) flags Flag287-Flag309.
......
gcc/ada/einfo.adb
...@@ -584,8 +584,8 @@ package body Einfo is ...@@ -584,8 +584,8 @@ package body Einfo is
-- Is_Static_Type Flag281 -- Is_Static_Type Flag281
-- Has_Nested_Subprogram Flag282 -- Has_Nested_Subprogram Flag282
-- Uplevel_Reference_Noted Flag283 -- Uplevel_Reference_Noted Flag283
-- Is_ARECnF_Entity Flag284
-- (unused) Flag284
-- (unused) Flag285 -- (unused) Flag285
-- (unused) Flag286 -- (unused) Flag286
-- (unused) Flag287 -- (unused) Flag287
...@@ -1915,11 +1915,6 @@ package body Einfo is ...@@ -1915,11 +1915,6 @@ package body Einfo is
return Flag146 (Id); return Flag146 (Id);
end Is_Abstract_Type; 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 function Is_Local_Anonymous_Access (Id : E) return B is
begin begin
pragma Assert (Is_Access_Type (Id)); pragma Assert (Is_Access_Type (Id));
...@@ -4802,11 +4797,6 @@ package body Einfo is ...@@ -4802,11 +4797,6 @@ package body Einfo is
Set_Flag146 (Id, V); Set_Flag146 (Id, V);
end Set_Is_Abstract_Type; 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 procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is
begin begin
pragma Assert (Is_Access_Type (Id)); pragma Assert (Is_Access_Type (Id));
...@@ -7586,7 +7576,7 @@ package body Einfo is ...@@ -7586,7 +7576,7 @@ package body Einfo is
function Last_Formal (Id : E) return E is function Last_Formal (Id : E) return E is
Formal : E; Formal : E;
NForm : E;
begin begin
pragma Assert pragma Assert
(Is_Overloadable (Id) (Is_Overloadable (Id)
...@@ -7601,10 +7591,8 @@ package body Einfo is ...@@ -7601,10 +7591,8 @@ package body Einfo is
Formal := First_Formal (Id); Formal := First_Formal (Id);
if Present (Formal) then if Present (Formal) then
loop while Present (Next_Formal (Formal)) loop
NForm := Next_Formal (Formal); Formal := Next_Formal (Formal);
exit when No (NForm) or else Is_ARECnF_Entity (NForm);
Formal := NForm;
end loop; end loop;
end if; end if;
...@@ -7812,19 +7800,8 @@ package body Einfo is ...@@ -7812,19 +7800,8 @@ package body Einfo is
loop loop
Next_Entity (P); Next_Entity (P);
-- Return Empty if no next entity, or its an ARECnF entity (since if No (P) or else Is_Formal (P) then
-- 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
return P; return P;
-- Else one, unless we have an internal entity, which we skip
elsif not Is_Internal (P) then elsif not Is_Internal (P) then
return Empty; return Empty;
end if; end if;
...@@ -7836,30 +7813,11 @@ package body Einfo is ...@@ -7836,30 +7813,11 @@ package body Einfo is
----------------------------- -----------------------------
function Next_Formal_With_Extras (Id : E) return E is function Next_Formal_With_Extras (Id : E) return E is
NForm : Entity_Id;
Next : Entity_Id;
begin begin
if Present (Extra_Formal (Id)) then if Present (Extra_Formal (Id)) then
return Extra_Formal (Id); 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 else
return Empty; return Next_Formal (Id);
end if;
end if;
end if; end if;
end Next_Formal_With_Extras; end Next_Formal_With_Extras;
...@@ -8708,7 +8666,6 @@ package body Einfo is ...@@ -8708,7 +8666,6 @@ package body Einfo is
W ("In_Use", Flag8 (Id)); W ("In_Use", Flag8 (Id));
W ("Is_Abstract_Subprogram", Flag19 (Id)); W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_ARECnF_Entity", Flag284 (Id));
W ("Is_Access_Constant", Flag69 (Id)); W ("Is_Access_Constant", Flag69 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id));
W ("Is_Ada_2012_Only", Flag199 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id));
......
gcc/ada/einfo.ads
...@@ -1214,10 +1214,12 @@ package Einfo is ...@@ -1214,10 +1214,12 @@ package Einfo is
-- Extra_Formal field (i.e. the Extra_Formal field of the last "real" -- 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 -- 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 -- 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) -- 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 -- and entry families. Returns first extra formal of the subprogram
-- or entry. Returns Empty if there are no extra formals. -- or entry. Returns Empty if there are no extra formals.
...@@ -2176,15 +2178,6 @@ package Einfo is ...@@ -2176,15 +2178,6 @@ package Einfo is
-- carry the keyword aliased, and on record components that have the -- carry the keyword aliased, and on record components that have the
-- keyword. For Ada 2012, also applies to formal parameters. -- 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) -- Is_Atomic (Flag85)
-- Defined in all type entities, and also in constants, components and -- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared applies to the entity. -- variables. Set if a pragma Atomic or Shared applies to the entity.
...@@ -5257,7 +5250,6 @@ package Einfo is ...@@ -5257,7 +5250,6 @@ package Einfo is
-- In_Private_Part (Flag45) -- In_Private_Part (Flag45)
-- Is_Ada_2005_Only (Flag185) -- Is_Ada_2005_Only (Flag185)
-- Is_Ada_2012_Only (Flag199) -- Is_Ada_2012_Only (Flag199)
-- Is_ARECnF_Entity (Flag284)
-- Is_Bit_Packed_Array (Flag122) (base type only) -- Is_Bit_Packed_Array (Flag122) (base type only)
-- Is_Aliased (Flag15) -- Is_Aliased (Flag15)
-- Is_Character_Type (Flag63) -- Is_Character_Type (Flag63)
...@@ -6811,7 +6803,6 @@ package Einfo is ...@@ -6811,7 +6803,6 @@ package Einfo is
function Is_Ada_2005_Only (Id : E) return B; function Is_Ada_2005_Only (Id : E) return B;
function Is_Ada_2012_Only (Id : E) return B; function Is_Ada_2012_Only (Id : E) return B;
function Is_Aliased (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_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B; function Is_Atomic (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B; function Is_Bit_Packed_Array (Id : E) return B;
...@@ -7460,7 +7451,6 @@ package Einfo is ...@@ -7460,7 +7451,6 @@ package Einfo is
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True); 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_Ada_2012_Only (Id : E; V : B := True);
procedure Set_Is_Aliased (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_Asynchronous (Id : E; V : B := True);
procedure Set_Is_Atomic (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); procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True);
...@@ -8228,7 +8218,6 @@ package Einfo is ...@@ -8228,7 +8218,6 @@ package Einfo is
pragma Inline (Is_Ada_2012_Only); pragma Inline (Is_Ada_2012_Only);
pragma Inline (Is_Aggregate_Type); pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased); pragma Inline (Is_Aliased);
pragma Inline (Is_ARECnF_Entity);
pragma Inline (Is_Array_Type); pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable); pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous); pragma Inline (Is_Asynchronous);
...@@ -8721,7 +8710,6 @@ package Einfo is ...@@ -8721,7 +8710,6 @@ package Einfo is
pragma Inline (Set_Is_Ada_2005_Only); pragma Inline (Set_Is_Ada_2005_Only);
pragma Inline (Set_Is_Ada_2012_Only); pragma Inline (Set_Is_Ada_2012_Only);
pragma Inline (Set_Is_Aliased); pragma Inline (Set_Is_Aliased);
pragma Inline (Set_Is_ARECnF_Entity);
pragma Inline (Set_Is_Asynchronous); pragma Inline (Set_Is_Asynchronous);
pragma Inline (Set_Is_Atomic); pragma Inline (Set_Is_Atomic);
pragma Inline (Set_Is_Bit_Packed_Array); pragma Inline (Set_Is_Bit_Packed_Array);
......
gcc/ada/exp_unst.adb
...@@ -611,7 +611,6 @@ package body Exp_Unst is ...@@ -611,7 +611,6 @@ package body Exp_Unst is
STJ.ARECnF := STJ.ARECnF :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F")); Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
Set_Is_ARECnF_Entity (STJ.ARECnF, True);
else else
STJ.ARECnF := Empty; STJ.ARECnF := Empty;
end if; end if;
...@@ -679,7 +678,7 @@ package body Exp_Unst is ...@@ -679,7 +678,7 @@ package body Exp_Unst is
-- and it is not obvious how we can get what we want if we -- and it is not obvious how we can get what we want if we
-- try to use the normal Analyze circuit. -- try to use the normal Analyze circuit.
Extra_Formal : declare Add_Extra_Formal : declare
Encl : constant SI_Type := Enclosing_Subp (J); Encl : constant SI_Type := Enclosing_Subp (J);
STJE : Subp_Entry renames Subps.Table (Encl); STJE : Subp_Entry renames Subps.Table (Encl);
-- Index and Subp_Entry for enclosing routine -- Index and Subp_Entry for enclosing routine
...@@ -688,12 +687,10 @@ package body Exp_Unst is ...@@ -688,12 +687,10 @@ package body Exp_Unst is
-- The formal to be added. Note that n here is one less -- The formal to be added. Note that n here is one less
-- than the level of the subprogram itself (STJ.Ent). -- 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); procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
-- S is an N_Function/Procedure_Specification node, and F -- 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 -- -- Add_Form_To_Spec --
...@@ -701,43 +698,33 @@ package body Exp_Unst is ...@@ -701,43 +698,33 @@ package body Exp_Unst is
procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
Sub : constant Entity_Id := Defining_Unit_Name (S); Sub : constant Entity_Id := Defining_Unit_Name (S);
Ent : Entity_Id;
begin begin
if No (First_Entity (Sub)) then -- Case of at least one Extra_Formal is present, set
Set_First_Entity (Sub, F); -- ARECnF as the new last entry in the list.
Set_Last_Entity (Sub, F);
else if Present (Extra_Formals (Sub)) then
declare Ent := Extra_Formals (Sub);
LastF : constant Entity_Id := Last_Formal (Sub); while Present (Extra_Formal (Ent)) loop
begin Ent := Extra_Formal (Ent);
if No (LastF) then end loop;
Set_Next_Entity (F, First_Entity (Sub));
Set_First_Entity (Sub, F); Set_Extra_Formal (Ent, F);
-- No Extra formals present
else else
Set_Next_Entity (F, Next_Entity (LastF)); Set_Extra_Formals (Sub, F);
Set_Next_Entity (LastF, F); Ent := Last_Formal (Sub);
if Last_Entity (Sub) = LastF then if Present (Ent) then
Set_Last_Entity (Sub, F); Set_Extra_Formal (Ent, F);
end if;
end if;
end;
end if; end if;
if No (Parameter_Specifications (S)) then
Set_Parameter_Specifications (S, Empty_List);
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; end Add_Form_To_Spec;
-- Start of processing for Extra_Formal -- Start of processing for Add_Extra_Formal
begin begin
-- Decorate the new formal entity -- Decorate the new formal entity
...@@ -758,12 +745,9 @@ package body Exp_Unst is ...@@ -758,12 +745,9 @@ package body Exp_Unst is
-- Case of separate spec -- Case of separate spec
else else
Formb := New_Entity (Nkind (Form), Sloc (Form));
Copy_Node (Form, Formb);
Add_Form_To_Spec (Form, Parent (STJ.Ent)); Add_Form_To_Spec (Form, Parent (STJ.Ent));
Add_Form_To_Spec (Formb, Specification (STJ.Bod));
end if; end if;
end Extra_Formal; end Add_Extra_Formal;
end if; end if;
-- Processing for subprograms that have at least one nested -- Processing for subprograms that have at least one nested
......
gcc/ada/sem_aggr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -607,7 +607,8 @@ package body Sem_Aggr is ...@@ -607,7 +607,8 @@ package body Sem_Aggr is
-- regardless of the staticness of the bounds themselves. Subsequent -- regardless of the staticness of the bounds themselves. Subsequent
-- checks in exp_aggr verify that type is not packed, etc. -- 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 Is_Fully_Positional
and then Comes_From_Source (N) and then Comes_From_Source (N)
and then Size_Known_At_Compile_Time (Component_Type (Typ))); and then Size_Known_At_Compile_Time (Component_Type (Typ)));
...@@ -807,8 +808,8 @@ package body Sem_Aggr is ...@@ -807,8 +808,8 @@ package body Sem_Aggr is
begin begin
return No (Expressions (Aggr)) return No (Expressions (Aggr))
and then and then
Nkind (First (Choices (First (Component_Associations (Aggr))))) Nkind (First (Choices (First (Component_Associations (Aggr))))) =
= N_Others_Choice; N_Others_Choice;
end Is_Others_Aggregate; end Is_Others_Aggregate;
---------------------------- ----------------------------
...@@ -1488,7 +1489,6 @@ package body Sem_Aggr is ...@@ -1488,7 +1489,6 @@ package body Sem_Aggr is
and then Compile_Time_Known_Value (First (Expressions (From))) and then Compile_Time_Known_Value (First (Expressions (From)))
then then
Value := Expr_Value (First (Expressions (From))); Value := Expr_Value (First (Expressions (From)));
else else
Value := Uint_0; Value := Uint_0;
OK := False; OK := False;
...@@ -1553,8 +1553,8 @@ package body Sem_Aggr is ...@@ -1553,8 +1553,8 @@ package body Sem_Aggr is
if Paren_Count (Expr) > 0 then if Paren_Count (Expr) > 0 then
Error_Msg_N Error_Msg_N
("\if single-component aggregate is intended," ("\if single-component aggregate is intended, "
& " write e.g. (1 ='> ...)", Expr); & "write e.g. (1 ='> ...)", Expr);
end if; end if;
return Failure; return Failure;
...@@ -1639,9 +1639,7 @@ package body Sem_Aggr is ...@@ -1639,9 +1639,7 @@ package body Sem_Aggr is
Assoc : Node_Id; Assoc : Node_Id;
Choice : Node_Id; Choice : Node_Id;
Expr : Node_Id; Expr : Node_Id;
Discard : Node_Id; Discard : Node_Id;
pragma Warnings (Off, Discard);
Delete_Choice : Boolean; Delete_Choice : Boolean;
-- Used when replacing a subtype choice with predicate by a list -- Used when replacing a subtype choice with predicate by a list
...@@ -1687,7 +1685,6 @@ package body Sem_Aggr is ...@@ -1687,7 +1685,6 @@ package body Sem_Aggr is
while Present (Assoc) loop while Present (Assoc) loop
Choice := First (Choices (Assoc)); Choice := First (Choices (Assoc));
Delete_Choice := False; Delete_Choice := False;
while Present (Choice) loop while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then if Nkind (Choice) = N_Others_Choice then
Others_Present := True; Others_Present := True;
...@@ -1897,7 +1894,8 @@ package body Sem_Aggr is ...@@ -1897,7 +1894,8 @@ package body Sem_Aggr is
if Has_Dynamic_Predicate_Aspect if Has_Dynamic_Predicate_Aspect
(Entity (Subtype_Mark (Choice))) (Entity (Subtype_Mark (Choice)))
then then
Error_Msg_NE ("subtype& has dynamic predicate, " Error_Msg_NE
("subtype& has dynamic predicate, "
& "not allowed in aggregate choice", & "not allowed in aggregate choice",
Choice, Entity (Subtype_Mark (Choice))); Choice, Entity (Subtype_Mark (Choice)));
end if; end if;
...@@ -1964,8 +1962,8 @@ package body Sem_Aggr is ...@@ -1964,8 +1962,8 @@ package body Sem_Aggr is
and then Nb_Choices /= 1 and then Nb_Choices /= 1
then then
Error_Msg_N Error_Msg_N
("dynamic or empty choice in aggregate " & ("dynamic or empty choice in aggregate "
"must be the only choice", Choice); & "must be the only choice", Choice);
return Failure; return Failure;
end if; end if;
...@@ -2332,11 +2330,11 @@ package body Sem_Aggr is ...@@ -2332,11 +2330,11 @@ package body Sem_Aggr is
-- any of the bounds have values that are not known at -- any of the bounds have values that are not known at
-- compile time. -- compile time.
-- Another case warranting a warning is when the length is -- Another case warranting a warning is when the length
-- right, but as above we have an index type that is an -- is right, but as above we have an index type that is
-- enumeration, and the bounds do not match. This is a -- an enumeration, and the bounds do not match. This is a
-- case where dubious sliding is allowed and we generate -- case where dubious sliding is allowed and we generate a
-- a warning that the bounds do not match. -- warning that the bounds do not match.
if No (Expressions (N)) if No (Expressions (N))
and then Nkind (Index) = N_Range and then Nkind (Index) = N_Range
...@@ -2444,9 +2442,7 @@ package body Sem_Aggr is ...@@ -2444,9 +2442,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231) -- Ada 2005 (AI-231)
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Known_Null (Expr) then
and then Known_Null (Expr)
then
Check_Can_Never_Be_Null (Etype (N), Expr); Check_Can_Never_Be_Null (Etype (N), Expr);
end if; end if;
...@@ -2471,9 +2467,7 @@ package body Sem_Aggr is ...@@ -2471,9 +2467,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231) -- Ada 2005 (AI-231)
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Known_Null (Assoc) then
and then Known_Null (Assoc)
then
Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); Check_Can_Never_Be_Null (Etype (N), Expression (Assoc));
end if; end if;
...@@ -2749,9 +2743,7 @@ package body Sem_Aggr is ...@@ -2749,9 +2743,7 @@ package body Sem_Aggr is
-- In SPARK, the ancestor part cannot be a type mark -- In SPARK, the ancestor part cannot be a type mark
if Is_Entity_Name (A) if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
and then Is_Type (Entity (A))
then
Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A); Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A);
-- AI05-0115: if the ancestor part is a subtype mark, the ancestor -- AI05-0115: if the ancestor part is a subtype mark, the ancestor
...@@ -2790,9 +2782,7 @@ package body Sem_Aggr is ...@@ -2790,9 +2782,7 @@ package body Sem_Aggr is
return; return;
end if; end if;
if Is_Entity_Name (A) if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
and then Is_Type (Entity (A))
then
A_Type := Get_Full_View (Entity (A)); A_Type := Get_Full_View (Entity (A));
if Valid_Ancestor_Type then if Valid_Ancestor_Type then
...@@ -2809,6 +2799,7 @@ package body Sem_Aggr is ...@@ -2809,6 +2799,7 @@ package body Sem_Aggr is
Get_First_Interp (A, I, It); Get_First_Interp (A, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
-- Only consider limited interpretations in the Ada 2005 case -- Only consider limited interpretations in the Ada 2005 case
if Is_Tagged_Type (It.Typ) if Is_Tagged_Type (It.Typ)
...@@ -2828,7 +2819,8 @@ package body Sem_Aggr is ...@@ -2828,7 +2819,8 @@ package body Sem_Aggr is
if A_Type = Any_Type then if A_Type = Any_Type then
if Ada_Version >= Ada_2005 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 else
Error_Msg_N Error_Msg_N
("ancestor part must be of a nonlimited tagged type", A); ("ancestor part must be of a nonlimited tagged type", A);
...@@ -3184,12 +3176,11 @@ package body Sem_Aggr is ...@@ -3184,12 +3176,11 @@ package body Sem_Aggr is
begin begin
Is_Box_Present := False; Is_Box_Present := False;
if Present (From) then if No (From) then
Assoc := First (From);
else
return Empty; return Empty;
end if; end if;
Assoc := First (From);
while Present (Assoc) loop while Present (Assoc) loop
Selector_Name := First (Choices (Assoc)); Selector_Name := First (Choices (Assoc));
while Present (Selector_Name) loop while Present (Selector_Name) loop
...@@ -3331,9 +3322,8 @@ package body Sem_Aggr is ...@@ -3331,9 +3322,8 @@ package body Sem_Aggr is
if Is_Generic_Type (Base_Type (Typ)) then if Is_Generic_Type (Base_Type (Typ)) then
Error_Msg_NE Error_Msg_NE
("\instance should provide actual " ("\instance should provide actual type with "
& "type with initialization for&", & "initialization for&", Assoc, Typ);
Assoc, Typ);
end if; end if;
end if; end if;
...@@ -3381,6 +3371,7 @@ package body Sem_Aggr is ...@@ -3381,6 +3371,7 @@ package body Sem_Aggr is
is is
New_Copy : constant Node_Id := New_Copy : constant Node_Id :=
New_Copy_Tree (Source, Map, New_Sloc, New_Scope); New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
begin begin
-- Move the dimensions of Source to New_Copy -- Move the dimensions of Source to New_Copy
...@@ -3774,7 +3765,7 @@ package body Sem_Aggr is ...@@ -3774,7 +3765,7 @@ package body Sem_Aggr is
if not Discr_Present (Discrim) then if not Discr_Present (Discrim) then
if Present (Expr) then if Present (Expr) then
Error_Msg_NE Error_Msg_NE
("more than one value supplied for discriminant&", ("more than one value supplied for discriminant &",
N, Discrim); N, Discrim);
end if; end if;
...@@ -3895,6 +3886,7 @@ package body Sem_Aggr is ...@@ -3895,6 +3886,7 @@ package body Sem_Aggr is
function Find_Private_Ancestor return Entity_Id is function Find_Private_Ancestor return Entity_Id is
Par : Entity_Id; Par : Entity_Id;
begin begin
Par := Typ; Par := Typ;
loop loop
...@@ -3941,8 +3933,7 @@ package body Sem_Aggr is ...@@ -3941,8 +3933,7 @@ package body Sem_Aggr is
Cunit_Entity Cunit_Entity
(Get_Source_Unit (Base_Type (Etype (Ancestor)))); (Get_Source_Unit (Base_Type (Etype (Ancestor))));
begin 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 -- over the private ancestor and its parent. This can
-- only happen if the derivation takes place in a child -- only happen if the derivation takes place in a child
-- unit of the unit that declares the parent, and we are -- unit of the unit that declares the parent, and we are
...@@ -4102,9 +4093,7 @@ package body Sem_Aggr is ...@@ -4102,9 +4093,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-231) -- Ada 2005 (AI-231)
if Ada_Version >= Ada_2005 if Ada_Version >= Ada_2005 and then Known_Null (Positional_Expr) then
and then Known_Null (Positional_Expr)
then
Check_Can_Never_Be_Null (Component, Positional_Expr); Check_Can_Never_Be_Null (Component, Positional_Expr);
end if; end if;
...@@ -4308,12 +4297,12 @@ package body Sem_Aggr is ...@@ -4308,12 +4297,12 @@ package body Sem_Aggr is
if Present if Present
(Entity (First (Choices (Assoc)))) (Entity (First (Choices (Assoc))))
and then and then
Entity (First (Choices (Assoc))) Entity (First (Choices (Assoc))) = Val
= Val
then then
Discr_Val := Expression (Assoc); Discr_Val := Expression (Assoc);
exit; exit;
end if; end if;
Next (Assoc); Next (Assoc);
end loop; end loop;
end if; end if;
...@@ -4325,11 +4314,13 @@ package body Sem_Aggr is ...@@ -4325,11 +4314,13 @@ package body Sem_Aggr is
-- If the discriminant constraint is a current -- If the discriminant constraint is a current
-- instance, mark the current aggregate so that -- instance, mark the current aggregate so that
-- the self-reference can be expanded later. -- 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 if Nkind (Discr_Val) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Discr_Val)) and then Is_Entity_Name (Prefix (Discr_Val))
and then Is_Type (Entity (Prefix (Discr_Val))) and then Is_Type (Entity (Prefix (Discr_Val)))
and then Etype (N) = and then Base_Type (Etype (N)) =
Entity (Prefix (Discr_Val)) Entity (Prefix (Discr_Val))
then then
Set_Has_Self_Reference (N); Set_Has_Self_Reference (N);
...@@ -4340,9 +4331,9 @@ package body Sem_Aggr is ...@@ -4340,9 +4331,9 @@ package body Sem_Aggr is
end loop; end loop;
end Add_Discriminant_Values; end Add_Discriminant_Values;
------------------------------ -----------------------------
-- Propagate_Discriminants -- -- Propagate_Discriminants --
------------------------------ -----------------------------
procedure Propagate_Discriminants procedure Propagate_Discriminants
(Aggr : Node_Id; (Aggr : Node_Id;
...@@ -4365,9 +4356,9 @@ package body Sem_Aggr is ...@@ -4365,9 +4356,9 @@ package body Sem_Aggr is
-- inner aggregate, and recurse if component is -- inner aggregate, and recurse if component is
-- itself composite. -- itself composite.
------------------------ -----------------------
-- Process_Component -- -- Process_Component --
------------------------ -----------------------
procedure Process_Component (Comp : Entity_Id) is procedure Process_Component (Comp : Entity_Id) is
T : constant Entity_Id := Etype (Comp); T : constant Entity_Id := Etype (Comp);
...@@ -4406,8 +4397,7 @@ package body Sem_Aggr is ...@@ -4406,8 +4397,7 @@ package body Sem_Aggr is
-- list of the current aggregate. -- list of the current aggregate.
if Nkind (Def_Node) = N_Record_Definition if Nkind (Def_Node) = N_Record_Definition
and then and then Present (Component_List (Def_Node))
Present (Component_List (Def_Node))
and then and then
Present Present
(Variant_Part (Component_List (Def_Node))) (Variant_Part (Component_List (Def_Node)))
...@@ -4420,8 +4410,7 @@ package body Sem_Aggr is ...@@ -4420,8 +4410,7 @@ package body Sem_Aggr is
Comp_Elmt := First_Elmt (Components); Comp_Elmt := First_Elmt (Components);
while Present (Comp_Elmt) loop while Present (Comp_Elmt) loop
if if Ekind (Node (Comp_Elmt)) /= E_Discriminant
Ekind (Node (Comp_Elmt)) /= E_Discriminant
then then
Process_Component (Node (Comp_Elmt)); Process_Component (Node (Comp_Elmt));
end if; end if;
...@@ -4488,8 +4477,8 @@ package body Sem_Aggr is ...@@ -4488,8 +4477,8 @@ package body Sem_Aggr is
(Component_Associations (Expr), (Component_Associations (Expr),
Make_Component_Association (Loc, Make_Component_Association (Loc,
Choices => Choices =>
New_List New_List (
(Make_Others_Choice (Loc)), Make_Others_Choice (Loc)),
Expression => Empty, Expression => Empty,
Box_Present => True)); Box_Present => True));
end if; end if;
...@@ -4567,9 +4556,7 @@ package body Sem_Aggr is ...@@ -4567,9 +4556,7 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): others choice may have expression or box -- Ada 2005 (AI-287): others choice may have expression or box
if No (Others_Etype) if No (Others_Etype) and then not Others_Box then
and then not Others_Box
then
Error_Msg_N Error_Msg_N
("OTHERS must represent at least one component", Selectr); ("OTHERS must represent at least one component", Selectr);
end if; end if;
......
gcc/ada/sprint.adb
...@@ -309,8 +309,9 @@ package body Sprint is ...@@ -309,8 +309,9 @@ package body Sprint is
-- characters {} if the Do_Overflow flag is set on the node N. -- characters {} if the Do_Overflow flag is set on the node N.
procedure Write_Param_Specs (N : Node_Id); procedure Write_Param_Specs (N : Node_Id);
-- Output parameter specifications for node (which is either a function -- Output parameter specifications for node N (which is a subprogram, or
-- or procedure specification with a Parameter_Specifications field) -- entry or entry family or access-subprogram-definition, all of which
-- have a Parameter_Specificatioons field).
procedure Write_Rewrite_Str (S : String); procedure Write_Rewrite_Str (S : String);
-- Writes out a string (typically containing <<< or >>>}) for a node -- Writes out a string (typically containing <<< or >>>}) for a node
...@@ -4554,17 +4555,25 @@ package body Sprint is ...@@ -4554,17 +4555,25 @@ package body Sprint is
----------------------- -----------------------
procedure Write_Param_Specs (N : Node_Id) 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; Spec : Node_Id;
Formal : Node_Id; Formal : Node_Id;
Output : Boolean := False;
-- Set true if we output at least one parameter
begin 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 (" ("); Write_Str_With_Col_Check (" (");
Spec := First (Specs); Output := True;
Spec := First (Specs);
loop loop
Sprint_Node (Spec); Sprint_Node (Spec);
Formal := Defining_Identifier (Spec); Formal := Defining_Identifier (Spec);
...@@ -4579,17 +4588,42 @@ package body Sprint is ...@@ -4579,17 +4588,42 @@ package body Sprint is
Write_Str ("; "); Write_Str ("; ");
end if; end if;
end loop; end loop;
end if;
-- Write out any extra formals -- See if we have extra formals
while Present (Extra_Formal (Formal)) loop if Nkind_In (N, N_Function_Specification,
Formal := Extra_Formal (Formal); 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 ("; "); Write_Str ("; ");
end if;
Write_Name_With_Col_Check (Chars (Formal)); Write_Name_With_Col_Check (Chars (Formal));
Write_Str (" : "); Write_Str (" : ");
Write_Name_With_Col_Check (Chars (Etype (Formal))); Write_Name_With_Col_Check (Chars (Etype (Formal)));
Formal := Extra_Formal (Formal);
end loop; end loop;
end if;
end if;
end if;
if Output then
Write_Char (')'); Write_Char (')');
end if; end if;
end Write_Param_Specs; end Write_Param_Specs;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment