From 59e9bc0b6ff7d00bd56a5b4767014b6529bf820b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 6 Jan 2015 11:22:41 +0100 Subject: [PATCH] [multiple changes] 2015-01-06 Ed Schonberg * sem_ch12.adb: Sloc of wrapper is that of instantiation. 2015-01-06 Robert Dewar * sem_ch11.adb: Minor reformatting. 2015-01-06 Ed Schonberg * 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 * 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 --- gcc/ada/ChangeLog | 23 ++++++++++++++ gcc/ada/bindgen.adb | 14 ++++++--- gcc/ada/exp_aggr.adb | 71 ++++++++++++++++++++++++-------------------- gcc/ada/initialize.c | 2 -- gcc/ada/rtinit.c | 21 +++++++------ gcc/ada/sem_ch11.adb | 21 ++++++------- gcc/ada/sem_ch12.adb | 13 ++++---- 7 files changed, 100 insertions(+), 65 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 196f0833e58..5f34d8f6cfc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2015-01-06 Ed Schonberg + + * sem_ch12.adb: Sloc of wrapper is that of instantiation. + +2015-01-06 Robert Dewar + + * sem_ch11.adb: Minor reformatting. + +2015-01-06 Ed Schonberg + + * 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 + + * 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 * freeze.adb (Set_SSO_From_Defaults): When setting scalar storage diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 0a9ece0b33d..9a5c1a8017e 100644 --- a/gcc/ada/bindgen.adb +++ b/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; diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index abf870b642b..f958c152b6e 100644 --- a/gcc/ada/exp_aggr.adb +++ b/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; diff --git a/gcc/ada/initialize.c b/gcc/ada/initialize.c index 8282ba57cf5..4343937e653 100644 --- a/gcc/ada/initialize.c +++ b/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 *); diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c index 59bac0f1036..97582db3a0f 100644 --- a/gcc/ada/rtinit.c +++ b/gcc/ada/rtinit.c @@ -76,7 +76,6 @@ int __gnat_rt_init_count = 0; #include 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 diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 2e3dbd9fe87..c193f1ad5ca 100644 --- a/gcc/ada/sem_ch11.adb +++ b/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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5d1ac9df615..e454ffe7500 100644 --- a/gcc/ada/sem_ch12.adb +++ b/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; -- 2.30.2