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

[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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gcc/ada/ChangeLog
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> 2015-11-13 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Check_Private_Overriding): Change * sem_ch6.adb (Check_Private_Overriding): Change

10
gcc/ada/exp_attr.adb
View File

@ -4462,7 +4462,7 @@ package body Exp_Attr is
X : constant Node_Id := Prefix (N); X : constant Node_Id := Prefix (N);
Y : constant Node_Id := First (Expressions (N)); Y : constant Node_Id := First (Expressions (N));
-- The argumens -- The arguments
X_Addr, Y_Addr : Node_Id; X_Addr, Y_Addr : Node_Id;
-- the expressions for their integer addresses -- the expressions for their integer addresses
@ -4483,7 +4483,9 @@ package body Exp_Attr is
-- with the proper address operations. We convert addresses to -- with the proper address operations. We convert addresses to
-- integer addresses to use predefined arithmetic. The size is -- 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 := X_Addr :=
Unchecked_Convert_To (RTE (RE_Integer_Address), Unchecked_Convert_To (RTE (RE_Integer_Address),
@ -4528,7 +4530,7 @@ package body Exp_Attr is
Make_Op_Ge (Loc, Make_Op_Ge (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => X_Addr, Left_Opnd => New_Copy_Tree (X_Addr),
Right_Opnd => Right_Opnd =>
Make_Op_Subtract (Loc, Make_Op_Subtract (Loc,
Left_Opnd => X_Size, Left_Opnd => X_Size,
@ -4537,7 +4539,7 @@ package body Exp_Attr is
Make_Op_Ge (Loc, Make_Op_Ge (Loc,
Make_Op_Add (Loc, Make_Op_Add (Loc,
Left_Opnd => Y_Addr, Left_Opnd => New_Copy_Tree (Y_Addr),
Right_Opnd => Right_Opnd =>
Make_Op_Subtract (Loc, Make_Op_Subtract (Loc,
Left_Opnd => Y_Size, Left_Opnd => Y_Size,

107
gcc/ada/exp_ch9.adb
View File

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

1
gcc/ada/g-debpoo.adb
View File

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

27
gcc/ada/init.c
View File

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

4
gcc/ada/s-gloloc.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- --
@ -51,7 +51,7 @@ package body System.Global_Locks is
File : String; File : String;
Wait : Duration := 0.1; Wait : Duration := 0.1;
Retries : Natural := Natural'Last); 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 -- locked because someone already owns the lock, this procedure
-- waits Wait seconds and retries at most Retries times. If the file -- 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 -- still cannot be locked, Lock_Error is raised. The default is to try

3
gcc/ada/sem_ch13.adb
View File

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

21
gcc/ada/sem_ch4.adb
View File

@ -3073,6 +3073,7 @@ package body Sem_Ch4 is
if not Is_Type (Nam) then if not Is_Type (Nam) then
if Is_Entity_Name (Name (N)) then if Is_Entity_Name (Name (N)) then
Set_Entity (Name (N), Nam); Set_Entity (Name (N), Nam);
Set_Etype (Name (N), Etype (Nam));
elsif Nkind (Name (N)) = N_Selected_Component then elsif Nkind (Name (N)) = N_Selected_Component then
Set_Entity (Selector_Name (Name (N)), Nam); Set_Entity (Selector_Name (Name (N)), Nam);
@ -7456,6 +7457,9 @@ package body Sem_Ch4 is
end if; end if;
else else
-- If there are multiple indexing functions, build a function call
-- and analyze it for each of the possible interpretations.
Indexing := Indexing :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
@ -7464,6 +7468,8 @@ package body Sem_Ch4 is
Set_Parent (Indexing, Parent (N)); Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing); Set_Generalized_Indexing (N, Indexing);
Set_Etype (N, Any_Type);
Set_Etype (Name (Indexing), Any_Type);
declare declare
I : Interp_Index; I : Interp_Index;
@ -7473,21 +7479,24 @@ package body Sem_Ch4 is
begin begin
Get_First_Interp (Func_Name, I, It); Get_First_Interp (Func_Name, I, It);
Set_Etype (Indexing, Any_Type); Set_Etype (Indexing, Any_Type);
while Present (It.Nam) loop while Present (It.Nam) loop
Analyze_One_Call (Indexing, It.Nam, False, Success); Analyze_One_Call (Indexing, It.Nam, False, Success);
if Success then 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 if Has_Discriminants (Etype (It.Nam)) then
Check_Implicit_Dereference (N, Etype (It.Nam)); Check_Implicit_Dereference (N, Etype (It.Nam));
end if; end if;
exit;
end if; end if;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);

13
gcc/ada/sem_ch5.adb
View File

@ -2057,19 +2057,20 @@ package body Sem_Ch5 is
Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ)); Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ));
-- AI12-0151 stipulates that the container cannot be a component -- AI12-0047 stipulates that the domain (array or container)
-- that depends on a discriminant if the enclosing object is -- cannot be a component that depends on a discriminant if the
-- mutable, to prevent a modification of the container in the -- enclosing object is mutable, to prevent a modification of the
-- course of an iteration. -- 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 if Nkind (Original_Node (Iter_Name)) = N_Selected_Component
and then Is_Dependent_Component_Of_Mutable_Object and then Is_Dependent_Component_Of_Mutable_Object
(Original_Node (Iter_Name)) (Original_Node (Iter_Name))
then then
Error_Msg_N Error_Msg_N
("container cannot be a discriminant-dependent " ("iterable name cannot be a discriminant-dependent "
& "component of a mutable object", N); & "component of a mutable object", N);
end if; end if;

13
gcc/ada/sem_prag.adb
View File

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

25
gcc/ada/sem_util.adb
View File

@ -1732,6 +1732,8 @@ package body Sem_Util is
Disc : Entity_Id) Disc : Entity_Id)
is is
Loc : constant Source_Ptr := Sloc (Expr); Loc : constant Source_Ptr := Sloc (Expr);
I : Interp_Index;
It : Interp;
begin begin
-- An entity of a type with a reference aspect is overloaded with -- 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))); Set_Etype (Expr, Etype (Entity (Expr)));
elsif Nkind (Expr) = N_Function_Call then 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))); Set_Etype (Expr, Etype (Name (Expr)));
end if; end if;

2
gcc/ada/sigtramp-ios.c
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(27))) \
TCR(COMMON_LONG128_CFI(GR(28))) \ TCR(COMMON_LONG128_CFI(GR(28))) \
TCR(COMMON_LONG128_CFI(GR(29))) \ TCR(COMMON_LONG128_CFI(GR(29))) \
TCR(COMMON_LONG256_CFI(PC)) \ TCR(COMMON_LONG256_CFI(PC))
/* Trampoline body block /* Trampoline body block
--------------------- */ --------------------- */