+2011-08-02 Javier Miranda <miranda@adacore.com>
+
+ * 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 <ruiz@adacore.com>
+
+ * 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 <celier@adacore.com>
+
+ * make.adb (Gnatmake): use <library dir>/lib<library name>.a to link
+ with an archive instead of -L<library dir> -l<library name>.
+
+2011-08-02 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <falis@adacore.com>
+
+ * 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 <dewar@adacore.com>
* sem_ch8.adb: Minor code reorganization, comment updates.
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 |
/* 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);
}
/* 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);
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;
asm ("mtspr 512, %0\n\tisync" : : "r" (spefscr));
}
#else
+ /* all except VxWorks 653 and MILS */
asm ("mtfsb0 25");
asm ("mtfsb0 26");
#endif
#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
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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
-- --
-- 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- --
-- 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
(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 --
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';
-- 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
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
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;
-- 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
-- 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 --
-- 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);
Self_ID : constant Task_Id := Self;
Old_Set : aliased sigset_t;
-
Result : int;
pragma Warnings (Off, Result);
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);
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);
-- 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;
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;
-- 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
(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 --
----------------------
-- 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));
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;
projects / gcc.git / commitdiff