From 7610fee82af0217dd376ce0213d195209f72b606 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 24 Jan 2014 15:23:03 +0100 Subject: [PATCH] [multiple changes] 2014-01-24 Doug Rupp * init.c: Add a handler section for Android. 2014-01-24 Arnaud Charlet * i-cexten.ads (Unsigned_33..64, Unsigned_33..64): New types. 2014-01-24 Ed Schonberg * sem_ch4.adb (Operator_Check): If one operand is a Raise_Expression, set its type to that of the other operand. * sem_res.adb (Resolve_Raise_Expression): new procedure. (Resolve_Actuals): For an actual that is a Raise_Expression, set the type to that of the formal. * sem_type.adb (Find_Unique_Type): If one of the operands is a Raise_Expression, return type of the other operand. 2014-01-24 Ed Schonberg * sem_aggr.adb (Resolve_Record_Aggregate): If a scalar component of the record has a type with a default aspect, and the corresponding aggregate component is initiaized with a box, use the default value in the rewritten aggregate. 2014-01-24 Tristan Gingold * s-interr.ads, s-interr.adb, s-interr-hwint.adb, s-interr-vms.adb, s-interr-sigaction.adb, s-interr-dummy.adb (Install_Restricted_Handlers): Add Prio parameter. * exp_ch9.adb (Make_Initialize_Protection): Add Prio parameter to the call to Install_Restricted_Handlers. 2014-01-24 Emmanuel Briot * prj-nmsc.adb (Check_File): Add protection when the source is not fully initialized. From-SVN: r207033 --- gcc/ada/ChangeLog | 38 +++++++ gcc/ada/exp_ch9.adb | 64 +++++------ gcc/ada/i-cexten.ads | 194 ++++++++++++++++++++++++++++++++- gcc/ada/init.c | 77 +++++++++++++ gcc/ada/prj-nmsc.adb | 4 +- gcc/ada/s-interr-dummy.adb | 7 +- gcc/ada/s-interr-hwint.adb | 8 +- gcc/ada/s-interr-sigaction.adb | 8 +- gcc/ada/s-interr-vms.adb | 8 +- gcc/ada/s-interr.adb | 8 +- gcc/ada/s-interr.ads | 14 ++- gcc/ada/sem_aggr.adb | 11 ++ gcc/ada/sem_ch4.adb | 13 +++ gcc/ada/sem_res.adb | 24 ++-- gcc/ada/sem_type.adb | 5 + 15 files changed, 427 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8c6087a7b46..fd2bca2cca0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2014-01-24 Doug Rupp + + * init.c: Add a handler section for Android. + +2014-01-24 Arnaud Charlet + + * i-cexten.ads (Unsigned_33..64, Unsigned_33..64): New types. + +2014-01-24 Ed Schonberg + + * sem_ch4.adb (Operator_Check): If one operand is a + Raise_Expression, set its type to that of the other operand. + * sem_res.adb (Resolve_Raise_Expression): new procedure. + (Resolve_Actuals): For an actual that is a Raise_Expression, + set the type to that of the formal. + * sem_type.adb (Find_Unique_Type): If one of the operands is a + Raise_Expression, return type of the other operand. + +2014-01-24 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): If a scalar + component of the record has a type with a default aspect, and + the corresponding aggregate component is initiaized with a box, + use the default value in the rewritten aggregate. + +2014-01-24 Tristan Gingold + + * s-interr.ads, s-interr.adb, s-interr-hwint.adb, s-interr-vms.adb, + s-interr-sigaction.adb, + s-interr-dummy.adb (Install_Restricted_Handlers): Add Prio parameter. + * exp_ch9.adb (Make_Initialize_Protection): Add Prio parameter + to the call to Install_Restricted_Handlers. + +2014-01-24 Emmanuel Briot + + * prj-nmsc.adb (Check_File): Add protection when the source is + not fully initialized. + 2014-01-24 Ed Schonberg * sem_util.adb (Is_Post_State): In a postcondition, a selected diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a03778ef30d..6adf7b384f4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -13451,6 +13451,7 @@ package body Exp_Ch9 is L : constant List_Id := New_List; Has_Entry : constant Boolean := Has_Entries (Ptyp); Prio_Type : Entity_Id; + Prio_Var : Entity_Id := Empty; Restricted : constant Boolean := Restricted_Profile; begin @@ -13509,7 +13510,6 @@ package body Exp_Ch9 is (Ptyp, Name_Priority, Check_Parents => False); Prio : Node_Id; - Temp : Entity_Id; begin -- Pragma Priority @@ -13539,37 +13539,21 @@ package body Exp_Ch9 is Prio := Expression (Prio_Clause); end if; - -- If priority is a static expression, then we can duplicate it - -- with no problem and simply append it to the argument list. - -- However, it has only be pre-analyzed, so we need to check - -- now that it is in the bounds of the priority type. + -- Always create a locale variable to capture the priority. + -- The priority is also passed to Install_Restriced_Handlers. + -- Note that it is really necessary to create this variable + -- explicitly. It might be thought that removing side effects + -- would the appropriate approach, but that could generate + -- declarations improperly placed in the enclosing scope. - if Is_Static_Expression (Prio) then - Set_Analyzed (Prio, False); - Append_To (Args, - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Prio_Type, Loc), - Expression => Duplicate_Subexpr (Prio))); - - -- Otherwise, the priority may be a per-object expression, if - -- it depends on a discriminant of the type. In this case, - -- create local variable to capture the expression. Note that - -- it is really necessary to create this variable explicitly. - -- It might be thought that removing side effects would the - -- appropriate approach, but that could generate declarations - -- improperly placed in the enclosing scope. + Prio_Var := Make_Temporary (Loc, 'R', Prio); + Append_To (L, + Make_Object_Declaration (Loc, + Defining_Identifier => Prio_Var, + Object_Definition => New_Occurrence_Of (Prio_Type, Loc), + Expression => Relocate_Node (Prio))); - else - Temp := Make_Temporary (Loc, 'R', Prio); - Append_To (L, - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Prio_Type, Loc), - Expression => Relocate_Node (Prio))); - - Append_To (Args, New_Occurrence_Of (Temp, Loc)); - end if; + Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); end; -- When no priority is specified but an xx_Handler pragma is, we @@ -13714,7 +13698,7 @@ package body Exp_Ch9 is -- or, in the case of Ravenscar: -- Install_Restricted_Handlers - -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); + -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access)); declare Args : constant List_Id := New_List; @@ -13722,6 +13706,24 @@ package body Exp_Ch9 is Ritem : Node_Id := First_Rep_Item (Ptyp); begin + -- Build the Priority parameter (only for ravenscar) + + if Restricted then + + -- Priority comes from a pragma + + if Present (Prio_Var) then + Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); + + -- Priority is the default one + + else + Append_To (Args, + New_Reference_To + (RTE (RE_Default_Interrupt_Priority), Loc)); + end if; + end if; + -- Build the Attach_Handler table argument while Present (Ritem) loop diff --git a/gcc/ada/i-cexten.ads b/gcc/ada/i-cexten.ads index 6be6f23ebe2..e256dec22ba 100644 --- a/gcc/ada/i-cexten.ads +++ b/gcc/ada/i-cexten.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -170,6 +170,102 @@ package Interfaces.C.Extensions is type Unsigned_32 is mod 2 ** 32; for Unsigned_32'Size use 32; + type Unsigned_33 is mod 2 ** 33; + for Unsigned_33'Size use 33; + + type Unsigned_34 is mod 2 ** 34; + for Unsigned_34'Size use 34; + + type Unsigned_35 is mod 2 ** 35; + for Unsigned_35'Size use 35; + + type Unsigned_36 is mod 2 ** 36; + for Unsigned_36'Size use 36; + + type Unsigned_37 is mod 2 ** 37; + for Unsigned_37'Size use 37; + + type Unsigned_38 is mod 2 ** 38; + for Unsigned_38'Size use 38; + + type Unsigned_39 is mod 2 ** 39; + for Unsigned_39'Size use 39; + + type Unsigned_40 is mod 2 ** 40; + for Unsigned_40'Size use 40; + + type Unsigned_41 is mod 2 ** 41; + for Unsigned_41'Size use 41; + + type Unsigned_42 is mod 2 ** 42; + for Unsigned_42'Size use 42; + + type Unsigned_43 is mod 2 ** 43; + for Unsigned_43'Size use 43; + + type Unsigned_44 is mod 2 ** 44; + for Unsigned_44'Size use 44; + + type Unsigned_45 is mod 2 ** 45; + for Unsigned_45'Size use 45; + + type Unsigned_46 is mod 2 ** 46; + for Unsigned_46'Size use 46; + + type Unsigned_47 is mod 2 ** 47; + for Unsigned_47'Size use 47; + + type Unsigned_48 is mod 2 ** 48; + for Unsigned_48'Size use 48; + + type Unsigned_49 is mod 2 ** 49; + for Unsigned_49'Size use 49; + + type Unsigned_50 is mod 2 ** 50; + for Unsigned_50'Size use 50; + + type Unsigned_51 is mod 2 ** 51; + for Unsigned_51'Size use 51; + + type Unsigned_52 is mod 2 ** 52; + for Unsigned_52'Size use 52; + + type Unsigned_53 is mod 2 ** 53; + for Unsigned_53'Size use 53; + + type Unsigned_54 is mod 2 ** 54; + for Unsigned_54'Size use 54; + + type Unsigned_55 is mod 2 ** 55; + for Unsigned_55'Size use 55; + + type Unsigned_56 is mod 2 ** 56; + for Unsigned_56'Size use 56; + + type Unsigned_57 is mod 2 ** 57; + for Unsigned_57'Size use 57; + + type Unsigned_58 is mod 2 ** 58; + for Unsigned_58'Size use 58; + + type Unsigned_59 is mod 2 ** 59; + for Unsigned_59'Size use 59; + + type Unsigned_60 is mod 2 ** 60; + for Unsigned_60'Size use 60; + + type Unsigned_61 is mod 2 ** 61; + for Unsigned_61'Size use 61; + + type Unsigned_62 is mod 2 ** 62; + for Unsigned_62'Size use 62; + + type Unsigned_63 is mod 2 ** 63; + for Unsigned_63'Size use 63; + + type Unsigned_64 is mod 2 ** 64; + for Unsigned_64'Size use 64; + type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1; for Signed_2'Size use 2; @@ -263,4 +359,100 @@ package Interfaces.C.Extensions is type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1; for Signed_32'Size use 32; + type Signed_33 is range -2 ** 32 .. 2 ** 32 - 1; + for Signed_33'Size use 33; + + type Signed_34 is range -2 ** 33 .. 2 ** 33 - 1; + for Signed_34'Size use 34; + + type Signed_35 is range -2 ** 34 .. 2 ** 34 - 1; + for Signed_35'Size use 35; + + type Signed_36 is range -2 ** 35 .. 2 ** 35 - 1; + for Signed_36'Size use 36; + + type Signed_37 is range -2 ** 36 .. 2 ** 36 - 1; + for Signed_37'Size use 37; + + type Signed_38 is range -2 ** 37 .. 2 ** 37 - 1; + for Signed_38'Size use 38; + + type Signed_39 is range -2 ** 38 .. 2 ** 38 - 1; + for Signed_39'Size use 39; + + type Signed_40 is range -2 ** 39 .. 2 ** 39 - 1; + for Signed_40'Size use 40; + + type Signed_41 is range -2 ** 40 .. 2 ** 40 - 1; + for Signed_41'Size use 41; + + type Signed_42 is range -2 ** 41 .. 2 ** 41 - 1; + for Signed_42'Size use 42; + + type Signed_43 is range -2 ** 42 .. 2 ** 42 - 1; + for Signed_43'Size use 43; + + type Signed_44 is range -2 ** 43 .. 2 ** 43 - 1; + for Signed_44'Size use 44; + + type Signed_45 is range -2 ** 44 .. 2 ** 44 - 1; + for Signed_45'Size use 45; + + type Signed_46 is range -2 ** 45 .. 2 ** 45 - 1; + for Signed_46'Size use 46; + + type Signed_47 is range -2 ** 46 .. 2 ** 46 - 1; + for Signed_47'Size use 47; + + type Signed_48 is range -2 ** 47 .. 2 ** 47 - 1; + for Signed_48'Size use 48; + + type Signed_49 is range -2 ** 48 .. 2 ** 48 - 1; + for Signed_49'Size use 49; + + type Signed_50 is range -2 ** 49 .. 2 ** 49 - 1; + for Signed_50'Size use 50; + + type Signed_51 is range -2 ** 50 .. 2 ** 50 - 1; + for Signed_51'Size use 51; + + type Signed_52 is range -2 ** 51 .. 2 ** 51 - 1; + for Signed_52'Size use 52; + + type Signed_53 is range -2 ** 52 .. 2 ** 52 - 1; + for Signed_53'Size use 53; + + type Signed_54 is range -2 ** 53 .. 2 ** 53 - 1; + for Signed_54'Size use 54; + + type Signed_55 is range -2 ** 54 .. 2 ** 54 - 1; + for Signed_55'Size use 55; + + type Signed_56 is range -2 ** 55 .. 2 ** 55 - 1; + for Signed_56'Size use 56; + + type Signed_57 is range -2 ** 56 .. 2 ** 56 - 1; + for Signed_57'Size use 57; + + type Signed_58 is range -2 ** 57 .. 2 ** 57 - 1; + for Signed_58'Size use 58; + + type Signed_59 is range -2 ** 58 .. 2 ** 58 - 1; + for Signed_59'Size use 59; + + type Signed_60 is range -2 ** 59 .. 2 ** 59 - 1; + for Signed_60'Size use 60; + + type Signed_61 is range -2 ** 60 .. 2 ** 60 - 1; + for Signed_61'Size use 61; + + type Signed_62 is range -2 ** 61 .. 2 ** 61 - 1; + for Signed_62'Size use 62; + + type Signed_63 is range -2 ** 62 .. 2 ** 62 - 1; + for Signed_63'Size use 63; + + type Signed_64 is range -2 ** 63 .. 2 ** 63 - 1; + for Signed_64'Size use 64; + end Interfaces.C.Extensions; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 7f8b3a3e58c..e943837d07a 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2320,6 +2320,83 @@ __gnat_install_handler (void) __gnat_handler_installed = 1; } +#elif defined(__ANDROID__) + +/*******************/ +/* Android Section */ +/*******************/ + +#include +#include + +static void +__gnat_error_handler (int sig, + siginfo_t *si ATTRIBUTE_UNUSED, + void *ucontext ATTRIBUTE_UNUSED) +{ + struct Exception_Data *exception; + const char *msg; + + switch (sig) + { + case SIGSEGV: + exception = &storage_error; + msg = "stack overflow or erroneous memory access"; + break; + + case SIGBUS: + exception = &constraint_error; + msg = "SIGBUS"; + break; + + case SIGFPE: + exception = &constraint_error; + msg = "SIGFPE"; + break; + + default: + exception = &program_error; + msg = "unhandled signal"; + } + + Raise_From_Signal_Handler (exception, msg); +} + +/* This must be in keeping with System.OS_Interface.Alternate_Stack_Size. */ +char __gnat_alternate_stack[16 * 1024]; + +void +__gnat_install_handler (void) +{ + struct sigaction act; + + /* Set up signal handler to map synchronous signals to appropriate + exceptions. Make sure that the handler isn't interrupted by another + signal that might cause a scheduling event! Also setup an alternate + stack region for the handler execution so that stack overflows can be + handled properly, avoiding a SEGV generation from stack usage by the + handler itself. */ + + stack_t stack; + stack.ss_sp = __gnat_alternate_stack; + stack.ss_size = sizeof (__gnat_alternate_stack); + stack.ss_flags = 0; + sigaltstack (&stack, NULL); + + act.sa_sigaction = __gnat_error_handler; + act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO; + sigemptyset (&act.sa_mask); + + sigaction (SIGABRT, &act, NULL); + sigaction (SIGFPE, &act, NULL); + sigaction (SIGILL, &act, NULL); + sigaction (SIGBUS, &act, NULL); + act.sa_flags |= SA_ONSTACK; + sigaction (SIGSEGV, &act, NULL); + + __gnat_handler_installed = 1; +} + #else /* For all other versions of GNAT, the handler does nothing. */ diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 54c4e4e3a44..e6a1f4c601b 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -7051,7 +7051,9 @@ package body Prj.Nmsc is -- Check if it is OK to have the same file name in several -- source directories. - if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then + if Name_Loc.Source /= No_Source + and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank + then Error_Msg_File_1 := File_Name; Error_Msg (Data.Flags, diff --git a/gcc/ada/s-interr-dummy.adb b/gcc/ada/s-interr-dummy.adb index 4e1828f71d9..87ed21d0367 100644 --- a/gcc/ada/s-interr-dummy.adb +++ b/gcc/ada/s-interr-dummy.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, AdaCore -- +-- Copyright (C) 1995-2013, AdaCore -- -- -- -- 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- -- @@ -187,7 +187,10 @@ package body System.Interrupts is -- Install_Restricted_Handlers -- --------------------------------- - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array) + is begin Unimplemented; end Install_Restricted_Handlers; diff --git a/gcc/ada/s-interr-hwint.adb b/gcc/ada/s-interr-hwint.adb index 1a43c952840..5cb38ea941c 100644 --- a/gcc/ada/s-interr-hwint.adb +++ b/gcc/ada/s-interr-hwint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -476,7 +476,11 @@ package body System.Interrupts is -- Install_Restricted_Handlers -- --------------------------------- - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array) + is + pragma Unreferenced (Prio); begin for N in Handlers'Range loop Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); diff --git a/gcc/ada/s-interr-sigaction.adb b/gcc/ada/s-interr-sigaction.adb index 46d38f39be0..233fdc38f28 100644 --- a/gcc/ada/s-interr-sigaction.adb +++ b/gcc/ada/s-interr-sigaction.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -292,7 +292,11 @@ package body System.Interrupts is -- Install_Restricted_Handlers -- --------------------------------- - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array) + is + pragma Unreferenced (Prio); begin for N in Handlers'Range loop Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); diff --git a/gcc/ada/s-interr-vms.adb b/gcc/ada/s-interr-vms.adb index c43b043685a..16dc88103c2 100644 --- a/gcc/ada/s-interr-vms.adb +++ b/gcc/ada/s-interr-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -1098,7 +1098,11 @@ package body System.Interrupts is -- Install_Restricted_Handlers -- --------------------------------- - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array) + is + pragma Unreferenced (Prio); begin for N in Handlers'Range loop Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index 3d33f6c9e13..7b7b7bd160e 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -469,7 +469,11 @@ package body System.Interrupts is -- Install_Restricted_Handlers -- --------------------------------- - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array) + is + pragma Unreferenced (Prio); begin for N in Handlers'Range loop Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads index a771db6f8a3..7c3ed56f9dc 100644 --- a/gcc/ada/s-interr.ads +++ b/gcc/ada/s-interr.ads @@ -266,11 +266,13 @@ package System.Interrupts is -- Store the old handlers in Object.Previous_Handlers and install -- the new static handlers. - procedure Install_Restricted_Handlers (Handlers : New_Handler_Array); - -- Install the static Handlers for the given interrupts and do not store - -- previously installed handlers. This procedure is used when the Ravenscar - -- restrictions are in place since in that case there are only - -- library-level protected handlers that will be installed at - -- initialization and never be replaced. + procedure Install_Restricted_Handlers + (Prio : Any_Priority; + Handlers : New_Handler_Array); + -- Install the static Handlers for the given interrupts and do not + -- store previously installed handlers. This procedure is used when + -- the Ravenscar restrictions are in place since in that case there + -- are only library-level protected handlers that will be installed + -- at initialization and never be replaced. end System.Interrupts; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 03930f5e3cf..374bb7b9081 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4204,6 +4204,17 @@ package body Sem_Aggr is end; end if; + -- Ada 2012: If component is scalar with default value, use it + + elsif Is_Scalar_Type (Ctyp) + and then Has_Default_Aspect (Ctyp) + then + Add_Association + (Component => Component, + Expr => Default_Aspect_Value + (First_Subtype (Underlying_Type (Ctyp))), + Assoc_List => New_Assoc_List); + elsif Has_Non_Null_Base_Init_Proc (Ctyp) or else not Expander_Active then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4bff4df47df..29e3e2faaac 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6298,6 +6298,19 @@ package body Sem_Ch4 is or else Etype (R) = Any_Type or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type) then + -- For the rather unusual case where one of the operands is + -- a Raise_Expression, whose initial type is Any_Type, use + -- the type of the other operand. + + if Nkind (L) = N_Raise_Expression then + Set_Etype (L, Etype (R)); + Set_Etype (N, Etype (R)); + + elsif Nkind (R) = N_Raise_Expression then + Set_Etype (R, Etype (L)); + Set_Etype (N, Etype (L)); + end if; + return; -- We explicitly check for the case of concatenation of component diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 730836437f7..751ca29bf5b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -193,6 +193,7 @@ package body Sem_Res is procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); @@ -2876,11 +2877,8 @@ package body Sem_Res is when N_Quantified_Expression => null; - -- Nothing to do for Raise_Expression, since we took care of - -- setting the Etype earlier, and no other processing is needed. - when N_Raise_Expression - => null; + => Resolve_Raise_Expression (N, Ctx_Type); when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); @@ -3453,13 +3451,16 @@ package body Sem_Res is -- If we have an error in any actual or formal, indicated by a type -- of Any_Type, then abandon resolution attempt, and set result type - -- to Any_Type. + -- to Any_Type. Skip this if the actual is a Raise_Expression, whose + -- type is imposed from context. elsif (Present (A) and then Etype (A) = Any_Type) or else Etype (F) = Any_Type then - Set_Etype (N, Any_Type); - return; + if Nkind (A) /= N_Raise_Expression then + Set_Etype (N, Any_Type); + return; + end if; end if; -- Case where actual is present @@ -8751,6 +8752,15 @@ package body Sem_Res is Eval_Qualified_Expression (N); end Resolve_Qualified_Expression; + ------------------------------ + -- Resolve_Raise_Expression -- + ------------------------------ + + procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Raise_Expression; + ------------------- -- Resolve_Range -- ------------------- diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index b7371b7d500..f0fea637a38 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -2221,6 +2221,11 @@ package body Sem_Type is then return Etype (R); + -- If one operand is a raise_expression, use type of other operand + + elsif Nkind (L) = N_Raise_Expression then + return Etype (R); + else return Specific_Type (T, Etype (R)); end if; -- 2.30.2