OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking code so if BIPAlloc is not passed in... 

gcc/ada/

2017-10-09  Bob Duff  <duff@adacore.com>

	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking
	code so if BIPAlloc is not passed in, it will likely raise
	Program_Error instead of cause miscellaneous chaos.
	(Is_Build_In_Place_Result_Type): Return False if not Expander_Active,
	as for the other Is_B-I-P... functions.
	* sem_aggr.adb (Resolve_Extension_Aggregate): For an extension
	aggregate whose ancestor part is a build-in-place call returning a
	nonlimited type, transform the assignment to the ancestor part to use a
	temp.
	* sem_ch3.adb (Build_Itype_Reference): Handle the case where we're
	creating an Itype for a library unit entity.
	(Check_Initialization): Avoid spurious error message on
	internally-generated call.
	* sem_ch5.adb (Analyze_Assignment): Handle the case where the
	right-hand side is a build-in-place call. This didn't happen when b-i-p
	was only for limited types.
	* sem_ch6.adb (Create_Extra_Formals): Remove assumption that b-i-p
	implies >= Ada 2005.
	* sem_ch7.adb (Scan_Subprogram_Refs): Avoid traversing the same nodes
	repeatedly.
	* sem_util.adb (Next_Actual): Handle case of build-in-place call.

2017-10-09  Arnaud Charlet  <charlet@adacore.com>

	* doc/gnat_ugn/gnat_and_program_execution.rst: Minor edit.

2017-10-09  Piotr Trojanek  <trojanek@adacore.com>

	* libgnarl/s-taprob.adb: Minor whitespace fix.

2017-10-09  Bob Duff  <duff@adacore.com>

	* namet.ads: Minor comment fix.

2017-10-09  Piotr Trojanek  <trojanek@adacore.com>

	* sem_aux.adb (Unit_Declaration_Node): Detect protected declarations,
	just like other program units listed in Ada RM 10.1(1).

2017-10-09  Justin Squirek  <squirek@adacore.com>

	* sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an
	actual for a formal package is an instantiation of a child unit, create
	a freeze node for the instance of the parent if it appears in the same
	scope and is not frozen yet.

2017-10-09  Pierre-Marie de Rodat  <derodat@adacore.com>

	* exp_atag.ads, libgnat/a-tags.adb, libgnat/a-tags.ads: Enhance
	in-source documentation for tagged types's Offset_To_Top.

2017-10-09  Bob Duff  <duff@adacore.com>

	* exp_ch3.adb (Build_Assignment): Parameter name N was somewhat
	confusing.  Same for N_Loc.  Remove assumption that b-i-p implies
	limited.  This is for the case of a function call that occurs as the
	default for a record component.
	(Expand_N_Object_Declaration): Deal with the case where expansion has
	created an object declaration initialized with something like
	F(...)'Reference.
	* exp_ch3.adb: Minor reformatting.

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of
	the attribute is an object, but it may appear within a conversion. The
	object itself must be retrieved when generating the range test that
	implements the validity check on a scalar type.

gcc/testsuite/

2017-10-09  Ed Schonberg  <schonberg@adacore.com>

	* gnat.dg/validity_check2.adb, gnat.dg/validity_check2_pkg.ads:
	New testcase.

From-SVN: r253548
This commit is contained in:
Pierre-Marie de Rodat 2017-10-09 15:17:16 +00:00
parent 18b4306c0a
commit 5168a9b3d0
21 changed files with 494 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
gcc/ada/ChangeLog
View File

@ -1,3 +1,78 @@
2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Add self-checking
code so if BIPAlloc is not passed in, it will likely raise
Program_Error instead of cause miscellaneous chaos.
(Is_Build_In_Place_Result_Type): Return False if not Expander_Active,
as for the other Is_B-I-P... functions.
* sem_aggr.adb (Resolve_Extension_Aggregate): For an extension
aggregate whose ancestor part is a build-in-place call returning a
nonlimited type, transform the assignment to the ancestor part to use a
temp.
* sem_ch3.adb (Build_Itype_Reference): Handle the case where we're
creating an Itype for a library unit entity.
(Check_Initialization): Avoid spurious error message on
internally-generated call.
* sem_ch5.adb (Analyze_Assignment): Handle the case where the
right-hand side is a build-in-place call. This didn't happen when b-i-p
was only for limited types.
* sem_ch6.adb (Create_Extra_Formals): Remove assumption that b-i-p
implies >= Ada 2005.
* sem_ch7.adb (Scan_Subprogram_Refs): Avoid traversing the same nodes
repeatedly.
* sem_util.adb (Next_Actual): Handle case of build-in-place call.
2017-10-09 Arnaud Charlet <charlet@adacore.com>
* doc/gnat_ugn/gnat_and_program_execution.rst: Minor edit.
2017-10-09 Piotr Trojanek <trojanek@adacore.com>
* libgnarl/s-taprob.adb: Minor whitespace fix.
2017-10-09 Bob Duff <duff@adacore.com>
* namet.ads: Minor comment fix.
2017-10-09 Piotr Trojanek <trojanek@adacore.com>
* sem_aux.adb (Unit_Declaration_Node): Detect protected declarations,
just like other program units listed in Ada RM 10.1(1).
2017-10-09 Justin Squirek <squirek@adacore.com>
* sem_ch8.adb (Update_Chain_In_Scope): Modify warning messages.
2017-10-09 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Associations, Check_Generic_Parent): If an
actual for a formal package is an instantiation of a child unit, create
a freeze node for the instance of the parent if it appears in the same
scope and is not frozen yet.
2017-10-09 Pierre-Marie de Rodat <derodat@adacore.com>
* exp_atag.ads, libgnat/a-tags.adb, libgnat/a-tags.ads: Enhance
in-source documentation for tagged types's Offset_To_Top.
2017-10-09 Bob Duff <duff@adacore.com>
* exp_ch3.adb (Build_Assignment): Parameter name N was somewhat
confusing. Same for N_Loc. Remove assumption that b-i-p implies
limited. This is for the case of a function call that occurs as the
default for a record component.
(Expand_N_Object_Declaration): Deal with the case where expansion has
created an object declaration initialized with something like
F(...)'Reference.
* exp_ch3.adb: Minor reformatting.
2017-10-09 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Expand_Attribute_Reference, case 'Valid): The prefix of
the attribute is an object, but it may appear within a conversion. The
object itself must be retrieved when generating the range test that
implements the validity check on a scalar type.
2017-10-05 Eric Botcazou <ebotcazou@adacore.com>
PR ada/82393

5
gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
View File

@ -4093,9 +4093,8 @@ execution of this erroneous program:
``gnatmem`` makes use of the output created by the special version of
allocation and deallocation routines that record call information. This allows
it to obtain accurate dynamic memory usage history at a minimal cost to the
execution speed. Note however, that ``gnatmem`` is not supported on all
platforms (currently, it is supported on AIX, HP-UX, GNU/Linux, Solaris and
Windows).
execution speed. Note however, that ``gnatmem`` is only supported on
GNU/Linux and Windows.
The ``gnatmem`` command has the form

4
gcc/ada/exp_atag.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2006-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -147,7 +147,7 @@ package Exp_Atag is
--
-- Generates:
-- Offset_To_Top_Ptr
-- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset)
-- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all
function Build_Set_Predefined_Prim_Op_Address
(Loc : Source_Ptr;

6
gcc/ada/exp_attr.adb
View File

@ -6512,7 +6512,9 @@ package body Exp_Attr is
begin
-- The prefix of attribute 'Valid should always denote an object
-- reference. The reference is either coming directly from source
-- or is produced by validity check expansion.
-- or is produced by validity check expansion. The object may be
-- wrapped in a conversion in which case the call to Unqual_Conv
-- will yield it.
-- If the prefix denotes a variable which captures the value of
-- an object for validation purposes, use the variable in the
@ -6523,7 +6525,7 @@ package body Exp_Attr is
-- if not Temp in ... then
if Is_Validation_Variable_Reference (Pref) then
Temp := New_Occurrence_Of (Entity (Pref), Loc);
Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
-- Otherwise the prefix is either a source object or a constant
-- produced by validity check expansion. Generate:

70
gcc/ada/exp_ch3.adb
View File

@ -1711,10 +1711,11 @@ package body Exp_Ch3 is
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
-- Build an assignment statement which assigns the default expression
-- to its corresponding record component if defined. The left hand side
-- of the assignment is marked Assignment_OK so that initialization of
function Build_Assignment
(Id : Entity_Id; Default : Node_Id) return List_Id;
-- Build an assignment statement that assigns the default expression to
-- its corresponding record component if defined. The left-hand side of
-- the assignment is marked Assignment_OK so that initialization of
-- limited private records works correctly. This routine may also build
-- an adjustment call if the component is controlled.
@ -1783,13 +1784,15 @@ package body Exp_Ch3 is
-- Build_Assignment --
----------------------
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
N_Loc : constant Source_Ptr := Sloc (N);
function Build_Assignment
(Id : Entity_Id; Default : Node_Id) return List_Id
is
Default_Loc : constant Source_Ptr := Sloc (Default);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
Adj_Call : Node_Id;
Exp : Node_Id := N;
Kind : Node_Kind := Nkind (N);
Exp : Node_Id := Default;
Kind : Node_Kind := Nkind (Default);
Lhs : Node_Id;
Res : List_Id;
@ -1815,10 +1818,11 @@ package body Exp_Ch3 is
and then Present (Discriminal_Link (Entity (N)))
then
Val :=
Make_Selected_Component (N_Loc,
Make_Selected_Component (Default_Loc,
Prefix => New_Copy_Tree (Lhs),
Selector_Name =>
New_Occurrence_Of (Discriminal_Link (Entity (N)), N_Loc));
New_Occurrence_Of
(Discriminal_Link (Entity (N)), Default_Loc));
if Present (Val) then
Rewrite (N, New_Copy_Tree (Val));
@ -1835,9 +1839,9 @@ package body Exp_Ch3 is
begin
Lhs :=
Make_Selected_Component (N_Loc,
Make_Selected_Component (Default_Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, N_Loc));
Selector_Name => New_Occurrence_Of (Id, Default_Loc));
Set_Assignment_OK (Lhs);
if Nkind (Exp) = N_Aggregate
@ -1866,16 +1870,16 @@ package body Exp_Ch3 is
-- traversing the expression. ???
if Kind = N_Attribute_Reference
and then Nam_In (Attribute_Name (N), Name_Unchecked_Access,
and then Nam_In (Attribute_Name (Default), Name_Unchecked_Access,
Name_Unrestricted_Access)
and then Is_Entity_Name (Prefix (N))
and then Is_Type (Entity (Prefix (N)))
and then Entity (Prefix (N)) = Rec_Type
and then Is_Entity_Name (Prefix (Default))
and then Is_Type (Entity (Prefix (Default)))
and then Entity (Prefix (Default)) = Rec_Type
then
Exp :=
Make_Attribute_Reference (N_Loc,
Make_Attribute_Reference (Default_Loc,
Prefix =>
Make_Identifier (N_Loc, Name_uInit),
Make_Identifier (Default_Loc, Name_uInit),
Attribute_Name => Name_Unrestricted_Access);
end if;
@ -1899,13 +1903,14 @@ package body Exp_Ch3 is
if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
Append_To (Res,
Make_Assignment_Statement (N_Loc,
Make_Assignment_Statement (Default_Loc,
Name =>
Make_Selected_Component (N_Loc,
Make_Selected_Component (Default_Loc,
Prefix =>
New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Typ), N_Loc)),
New_Occurrence_Of
(First_Tag_Component (Typ), Default_Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
@ -1913,19 +1918,19 @@ package body Exp_Ch3 is
(Node
(First_Elmt
(Access_Disp_Table (Underlying_Type (Typ)))),
N_Loc))));
Default_Loc))));
end if;
-- Adjust the component if controlled except if it is an aggregate
-- that will be expanded inline.
if Kind = N_Qualified_Expression then
Kind := Nkind (Expression (N));
Kind := Nkind (Expression (Default));
end if;
if Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
and then not Is_Limited_View (Typ)
and then not Is_Build_In_Place_Function_Call (Exp)
then
Adj_Call :=
Make_Adjust_Call
@ -6308,6 +6313,23 @@ package body Exp_Ch3 is
return;
-- This is the same as the previous 'elsif', except that the call has
-- been transformed by other expansion activities into something like
-- F(...)'Reference.
elsif Nkind (Expr_Q) = N_Reference
and then Is_Build_In_Place_Function_Call (Prefix (Expr_Q))
and then not Is_Expanded_Build_In_Place_Call
(Unqual_Conv (Prefix (Expr_Q)))
then
Make_Build_In_Place_Call_In_Anonymous_Context (Prefix (Expr_Q));
-- The previous call expands the expression initializing the
-- built-in-place object into further code that will be analyzed
-- later. No further expansion needed here.
return;
-- Ada 2005 (AI-318-02): Specialization of the previous case for
-- expressions containing a build-in-place function call whose
-- returned object covers interface types, and Expr_Q has calls to

43
gcc/ada/exp_ch6.adb
View File

@ -5298,16 +5298,39 @@ package body Exp_Ch6 is
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
Ret_Typ => Ret_Obj_Typ,
Alloc_Expr => Heap_Allocator)))),
Alloc_Expr => Heap_Allocator))),
-- ???If all is well, we can put the following
-- 'elsif' in the 'else', but this is a useful
-- self-check in case caller and callee don't agree
-- on whether BIPAlloc and so on should be passed.
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Obj_Alloc_Formal, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc,
UI_From_Int (BIP_Allocation_Form'Pos
(User_Storage_Pool)))),
Then_Statements => New_List (
Pool_Decl,
Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
Ret_Typ => Ret_Obj_Typ,
Alloc_Expr => Pool_Allocator)))),
-- Raise Program_Error if it's none of the above;
-- this is a compiler bug. ???PE_All_Guards_Closed
-- is bogus; we should have a new code.
Else_Statements => New_List (
Pool_Decl,
Build_Heap_Allocator
(Temp_Id => Alloc_Obj_Id,
Temp_Typ => Ref_Type,
Func_Id => Func_Id,
Ret_Typ => Ret_Obj_Typ,
Alloc_Expr => Pool_Allocator)));
Make_Raise_Program_Error (Loc,
Reason => PE_All_Guards_Closed)));
-- If a separate initialization assignment was created
-- earlier, append that following the assignment of the
@ -7205,6 +7228,10 @@ package body Exp_Ch6 is
function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean is
begin
if not Expander_Active then
return False;
end if;
-- In Ada 2005 all functions with an inherently limited return type
-- must be handled using a build-in-place profile, including the case
-- of a function with a limited interface result, where the function

2
gcc/ada/libgnarl/s-taprob.adb
View File

@ -75,7 +75,7 @@ package body System.Tasking.Protected_Objects is
begin
if Init_Priority = Unspecified_Priority then
Init_Priority := System.Priority'Last;
Init_Priority := System.Priority'Last;
end if;
Initialize_Lock (Init_Priority, Object.L'Access);

12
gcc/ada/libgnat/a-tags.adb
View File

@ -842,9 +842,21 @@ package body Ada.Tags is
begin
Curr_DT := DT (To_Tag_Ptr (This).all);
-- See the documentation of Dispatch_Table_Wrapper.Offset_To_Top
if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then
-- The parent record type has variable-size components, so the
-- instance-specific offset is stored in the tagged record, right
-- after the reference to Curr_DT (which is a secondary dispatch
-- table).
return To_Storage_Offset_Ptr (This + Tag_Size).all;
else
-- The offset is compile-time known, so it is simply stored in the
-- Offset_To_Top field.
return Curr_DT.Offset_To_Top;
end if;
end Offset_To_Top;

13
gcc/ada/libgnat/a-tags.ads
View File

@ -380,12 +380,21 @@ private
-- Prims_Ptr table.
Offset_To_Top : SSE.Storage_Offset;
TSD : System.Address;
-- Offset between the _Tag field and the field that contains the
-- reference to this dispatch table. For primary dispatch tables it is
-- zero. For secondary dispatch tables: if the parent record type (if
-- any) has a compile-time-known size, then Offset_To_Top contains the
-- expected value, otherwise it contains SSE.Storage_Offset'Last and the
-- actual offset is to be found in the tagged record, right after the
-- field that contains the reference to this dispatch table. See the
-- implementation of Ada.Tags.Offset_To_Top for the corresponding logic.
TSD : System.Address;
Prims_Ptr : aliased Address_Array (1 .. Num_Prims);
-- The size of the Prims_Ptr array actually depends on the tagged type
-- to which it applies. For each tagged type, the expander computes the
-- actual array size, allocates the Dispatch_Table record accordingly.
-- actual array size, allocating the Dispatch_Table record accordingly.
end record;
type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper;

2
gcc/ada/namet.ads
View File

@ -477,7 +477,7 @@ package Namet is
-- Sets the Int value associated with the given name
function Is_Internal_Name (Id : Name_Id) return Boolean;
-- Returns True if the name is an internal name (i.e. contains a character
-- Returns True if the name is an internal name, i.e. contains a character
-- for which Is_OK_Internal_Letter is true, or if the name starts or ends
-- with an underscore.
--

37
gcc/ada/sem_aggr.adb
View File

@ -30,6 +30,7 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
@ -2932,6 +2933,11 @@ package body Sem_Aggr is
-- Verify that the type of the ancestor part is a non-private ancestor
-- of the expected type, which must be a type extension.
procedure Transform_BIP_Assignment (Typ : Entity_Id);
-- For an extension aggregate whose ancestor part is a build-in-place
-- call returning a nonlimited type, this is used to transform the
-- assignment to the ancestor part to use a temp.
----------------------------
-- Valid_Limited_Ancestor --
----------------------------
@ -3013,6 +3019,23 @@ package body Sem_Aggr is
return False;
end Valid_Ancestor_Type;
procedure Transform_BIP_Assignment (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A);
Obj_Decl : constant Node_Id :=
Make_Object_Declaration
(Loc,
Defining_Identifier => Def_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => A,
Has_Init_Expression => True);
begin
Set_Etype (Def_Id, Typ);
Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc));
Insert_Action (N, Obj_Decl);
end Transform_BIP_Assignment;
-- Start of processing for Resolve_Extension_Aggregate
begin
@ -3081,7 +3104,7 @@ package body Sem_Aggr is
Get_First_Interp (A, I, It);
while Present (It.Typ) loop
-- Only consider limited interpretations in the Ada 2005 case
-- Consider limited interpretations if Ada 2005 or higher
if Is_Tagged_Type (It.Typ)
and then (Ada_Version >= Ada_2005
@ -3177,6 +3200,18 @@ package body Sem_Aggr is
Error_Msg_N ("ancestor part must be statically tagged", A);
else
-- We are using the build-in-place protocol, but we can't build
-- in place, because we need to call the function before
-- allocating the aggregate. Could do better for null
-- extensions, and maybe for nondiscriminated types.
-- This is wrong for limited, but those were wrong already.
if not Is_Limited_View (A_Type)
and then Is_Build_In_Place_Function_Call (A)
then
Transform_BIP_Assignment (A_Type);
end if;
Resolve_Record_Aggregate (N, Typ);
end if;
end if;

1
gcc/ada/sem_aux.adb
View File

@ -1693,6 +1693,7 @@ package body Sem_Aux is
and then Nkind (N) /= N_Package_Renaming_Declaration
and then Nkind (N) /= N_Procedure_Instantiation
and then Nkind (N) /= N_Protected_Body
and then Nkind (N) /= N_Protected_Type_Declaration
and then Nkind (N) /= N_Subprogram_Declaration
and then Nkind (N) /= N_Subprogram_Body
and then Nkind (N) /= N_Subprogram_Body_Stub

72
gcc/ada/sem_ch12.adb
View File

@ -1903,7 +1903,8 @@ package body Sem_Ch12 is
-- body.
Explicit_Freeze_Check : declare
Actual : constant Entity_Id := Entity (Match);
Actual : constant Entity_Id := Entity (Match);
Gen_Par : Entity_Id;
Needs_Freezing : Boolean;
S : Entity_Id;
@ -1912,7 +1913,11 @@ package body Sem_Ch12 is
-- The actual may be an instantiation of a unit
-- declared in a previous instantiation. If that
-- one is also in the current compilation, it must
-- itself be frozen before the actual.
-- itself be frozen before the actual. The actual
-- may be an instantiation of a generic child unit,
-- in which case the same applies to the instance
-- of the parent which must be frozen before the
-- actual.
-- Should this itself be recursive ???
--------------------------
@ -1920,30 +1925,71 @@ package body Sem_Ch12 is
--------------------------
procedure Check_Generic_Parent is
Par : Entity_Id;
Inst : constant Node_Id :=
Next (Unit_Declaration_Node (Actual));
Par : Entity_Id;
begin
if Nkind (Parent (Actual)) =
N_Package_Specification
Par := Empty;
if Nkind (Parent (Actual)) = N_Package_Specification
then
Par := Scope (Generic_Parent (Parent (Actual)));
if Is_Generic_Instance (Par) then
null;
if Is_Generic_Instance (Par)
and then Scope (Par) = Current_Scope
and then
(No (Freeze_Node (Par))
or else
not Is_List_Member (Freeze_Node (Par)))
-- If the actual is a child generic unit, check
-- whether the instantiation of the parent is
-- also local and must also be frozen now.
-- We must retrieve the instance node to locate
-- the parent instance if any.
elsif Ekind (Par) = E_Generic_Package
and then Is_Child_Unit (Gen_Par)
and then Ekind (Scope (Gen_Par))
= E_Generic_Package
then
Set_Has_Delayed_Freeze (Par);
Append_Elmt (Par, Actuals_To_Freeze);
if Nkind (Inst) = N_Package_Instantiation
and then
Nkind (Name (Inst)) = N_Expanded_Name
then
-- Retrieve entity of psarent instance.
Par := Entity (Prefix (Name (Inst)));
end if;
else
Par := Empty;
end if;
end if;
if Present (Par)
and then Is_Generic_Instance (Par)
and then Scope (Par) = Current_Scope
and then
(No (Freeze_Node (Par))
or else
not Is_List_Member (Freeze_Node (Par)))
then
Set_Has_Delayed_Freeze (Par);
Append_Elmt (Par, Actuals_To_Freeze);
end if;
end Check_Generic_Parent;
-- Start of processing for Explicit_Freeze_Check
begin
if Present (Renamed_Entity (Actual)) then
Gen_Par :=
Generic_Parent (Specification (
Unit_Declaration_Node (
Renamed_Entity (Actual))));
else
Gen_Par := Generic_Parent
(Specification (Unit_Declaration_Node (Actual)));
end if;
if not Expander_Active
or else not Has_Completion (Actual)
or else not In_Same_Source_Unit (I_Node, Actual)

34
gcc/ada/sem_ch3.adb
View File

@ -10257,7 +10257,22 @@ package body Sem_Ch3 is
return;
else
Set_Itype (IR, Ityp);
Insert_After (Nod, IR);
-- If Nod is a library unit entity, then Insert_After won't work,
-- because Nod is not a member of any list. Therefore, we use
-- Add_Global_Declaration in this case. This can happen if we have a
-- build-in-place library function.
if (Nkind (Nod) in N_Entity
and then Is_Compilation_Unit (Nod))
or else
(Nkind (Nod) = N_Defining_Program_Unit_Name
and then Is_Compilation_Unit (Defining_Identifier (Nod)))
then
Add_Global_Declaration (IR);
else
Insert_After (Nod, IR);
end if;
end if;
end Build_Itype_Reference;
@ -11777,9 +11792,20 @@ package body Sem_Ch3 is
if Nkind (Exp) = N_Type_Conversion
and then Nkind (Expression (Exp)) = N_Function_Call
then
Error_Msg_N
("illegal context for call"
& " to function with limited result", Exp);
-- No error for internally-generated object declarations,
-- which can come from build-in-place assignment statements.
if Nkind (Parent (Exp)) = N_Object_Declaration
and then not Comes_From_Source
(Defining_Identifier (Parent (Exp)))
then
null;
else
Error_Msg_N
("illegal context for call"
& " to function with limited result", Exp);
end if;
else
Error_Msg_N

119
gcc/ada/sem_ch5.adb
View File

@ -101,13 +101,7 @@ package body Sem_Ch5 is
procedure Analyze_Assignment (N : Node_Id) is
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
Decl : Node_Id;
T1 : Entity_Id;
T2 : Entity_Id;
Save_Full_Analysis : Boolean := False; -- initialize to prevent warning
Rhs : Node_Id := Expression (N);
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it is not
@ -126,6 +120,93 @@ package body Sem_Ch5 is
-- nominal subtype. This procedure is used to deal with cases where the
-- nominal subtype must be replaced by the actual subtype.
procedure Transform_BIP_Assignment (Typ : Entity_Id);
function Should_Transform_BIP_Assignment
(Typ : Entity_Id) return Boolean;
-- If the right-hand side of an assignment statement is a build-in-place
-- call we cannot build in place, so we insert a temp initialized with
-- the call, and transform the assignment statement to copy the temp.
-- Transform_BIP_Assignment does the tranformation, and
-- Should_Transform_BIP_Assignment determines whether we should.
-- The same goes for qualified expressions and conversions whose
-- operand is such a call.
--
-- This is only for nonlimited types; assignment statements are illegal
-- for limited types, but are generated internally for aggregates and
-- init procs. These limited-type are not really assignment statements
-- -- conceptually, they are initializations, so should not be
-- transformed.
--
-- Similarly, for nonlimited types, aggregates and init procs generate
-- assignment statements that are really initializations. These are
-- marked No_Ctrl_Actions.
function Should_Transform_BIP_Assignment
(Typ : Entity_Id) return Boolean
is
Result : Boolean;
begin
if Expander_Active
and then not Is_Limited_View (Typ)
and then Is_Build_In_Place_Result_Type (Typ)
and then not No_Ctrl_Actions (N)
then
-- This function is called early, before name resolution is
-- complete, so we have to deal with things that might turn into
-- function calls later. N_Function_Call and N_Op nodes are the
-- obvious case. An N_Identifier or N_Expanded_Name is a
-- parameterless function call if it denotes a function.
-- Finally, an attribute reference can be a function call.
case Nkind (Unqual_Conv (Rhs)) is
when N_Function_Call | N_Op =>
Result := True;
when N_Identifier | N_Expanded_Name =>
case Ekind (Entity (Unqual_Conv (Rhs))) is
when E_Function | E_Operator =>
Result := True;
when others =>
Result := False;
end case;
when N_Attribute_Reference =>
Result := Attribute_Name (Unqual_Conv (Rhs)) = Name_Input;
-- T'Input will turn into a call whose result type is T
when others =>
Result := False;
end case;
else
Result := False;
end if;
return Result;
end Should_Transform_BIP_Assignment;
procedure Transform_BIP_Assignment (Typ : Entity_Id) is
-- Tranform "X : [constant] T := F (...);" into:
--
-- Temp : constant T := F (...);
-- X := Temp;
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', Rhs);
Obj_Decl : constant Node_Id :=
Make_Object_Declaration
(Loc,
Defining_Identifier => Def_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Rhs,
Has_Init_Expression => True);
begin
Set_Etype (Def_Id, Typ);
Set_Expression (N, New_Occurrence_Of (Def_Id, Loc));
-- At this point, Rhs is no longer equal to Expression (N), so:
Rhs := Expression (N);
Insert_Action (N, Obj_Decl);
end Transform_BIP_Assignment;
-------------------------------
-- Diagnose_Non_Variable_Lhs --
-------------------------------
@ -232,6 +313,7 @@ package body Sem_Ch5 is
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id)
is
Decl : Node_Id;
begin
Require_Entity (Opnd);
@ -284,6 +366,11 @@ package body Sem_Ch5 is
-- Local variables
T1 : Entity_Id;
T2 : Entity_Id;
Save_Full_Analysis : Boolean;
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
-- Save the Ghost mode to restore on exit
@ -360,8 +447,9 @@ package body Sem_Ch5 is
null;
elsif Has_Compatible_Type (Rhs, It.Typ) then
if T1 /= Any_Type then
if T1 = Any_Type then
T1 := It.Typ;
else
-- An explicit dereference is overloaded if the prefix
-- is. Try to remove the ambiguity on the prefix, the
-- error will be posted there if the ambiguity is real.
@ -412,8 +500,6 @@ package body Sem_Ch5 is
("ambiguous left-hand side in assignment", Lhs);
exit;
end if;
else
T1 := It.Typ;
end if;
end if;
@ -429,6 +515,15 @@ package body Sem_Ch5 is
end if;
end if;
-- Deal with build-in-place calls for nonlimited types.
-- We don't do this later, because resolving the rhs
-- tranforms it incorrectly for build-in-place.
if Should_Transform_BIP_Assignment (Typ => T1) then
Transform_BIP_Assignment (Typ => T1);
end if;
pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
-- The resulting assignment type is T1, so now we will resolve the left
-- hand side of the assignment using this determined type.
@ -971,6 +1066,8 @@ package body Sem_Ch5 is
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end if;
pragma Assert (not Should_Transform_BIP_Assignment (Typ => T1));
end Analyze_Assignment;
-----------------------------

2
gcc/ada/sem_ch6.adb
View File

@ -8002,7 +8002,7 @@ package body Sem_Ch6 is
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
if Ada_Version >= Ada_2005 and then Is_Build_In_Place_Function (E) then
if Is_Build_In_Place_Function (E) then
declare
Result_Subt : constant Entity_Id := Etype (E);
Full_Subt : constant Entity_Id := Available_View (Result_Subt);

35
gcc/ada/sem_ch7.adb
View File

@ -199,7 +199,7 @@ package body Sem_Ch7 is
subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1;
-- Range of headers in hash table
function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
function Node_Hash (Id : Entity_Id) return Entity_Header_Num;
-- Simple hash function for Entity_Ids
package Subprogram_Table is new GNAT.Htable.Simple_HTable
@ -207,19 +207,29 @@ package body Sem_Ch7 is
Element => Boolean,
No_Element => False,
Key => Entity_Id,
Hash => Entity_Hash,
Hash => Node_Hash,
Equal => "=");
-- Hash table to record which subprograms are referenced. It is declared
-- at library level to avoid elaborating it for every call to Analyze.
package Traversed_Table is new GNAT.Htable.Simple_HTable
(Header_Num => Entity_Header_Num,
Element => Boolean,
No_Element => False,
Key => Node_Id,
Hash => Node_Hash,
Equal => "=");
-- Hash table to record which nodes we have traversed, so we can avoid
-- traversing the same nodes repeatedly.
-----------------
-- Entity_Hash --
-- Node_Hash --
-----------------
function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
function Node_Hash (Id : Entity_Id) return Entity_Header_Num is
begin
return Entity_Header_Num (Id mod Entity_Table_Size);
end Entity_Hash;
end Node_Hash;
---------------------------------
-- Analyze_Package_Body_Helper --
@ -260,13 +270,25 @@ package body Sem_Ch7 is
function Scan_Subprogram_Ref (N : Node_Id) return Traverse_Result;
-- Determine whether a node denotes a reference to a subprogram
procedure Scan_Subprogram_Refs is
procedure Traverse_And_Scan_Subprogram_Refs is
new Traverse_Proc (Scan_Subprogram_Ref);
-- Subsidiary to routine Has_Referencer. Determine whether a node
-- contains references to a subprogram and record them.
-- WARNING: this is a very expensive routine as it performs a full
-- tree traversal.
procedure Scan_Subprogram_Refs (Node : Node_Id);
-- If we haven't already traversed Node, then mark it and traverse
-- it.
procedure Scan_Subprogram_Refs (Node : Node_Id) is
begin
if not Traversed_Table.Get (Node) then
Traversed_Table.Set (Node, True);
Traverse_And_Scan_Subprogram_Refs (Node);
end if;
end Scan_Subprogram_Refs;
--------------------
-- Has_Referencer --
--------------------
@ -581,6 +603,7 @@ package body Sem_Ch7 is
-- actual parameters of the instantiations matter here, and they are
-- present in the declarations list of the instantiated packages.
Traversed_Table.Reset;
Subprogram_Table.Reset;
Discard := Has_Referencer (Decls, Top_Level => True);
end Hide_Public_Entities;

4
gcc/ada/sem_ch8.adb
View File

@ -9069,7 +9069,7 @@ package body Sem_Ch8 is
(Current_Use_Clause (Associated_Node (N))))
then
Error_Msg_Node_1 := Entity (N);
Error_Msg_NE ("ineffective use clause for package &?",
Error_Msg_NE ("use clause for package &? has no effect",
Curr, Entity (N));
end if;
@ -9077,7 +9077,7 @@ package body Sem_Ch8 is
else
Error_Msg_Node_1 := Etype (N);
Error_Msg_NE ("ineffective use clause for }?",
Error_Msg_NE ("use clause for }? has no effect",
Curr, Etype (N));
end if;
end if;

13
gcc/ada/sem_util.adb
View File

@ -19059,7 +19059,18 @@ package body Sem_Util is
N := Next (Actual_Id);
if Nkind (N) = N_Parameter_Association then
return First_Named_Actual (Parent (Actual_Id));
-- In case of a build-in-place call, the call will no longer be a
-- call; it will have been rewritten.
if Nkind_In (Parent (Actual_Id),
N_Entry_Call_Statement,
N_Function_Call,
N_Procedure_Call_Statement)
then
return First_Named_Actual (Parent (Actual_Id));
else
return Empty;
end if;
else
return N;
end if;

11
gcc/testsuite/gnat.dg/validity_check2.adb Normal file
View File

@ -0,0 +1,11 @@
-- { dg-do compile }
-- { dg-options "-gnatVi -gnatws" }
with Validity_Check2_Pkg; use Validity_Check2_Pkg;
procedure Validity_Check2 (R : access Rec) is
begin
if Op_Code_To_Msg (R.Code) in Valid_Msg then
raise Program_Error;
end if;
end;

16
gcc/testsuite/gnat.dg/validity_check2_pkg.ads Normal file
View File

@ -0,0 +1,16 @@
with Ada.unchecked_conversion;
package Validity_Check2_Pkg is
type Op_Code is (One, Two, Three, Four);
subtype Valid_Msg is Integer range 0 .. 15;
function Op_Code_To_Msg is
new Ada.Unchecked_Conversion (Source => Op_code, Target => Valid_Msg);
type Rec is record
Code : Op_Code;
end record;
end Validity_Check2_Pkg;