mirror of git://gcc.gnu.org/git/gcc.git
[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
This commit is contained in:
Arnaud Charlet
parent
e0601c0df9
commit
58009744b5
|
|
@ -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>
|
2015-03-04 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* atree.h: Add entries for Flag287-Flag309.
|
* atree.h: Add entries for Flag287-Flag309.
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
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
|
||||||
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
|
||||||
|
|
||||||
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
|
||||||
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
|
||||||
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
|
||||||
-----------------------------
|
-----------------------------
|
||||||
|
|
||||||
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;
|
||||||
|
|
||||||
|
|
@ -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));
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
-- 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
|
||||||
-- 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
|
||||||
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
|
||||||
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
|
||||||
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
|
||||||
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);
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
-- 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
|
||||||
-- 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
|
||||||
|
|
||||||
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
|
if Present (Ent) then
|
||||||
Set_Next_Entity (F, Next_Entity (LastF));
|
Set_Extra_Formal (Ent, F);
|
||||||
Set_Next_Entity (LastF, F);
|
|
||||||
|
|
||||||
if Last_Entity (Sub) = LastF then
|
|
||||||
Set_Last_Entity (Sub, F);
|
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end;
|
|
||||||
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;
|
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
|
||||||
-- 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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
-- 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
|
||||||
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
|
||||||
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;
|
||||||
|
|
@ -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
|
||||||
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
|
||||||
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
|
||||||
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
|
||||||
-- 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
|
||||||
|
|
||||||
-- 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
|
||||||
|
|
||||||
-- 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
|
||||||
|
|
||||||
-- 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
|
||||||
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
|
||||||
|
|
||||||
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
|
||||||
|
|
||||||
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
|
||||||
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
|
||||||
|
|
||||||
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
|
||||||
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
|
||||||
|
|
||||||
|
|
@ -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
|
||||||
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
|
||||||
|
|
||||||
-- 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
|
||||||
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
|
||||||
-- 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
|
||||||
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
|
||||||
-- 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
|
||||||
-- 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
|
||||||
|
|
||||||
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
|
||||||
(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
|
||||||
|
|
||||||
-- 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;
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
-----------------------
|
-----------------------
|
||||||
|
|
||||||
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
|
||||||
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;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue