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 178 additions and 205 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 else
NForm := Next_Formal (Id); return 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;
end if; end if;
end Next_Formal_With_Extras; end Next_Formal_With_Extras;
...@@ -7922,8 +7880,8 @@ package body Einfo is ...@@ -7922,8 +7880,8 @@ package body Einfo is
-------------------- --------------------
function Number_Entries (Id : E) return Nat is function Number_Entries (Id : E) return Nat is
N : Int; N : Int;
Ent : Entity_Id; Ent : Entity_Id;
begin begin
pragma Assert (Is_Concurrent_Type (Id)); pragma Assert (Is_Concurrent_Type (Id));
...@@ -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);
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 else
declare Set_Extra_Formals (Sub, F);
LastF : constant Entity_Id := Last_Formal (Sub); Ent := 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;
if No (Parameter_Specifications (S)) then if Present (Ent) then
Set_Parameter_Specifications (S, Empty_List); Set_Extra_Formal (Ent, F);
end if;
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- --
...@@ -430,8 +430,8 @@ package body Sem_Aggr is ...@@ -430,8 +430,8 @@ package body Sem_Aggr is
Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-- Constrained N_Range of each index dimension in our aggregate itype -- Constrained N_Range of each index dimension in our aggregate itype
Aggr_Low : 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); Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty);
-- Low and High bounds for each index dimension in our aggregate itype -- Low and High bounds for each index dimension in our aggregate itype
Is_Fully_Positional : Boolean := True; Is_Fully_Positional : Boolean := True;
...@@ -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)));
...@@ -778,7 +779,7 @@ package body Sem_Aggr is ...@@ -778,7 +779,7 @@ package body Sem_Aggr is
Ind := First_Index (Etype (Comp)); Ind := First_Index (Etype (Comp));
while Present (Ind) loop while Present (Ind) loop
if Nkind (Ind) /= N_Range 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 or else Nkind (High_Bound (Ind)) /= N_Integer_Literal
then then
return; return;
...@@ -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;
---------------------------- ----------------------------
...@@ -1294,8 +1295,8 @@ package body Sem_Aggr is ...@@ -1294,8 +1295,8 @@ package body Sem_Aggr is
Expr_Pos := Expr_Pos :=
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => To_Pos, Left_Opnd => To_Pos,
Right_Opnd => Make_Integer_Literal (Loc, Val)); Right_Opnd => Make_Integer_Literal (Loc, Val));
Expr := Expr :=
Make_Attribute_Reference Make_Attribute_Reference
...@@ -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;
...@@ -1636,12 +1636,10 @@ package body Sem_Aggr is ...@@ -1636,12 +1636,10 @@ package body Sem_Aggr is
-- Variables local to Resolve_Array_Aggregate -- Variables local to Resolve_Array_Aggregate
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,9 +1894,10 @@ package body Sem_Aggr is ...@@ -1897,9 +1894,10 @@ 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
& "not allowed in aggregate choice", ("subtype& has dynamic predicate, "
Choice, Entity (Subtype_Mark (Choice))); & "not allowed in aggregate choice",
Choice, Entity (Subtype_Mark (Choice)));
end if; end if;
-- Does the subtype indication evaluation raise CE? -- Does the subtype indication evaluation raise CE?
...@@ -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;
...@@ -2517,8 +2511,8 @@ package body Sem_Aggr is ...@@ -2517,8 +2511,8 @@ package body Sem_Aggr is
if Is_Tagged_Type (Etype (Expr)) then if Is_Tagged_Type (Etype (Expr)) then
Check_Dynamically_Tagged_Expression Check_Dynamically_Tagged_Expression
(Expr => Expr, (Expr => Expr,
Typ => Component_Type (Etype (N)), Typ => Component_Type (Etype (N)),
Related_Nod => N); Related_Nod => N);
end if; end if;
end; end;
...@@ -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
...@@ -3727,7 +3718,7 @@ package body Sem_Aggr is ...@@ -3727,7 +3718,7 @@ package body Sem_Aggr is
then then
Error_Msg_NE Error_Msg_NE
("aggregate not available for type& whose ancestor " ("aggregate not available for type& whose ancestor "
& "has unknown discriminants ", N, Typ); & "has unknown discriminants ", N, Typ);
end if; end if;
if Has_Unknown_Discriminants (Typ) if Has_Unknown_Discriminants (Typ)
...@@ -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;
...@@ -3816,7 +3807,7 @@ package body Sem_Aggr is ...@@ -3816,7 +3807,7 @@ package body Sem_Aggr is
if Has_Discriminants (Typ) if Has_Discriminants (Typ)
or else (Has_Unknown_Discriminants (Typ) or else (Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))) and then Present (Underlying_Record_View (Typ)))
then then
Build_Constrained_Itype : declare Build_Constrained_Itype : declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -3840,14 +3831,14 @@ package body Sem_Aggr is ...@@ -3840,14 +3831,14 @@ package body Sem_Aggr is
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc), New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C)); Make_Index_Or_Discriminant_Constraint (Loc, C));
else else
Indic := Indic :=
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc), New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, C)); Make_Index_Or_Discriminant_Constraint (Loc, C));
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
...@@ -3954,14 +3945,14 @@ package body Sem_Aggr is ...@@ -3954,14 +3945,14 @@ package body Sem_Aggr is
and then In_Open_Scopes (Scope (Ancestor)) and then In_Open_Scopes (Scope (Ancestor))
and then and then
(In_Private_Part (Scope (Ancestor)) (In_Private_Part (Scope (Ancestor))
or else In_Package_Body (Scope (Ancestor))) or else In_Package_Body (Scope (Ancestor)))
then then
null; null;
else else
Error_Msg_NE Error_Msg_NE
("type of aggregate has private ancestor&!", ("type of aggregate has private ancestor&!",
N, Root_Typ); N, Root_Typ);
Error_Msg_N ("must use extension aggregate!", N); Error_Msg_N ("must use extension aggregate!", N);
return; return;
end if; end if;
...@@ -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;
...@@ -4306,31 +4295,33 @@ package body Sem_Aggr is ...@@ -4306,31 +4295,33 @@ package body Sem_Aggr is
Assoc := First (Assoc_List); Assoc := First (Assoc_List);
while Present (Assoc) loop while Present (Assoc) loop
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;
Add_Association Add_Association
(Discr, New_Copy_Tree (Discr_Val), (Discr, New_Copy_Tree (Discr_Val),
Component_Associations (New_Aggr)); Component_Associations (New_Aggr));
-- 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);
end if; end if;
...@@ -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,13 +4356,13 @@ package body Sem_Aggr is ...@@ -4365,13 +4356,13 @@ 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);
New_Aggr : Node_Id; New_Aggr : Node_Id;
begin begin
if Is_Record_Type (T) if Is_Record_Type (T)
...@@ -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,10 +4477,10 @@ package body Sem_Aggr is ...@@ -4488,10 +4477,10 @@ 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;
exit; exit;
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)
Write_Str ("; "); then
Write_Name_With_Col_Check (Chars (Formal)); Ent := Defining_Entity (N);
Write_Str (" : ");
Write_Name_With_Col_Check (Chars (Etype (Formal))); -- Loop to write extra formals (if any)
end loop;
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 (')'); 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