Skip to content

R
riscv-gcc-1
Commit 59e9bc0b by Arnaud Charlet
Options

[multiple changes] 

2015-01-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb: Sloc of wrapper is that of instantiation.

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* sem_ch11.adb: Minor reformatting.

2015-01-06  Ed Schonberg  <schonberg@adacore.com>

	* exp_aggr.adb (Get_Assoc_Expr): New routine internal to
	Build_Array_Aggr_Code, used to initialized components covered
	by a box association. If the component type is scalar and has
	a default aspect, use it to initialize such components.

2015-01-06  Pascal Obry  <obry@adacore.com>

	* rtinit.c (__gnat_runtime_initialize): Add a parameter to
	control the setup of the exception handler.
	* initialize.c: Remove unused declaration.
	* bindgen.adb: Always call __gnat_runtime_initialize and pass
	whether the exeception handler must be set or not.

From-SVN: r219251
parent 1a779058
Showing with 100 additions and 65 deletions
gcc/ada/ChangeLog
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb: Sloc of wrapper is that of instantiation.
2015-01-06 Robert Dewar <dewar@adacore.com>
* sem_ch11.adb: Minor reformatting.
2015-01-06 Ed Schonberg <schonberg@adacore.com>
* exp_aggr.adb (Get_Assoc_Expr): New routine internal to
Build_Array_Aggr_Code, used to initialized components covered
by a box association. If the component type is scalar and has
a default aspect, use it to initialize such components.
2015-01-06 Pascal Obry <obry@adacore.com>
* rtinit.c (__gnat_runtime_initialize): Add a parameter to
control the setup of the exception handler.
* initialize.c: Remove unused declaration.
* bindgen.adb: Always call __gnat_runtime_initialize and pass
whether the exeception handler must be set or not.
2015-01-06 Thomas Quinot <quinot@adacore.com>
* freeze.adb (Set_SSO_From_Defaults): When setting scalar storage
......
gcc/ada/bindgen.adb
......@@ -606,7 +606,8 @@ package body Bindgen is
-- installation, and indication of if it's been called previously.
WBI ("");
WBI (" procedure Runtime_Initialize;");
WBI (" procedure Runtime_Initialize " &
"(Install_Handler : Integer);");
WBI (" pragma Import (C, Runtime_Initialize, " &
"""__gnat_runtime_initialize"");");
......@@ -838,9 +839,14 @@ package body Bindgen is
-- In .NET, when binding with -z, we don't install the signal handler
-- to let the caller handle the last exception handler.
if Bind_Main_Program then
WBI ("");
WBI (" Runtime_Initialize;");
WBI ("");
if VM_Target /= CLI_Target
or else Bind_Main_Program
then
WBI (" Runtime_Initialize (1);");
else
WBI (" Runtime_Initialize (0);");
end if;
end if;
......
gcc/ada/exp_aggr.adb
......@@ -785,6 +785,10 @@ package body Exp_Aggr is
--
-- Otherwise we call Build_Code recursively
function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id;
-- For an association with a box, use default aspect of component type
-- if present, to initialize one or more components.
function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
function Local_Expr_Value (E : Node_Id) return Uint;
-- These two Local routines are used to replace the corresponding ones
......@@ -1524,6 +1528,26 @@ package body Exp_Aggr is
return S;
end Gen_While;
--------------------
-- Get_Assoc_Expr --
--------------------
function Get_Assoc_Expr (Assoc : Node_Id) return Node_Id is
begin
if Box_Present (Assoc) then
if Is_Scalar_Type (Ctype)
and then Present (Default_Aspect_Value (Ctype))
then
return Default_Aspect_Value (Ctype);
else
return Empty;
end if;
else
return Expression (Assoc);
end if;
end Get_Assoc_Expr;
---------------------
-- Index_Base_Name --
---------------------
......@@ -1566,8 +1590,7 @@ package body Exp_Aggr is
Expr : Node_Id;
Typ : Entity_Id;
Others_Expr : Node_Id := Empty;
Others_Box_Present : Boolean := False;
Others_Assoc : Node_Id := Empty;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
......@@ -1637,12 +1660,7 @@ package body Exp_Aggr is
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Set_Loop_Actions (Assoc, New_List);
if Box_Present (Assoc) then
Others_Box_Present := True;
else
Others_Expr := Expression (Assoc);
end if;
Others_Assoc := Assoc;
exit;
end if;
......@@ -1653,15 +1671,12 @@ package body Exp_Aggr is
end if;
Nb_Choices := Nb_Choices + 1;
if Box_Present (Assoc) then
Table (Nb_Choices) := (Choice_Lo => Low,
Choice_Hi => High,
Choice_Node => Empty);
else
Table (Nb_Choices) := (Choice_Lo => Low,
Choice_Hi => High,
Choice_Node => Expression (Assoc));
end if;
Table (Nb_Choices) :=
(Choice_Lo => Low,
Choice_Hi => High,
Choice_Node => Get_Assoc_Expr (Assoc));
Next (Choice);
end loop;
......@@ -1689,7 +1704,7 @@ package body Exp_Aggr is
-- We don't need to generate loops over empty gaps, but if there is
-- a single empty range we must analyze the expression for semantics
if Present (Others_Expr) or else Others_Box_Present then
if Present (Others_Assoc) then
declare
First : Boolean := True;
......@@ -1730,7 +1745,8 @@ package body Exp_Aggr is
then
First := False;
Append_List
(Gen_Loop (Low, High, Others_Expr), To => New_Code);
(Gen_Loop (Low, High,
Get_Assoc_Expr (Others_Assoc)), To => New_Code);
end if;
end loop;
end;
......@@ -1760,19 +1776,10 @@ package body Exp_Aggr is
-- Ada 2005 (AI-287)
if Box_Present (Assoc) then
Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
Aggr_High,
Empty),
To => New_Code);
else
Expr := Expression (Assoc);
Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
Aggr_High,
Expr), -- AI-287
To => New_Code);
end if;
Append_List (Gen_While (Add (Nb_Elements, To => Aggr_L),
Aggr_High,
Get_Assoc_Expr (Assoc)), -- AI-287
To => New_Code);
end if;
end if;
......
gcc/ada/initialize.c
......@@ -62,8 +62,6 @@ extern "C" {
/* __gnat_initialize (NT-mingw32 Version) */
/******************************************/
extern void __gnat_install_handler(void);
#if defined (__MINGW32__)
extern void __gnat_install_SEH_handler (void *);
......
gcc/ada/rtinit.c
......@@ -76,7 +76,6 @@ int __gnat_rt_init_count = 0;
#include <windows.h>
extern void __gnat_init_float (void);
extern void __gnat_install_SEH_handler (void *);
extern int gnat_argc;
extern char **gnat_argv;
......@@ -138,7 +137,7 @@ append_arg (int *index, LPWSTR dir, LPWSTR value,
#endif
void
__gnat_runtime_initialize(void)
__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
......@@ -302,7 +301,8 @@ __gnat_runtime_initialize(void)
}
#endif
__gnat_install_handler();
if (install_handler)
__gnat_install_handler();
}
/**************************************************/
......@@ -315,7 +315,7 @@ __gnat_runtime_initialize(void)
extern void __gnat_init_float (void);
void
__gnat_runtime_initialize(void)
__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
......@@ -327,7 +327,8 @@ __gnat_runtime_initialize(void)
__gnat_init_float ();
__gnat_install_handler();
if (install_handler)
__gnat_install_handler();
}
/***********************************************/
......@@ -339,7 +340,7 @@ __gnat_runtime_initialize(void)
extern void __gnat_init_float (void);
void
__gnat_runtime_initialize(void)
__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
......@@ -351,7 +352,8 @@ __gnat_runtime_initialize(void)
__gnat_init_float ();
__gnat_install_handler();
if (install_handler)
__gnat_install_handler();
}
#else
......@@ -361,7 +363,7 @@ __gnat_runtime_initialize(void)
/***********************************************/
void
__gnat_runtime_initialize(void)
__gnat_runtime_initialize(int install_handler)
{
/* increment the reference counter */
......@@ -371,7 +373,8 @@ __gnat_runtime_initialize(void)
if (__gnat_rt_init_count > 1)
return;
__gnat_install_handler();
if (install_handler)
__gnat_install_handler();
}
#endif
......
gcc/ada/sem_ch11.adb
......@@ -121,12 +121,11 @@ package body Sem_Ch11 is
elsif Nkind (Id1) /= N_Others_Choice
and then
(Id_Entity = Entity (Id1)
or else (Id_Entity = Renamed_Entity (Entity (Id1))))
or else (Id_Entity = Renamed_Entity (Entity (Id1))))
then
if Handler /= Parent (Id) then
Error_Msg_Sloc := Sloc (Id1);
Error_Msg_NE
("exception choice duplicates &#", Id, Id1);
Error_Msg_NE ("exception choice duplicates &#", Id, Id1);
else
if Ada_Version = Ada_83
......@@ -348,7 +347,7 @@ package body Sem_Ch11 is
and then Nkind (First (Statements (Handler))) = N_Raise_Statement
and then No (Name (First (Statements (Handler))))
and then (not Others_Present
or else Nkind (First (Exception_Choices (Handler))) =
or else Nkind (First (Exception_Choices (Handler))) =
N_Others_Choice)
then
Error_Msg_N
......@@ -534,9 +533,7 @@ package body Sem_Ch11 is
-- See if preceding statement is an assignment
if Present (P)
and then Nkind (P) = N_Assignment_Statement
then
if Present (P) and then Nkind (P) = N_Assignment_Statement then
L := Name (P);
-- Give warning for assignment to scalar formal
......@@ -549,7 +546,7 @@ package body Sem_Ch11 is
-- This avoids some false positives for the nested case.
and then Nearest_Dynamic_Scope (Current_Scope) =
Scope (Entity (L))
Scope (Entity (L))
then
-- Don't give warning if we are covered by an exception
......@@ -571,11 +568,11 @@ package body Sem_Ch11 is
if No (Exception_Handlers (Par)) then
Error_Msg_N
("assignment to pass-by-copy formal " &
"may have no effect??", P);
("assignment to pass-by-copy formal "
& "may have no effect??", P);
Error_Msg_N
("\RAISE statement may result in abnormal return" &
" (RM 6.4.1(17))??", P);
("\RAISE statement may result in abnormal return "
& "(RM 6.4.1(17))??", P);
end if;
end if;
end if;
......
gcc/ada/sem_ch12.adb
......@@ -5112,7 +5112,7 @@ package body Sem_Ch12 is
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Formal_Subp);
Loc : constant Source_Ptr := Sloc (Current_Scope);
Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
Actuals : List_Id;
Decl : Node_Id;
......@@ -5187,11 +5187,12 @@ package body Sem_Ch12 is
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Formal_Subp);
Ret_Type : constant Entity_Id := Get_Instance_Of (Etype (Formal_Subp));
Op_Type : constant Entity_Id := Get_Instance_Of
(Etype (First_Formal (Formal_Subp)));
Is_Binary : constant Boolean :=
Loc : constant Source_Ptr := Sloc (Current_Scope);
Ret_Type : constant Entity_Id :=
Get_Instance_Of (Etype (Formal_Subp));
Op_Type : constant Entity_Id :=
Get_Instance_Of (Etype (First_Formal (Formal_Subp)));
Is_Binary : constant Boolean :=
Present (Next_Formal (First_Formal (Formal_Subp)));
Decl : Node_Id;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment