From 90878b1250d7ef591b61912449df3d14bdec05cd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 12:36:15 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Ed Schonberg * exp_ch5.adb (Expand_N_Assignment_Statement): under restriction No_Dispatching_Calls, do not look for the Assign primitive, because predefined primitives are not created in this case. 2011-08-02 Bob Duff * stylesw.ads: Minor comment fixes. 2011-08-02 Robert Dewar * freeze.adb (Add_To_Result): New procedure. 2011-08-02 Jose Ruiz * exp_attr.adb (Find_Stream_Subprogram): When using a configurable run time, if the specific run-time routines for handling streams of strings are not available, use the default mechanism. 2011-08-02 Arnaud Charlet * s-regpat.ads: Fix typo. 2011-08-02 Vincent Celier * prj-conf.adb (Get_Or_Create_Configuration_File): If On_Load_Config is not null, call it to create the in memory config project file without parsing an existing default config project file. 2011-08-02 Eric Botcazou * atree.adb (Allocate_Initialize_Node): Remove useless temporaries. 2011-08-02 Ed Schonberg * sem_elim.adb: an abstract subprogram does not need an eliminate pragma for its descendant to be eliminable. 2011-08-02 Ed Falis * init.c: revert to handling before previous checkin for VxWorks * s-intman-vxworks.adb: delete unnecessary declarations related to using Ada interrupt facilities for handling signals. Delete Initialize_Interrupts. Use __gnat_install_handler instead. * s-intman-vxworks.ads: Import __gnat_install_handler as Initialize_Interrupts. * s-taprop-vxworks.adb: Delete Signal_Mask. (Abort_Handler): change construction of mask to unblock exception signals. From-SVN: r177130 --- gcc/ada/ChangeLog | 51 +++++++++++ gcc/ada/atree.adb | 48 +++++------ gcc/ada/exp_attr.adb | 159 +++++++++++++++++++++++++++++------ gcc/ada/exp_ch5.adb | 8 +- gcc/ada/freeze.adb | 43 +++++----- gcc/ada/init.c | 64 ++++++-------- gcc/ada/prj-conf.adb | 14 ++- gcc/ada/s-intman-vxworks.adb | 55 +----------- gcc/ada/s-intman-vxworks.ads | 9 +- gcc/ada/s-regpat.ads | 2 +- gcc/ada/s-taprop-vxworks.adb | 40 ++++++--- gcc/ada/sem_elim.adb | 1 + gcc/ada/stylesw.ads | 8 +- 13 files changed, 311 insertions(+), 191 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 693d8654302..61cb60a3a50 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,54 @@ +2011-08-02 Ed Schonberg + + * exp_ch5.adb (Expand_N_Assignment_Statement): under restriction + No_Dispatching_Calls, do not look for the Assign primitive, because + predefined primitives are not created in this case. + +2011-08-02 Bob Duff + + * stylesw.ads: Minor comment fixes. + +2011-08-02 Robert Dewar + + * freeze.adb (Add_To_Result): New procedure. + +2011-08-02 Jose Ruiz + + * exp_attr.adb (Find_Stream_Subprogram): When using a configurable run + time, if the specific run-time routines for handling streams of strings + are not available, use the default mechanism. + +2011-08-02 Arnaud Charlet + + * s-regpat.ads: Fix typo. + +2011-08-02 Vincent Celier + + * prj-conf.adb (Get_Or_Create_Configuration_File): If On_Load_Config is + not null, call it to create the in memory config project file without + parsing an existing default config project file. + +2011-08-02 Eric Botcazou + + * atree.adb (Allocate_Initialize_Node): Remove useless temporaries. + +2011-08-02 Ed Schonberg + + * sem_elim.adb: an abstract subprogram does not need an eliminate + pragma for its descendant to be eliminable. + +2011-08-02 Ed Falis + + * init.c: revert to handling before previous checkin for VxWorks + * s-intman-vxworks.adb: delete unnecessary declarations related to + using Ada interrupt facilities for handling signals. + Delete Initialize_Interrupts. Use __gnat_install_handler instead. + * s-intman-vxworks.ads: Import __gnat_install_handler as + Initialize_Interrupts. + * s-taprop-vxworks.adb: Delete Signal_Mask. + (Abort_Handler): change construction of mask to unblock exception + signals. + 2011-08-02 Jerome Guitton * a-except-2005.adb (Raise_From_Signal_Handler): Call diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 306845b5f75..bb678a5b9cb 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -481,34 +481,25 @@ package body Atree is (Src : Node_Id; With_Extension : Boolean) return Node_Id is - New_Id : Node_Id := Src; - Nod : Node_Record := Default_Node; - Ext1 : Node_Record := Default_Node_Extension; - Ext2 : Node_Record := Default_Node_Extension; - Ext3 : Node_Record := Default_Node_Extension; - Ext4 : Node_Record := Default_Node_Extension; + New_Id : Node_Id; begin - if Present (Src) then - Nod := Nodes.Table (Src); - - if Has_Extension (Src) then - Ext1 := Nodes.Table (Src + 1); - Ext2 := Nodes.Table (Src + 2); - Ext3 := Nodes.Table (Src + 3); - Ext4 := Nodes.Table (Src + 4); - end if; - end if; - - if not (Present (Src) - and then not Has_Extension (Src) - and then With_Extension - and then Src = Nodes.Last) + if Present (Src) + and then not Has_Extension (Src) + and then With_Extension + and then Src = Nodes.Last then + New_Id := Src; + else -- We are allocating a new node, or extending a node -- other than Nodes.Last. - Nodes.Append (Nod); + if Present (Src) then + Nodes.Append (Nodes.Table (Src)); + else + Nodes.Append (Default_Node); + end if; + New_Id := Nodes.Last; Orig_Nodes.Append (New_Id); Node_Count := Node_Count + 1; @@ -524,10 +515,15 @@ package body Atree is -- Set extension nodes if required if With_Extension then - Nodes.Append (Ext1); - Nodes.Append (Ext2); - Nodes.Append (Ext3); - Nodes.Append (Ext4); + if Present (Src) and then Has_Extension (Src) then + for J in 1 .. 4 loop + Nodes.Append (Nodes.Table (Src + Node_Id (J))); + end loop; + else + for J in 1 .. 4 loop + Nodes.Append (Default_Node_Extension); + end loop; + end if; end if; Orig_Nodes.Set_Last (Nodes.Last); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 56ca1ae00ca..008c8138dcb 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5517,6 +5517,21 @@ package body Exp_Attr is Base_Typ : constant Entity_Id := Base_Type (Typ); Ent : constant Entity_Id := TSS (Typ, Nam); + function Is_Available (Entity : RE_Id) return Boolean; + pragma Inline (Is_Available); + -- Function to check whether the specified run-time call is available + -- in the run time used. In the case of a configurable run time, it + -- is normal that some subprograms are not there. + + function Is_Available (Entity : RE_Id) return Boolean is + begin + -- Assume that the unit will always be available when using a + -- "normal" (not configurable) run time. + + return not Configurable_Run_Time_Mode + or else RTE_Available (Entity); + end Is_Available; + begin if Present (Ent) then return Ent; @@ -5535,6 +5550,12 @@ package body Exp_Attr is -- This is disabled for AAMP, to avoid creating dependences on files not -- supported in the AAMP library (such as s-fileio.adb). + -- In the case of using a configurable run time, it is very likely + -- that stream routines for string types are not present (they require + -- file system support). In this case, the specific stream routines for + -- strings are not used, relying on the regular stream mechanism + -- instead. + if VM_Target /= JVM_Target and then not AAMP_On_Target and then @@ -5544,31 +5565,61 @@ package body Exp_Attr is if Base_Typ = Standard_String then if Restriction_Active (No_Stream_Optimizations) then - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_String_Input) + then return RTE (RE_String_Input); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_String_Output) + then return RTE (RE_String_Output); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_String_Read) + then return RTE (RE_String_Read); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_String_Write) + then return RTE (RE_String_Write); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; else - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_String_Input_Blk_IO) + then return RTE (RE_String_Input_Blk_IO); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_String_Output_Blk_IO) + then return RTE (RE_String_Output_Blk_IO); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_String_Read_Blk_IO) + then return RTE (RE_String_Read_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_String_Write_Blk_IO) + then return RTE (RE_String_Write_Blk_IO); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; end if; @@ -5576,31 +5627,61 @@ package body Exp_Attr is elsif Base_Typ = Standard_Wide_String then if Restriction_Active (No_Stream_Optimizations) then - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Wide_String_Input) + then return RTE (RE_Wide_String_Input); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Wide_String_Output) + then return RTE (RE_Wide_String_Output); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Wide_String_Read) + then return RTE (RE_Wide_String_Read); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Wide_String_Write) + then return RTE (RE_Wide_String_Write); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; else - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Wide_String_Input_Blk_IO) + then return RTE (RE_Wide_String_Input_Blk_IO); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Wide_String_Output_Blk_IO) + then return RTE (RE_Wide_String_Output_Blk_IO); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Wide_String_Read_Blk_IO) + then return RTE (RE_Wide_String_Read_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Wide_String_Write_Blk_IO) + then return RTE (RE_Wide_String_Write_Blk_IO); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; end if; @@ -5608,31 +5689,61 @@ package body Exp_Attr is elsif Base_Typ = Standard_Wide_Wide_String then if Restriction_Active (No_Stream_Optimizations) then - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Wide_Wide_String_Input) + then return RTE (RE_Wide_Wide_String_Input); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Wide_Wide_String_Output) + then return RTE (RE_Wide_Wide_String_Output); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Wide_Wide_String_Read) + then return RTE (RE_Wide_Wide_String_Read); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Wide_Wide_String_Write) + then return RTE (RE_Wide_Wide_String_Write); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; else - if Nam = TSS_Stream_Input then + if Nam = TSS_Stream_Input + and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO) + then return RTE (RE_Wide_Wide_String_Input_Blk_IO); - elsif Nam = TSS_Stream_Output then + elsif Nam = TSS_Stream_Output + and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO) + then return RTE (RE_Wide_Wide_String_Output_Blk_IO); - elsif Nam = TSS_Stream_Read then + elsif Nam = TSS_Stream_Read + and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO) + then return RTE (RE_Wide_Wide_String_Read_Blk_IO); - else pragma Assert (Nam = TSS_Stream_Write); + elsif Nam = TSS_Stream_Write + and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO) + then return RTE (RE_Wide_Wide_String_Write_Blk_IO); + + elsif Nam /= TSS_Stream_Input and then + Nam /= TSS_Stream_Output and then + Nam /= TSS_Stream_Read and then + Nam /= TSS_Stream_Write + then + raise Program_Error; end if; end if; end if; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 8acbd877cc7..bd85af264c9 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1943,13 +1943,17 @@ package body Exp_Ch5 is -- correspond to initializations, where we do want to copy the -- tag (No_Ctrl_Actions flag set True) by the expander and we -- do not need to mess with tags ever (Expand_Ctrl_Actions flag - -- is set True in this case). + -- is set True in this case). Finally, it is suppressed if the + -- restriction No_Dispatching_Calls is in force because in that + -- case predefined primitives are not generated. or else (Is_Tagged_Type (Typ) and then not Is_Value_Type (Etype (Lhs)) and then Chars (Current_Scope) /= Name_uAssign and then Expand_Ctrl_Actions - and then not Discriminant_Checks_Suppressed (Empty)) + and then not Discriminant_Checks_Suppressed (Empty) + and then + not Restriction_Active (No_Dispatching_Calls)) then -- Fetch the primitive op _assign and proper type to call it. -- Because of possible conflicts between private and full view, diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0db54598599..f1a2b829bd0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1502,14 +1502,19 @@ package body Freeze is Test_E : Entity_Id := E; Comp : Entity_Id; F_Node : Node_Id; - Result : List_Id; Indx : Node_Id; Formal : Entity_Id; Atype : Entity_Id; + Result : List_Id := No_List; + -- List of freezing actions, left at No_List if none + Has_Default_Initialization : Boolean := False; -- This flag gets set to true for a variable with default initialization + procedure Add_To_Result (N : Node_Id); + -- N is a freezing action to be appended to the Result + procedure Check_Current_Instance (Comp_Decl : Node_Id); -- Check that an Access or Unchecked_Access attribute with a prefix -- which is the current instance type can only be applied when the type @@ -1528,6 +1533,19 @@ package body Freeze is -- Freeze each component, handle some representation clauses, and freeze -- primitive operations if this is a tagged type. + ------------------- + -- Add_To_Result -- + ------------------- + + procedure Add_To_Result (N : Node_Id) is + begin + if No (Result) then + Result := New_List (N); + else + Append (N, Result); + end if; + end Add_To_Result; + ---------------------------- -- After_Last_Declaration -- ---------------------------- @@ -1769,12 +1787,7 @@ package body Freeze is then IR := Make_Itype_Reference (Sloc (Comp)); Set_Itype (IR, Desig); - - if No (Result) then - Result := New_List (IR); - else - Append (IR, Result); - end if; + Add_To_Result (IR); end if; elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type @@ -2421,7 +2434,6 @@ package body Freeze is -- Here to freeze the entity - Result := No_List; Set_Is_Frozen (E); -- Case of entity being frozen is other than a type @@ -3602,11 +3614,7 @@ package body Freeze is begin Set_Itype (Ref, E); - if No (Result) then - Result := New_List (Ref); - else - Append (Ref, Result); - end if; + Add_To_Result (Ref); end; end if; @@ -4052,12 +4060,7 @@ package body Freeze is end if; Set_Entity (F_Node, E); - - if Result = No_List then - Result := New_List (F_Node); - else - Append (F_Node, Result); - end if; + Add_To_Result (F_Node); -- A final pass over record types with discriminants. If the type -- has an incomplete declaration, there may be constrained access @@ -4135,6 +4138,8 @@ package body Freeze is -- subprogram in main unit, generate descriptor if we are in -- Propagate_Exceptions mode. + -- This is very odd code, it makes a null result, why ??? + elsif Propagate_Exceptions and then Is_Imported (E) and then not Is_Intrinsic_Subprogram (E) diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 53d72d9dbe9..822837c0d19 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -10,19 +10,20 @@ * * * 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- * - * ware Foundation; either version 3, or (at your option) any later ver- * + * ware Foundation; either version 2, or (at your option) any later ver- * * sion. GNAT is distributed in the hope that it will be useful, but WITH- * * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * - * or FITNESS FOR A PARTICULAR PURPOSE. * + * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * + * for more details. You should have received a copy of the GNU General * + * Public License distributed with GNAT; see file COPYING. If not, write * + * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, * + * Boston, MA 02110-1301, USA. * * * - * As a special exception under Section 7 of GPL version 3, you are granted * - * additional permissions described in the GCC Runtime Library Exception, * - * version 3.1, as published by the Free Software Foundation. * - * * - * You should have received a copy of the GNU General Public License and * - * a copy of the GCC Runtime Library Exception along with this program; * - * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * - * . * + * As a special exception, if you link this file with other files to * + * produce an executable, this file does not by itself cause the resulting * + * executable to be covered by the GNU General Public License. This except- * + * ion does not however invalidate any other reasons why the executable * + * file might be covered by the GNU Public License. * * * * GNAT was originally developed by the GNAT team at New York University. * * Extensive contributions were provided by Ada Core Technologies Inc. * @@ -378,7 +379,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) } recurse = 0; - Raise_From_Signal_Handler (exception, (const char *) msg); + Raise_From_Signal_Handler (exception, (char *) msg); } void @@ -1975,23 +1976,20 @@ __gnat_map_signal (int sig) /* Tasking and Non-tasking signal handler. Map SIGnal to Ada exception propagation after the required low level adjustments. */ -sigset_t __gnat_signal_mask; - - /* VxWorks will always mask out the signal during the signal handler and - will reenable it on a longjmp. GNAT does not generate a longjmp to - return from a signal handler so exception signals will still be masked - unless we unmask it. __gnat_signal mask tells sigaction to block the - exception signals and sigprocmask to unblock them. */ - void __gnat_error_handler (int sig, void *si ATTRIBUTE_UNUSED, struct sigcontext *sc ATTRIBUTE_UNUSED) { + sigset_t mask; - /* This routine handles the exception signals for all tasks */ - - sigprocmask (SIG_UNBLOCK, &__gnat_signal_mask, NULL); + /* VxWorks will always mask out the signal during the signal handler and + will reenable it on a longjmp. GNAT does not generate a longjmp to + return from a signal handler so the signal will still be masked unless + we unmask it. */ + sigprocmask (SIG_SETMASK, NULL, &mask); + sigdelset (&mask, sig); + sigprocmask (SIG_SETMASK, &mask, NULL); __gnat_map_signal (sig); } @@ -2003,24 +2001,14 @@ __gnat_install_handler (void) /* Setup 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! This routine is called - only once, for the environment task. Other tasks are set up in the - System.Interrupt_Manager package. */ - - sigemptyset (&__gnat_signal_mask); - sigaddset (SIGBUS, &__gnat_signal_mask); - sigaddset (SIGFPE, &__gnat_signal_mask); - sigaddset (SIGILL, &__gnat_signal_mask); - sigaddset (SIGSEGV, &__gnat_signal_mask); + signal that might cause a scheduling event! */ act.sa_handler = __gnat_error_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK; - act.sa_mask = __gnat_signal_mask; - - /* For VxWorks, unconditionally install the exception signal handlers, since - pragma Interrupt_State applies to vectored hardware interrupts, not - signals. */ + sigemptyset (&act.sa_mask); + /* For VxWorks, install all signal handlers, since pragma Interrupt_State + applies to vectored hardware interrupts, not signals. */ sigaction (SIGFPE, &act, NULL); sigaction (SIGILL, &act, NULL); sigaction (SIGSEGV, &act, NULL); @@ -2040,7 +2028,6 @@ __gnat_init_float (void) below have no effect. */ #if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS) #if defined (__SPE__) - /* VxWorks 6 */ { const unsigned long spefscr_mask = 0xfffffff3; unsigned long spefscr; @@ -2049,7 +2036,6 @@ __gnat_init_float (void) asm ("mtspr 512, %0\n\tisync" : : "r" (spefscr)); } #else - /* all except VxWorks 653 and MILS */ asm ("mtfsb0 25"); asm ("mtfsb0 26"); #endif @@ -2057,7 +2043,7 @@ __gnat_init_float (void) #if (defined (__i386__) || defined (i386)) && !defined (VTHREADS) /* This is used to properly initialize the FPU on an x86 for each - process thread. For all except VxWorks 653 */ + process thread. */ asm ("finit"); #endif diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb index b3827d2f39e..57b9fcafcca 100644 --- a/gcc/ada/prj-conf.adb +++ b/gcc/ada/prj-conf.adb @@ -1107,7 +1107,12 @@ package body Prj.Conf is Write_Line (Config_File_Path.all); end if; - if Config_File_Path /= null then + if On_Load_Config /= null then + On_Load_Config + (Config_File => Config_Project_Node, + Project_Node_Tree => Project_Node_Tree); + + elsif Config_File_Path /= null then Prj.Part.Parse (In_Tree => Project_Node_Tree, Project => Config_Project_Node, @@ -1119,16 +1124,9 @@ package body Prj.Conf is Flags => Flags, Target_Name => Target_Name); else - -- Maybe the user will want to create his own configuration file Config_Project_Node := Empty_Node; end if; - if On_Load_Config /= null then - On_Load_Config - (Config_File => Config_Project_Node, - Project_Node_Tree => Project_Node_Tree); - end if; - if Config_Project_Node /= Empty_Node then Prj.Proc.Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb index 853d746d137..35ab83cee47 100644 --- a/gcc/ada/s-intman-vxworks.adb +++ b/gcc/ada/s-intman-vxworks.adb @@ -19,10 +19,10 @@ -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- @@ -39,27 +39,6 @@ package body System.Interrupt_Management is use System.OS_Interface; use type Interfaces.C.int; - type Signal_List is array (Signal_ID range <>) of Signal_ID; - Exception_Signals : constant Signal_List (1 .. 4) := - (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - - Exception_Action : aliased struct_sigaction; - -- Keep this a variable global so that it is initialized only once - - Signal_Mask : aliased sigset_t; - pragma Import (C, Signal_Mask, "__gnat_signal_mask"); - -- Mask indicating that all exception signals are to be masked - -- when a signal is propagated. - - procedure Notify_Exception - (signo : Signal; - siginfo : System.Address; - sigcontext : System.Address); - pragma Import (C, Notify_Exception, "__gnat_error_handler"); - -- Map a signal to Ada exception and raise it. Different versions - -- of VxWorks need different mappings. This is addressed in init.c in - -- __gnat_map_signal. - ----------------------- -- Local Subprograms -- ----------------------- @@ -77,26 +56,6 @@ package body System.Interrupt_Management is -- 's' Interrupt_State pragma set state to System (use "default" -- system handler) - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Since there is no signal inheritance between VxWorks tasks, we need - -- to initialize signal handling in each task. - - procedure Initialize_Interrupts is - Result : int; - old_act : aliased struct_sigaction; - begin - for J in Exception_Signals'Range loop - Result := - sigaction - (Signal (Exception_Signals (J)), Exception_Action'Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end loop; - end Initialize_Interrupts; - ---------------- -- Initialize -- ---------------- @@ -118,12 +77,6 @@ package body System.Interrupt_Management is Abort_Task_Interrupt := SIGABRT; - -- Signal_Mask was initialized in __gnat_install_handler - - Exception_Action.sa_handler := Notify_Exception'Address; - Exception_Action.sa_flags := SA_ONSTACK + SA_SIGINFO; - Exception_Action.sa_mask := Signal_Mask; - -- Initialize hardware interrupt handling pragma Assert (Reserve = (Interrupt_ID'Range => False)); diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index c86410a8695..d73324d9bc7 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -19,10 +19,10 @@ -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- @@ -87,6 +87,7 @@ package System.Interrupt_Management is -- or used to implement time delays. procedure Initialize_Interrupts; + pragma Import (C, Initialize_Interrupts, "__gnat_install_handler"); -- Under VxWorks, there is no signal inheritance between tasks. -- This procedure is used to initialize signal-to-exception mapping in -- each task. diff --git a/gcc/ada/s-regpat.ads b/gcc/ada/s-regpat.ads index 07911aa82d2..74e617fcdfb 100755 --- a/gcc/ada/s-regpat.ads +++ b/gcc/ada/s-regpat.ads @@ -349,7 +349,7 @@ package System.Regpat is -- 12 3 -- Matches (0) is for "a((b*)c+)(d+)" (the entire expression) -- Matches (1) is for "(b*)c+" - -- Matches (2) is for "c+" + -- Matches (2) is for "b*" -- Matches (3) is for "d+" -- -- The number of parenthesis groups that can be retrieved is limited only diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 207b465c579..c2b04a55c57 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -19,10 +19,10 @@ -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- @@ -94,11 +94,6 @@ package body System.Task_Primitives.Operations is Mutex_Protocol : Priority_Type; - Signal_Mask : aliased sigset_t; - pragma Import (C, Signal_Mask, "__gnat_signal_mask"); - -- Mask indicating that all exception signals are to be masked - -- when a signal is propagated. - Single_RTS_Lock : aliased RTS_Lock; -- This is a lock to allow only one thread of control in the RTS at a -- time; it is used to execute in mutual exclusion from all other tasks. @@ -180,11 +175,14 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (signo : Signal) is pragma Unreferenced (signo); - Self_ID : constant Task_Id := Self; - Old_Set : aliased sigset_t; - Result : int; + Self_ID : constant Task_Id := Self; + Old_Set : aliased sigset_t; + Unblocked_Mask : aliased sigset_t; + Result : int; pragma Warnings (Off, Result); + use System.Interrupt_Management; + begin -- It is not safe to raise an exception when using ZCX and the GCC -- exception handling mechanism. @@ -201,10 +199,26 @@ package body System.Task_Primitives.Operations is -- Make sure signals used for RTS internal purposes are unmasked + Result := sigemptyset (Unblocked_Mask'Access); + pragma Assert (Result = 0); + Result := + sigaddset + (Unblocked_Mask'Access, + Signal (Abort_Task_Interrupt)); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGBUS); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGFPE); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGILL); + pragma Assert (Result = 0); + Result := sigaddset (Unblocked_Mask'Access, SIGSEGV); + pragma Assert (Result = 0); + Result := pthread_sigmask (SIG_UNBLOCK, - Signal_Mask'Access, + Unblocked_Mask'Access, Old_Set'Access); pragma Assert (Result = 0); diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb index dedc52d8a89..aa6bbed1c88 100644 --- a/gcc/ada/sem_elim.adb +++ b/gcc/ada/sem_elim.adb @@ -282,6 +282,7 @@ package body Sem_Elim is if Present (Overridden) and then not Is_Eliminated (Overridden) + and then not Is_Abstract_Subprogram (Overridden) then Error_Msg_Name_1 := Chars (E); Error_Msg_N ("cannot eliminate subprogram %", E); diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 401373474ad..22270491492 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -40,10 +40,10 @@ package Stylesw is -- options. The default values shown here correspond to no style checking. -- If any of these values is set to a non-default value, then - -- Opt.Style_Check is set True to active calls to this package. + -- Opt.Style_Check is set True to activate calls to this package. -- The actual mechanism for setting these switches to other than default - -- values is via the Set_Style_Check_Option procedure or through a call to + -- values is via the Set_Style_Check_Options procedure or through a call to -- Set_Default_Style_Check_Options. They should not be set directly in any -- other manner. @@ -315,8 +315,8 @@ package Stylesw is procedure Set_Style_Check_Options (Options : String); -- Like the above procedure, but used when the Options string is known to - -- be valid. This is for example appropriate for calls where the string == - -- was obtained by Save_Style_Check_Options. + -- be valid. This is for example appropriate for calls where the string was + -- obtained by Save_Style_Check_Options. procedure Reset_Style_Check_Options; -- Sets all style check options to off -- 2.30.2