[multiple changes]

2015-11-13  Eric Botcazou  <ebotcazou@adacore.com>

	* sigtramp-ios.c, init.c: Minor cosmetic tweaks.

2015-11-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* s-gloloc.adb, g-debpoo.adb: Minor reformatting.

2015-11-13  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): Improve error
	message for the case the iterable name (array or container)
	is a component that depends on a discriminant.

2015-11-13  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Indicate_Name_And_Type): If the analysis of
	one interpretation succeeds, set type of name in call, for
	completeness.
	(Try_Container_Indexing): If there are multiple indexing
	functions, collect possible interpretations that are compatible
	with given parameters, and add implicit dereference types when
	present.
	* sem_util.adb (Build_Explicit_Dereference): If the expression
	is an overloaded function call use the given discriminant to
	resolve the call, and set properly the type of the call and of
	the resulting dereference.

2015-11-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Pragma Constant_After_Elaboration can
	now apply to a variable without an initialization expression.

2015-11-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch9.adb (Add_Matching_Formals): Parameter Actuals is now of mode
	IN OUT. Create a new list when list Actuals is not present.
	(Build_Contract_Wrapper): Create the wrapper
	only when the entry has at least on checked contract case or
	pre/postcondition. Ensure that the call to the original entry
	lacks an actual parameter list when the entry appears without
	formal parameters.
	(Expand_Entry_Declaration): Code cleanup.

2015-11-13  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Continue the analysis
	after encountering an illegal aspect Part_Of.

2015-11-13  Ed Schonberg  <schonberg@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, case
	Overlaps_Storage): Add copies for nodes that represent the integer
	addresses of the two actuals, to prevent identical nodes in the
	tree, which the backend cannot handle properly.

From-SVN: r230316
This commit is contained in:
Arnaud Charlet 2015-11-13 14:14:44 +01:00
parent 6672e40209
commit 90b510e4aa
12 changed files with 192 additions and 90 deletions

View File

@ -1,3 +1,59 @@
2015-11-13 Eric Botcazou <ebotcazou@adacore.com>
* sigtramp-ios.c, init.c: Minor cosmetic tweaks.
2015-11-13 Hristian Kirtchev <kirtchev@adacore.com>
* s-gloloc.adb, g-debpoo.adb: Minor reformatting.
2015-11-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): Improve error
message for the case the iterable name (array or container)
is a component that depends on a discriminant.
2015-11-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Indicate_Name_And_Type): If the analysis of
one interpretation succeeds, set type of name in call, for
completeness.
(Try_Container_Indexing): If there are multiple indexing
functions, collect possible interpretations that are compatible
with given parameters, and add implicit dereference types when
present.
* sem_util.adb (Build_Explicit_Dereference): If the expression
is an overloaded function call use the given discriminant to
resolve the call, and set properly the type of the call and of
the resulting dereference.
2015-11-13 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Pragma): Pragma Constant_After_Elaboration can
now apply to a variable without an initialization expression.
2015-11-13 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb (Add_Matching_Formals): Parameter Actuals is now of mode
IN OUT. Create a new list when list Actuals is not present.
(Build_Contract_Wrapper): Create the wrapper
only when the entry has at least on checked contract case or
pre/postcondition. Ensure that the call to the original entry
lacks an actual parameter list when the entry appears without
formal parameters.
(Expand_Entry_Declaration): Code cleanup.
2015-11-13 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Continue the analysis
after encountering an illegal aspect Part_Of.
2015-11-13 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case
Overlaps_Storage): Add copies for nodes that represent the integer
addresses of the two actuals, to prevent identical nodes in the
tree, which the backend cannot handle properly.
2015-11-13 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Change

View File

@ -4462,7 +4462,7 @@ package body Exp_Attr is
X : constant Node_Id := Prefix (N);
Y : constant Node_Id := First (Expressions (N));
-- The argumens
-- The arguments
X_Addr, Y_Addr : Node_Id;
-- the expressions for their integer addresses
@ -4483,7 +4483,9 @@ package body Exp_Attr is
-- with the proper address operations. We convert addresses to
-- integer addresses to use predefined arithmetic. The size is
-- expressed in storage units.
-- expressed in storage units. We add copies of X_Addr and Y_Addr
-- to prevent the appearance of the same node in two places in
-- the tree.
X_Addr :=
Unchecked_Convert_To (RTE (RE_Integer_Address),
@ -4528,7 +4530,7 @@ package body Exp_Attr is
Make_Op_Ge (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => X_Addr,
Left_Opnd => New_Copy_Tree (X_Addr),
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => X_Size,
@ -4537,7 +4539,7 @@ package body Exp_Attr is
Make_Op_Ge (Loc,
Make_Op_Add (Loc,
Left_Opnd => Y_Addr,
Left_Opnd => New_Copy_Tree (Y_Addr),
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => Y_Size,

View File

@ -1234,7 +1234,9 @@ package body Exp_Ch9 is
-- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which
-- represents the concurrent object.
procedure Add_Matching_Formals (Formals : List_Id; Actuals : List_Id);
procedure Add_Matching_Formals
(Formals : List_Id;
Actuals : in out List_Id);
-- Add formal parameters that match those of entry E to list Formals.
-- The routine also adds matching actuals for the new formals to list
-- Actuals.
@ -1281,7 +1283,10 @@ package body Exp_Ch9 is
-- Add_Matching_Formals --
--------------------------
procedure Add_Matching_Formals (Formals : List_Id; Actuals : List_Id) is
procedure Add_Matching_Formals
(Formals : List_Id;
Actuals : in out List_Id)
is
Formal : Entity_Id;
New_Formal : Entity_Id;
@ -1301,6 +1306,10 @@ package body Exp_Ch9 is
Parameter_Type =>
New_Occurrence_Of (Etype (Formal), Loc)));
if No (Actuals) then
Actuals := New_List;
end if;
Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc));
Next_Formal (Formal);
end loop;
@ -1327,7 +1336,7 @@ package body Exp_Ch9 is
-- Local variables
Items : constant Node_Id := Contract (E);
Actuals : List_Id;
Actuals : List_Id := No_List;
Call : Node_Id;
Call_Nam : Node_Id;
Decls : List_Id := No_List;
@ -1384,6 +1393,7 @@ package body Exp_Ch9 is
while Present (Prag) loop
if Nam_In (Pragma_Name (Prag), Name_Postcondition,
Name_Precondition)
and then Is_Checked (Prag)
then
Has_Pragma := True;
Transfer_Pragma (Prag, To => Decls);
@ -1397,7 +1407,9 @@ package body Exp_Ch9 is
Prag := Contract_Test_Cases (Items);
while Present (Prag) loop
if Pragma_Name (Prag) = Name_Contract_Cases then
if Pragma_Name (Prag) = Name_Contract_Cases
and then Is_Checked (Prag)
then
Has_Pragma := True;
Transfer_Pragma (Prag, To => Decls);
end if;
@ -1455,17 +1467,16 @@ package body Exp_Ch9 is
Expressions => New_List (New_Occurrence_Of (Index_Id, Loc)));
end if;
Actuals := New_List;
Call :=
Make_Procedure_Call_Statement (Loc,
Name => Call_Nam,
Parameter_Associations => Actuals);
-- Add formal parameters to match those of the entry and build actuals
-- for the entry call.
Add_Matching_Formals (Formals, Actuals);
Call :=
Make_Procedure_Call_Statement (Loc,
Name => Call_Nam,
Parameter_Associations => Actuals);
-- Add renaming declarations for the discriminants of the enclosing type
-- as the various contract items may reference them.
@ -9030,7 +9041,6 @@ package body Exp_Ch9 is
Body_Id : Entity_Id;
Cdecls : List_Id;
Comp : Node_Id;
Comp_Id : Entity_Id;
Current_Node : Node_Id := N;
E_Count : Int;
Entries_Aggr : Node_Id;
@ -9038,7 +9048,6 @@ package body Exp_Ch9 is
Object_Comp : Node_Id;
Priv : Node_Id;
Rec_Decl : Node_Id;
Sub : Node_Id;
procedure Check_Inlining (Subp : Entity_Id);
-- If the original operation has a pragma Inline, propagate the flag
@ -9051,9 +9060,9 @@ package body Exp_Ch9 is
-- static because of a discriminant constraint we can specialize the
-- warning by mentioning discriminants explicitly.
procedure Expand_Entry_Declaration (Comp : Entity_Id);
-- Create the subprograms for the barrier and for the body, and append
-- then to Entry_Bodies_Array.
procedure Expand_Entry_Declaration (Decl : Node_Id);
-- Create the entry barrier and the procedure body for entry declaration
-- Decl. All generated subprograms are added to Entry_Bodies_Array.
function Static_Component_Size (Comp : Entity_Id) return Boolean;
-- When compiling under the Ravenscar profile, private components must
@ -9173,51 +9182,57 @@ package body Exp_Ch9 is
-- Expand_Entry_Declaration --
------------------------------
procedure Expand_Entry_Declaration (Comp : Entity_Id) is
Bdef : Entity_Id;
Edef : Entity_Id;
procedure Expand_Entry_Declaration (Decl : Node_Id) is
Ent_Id : constant Entity_Id := Defining_Entity (Decl);
Bar_Id : Entity_Id;
Bod_Id : Entity_Id;
Subp : Node_Id;
begin
E_Count := E_Count + 1;
Comp_Id := Defining_Identifier (Comp);
Edef :=
-- Create the protected body subprogram
Bod_Id :=
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E'));
Sub :=
Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E'));
Set_Protected_Body_Subprogram (Ent_Id, Bod_Id);
Subp :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Entry_Specification (Loc, Edef, Comp_Id));
Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id));
Insert_After (Current_Node, Sub);
Analyze (Sub);
Insert_After (Current_Node, Subp);
Current_Node := Subp;
Analyze (Subp);
-- Build a wrapper procedure to handle contract cases, preconditions,
-- and postconditions.
Build_Contract_Wrapper (Comp_Id, N);
Build_Contract_Wrapper (Ent_Id, N);
Set_Protected_Body_Subprogram
(Defining_Identifier (Comp),
Defining_Unit_Name (Specification (Sub)));
-- Create the barrier function
Current_Node := Sub;
Bdef :=
Bar_Id :=
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B'));
Sub :=
Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B'));
Set_Barrier_Function (Ent_Id, Bar_Id);
Subp :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Barrier_Function_Specification (Loc, Bdef));
Set_Is_Entry_Barrier_Function (Sub);
Build_Barrier_Function_Specification (Loc, Bar_Id));
Set_Is_Entry_Barrier_Function (Subp);
Insert_After (Current_Node, Sub);
Analyze (Sub);
Set_Protected_Body_Subprogram (Bdef, Bdef);
Set_Barrier_Function (Comp_Id, Bdef);
Set_Scope (Bdef, Scope (Comp_Id));
Current_Node := Sub;
Insert_After (Current_Node, Subp);
Current_Node := Subp;
Analyze (Subp);
Set_Protected_Body_Subprogram (Bar_Id, Bar_Id);
Set_Scope (Bar_Id, Scope (Ent_Id));
-- Collect pointers to the protected subprogram and the barrier
-- of the current entry, for insertion into Entry_Bodies_Array.
@ -9226,10 +9241,10 @@ package body Exp_Ch9 is
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Bdef, Loc),
Prefix => New_Occurrence_Of (Bar_Id, Loc),
Attribute_Name => Name_Unrestricted_Access),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Edef, Loc),
Prefix => New_Occurrence_Of (Bod_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end Expand_Entry_Declaration;
@ -9260,6 +9275,10 @@ package body Exp_Ch9 is
Append_Freeze_Action (Prot_Proc, RTS_Call);
end Register_Handler;
-- Local variables
Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration
begin

View File

@ -482,6 +482,7 @@ package body GNAT.Debug_Pools is
-- Warning: secondary stack cannot be used here. When System.Memory
-- implementation uses Debug_Pool, Print_Address can be called during
-- secondary stack creation for foreign threads.
Put (File, Image_C (Addr));
end Print_Address;

View File

@ -324,9 +324,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
propagation after the required low level adjustments. */
static void
__gnat_error_handler (int sig,
siginfo_t *si ATTRIBUTE_UNUSED,
void *ucontext ATTRIBUTE_UNUSED)
__gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext)
{
struct Exception_Data *exception;
const char *msg;
@ -683,7 +681,7 @@ __gnat_error_handler (int sig)
}
void
__gnat_install_handler(void)
__gnat_install_handler (void)
{
struct sigaction act;
@ -1930,10 +1928,9 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
void *sc ATTRIBUTE_UNUSED)
{
/* In case of ARM exceptions, the registers context have the PC pointing
to the instruction that raised the signal. However the Unwinder expects
the instruction to be in the range ]PC,PC+1].
*/
uintptr_t *pc_addr; /* address of the pc value to restore */
to the instruction that raised the signal. However the unwinder expects
the instruction to be in the range ]PC,PC+1]. */
uintptr_t *pc_addr;
#ifdef __RTP__
mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext;
pc_addr = (uintptr_t*)&mcontext->regs.pc;
@ -1997,7 +1994,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
__gnat_adjust_context_for_raise (sig, sc);
#endif
#include "sigtramp.h"
#include "sigtramp.h"
__gnat_sigtramp (sig, (void *)si, (void *)sc,
(__sigtramphandler_t *)&__gnat_map_signal);
@ -2189,7 +2186,7 @@ __gnat_error_handler (int sig)
}
void
__gnat_install_handler(void)
__gnat_install_handler (void)
{
struct sigaction act;
@ -2252,7 +2249,7 @@ __gnat_error_handler (int sig)
}
void
__gnat_install_handler(void)
__gnat_install_handler (void)
{
struct sigaction act;
@ -2443,8 +2440,8 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
{
__gnat_adjust_context_for_raise (sig, ucontext);
/* The Darwin libc comes with a signal trampoline, except for ARM64. */
#ifdef __arm64__
/* Use a trampoline so that the unwinder won't see the signal frame. */
__gnat_sigtramp (sig, (void *)si, ucontext,
(__sigtramphandler_t *)&__gnat_map_signal);
#else
@ -2515,7 +2512,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
static void
__gnat_map_signal (int sig,
siginfo_t *si ATTRIBUTE_UNUSED,
void *ucontext ATTRIBUTE_UNUSED)
void *mcontext ATTRIBUTE_UNUSED)
{
struct Exception_Data *exception;
const char *msg;
@ -2546,9 +2543,7 @@ __gnat_map_signal (int sig,
}
static void
__gnat_error_handler (int sig,
siginfo_t *si ATTRIBUTE_UNUSED,
void *ucontext ATTRIBUTE_UNUSED)
__gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
{
__gnat_adjust_context_for_raise (sig, ucontext);

View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -51,7 +51,7 @@ package body System.Global_Locks is
File : String;
Wait : Duration := 0.1;
Retries : Natural := Natural'Last);
-- Create a lock file File in directory Dir. If the file cannot be
-- Create a lock file File in directory Dir. If the file cannot be
-- locked because someone already owns the lock, this procedure
-- waits Wait seconds and retries at most Retries times. If the file
-- still cannot be locked, Lock_Error is raised. The default is to try

View File

@ -2673,7 +2673,6 @@ package body Sem_Ch13 is
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
else
Error_Msg_NE
@ -2682,6 +2681,8 @@ package body Sem_Ch13 is
Aspect, Id);
end if;
goto Continue;
-- SPARK_Mode
when Aspect_SPARK_Mode =>

View File

@ -3073,6 +3073,7 @@ package body Sem_Ch4 is
if not Is_Type (Nam) then
if Is_Entity_Name (Name (N)) then
Set_Entity (Name (N), Nam);
Set_Etype (Name (N), Etype (Nam));
elsif Nkind (Name (N)) = N_Selected_Component then
Set_Entity (Selector_Name (Name (N)), Nam);
@ -7456,6 +7457,9 @@ package body Sem_Ch4 is
end if;
else
-- If there are multiple indexing functions, build a function call
-- and analyze it for each of the possible interpretations.
Indexing :=
Make_Function_Call (Loc,
Name =>
@ -7464,6 +7468,8 @@ package body Sem_Ch4 is
Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing);
Set_Etype (N, Any_Type);
Set_Etype (Name (Indexing), Any_Type);
declare
I : Interp_Index;
@ -7473,21 +7479,24 @@ package body Sem_Ch4 is
begin
Get_First_Interp (Func_Name, I, It);
Set_Etype (Indexing, Any_Type);
while Present (It.Nam) loop
Analyze_One_Call (Indexing, It.Nam, False, Success);
if Success then
Set_Etype (Name (Indexing), It.Typ);
Set_Entity (Name (Indexing), It.Nam);
Set_Etype (N, Etype (Indexing));
-- Add implicit dereference interpretation
-- Function in current interpretation is a valid candidate.
-- Its result type is also a potential type for the
-- original Indexed_Component node.
Add_One_Interp (Name (Indexing), It.Nam, It.Typ);
Add_One_Interp (N, It.Nam, It.Typ);
-- Add implicit dereference interpretation to original node
if Has_Discriminants (Etype (It.Nam)) then
Check_Implicit_Dereference (N, Etype (It.Nam));
end if;
exit;
end if;
Get_Next_Interp (I, It);

View File

@ -2057,19 +2057,20 @@ package body Sem_Ch5 is
Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ));
-- AI12-0151 stipulates that the container cannot be a component
-- that depends on a discriminant if the enclosing object is
-- mutable, to prevent a modification of the container in the
-- course of an iteration.
-- AI12-0047 stipulates that the domain (array or container)
-- cannot be a component that depends on a discriminant if the
-- enclosing object is mutable, to prevent a modification of the
-- dowmain of iteration in the course of an iteration.
-- Should comment on need to go to Original_Node ???
-- If the object is an expression it has been captured in a
-- temporary, so examine original node.
if Nkind (Original_Node (Iter_Name)) = N_Selected_Component
and then Is_Dependent_Component_Of_Mutable_Object
(Original_Node (Iter_Name))
then
Error_Msg_N
("container cannot be a discriminant-dependent "
("iterable name cannot be a discriminant-dependent "
& "component of a mutable object", N);
end if;

View File

@ -12604,22 +12604,15 @@ package body Sem_Prag is
Obj_Id := Defining_Entity (Obj_Decl);
-- The object declaration must be a library-level variable with
-- an initialization expression. The expression must depend on
-- a variable, parameter, or another constant_after_elaboration,
-- but the compiler cannot detect this property, as this requires
-- full flow analysis (SPARK RM 3.3.1).
-- The object declaration must be a library-level variable which
-- is either explicitly initialized or obtains a value during the
-- elaboration of a package body (SPARK RM 3.3.1).
if Ekind (Obj_Id) = E_Variable then
if not Is_Library_Level_Entity (Obj_Id) then
Error_Pragma
("pragma % must apply to a library level variable");
return;
elsif not Has_Init_Expression (Obj_Decl) then
Error_Pragma
("pragma % must apply to a variable with initialization "
& "expression");
end if;
-- Otherwise the pragma applies to a constant, which is illegal

View File

@ -1732,6 +1732,8 @@ package body Sem_Util is
Disc : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Expr);
I : Interp_Index;
It : Interp;
begin
-- An entity of a type with a reference aspect is overloaded with
@ -1744,6 +1746,29 @@ package body Sem_Util is
Set_Etype (Expr, Etype (Entity (Expr)));
elsif Nkind (Expr) = N_Function_Call then
-- If the name of the indexing function is overloaded, locate the one
-- whose return type has an implicit dereference on the desired
-- discriminant, and set entity and type of function call.
if Is_Overloaded (Name (Expr)) then
Get_First_Interp (Name (Expr), I, It);
while Present (It.Nam) loop
if Ekind ((It.Typ)) = E_Record_Type
and then First_Entity ((It.Typ)) = Disc
then
Set_Entity (Name (Expr), It.Nam);
Set_Etype (Name (Expr), Etype (It.Nam));
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
-- Set type of call from resolved function name.
Set_Etype (Expr, Etype (Name (Expr)));
end if;

View File

@ -178,7 +178,7 @@ void __gnat_sigtramp (int signo, void *si, void *ucontext,
TCR(COMMON_LONG128_CFI(GR(27))) \
TCR(COMMON_LONG128_CFI(GR(28))) \
TCR(COMMON_LONG128_CFI(GR(29))) \
TCR(COMMON_LONG256_CFI(PC)) \
TCR(COMMON_LONG256_CFI(PC))
/* Trampoline body block
--------------------- */