From: Arnaud Charlet Date: Tue, 2 Aug 2011 08:13:21 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=806f6d372157633408dc26c7903e43b732710530;p=gcc.git [multiple changes] 2011-08-02 Javier Miranda * sem_ch6.adb (Can_Override_Operator): New function. (Verify_Overriding_Indicator): Add missing code to check overriding indicator in operators. Fixes regression. (Check_Overriding_Indicator): Minor reformating after replacing the code that evaluates if the subprogram can override an operator by invocations to the above new function. * einfo.adb (Write_Field26_Name): Add missing code to ensure that, following the documentation in einfo.ads, this field is not shown as attribute "Static_Initialization" on non-dispatching functions. 2011-08-02 Jose Ruiz * sem_res.adb (Resolve_Call): A call to Ada.Real_Time.Timing_Events.Set_Handler violates restriction No_Relative_Delay (AI-0211) only when it sets a relative timing event, i.e., when the second parameter is of type Time_Span. 2011-08-02 Vincent Celier * make.adb (Gnatmake): use /lib.a to link with an archive instead of -L -l. 2011-08-02 Ed Schonberg * sem_ch8.adb (Analyze_Use_Type): If the clause is being re-analyzed, mark the base types In_Use in addition to making the operations use_visible. 2011-08-02 Ed Falis * init.c: add and setup __gnat_signal_mask for the exception signals * s-inmaop-vxworks.adb: new file. * s-intman-vxworks.adb: remove unnecessary initializations and simplify remaining * s-intman-vxworks.ads: remove unnecessary variable * s-taprop-vxworks.adb: simplify signal initialization From-SVN: r177092 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ae47e20e5a1..5155a79c3bf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2011-08-02 Javier Miranda + + * sem_ch6.adb (Can_Override_Operator): New function. + (Verify_Overriding_Indicator): Add missing code to check overriding + indicator in operators. Fixes regression. + (Check_Overriding_Indicator): Minor reformating after replacing the + code that evaluates if the subprogram can override an operator by + invocations to the above new function. + * einfo.adb + (Write_Field26_Name): Add missing code to ensure that, following + the documentation in einfo.ads, this field is not shown as attribute + "Static_Initialization" on non-dispatching functions. + +2011-08-02 Jose Ruiz + + * sem_res.adb (Resolve_Call): A call to + Ada.Real_Time.Timing_Events.Set_Handler violates restriction + No_Relative_Delay (AI-0211) only when it sets a relative timing event, + i.e., when the second parameter is of type Time_Span. + +2011-08-02 Vincent Celier + + * make.adb (Gnatmake): use /lib.a to link + with an archive instead of -L -l. + +2011-08-02 Ed Schonberg + + * sem_ch8.adb (Analyze_Use_Type): If the clause is being re-analyzed, + mark the base types In_Use in addition to making the operations + use_visible. + +2011-08-02 Ed Falis + + * init.c: add and setup __gnat_signal_mask for the exception signals + * s-inmaop-vxworks.adb: new file. + * s-intman-vxworks.adb: remove unnecessary initializations and + simplify remaining + * s-intman-vxworks.ads: remove unnecessary variable + * s-taprop-vxworks.adb: simplify signal initialization + 2011-08-02 Robert Dewar * sem_ch8.adb: Minor code reorganization, comment updates. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8d65e9e7513..499db134ec8 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -8497,10 +8497,12 @@ package body Einfo is when E_Procedure | E_Function => - if Is_Dispatching_Operation (Id) then - Write_Str ("Overridden_Operation"); - else + if Ekind (Id) = E_Procedure + and then not Is_Dispatching_Operation (Id) + then Write_Str ("Static_Initialization"); + else + Write_Str ("Overridden_Operation"); end if; when E_Record_Type | diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 52d775586d2..53d72d9dbe9 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1975,20 +1975,23 @@ __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; - /* 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); + /* This routine handles the exception signals for all tasks */ + + sigprocmask (SIG_UNBLOCK, &__gnat_signal_mask, NULL); __gnat_map_signal (sig); } @@ -2000,14 +2003,24 @@ __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! */ + 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); act.sa_handler = __gnat_error_handler; act.sa_flags = SA_SIGINFO | SA_ONSTACK; - sigemptyset (&act.sa_mask); + 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. */ - /* 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); @@ -2027,6 +2040,7 @@ __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; @@ -2035,6 +2049,7 @@ __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 @@ -2042,7 +2057,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. */ + process thread. For all except VxWorks 653 */ asm ("finit"); #endif diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index cc8cb36a921..6051c794d0e 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6066,24 +6066,41 @@ package body Make is end loop; for Index in 1 .. Library_Projs.Last loop + if + Library_Projs.Table (Index).Library_Kind = Static + then + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String' + (Get_Name_String + (Library_Projs.Table (Index). + Library_Dir.Display_Name) & + Directory_Separator & + "lib" & + Get_Name_String + (Library_Projs.Table (Index). + Library_Name) & + ".a"); - -- Add the -L switch - - Linker_Switches.Increment_Last; - Linker_Switches.Table (Linker_Switches.Last) := - new String'("-L" & - Get_Name_String - (Library_Projs.Table (Index). - Library_Dir.Display_Name)); - - -- Add the -l switch - - Linker_Switches.Increment_Last; - Linker_Switches.Table (Linker_Switches.Last) := - new String'("-l" & - Get_Name_String - (Library_Projs.Table (Index). - Library_Name)); + else + -- Add the -L switch + + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-L" & + Get_Name_String + (Library_Projs.Table (Index). + Library_Dir.Display_Name)); + + -- Add the -l switch + + Linker_Switches.Increment_Last; + Linker_Switches.Table (Linker_Switches.Last) := + new String'("-l" & + Get_Name_String + (Library_Projs.Table (Index). + Library_Name)); + end if; end loop; end if; diff --git a/gcc/ada/s-inmaop-vxworks.adb b/gcc/ada/s-inmaop-vxworks.adb new file mode 100755 index 00000000000..fe3b7417120 --- /dev/null +++ b/gcc/ada/s-inmaop-vxworks.adb @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-2010, 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- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a VxWorks version of this package. Many operations are null as this +-- package supports the use of Ada interrupt handling facilities for signals, +-- while those facilities are used for hardware interrupts on these targets. + +with Ada.Exceptions; + +with Interfaces.C; + +with System.OS_Interface; + +package body System.Interrupt_Management.Operations is + + use Ada.Exceptions; + use Interfaces.C; + use System.OS_Interface; + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt + (Interrupt : Interrupt_ID) + is + pragma Unreferenced (Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Thread_Block_Interrupt unimplemented"); + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt + (Interrupt : Interrupt_ID) + is + pragma Unreferenced (Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Thread_Unblock_Interrupt unimplemented"); + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Unreferenced (Mask); + begin + null; + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) + is + pragma Unreferenced (Mask, OMask); + begin + Raise_Exception + (Program_Error'Identity, + "Set_Interrupt_Mask unimplemented"); + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Unreferenced (Mask); + begin + Raise_Exception + (Program_Error'Identity, + "Get_Interrupt_Mask unimplemented"); + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function Interrupt_Wait + (Mask : access Interrupt_Mask) return Interrupt_ID + is + pragma Unreferenced (Mask); + begin + Raise_Exception + (Program_Error'Identity, + "Interrupt_Wait unimplemented"); + return 0; + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + pragma Unreferenced (Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Install_Default_Action unimplemented"); + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + pragma Unreferenced (Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Install_Ignore_Action unimplemented"); + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Unreferenced (Mask); + begin + Raise_Exception + (Program_Error'Identity, + "Fill_Interrupt_Mask unimplemented"); + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Unreferenced (Mask); + begin + Raise_Exception + (Program_Error'Identity, + "Empty_Interrupt_Mask unimplemented"); + end Empty_Interrupt_Mask; + + --------------------------- + -- Add_To_Interrupt_Mask -- + --------------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + pragma Unreferenced (Mask, Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Add_To_Interrupt_Mask unimplemented"); + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + pragma Unreferenced (Mask, Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Delete_From_Interrupt_Mask unimplemented"); + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + pragma Unreferenced (Mask, Interrupt); + begin + Raise_Exception + (Program_Error'Identity, + "Is_Member unimplemented"); + return False; + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) is + pragma Unreferenced (X, Y); + begin + Raise_Exception + (Program_Error'Identity, + "Copy_Interrupt_Mask unimplemented"); + end Copy_Interrupt_Mask; + + ---------------------------- + -- Interrupt_Self_Process -- + ---------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + Result : Interfaces.C.int; + begin + Result := kill (getpid, Signal (Interrupt)); + pragma Assert (Result = 0); + end Interrupt_Self_Process; + + -------------------------- + -- Setup_Interrupt_Mask -- + -------------------------- + + procedure Setup_Interrupt_Mask is + begin + Raise_Exception + (Program_Error'Identity, + "Setup_Interrupt_Mask unimplemented"); + end Setup_Interrupt_Mask; + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb index dacc418f05c..853d746d137 100644 --- a/gcc/ada/s-intman-vxworks.adb +++ b/gcc/ada/s-intman-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -31,9 +31,8 @@ -- This is the VxWorks version of this package --- Make a careful study of all signals available under the OS, to see which --- need to be reserved, kept always unmasked, or kept always unmasked. Be on --- the lookout for special signals that may be used by the thread library. +-- It is simpler than other versions because the Ada interrupt handling +-- mechanisms are used for hardware interrupts rather than signals. package body System.Interrupt_Management is @@ -45,15 +44,21 @@ package body System.Interrupt_Management is (SIGFPE, SIGILL, SIGSEGV, SIGBUS); Exception_Action : aliased struct_sigaction; - -- Keep this variable global so that it is initialized only once + -- 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 signal to Ada exception and raise it. Different versions - -- of VxWorks need different mappings. + -- 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 -- @@ -62,7 +67,7 @@ package body System.Interrupt_Management is function State (Int : Interrupt_ID) return Character; pragma Import (C, State, "__gnat_get_interrupt_state"); -- Get interrupt state. Defined in init.c The input argument is the - -- interrupt number, and the result is one of the following: + -- hardware interrupt number, and the result is one of the following: Runtime : constant Character := 'r'; Default : constant Character := 's'; @@ -100,8 +105,6 @@ package body System.Interrupt_Management is -- Set to True once Initialize is called, further calls have no effect procedure Initialize is - mask : aliased sigset_t; - Result : int; begin if Initialized then @@ -115,17 +118,11 @@ 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; - Result := sigemptyset (mask'Access); - pragma Assert (Result = 0); - - for J in Exception_Signals'Range loop - Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); - pragma Assert (Result = 0); - end loop; - - Exception_Action.sa_mask := mask; + Exception_Action.sa_mask := Signal_Mask; -- Initialize hardware interrupt handling @@ -139,15 +136,6 @@ package body System.Interrupt_Management is end if; end loop; - -- Add exception signals to the set of unmasked signals - - for J in Exception_Signals'Range loop - Keep_Unmasked (Exception_Signals (J)) := True; - end loop; - - -- The abort signal must also be unmasked - - Keep_Unmasked (Abort_Task_Interrupt) := True; end Initialize; end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index 5614553c77b..c86410a8695 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -80,14 +80,6 @@ package System.Interrupt_Management is -- The signal that is used to implement task abort if an interrupt is used -- for that purpose. This is one of the reserved signals. - Keep_Unmasked : Signal_Set := (others => False); - -- Keep_Unmasked (I) is true iff the signal I is one that must that must - -- be kept unmasked at all times, except (perhaps) for short critical - -- sections. This includes signals that are mapped to exceptions, but may - -- also include interrupts (e.g. timer) that need to be kept unmasked for - -- other reasons. Where signal masking is per-task, the signal should be - -- unmasked in ALL TASKS. - Reserve : Interrupt_Set := (others => False); -- Reserve (I) is true iff the interrupt I is one that cannot be permitted -- to be attached to a user handler. The possible reasons are many. For diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 3186f6fb962..207b465c579 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -78,40 +78,34 @@ package body System.Task_Primitives.Operations is -- The followings are logically constants, but need to be initialized at -- run time. - 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. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - Environment_Task_Id : Task_Id; -- A variable to hold Task_Id for the environment task - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - -- The followings are internal configuration constants needed - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads) Locking_Policy : Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - Mutex_Protocol : Priority_Type; - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads) + 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. - type Set_Stack_Limit_Proc_Acc is access procedure; - pragma Convention (C, Set_Stack_Limit_Proc_Acc); + 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. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; - pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); - -- Procedure to be called when a task is created to set stack - -- limit. + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); -------------------- -- Local Packages -- @@ -168,6 +162,14 @@ package body System.Task_Primitives.Operations is -- This function returns True if the current execution is in the context -- of a task, and False if it is an interrupt context. + type Set_Stack_Limit_Proc_Acc is access procedure; + pragma Convention (C, Set_Stack_Limit_Proc_Acc); + + Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; + pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); + -- Procedure to be called when a task is created to set stack + -- limit. Used only for VxWorks 5 and VxWorks MILS guest OS. + function To_Address is new Ada.Unchecked_Conversion (Task_Id, System.Address); @@ -180,7 +182,6 @@ package body System.Task_Primitives.Operations is Self_ID : constant Task_Id := Self; Old_Set : aliased sigset_t; - Result : int; pragma Warnings (Off, Result); @@ -198,12 +199,12 @@ package body System.Task_Primitives.Operations is then Self_ID.Aborting := True; - -- Make sure signals used for RTS internal purpose are unmasked + -- Make sure signals used for RTS internal purposes are unmasked Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Access, + Signal_Mask'Access, Old_Set'Access); pragma Assert (Result = 0); @@ -1380,16 +1381,6 @@ package body System.Task_Primitives.Operations is end if; - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Signal_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index af20ffaa40f..3dc7ee8dd85 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -128,6 +128,9 @@ package body Sem_Ch6 is -- If proper warnings are enabled and the subprogram contains a construct -- that cannot be inlined, the offending construct is flagged accordingly. + function Can_Override_Operator (Subp : Entity_Id) return Boolean; + -- Returns true if Subp can override a predefined operator. + procedure Check_Conformance (New_Id : Entity_Id; Old_Id : Entity_Id; @@ -2099,11 +2102,19 @@ package body Sem_Ch6 is Body_Spec); end if; - elsif Style_Check -- ??? incorrect use of Style_Check! + elsif Style_Check and then Present (Overridden_Operation (Spec_Id)) then pragma Assert (Unit_Declaration_Node (Body_Id) = N); Style.Missing_Overriding (N, Body_Id); + + elsif Style_Check + and then Can_Override_Operator (Spec_Id) + and then not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Spec_Id))) + then + pragma Assert (Unit_Declaration_Node (Body_Id) = N); + Style.Missing_Overriding (N, Body_Id); end if; end Verify_Overriding_Indicator; @@ -4854,61 +4865,50 @@ package body Sem_Ch6 is -- explicit overridden operation. elsif Nkind (Subp) = N_Defining_Operator_Symbol then - declare - Typ : constant Entity_Id := - Base_Type (Etype (First_Formal (Subp))); - - Can_Override : constant Boolean := - Operator_Matches_Spec (Subp, Subp) - and then Scope (Subp) = Scope (Typ) - and then not Is_Class_Wide_Type (Typ); + if Must_Not_Override (Spec) then - begin - if Must_Not_Override (Spec) then + -- If this is not a primitive or a protected subprogram, then + -- "not overriding" is illegal. - -- If this is not a primitive or a protected subprogram, then - -- "not overriding" is illegal. + if not Is_Primitive + and then Ekind (Scope (Subp)) /= E_Protected_Type + then + Error_Msg_N + ("overriding indicator only allowed " + & "if subprogram is primitive", Subp); - if not Is_Primitive - and then Ekind (Scope (Subp)) /= E_Protected_Type - then - Error_Msg_N - ("overriding indicator only allowed " - & "if subprogram is primitive", Subp); + elsif Can_Override_Operator (Subp) then + Error_Msg_NE + ("subprogram& overrides predefined operator ", Spec, Subp); + end if; - elsif Can_Override then - Error_Msg_NE - ("subprogram& overrides predefined operator ", Spec, Subp); - end if; + elsif Must_Override (Spec) then + if No (Overridden_Operation (Subp)) + and then not Can_Override_Operator (Subp) + then + Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); + end if; - elsif Must_Override (Spec) then - if No (Overridden_Operation (Subp)) - and then not Can_Override - then - Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); - end if; + elsif not Error_Posted (Subp) + and then Style_Check + and then Can_Override_Operator (Subp) + and then + not Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))) + then + -- If style checks are enabled, indicate that the indicator is + -- missing. However, at the point of declaration, the type of + -- which this is a primitive operation may be private, in which + -- case the indicator would be premature. - elsif not Error_Posted (Subp) - and then Style_Check - and then Can_Override - and then - not Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Subp))) + if Has_Private_Declaration (Etype (Subp)) + or else Has_Private_Declaration (Etype (First_Formal (Subp))) then - -- If style checks are enabled, indicate that the indicator is - -- missing. However, at the point of declaration, the type of - -- which this is a primitive operation may be private, in which - -- case the indicator would be premature. - - if Has_Private_Declaration (Etype (Subp)) - or else Has_Private_Declaration (Etype (First_Formal (Subp))) - then - null; - else - Style.Missing_Overriding (Decl, Subp); - end if; + null; + else + Style.Missing_Overriding (Decl, Subp); end if; - end; + end if; elsif Must_Override (Spec) then if Ekind (Subp) = E_Entry then @@ -5442,6 +5442,25 @@ package body Sem_Ch6 is (New_Id, Old_Id, Type_Conformant, True, Result, Err_Loc); end Check_Type_Conformant; + --------------------------- + -- Can_Override_Operator -- + --------------------------- + + function Can_Override_Operator (Subp : Entity_Id) return Boolean is + Typ : Entity_Id; + begin + if Nkind (Subp) /= N_Defining_Operator_Symbol then + return False; + + else + Typ := Base_Type (Etype (First_Formal (Subp))); + + return Operator_Matches_Spec (Subp, Subp) + and then Scope (Subp) = Scope (Typ) + and then not Is_Class_Wide_Type (Typ); + end if; + end Can_Override_Operator; + ---------------------- -- Conforming_Types -- ---------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7f4e4b166ff..32d40020343 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -2683,12 +2683,24 @@ package body Sem_Ch8 is -- been analyzed previously, and it is begin reinstalled, for example -- when the clause appears in a package spec and we are compiling the -- corresponding package body. In that case, make the entities on the - -- existing list use-visible. + -- existing list use_visible, and mark the corresponding types In_Use. if Present (Used_Operations (N)) then declare + Mark : Node_Id; Elmt : Elmt_Id; + begin + Mark := First (Subtype_Marks (N)); + while Present (Mark) loop + if not In_Use (Entity (Mark)) + and then not Is_Potentially_Use_Visible (Entity (Mark)) + then + Set_In_Use (Base_Type (Entity (Mark))); + end if; + Next (Mark); + end loop; + Elmt := First_Elmt (Used_Operations (N)); while Present (Elmt) loop Set_Is_Potentially_Use_Visible (Node (Elmt)); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 7f71d1bfff1..d40ad9b2b6e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5648,10 +5648,14 @@ package body Sem_Res is Check_Potentially_Blocking_Operation (N); end if; - -- A call to Ada.Real_Time.Timing_Events.Set_Handler violates - -- restriction No_Relative_Delay (AI-0211). + -- A call to Ada.Real_Time.Timing_Events.Set_Handler to set a relative + -- timing event violates restriction No_Relative_Delay (AI-0211). We + -- need to check the second argument to determine whether it is an + -- absolute or relative timing event. - if Is_RTE (Nam, RE_Set_Handler) then + if Is_RTE (Nam, RE_Set_Handler) + and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) + then Check_Restriction (No_Relative_Delay, N); end if;