OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-07-16  Bob Duff  <duff@adacore.com>

	* gnat_ugn.texi: Document need for project file
	for --incremental switch for gnat2xml.

2014-07-16  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Fix example of non-packable components in packed
	records section.

2014-07-16  Robert Dewar  <dewar@adacore.com>

	* s-tpoben.adb, s-tasren.adb, s-interr.adb, s-interr-hwint.adb,
	s-shasto.adb, s-interr-vms.adb, s-interr-sigaction.adb: Avoid use of
	upper case in exception messages.

From-SVN: r212650
This commit is contained in:
Arnaud Charlet 2014-07-16 16:19:43 +02:00
parent ea70f3d0c1
commit 350f5d3bc4
10 changed files with 305 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/ada/ChangeLog
View File

@ -1,3 +1,19 @@
2014-07-16 Bob Duff <duff@adacore.com>
* gnat_ugn.texi: Document need for project file
for --incremental switch for gnat2xml.
2014-07-16 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Fix example of non-packable components in packed
records section.
2014-07-16 Robert Dewar <dewar@adacore.com>
* s-tpoben.adb, s-tasren.adb, s-interr.adb, s-interr-hwint.adb,
s-shasto.adb, s-interr-vms.adb, s-interr-sigaction.adb: Avoid use of
upper case in exception messages.
2014-07-16 Robert Dewar <dewar@adacore.com> 2014-07-16 Robert Dewar <dewar@adacore.com>
* snames.ads-tmpl, sem_attr.adb, exp_attr.adb: Same_Storage attribute * snames.ads-tmpl, sem_attr.adb, exp_attr.adb: Same_Storage attribute

11
gcc/ada/gnat_rm.texi
View File

@ -15464,7 +15464,8 @@ taken by components. We distinguish between @emph{packable} components and
Components of the following types are considered packable: Components of the following types are considered packable:
@itemize @bullet @itemize @bullet
@item @item
All primitive types are packable. Components of a primitive type are packable unless they are aliased
or of an atomic type.
@item @item
Small packed arrays, whose size does not exceed 64 bits, and where the Small packed arrays, whose size does not exceed 64 bits, and where the
@ -15491,10 +15492,12 @@ For example, consider the record
type Rb2 is array (1 .. 65) of Boolean; type Rb2 is array (1 .. 65) of Boolean;
pragma Pack (rb2); pragma Pack (rb2);
type AF is new Float with Atomic;
type x2 is record type x2 is record
l1 : Boolean; l1 : Boolean;
l2 : Duration; l2 : Duration;
l3 : Float; l3 : AF;
l4 : Boolean; l4 : Boolean;
l5 : Rb1; l5 : Rb1;
l6 : Rb2; l6 : Rb2;
@ -15522,8 +15525,8 @@ Studying this example, we see that the packable fields @code{l1}
and @code{l2} are and @code{l2} are
of length equal to their sizes, and placed at specific bit boundaries (and of length equal to their sizes, and placed at specific bit boundaries (and
not byte boundaries) to not byte boundaries) to
eliminate padding. But @code{l3} is of a non-packable float type, so eliminate padding. But @code{l3} is of a non-packable float type (because
it is on the next appropriate alignment boundary. it is aliased), so it is on the next appropriate alignment boundary.
The next two fields are fully packable, so @code{l4} and @code{l5} are The next two fields are fully packable, so @code{l4} and @code{l5} are
minimally packed with no gaps. However, type @code{Rb2} is a packed minimally packed with no gaps. However, type @code{Rb2} is a packed

3
gcc/ada/gnat_ugn.texi
View File

@ -15145,7 +15145,8 @@ Options:
--incremental -- incremental processing on a per-file basis. Source files are --incremental -- incremental processing on a per-file basis. Source files are
only processed if they have been modified, or if files they depend only processed if they have been modified, or if files they depend
on have been modified. This is similar to the way gnatmake/gprbuild on have been modified. This is similar to the way gnatmake/gprbuild
only compiles files that need to be recompiled. only compiles files that need to be recompiled. You need to use a project
file for this to work.
--output-dir=@var{dir} -- generate one .xml file for each Ada source file, in --output-dir=@var{dir} -- generate one .xml file for each Ada source file, in
directory @file{dir}. (Default is to generate the XML to standard directory @file{dir}. (Default is to generate the XML to standard

192
gcc/ada/s-interr-hwint.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -54,14 +54,14 @@
-- any time. -- any time.
-- Within this package, the lock L is used to protect the various status -- Within this package, the lock L is used to protect the various status
-- tables. If there is a Server_Task associated with a signal or interrupt, we -- tables. If there is a Server_Task associated with a signal or interrupt,
-- use the per-task lock of the Server_Task instead so that we protect the -- we use the per-task lock of the Server_Task instead so that we protect the
-- status between Interrupt_Manager and Server_Task. Protection among service -- status between Interrupt_Manager and Server_Task. Protection among service
-- requests are ensured via user calls to the Interrupt_Manager entries. -- requests are ensured via user calls to the Interrupt_Manager entries.
-- This is reasonably generic version of this package, supporting vectored -- This is reasonably generic version of this package, supporting vectored
-- hardware interrupts using non-RTOS specific adapter routines which -- hardware interrupts using non-RTOS specific adapter routines which should
-- should easily implemented on any RTOS capable of supporting GNAT. -- easily implemented on any RTOS capable of supporting GNAT.
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with Ada.Task_Identification; with Ada.Task_Identification;
@ -92,8 +92,8 @@ package body System.Interrupts is
-- Local Tasks -- -- Local Tasks --
----------------- -----------------
-- WARNING: System.Tasking.Stages performs calls to this task with -- WARNING: System.Tasking.Stages performs calls to this task with low-
-- low-level constructs. Do not change this spec without synchronizing it. -- level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id); entry Detach_Interrupt_Entries (T : Task_Id);
@ -148,8 +148,8 @@ package body System.Interrupts is
(others => (null, Static => False)); (others => (null, Static => False));
pragma Volatile_Components (User_Handler); pragma Volatile_Components (User_Handler);
-- Holds the protected procedure handler (if any) and its Static -- Holds the protected procedure handler (if any) and its Static
-- information for each interrupt or signal. A handler is static -- information for each interrupt or signal. A handler is static iff it
-- iff it is specified through the pragma Attach_Handler. -- is specified through the pragma Attach_Handler.
User_Entry : array (Interrupt_ID) of Entry_Assoc := User_Entry : array (Interrupt_ID) of Entry_Assoc :=
(others => (T => Null_Task, E => Null_Task_Entry)); (others => (T => Null_Task, E => Null_Task_Entry));
@ -181,8 +181,8 @@ package body System.Interrupts is
Semaphore_ID_Map : array Semaphore_ID_Map : array
(Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt)
of Binary_Semaphore_Id := (others => 0); of Binary_Semaphore_Id := (others => 0);
-- Array of binary semaphores associated with vectored interrupts -- Array of binary semaphores associated with vectored interrupts. Note
-- Note that the last bound should be Max_HW_Interrupt, but this will raise -- that the last bound should be Max_HW_Interrupt, but this will raise
-- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
-- instead. -- instead.
@ -190,9 +190,9 @@ package body System.Interrupts is
-- Variable for allocating an Interrupt_Server_Task -- Variable for allocating an Interrupt_Server_Task
Handler_Installed : array (HW_Interrupt) of Boolean := (others => False); Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
-- True if Notify_Interrupt was connected to the interrupt. Handlers -- True if Notify_Interrupt was connected to the interrupt. Handlers can
-- can be connected but disconnection is not possible on VxWorks. -- be connected but disconnection is not possible on VxWorks. Therefore
-- Therefore we ensure Notify_Installed is connected at most once. -- we ensure Notify_Installed is connected at most once.
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
@ -230,12 +230,12 @@ package body System.Interrupts is
-------------------- --------------------
-- Calling this procedure with New_Handler = null and Static = True -- Calling this procedure with New_Handler = null and Static = True
-- means we want to detach the current handler regardless of the -- means we want to detach the current handler regardless of the previous
-- previous handler's binding status (i.e. do not care if it is a -- handler's binding status (i.e. do not care if it is a dynamic or static
-- dynamic or static handler). -- handler).
-- This option is needed so that during the finalization of a PO, we -- This option is needed so that during the finalization of a PO, we can
-- can detach handlers attached through pragma Attach_Handler. -- detach handlers attached through pragma Attach_Handler.
procedure Attach_Handler procedure Attach_Handler
(New_Handler : Parameterless_Handler; (New_Handler : Parameterless_Handler;
@ -260,8 +260,7 @@ package body System.Interrupts is
Int_Ref : System.Address) Int_Ref : System.Address)
is is
Interrupt : constant Interrupt_ID := Interrupt : constant Interrupt_ID :=
Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
begin begin
Check_Reserved_Interrupt (Interrupt); Check_Reserved_Interrupt (Interrupt);
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
@ -284,7 +283,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
else else
return; return;
end if; end if;
@ -300,9 +299,9 @@ package body System.Interrupts is
begin begin
Check_Reserved_Interrupt (Interrupt); Check_Reserved_Interrupt (Interrupt);
-- ??? Since Parameterless_Handler is not Atomic, the -- ??? Since Parameterless_Handler is not Atomic, the current
-- current implementation is wrong. We need a new service in -- implementation is wrong. We need a new service in Interrupt_Manager
-- Interrupt_Manager to ensure atomicity. -- to ensure atomicity.
return User_Handler (Interrupt).H; return User_Handler (Interrupt).H;
end Current_Handler; end Current_Handler;
@ -320,7 +319,8 @@ package body System.Interrupts is
procedure Detach_Handler procedure Detach_Handler
(Interrupt : Interrupt_ID; (Interrupt : Interrupt_ID;
Static : Boolean := False) is Static : Boolean := False)
is
begin begin
Check_Reserved_Interrupt (Interrupt); Check_Reserved_Interrupt (Interrupt);
Interrupt_Manager.Detach_Handler (Interrupt, Static); Interrupt_Manager.Detach_Handler (Interrupt, Static);
@ -340,12 +340,12 @@ package body System.Interrupts is
---------------------- ----------------------
-- Calling this procedure with New_Handler = null and Static = True -- Calling this procedure with New_Handler = null and Static = True
-- means we want to detach the current handler regardless of the -- means we want to detach the current handler regardless of the previous
-- previous handler's binding status (i.e. do not care if it is a -- handler's binding status (i.e. we do not care if it is a dynamic or
-- dynamic or static handler). -- static handler).
-- This option is needed so that during the finalization of a PO, we -- This option is needed so that during the finalization of a PO, we can
-- can detach handlers attached through pragma Attach_Handler. -- detach handlers attached through pragma Attach_Handler.
procedure Exchange_Handler procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler; (Old_Handler : out Parameterless_Handler;
@ -394,7 +394,6 @@ package body System.Interrupts is
procedure Finalize_Interrupt_Servers is procedure Finalize_Interrupt_Servers is
HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
begin begin
if HW_Interrupts then if HW_Interrupts then
for Int in HW_Interrupt loop for Int in HW_Interrupt loop
@ -405,8 +404,8 @@ package body System.Interrupts is
then then
Interrupt_Manager.Attach_Handler Interrupt_Manager.Attach_Handler
(New_Handler => null, (New_Handler => null,
Interrupt => Interrupt_ID (Int), Interrupt => Interrupt_ID (Int),
Static => True, Static => True,
Restoration => True); Restoration => True);
end if; end if;
end loop; end loop;
@ -579,7 +578,6 @@ package body System.Interrupts is
Fat := To_Fat_Ptr (Handler); Fat := To_Fat_Ptr (Handler);
Ptr := Registered_Handler_Head; Ptr := Registered_Handler_Head;
while Ptr /= null loop while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then if Ptr.H = Fat.Handler_Addr then
return True; return True;
@ -605,31 +603,28 @@ package body System.Interrupts is
-- Notify_Interrupt -- -- Notify_Interrupt --
---------------------- ----------------------
-- Umbrella handler for vectored hardware interrupts (as opposed to -- Umbrella handler for vectored hardware interrupts (as opposed to signals
-- signals and exceptions). As opposed to the signal implementation, -- and exceptions). As opposed to the signal implementation, this handler
-- this handler is installed in the vector table when the first Ada -- is installed in the vector table when the first Ada handler is attached
-- handler is attached to the interrupt. However because VxWorks don't -- to the interrupt. However because VxWorks don't support disconnecting
-- support disconnecting handlers, this subprogram always test whether -- handlers, this subprogram always test whether or not an Ada handler is
-- or not an Ada handler is effectively attached. -- effectively attached.
-- Otherwise, the handler that existed prior to program startup is -- Otherwise, the handler that existed prior to program startup is in the
-- in the vector table. This ensures that handlers installed by -- vector table. This ensures that handlers installed by the BSP are active
-- the BSP are active unless explicitly replaced in the program text. -- unless explicitly replaced in the program text.
-- Each Interrupt_Server_Task has an associated binary semaphore -- Each Interrupt_Server_Task has an associated binary semaphore on which
-- on which it pends once it's been started. This routine determines -- it pends once it's been started. This routine determines The appropriate
-- The appropriate semaphore and issues a semGive call, waking -- semaphore and issues a semGive call, waking the server task. When
-- the server task. When a handler is unbound, -- a handler is unbound, System.Interrupts.Unbind_Handler issues a
-- System.Interrupts.Unbind_Handler issues a Binary_Semaphore_Flush, -- Binary_Semaphore_Flush, and the server task deletes its semaphore
-- and the server task deletes its semaphore and terminates. -- and terminates.
procedure Notify_Interrupt (Param : System.Address) is procedure Notify_Interrupt (Param : System.Address) is
Interrupt : constant Interrupt_ID := Interrupt_ID (Param); Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt); Status : int;
Status : int;
begin begin
if Id /= 0 then if Id /= 0 then
Status := Binary_Semaphore_Release (Id); Status := Binary_Semaphore_Release (Id);
@ -645,7 +640,7 @@ package body System.Interrupts is
begin begin
Check_Reserved_Interrupt (Interrupt); Check_Reserved_Interrupt (Interrupt);
return Storage_Elements.To_Address return Storage_Elements.To_Address
(Storage_Elements.Integer_Address (Interrupt)); (Storage_Elements.Integer_Address (Interrupt));
end Reference; end Reference;
-------------------------------- --------------------------------
@ -656,15 +651,15 @@ package body System.Interrupts is
New_Node_Ptr : R_Link; New_Node_Ptr : R_Link;
begin begin
-- This routine registers a handler as usable for dynamic -- This routine registers a handler as usable for dynamic interrupt
-- interrupt handler association. Routines attaching and detaching -- handler association. Routines attaching and detaching handlers
-- handlers dynamically should determine whether the handler is -- dynamically should determine whether the handler is registered.
-- registered. Program_Error should be raised if it is not registered. -- Program_Error should be raised if it is not registered.
-- Pragma Interrupt_Handler can only appear in a library -- Pragma Interrupt_Handler can only appear in a library level PO
-- level PO definition and instantiation. Therefore, we do not need -- definition and instantiation. Therefore, we do not need to implement
-- to implement an unregister operation. Nor do we need to -- an unregister operation. Nor do we need to protect the queue
-- protect the queue structure with a lock. -- structure with a lock.
pragma Assert (Handler_Addr /= System.Null_Address); pragma Assert (Handler_Addr /= System.Null_Address);
@ -674,7 +669,6 @@ package body System.Interrupts is
if Registered_Handler_Head = null then if Registered_Handler_Head = null then
Registered_Handler_Head := New_Node_Ptr; Registered_Handler_Head := New_Node_Ptr;
Registered_Handler_Tail := New_Node_Ptr; Registered_Handler_Tail := New_Node_Ptr;
else else
Registered_Handler_Tail.Next := New_Node_Ptr; Registered_Handler_Tail.Next := New_Node_Ptr;
Registered_Handler_Tail := New_Node_Ptr; Registered_Handler_Tail := New_Node_Ptr;
@ -717,7 +711,7 @@ package body System.Interrupts is
procedure Unimplemented (Feature : String) is procedure Unimplemented (Feature : String) is
begin begin
raise Program_Error with Feature & " not implemented on VxWorks"; raise Program_Error with feature & " not implemented on VxWorks";
end Unimplemented; end Unimplemented;
----------------------- -----------------------
@ -732,8 +726,8 @@ package body System.Interrupts is
procedure Bind_Handler (Interrupt : Interrupt_ID); procedure Bind_Handler (Interrupt : Interrupt_ID);
-- This procedure does not do anything if a signal is blocked. -- This procedure does not do anything if a signal is blocked.
-- Otherwise, we have to interrupt Server_Task for status change through -- Otherwise, we have to interrupt Server_Task for status change
-- a wakeup signal. -- through a wakeup signal.
procedure Unbind_Handler (Interrupt : Interrupt_ID); procedure Unbind_Handler (Interrupt : Interrupt_ID);
-- This procedure does not do anything if a signal is blocked. -- This procedure does not do anything if a signal is blocked.
@ -767,8 +761,8 @@ package body System.Interrupts is
procedure Unbind_Handler (Interrupt : Interrupt_ID) is procedure Unbind_Handler (Interrupt : Interrupt_ID) is
Status : int; Status : int;
begin
begin
-- Flush server task off semaphore, allowing it to terminate -- Flush server task off semaphore, allowing it to terminate
Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt)); Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
@ -786,11 +780,12 @@ package body System.Interrupts is
Old_Handler : Parameterless_Handler; Old_Handler : Parameterless_Handler;
begin begin
if User_Entry (Interrupt).T /= Null_Task then if User_Entry (Interrupt).T /= Null_Task then
-- If an interrupt entry is installed raise
-- Program_Error. (propagate it to the caller). -- If an interrupt entry is installed raise Program_Error
-- (propagate it to the caller).
raise Program_Error with raise Program_Error with
"An interrupt entry is already installed"; "an interrupt entry is already installed";
end if; end if;
-- Note : Static = True will pass the following check. This is the -- Note : Static = True will pass the following check. This is the
@ -799,11 +794,11 @@ package body System.Interrupts is
if not Static and then User_Handler (Interrupt).Static then if not Static and then User_Handler (Interrupt).Static then
-- Trying to detach a static Interrupt Handler. raise -- Trying to detach a static Interrupt Handler, raise
-- Program_Error. -- Program_Error.
raise Program_Error with raise Program_Error with
"Trying to detach a static Interrupt Handler"; "trying to detach a static Interrupt Handler";
end if; end if;
Old_Handler := User_Handler (Interrupt).H; Old_Handler := User_Handler (Interrupt).H;
@ -833,32 +828,32 @@ package body System.Interrupts is
if User_Entry (Interrupt).T /= Null_Task then if User_Entry (Interrupt).T /= Null_Task then
-- If an interrupt entry is already installed, raise -- If an interrupt entry is already installed, raise
-- Program_Error. (propagate it to the caller). -- Program_Error (propagate it to the caller).
raise Program_Error with "An interrupt is already installed"; raise Program_Error with "an interrupt is already installed";
end if; end if;
-- Note : A null handler with Static = True will -- Note : A null handler with Static = True will pass the following
-- pass the following check. This is the case when we want to -- check. This is the case when we want to detach a handler
-- detach a handler regardless of the Static status -- regardless of the Static status of Current_Handler.
-- of Current_Handler.
-- We don't check anything if Restoration is True, since we -- We don't check anything if Restoration is True, since we may be
-- may be detaching a static handler to restore a dynamic one. -- detaching a static handler to restore a dynamic one.
if not Restoration and then not Static if not Restoration and then not Static
and then (User_Handler (Interrupt).Static and then (User_Handler (Interrupt).Static
-- Trying to overwrite a static Interrupt Handler with a -- Trying to overwrite a static Interrupt Handler with a dynamic
-- dynamic Handler -- Handler
-- The new handler is not specified as an -- The new handler is not specified as an Interrupt Handler by a
-- Interrupt Handler by a pragma. -- pragma.
or else not Is_Registered (New_Handler)) or else not Is_Registered (New_Handler))
then then
raise Program_Error with raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " & "trying to overwrite a static interrupt handler with a "
"dynamic Handler"; & "dynamic handler";
end if; end if;
-- Save the old handler -- Save the old handler
@ -879,8 +874,8 @@ package body System.Interrupts is
User_Handler (Interrupt).Static := Static; User_Handler (Interrupt).Static := Static;
end if; end if;
-- Invoke a corresponding Server_Task if not yet created. -- Invoke a corresponding Server_Task if not yet created. Place
-- Place Task_Id info in Server_ID array. -- Task_Id info in Server_ID array.
if New_Handler /= null if New_Handler /= null
and then and then
@ -909,11 +904,11 @@ package body System.Interrupts is
end if; end if;
end Unprotected_Exchange_Handler; end Unprotected_Exchange_Handler;
-- Start of processing for Interrupt_Manager -- Start of processing for Interrupt_Manager
begin begin
-- By making this task independent of any master, when the process -- By making this task independent of any master, when the process goes
-- goes away, the Interrupt_Manager will terminate gracefully. -- away, the Interrupt_Manager will terminate gracefully.
System.Tasking.Utilities.Make_Independent; System.Tasking.Utilities.Make_Independent;
@ -948,15 +943,16 @@ package body System.Interrupts is
or or
accept Detach_Handler accept Detach_Handler
(Interrupt : Interrupt_ID; (Interrupt : Interrupt_ID;
Static : Boolean) Static : Boolean)
do do
Unprotected_Detach_Handler (Interrupt, Static); Unprotected_Detach_Handler (Interrupt, Static);
end Detach_Handler; end Detach_Handler;
or or
accept Bind_Interrupt_To_Entry accept Bind_Interrupt_To_Entry
(T : Task_Id; (T : Task_Id;
E : Task_Entry_Index; E : Task_Entry_Index;
Interrupt : Interrupt_ID) Interrupt : Interrupt_ID)
do do
-- If there is a binding already (either a procedure or an -- If there is a binding already (either a procedure or an
@ -966,7 +962,7 @@ package body System.Interrupts is
or else User_Entry (Interrupt).T /= Null_Task or else User_Entry (Interrupt).T /= Null_Task
then then
raise Program_Error with raise Program_Error with
"A binding for this interrupt is already present"; "a binding for this interrupt is already present";
end if; end if;
User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);

30
gcc/ada/s-interr-sigaction.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -86,8 +86,8 @@ package body System.Interrupts is
Interrupt : Interrupt_ID; Interrupt : Interrupt_ID;
Static : Boolean; Static : Boolean;
Restoration : Boolean); Restoration : Boolean);
-- This internal procedure is needed to finalize protected objects -- This internal procedure is needed to finalize protected objects that
-- that contain interrupt handlers. -- contain interrupt handlers.
procedure Signal_Handler (Sig : Interrupt_ID); procedure Signal_Handler (Sig : Interrupt_ID);
pragma Convention (C, Signal_Handler); pragma Convention (C, Signal_Handler);
@ -157,7 +157,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Descriptors (Interrupt).T /= Null_Task; return Descriptors (Interrupt).T /= Null_Task;
@ -171,7 +171,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
else else
return Descriptors (Interrupt).Kind /= Unknown; return Descriptors (Interrupt).Kind /= Unknown;
end if; end if;
@ -329,7 +329,8 @@ package body System.Interrupts is
procedure Attach_Handler procedure Attach_Handler
(New_Handler : Parameterless_Handler; (New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID; Interrupt : Interrupt_ID;
Static : Boolean := False) is Static : Boolean := False)
is
begin begin
Attach_Handler (New_Handler, Interrupt, Static, False); Attach_Handler (New_Handler, Interrupt, Static, False);
end Attach_Handler; end Attach_Handler;
@ -359,8 +360,8 @@ package body System.Interrupts is
or else not Is_Registered (New_Handler)) or else not Is_Registered (New_Handler))
then then
raise Program_Error with raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " & "trying to overwrite a static interrupt handler with a " &
"dynamic Handler"; "dynamic handler";
end if; end if;
if Handlers (Interrupt) = null then if Handlers (Interrupt) = null then
@ -405,10 +406,10 @@ package body System.Interrupts is
if Descriptors (Interrupt).Kind = Task_Entry then if Descriptors (Interrupt).Kind = Task_Entry then
-- In case we have an Interrupt Entry already installed. -- In case we have an Interrupt Entry already installed, raise a
-- raise a program error. (propagate it to the caller). -- program error (propagate it to the caller).
raise Program_Error with "An interrupt is already installed"; raise Program_Error with "an interrupt is already installed";
else else
Old_Handler := Current_Handler (Interrupt); Old_Handler := Current_Handler (Interrupt);
@ -430,12 +431,12 @@ package body System.Interrupts is
end if; end if;
if Descriptors (Interrupt).Kind = Task_Entry then if Descriptors (Interrupt).Kind = Task_Entry then
raise Program_Error with "Trying to detach an Interrupt Entry"; raise Program_Error with "trying to detach an interrupt entry";
end if; end if;
if not Static and then Descriptors (Interrupt).Static then if not Static and then Descriptors (Interrupt).Static then
raise Program_Error with raise Program_Error with
"Trying to detach a static Interrupt Handler"; "trying to detach a static interrupt handler";
end if; end if;
Descriptors (Interrupt) := Descriptors (Interrupt) :=
@ -504,7 +505,6 @@ package body System.Interrupts is
Fat := To_Fat_Ptr (Handler); Fat := To_Fat_Ptr (Handler);
while Ptr /= null loop while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then if Ptr.H = Fat.Handler_Addr then
return True; return True;
end if; end if;
@ -536,7 +536,7 @@ package body System.Interrupts is
if Descriptors (Interrupt).Kind /= Unknown then if Descriptors (Interrupt).Kind /= Unknown then
raise Program_Error with raise Program_Error with
"A binding for this interrupt is already present"; "a binding for this interrupt is already present";
end if; end if;
if Handlers (Interrupt) = null then if Handlers (Interrupt) = null then

145
gcc/ada/s-interr-vms.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -104,8 +104,8 @@ package body System.Interrupts is
Static : Boolean); Static : Boolean);
entry Detach_Handler entry Detach_Handler
(Interrupt : Interrupt_ID; (Interrupt : Interrupt_ID;
Static : Boolean); Static : Boolean);
entry Bind_Interrupt_To_Entry entry Bind_Interrupt_To_Entry
(T : Task_Id; (T : Task_Id;
@ -172,10 +172,10 @@ package body System.Interrupts is
Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id := Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task); (others => Null_Task);
-- ??? pragma Volatile_Components (Last_Unblocker); -- ??? pragma Volatile_Components (Last_Unblocker);
-- Holds the ID of the last Task which Unblocked this Interrupt. -- Holds the ID of the last Task which Unblocked this Interrupt. It
-- It contains Null_Task if no tasks have ever requested the -- contains Null_Task if no tasks have ever requested the Unblocking
-- Unblocking operation or the Interrupt is currently Blocked. -- operation or the Interrupt is currently Blocked.
Server_ID : array (Interrupt_ID'Range) of Task_Id := Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task); (others => Null_Task);
@ -185,8 +185,8 @@ package body System.Interrupts is
-- decide whether to create a new Server_Task. -- decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt -- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers specified -- Handlers. These definitions are used to register the handlers
-- by the pragma Interrupt_Handler. -- specified by the pragma Interrupt_Handler.
type Registered_Handler; type Registered_Handler;
type R_Link is access all Registered_Handler; type R_Link is access all Registered_Handler;
@ -218,15 +218,15 @@ package body System.Interrupts is
New_Node_Ptr : R_Link; New_Node_Ptr : R_Link;
begin begin
-- This routine registers the Handler as usable for Dynamic -- This routine registers the Handler as usable for Dynamic Interrupt
-- Interrupt Handler. Routines attaching and detaching Handler -- Handler. Routines attaching and detaching Handler dynamically should
-- dynamically should first consult if the Handler is registered. -- first consult if the Handler is registered. A Program Error should be
-- A Program Error should be raised if it is not registered. -- raised if it is not registered.
-- The pragma Interrupt_Handler can only appear in the library -- The pragma Interrupt_Handler can only appear in the library level PO
-- level PO definition and instantiation. Therefore, we do not need -- definition and instantiation. Therefore, we do not need to implement
-- to implement Unregistering operation. Neither we need to -- Unregistering operation. Neither we need to protect the queue
-- protect the queue structure using a Lock. -- structure using a Lock.
pragma Assert (Handler_Addr /= System.Null_Address); pragma Assert (Handler_Addr /= System.Null_Address);
@ -267,7 +267,6 @@ package body System.Interrupts is
Fat := To_Fat_Ptr (Handler); Fat := To_Fat_Ptr (Handler);
Ptr := Registered_Handler_Head; Ptr := Registered_Handler_Head;
while Ptr /= null loop while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then if Ptr.H = Fat.Handler_Addr then
return True; return True;
@ -296,7 +295,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return User_Entry (Interrupt).T /= Null_Task; return User_Entry (Interrupt).T /= Null_Task;
@ -310,7 +309,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return User_Handler (Interrupt).H /= null; return User_Handler (Interrupt).H /= null;
@ -324,7 +323,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Blocked (Interrupt); return Blocked (Interrupt);
@ -338,7 +337,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Ignored (Interrupt); return Ignored (Interrupt);
@ -354,7 +353,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
-- ??? Since Parameterless_Handler is not Atomic, the current -- ??? Since Parameterless_Handler is not Atomic, the current
@ -369,9 +368,9 @@ package body System.Interrupts is
-------------------- --------------------
-- Calling this procedure with New_Handler = null and Static = True -- Calling this procedure with New_Handler = null and Static = True
-- means we want to detach the current handler regardless of the -- means we want to detach the current handler regardless of the previous
-- previous handler's binding status (i.e. do not care if it is a -- handler's binding status (i.e. we do not care if it is a dynamic or
-- dynamic or static handler). -- static handler).
-- This option is needed so that during the finalization of a PO, we -- This option is needed so that during the finalization of a PO, we
-- can detach handlers attached through pragma Attach_Handler. -- can detach handlers attached through pragma Attach_Handler.
@ -379,15 +378,15 @@ package body System.Interrupts is
procedure Attach_Handler procedure Attach_Handler
(New_Handler : Parameterless_Handler; (New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID; Interrupt : Interrupt_ID;
Static : Boolean := False) is Static : Boolean := False)
is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
end Attach_Handler; end Attach_Handler;
---------------------- ----------------------
@ -411,12 +410,11 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Exchange_Handler Interrupt_Manager.Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static); (Old_Handler, New_Handler, Interrupt, Static);
end Exchange_Handler; end Exchange_Handler;
-------------------- --------------------
@ -437,7 +435,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Detach_Handler (Interrupt, Static); Interrupt_Manager.Detach_Handler (Interrupt, Static);
@ -451,11 +449,11 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Storage_Elements.To_Address return Storage_Elements.To_Address
(Storage_Elements.Integer_Address (Interrupt)); (Storage_Elements.Integer_Address (Interrupt));
end Reference; end Reference;
----------------------------- -----------------------------
@ -472,16 +470,15 @@ package body System.Interrupts is
Int_Ref : System.Address) Int_Ref : System.Address)
is is
Interrupt : constant Interrupt_ID := Interrupt : constant Interrupt_ID :=
Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
end Bind_Interrupt_To_Entry; end Bind_Interrupt_To_Entry;
------------------------------ ------------------------------
@ -501,7 +498,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Block_Interrupt (Interrupt); Interrupt_Manager.Block_Interrupt (Interrupt);
@ -515,7 +512,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Unblock_Interrupt (Interrupt); Interrupt_Manager.Unblock_Interrupt (Interrupt);
@ -530,7 +527,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Last_Unblocker (Interrupt); return Last_Unblocker (Interrupt);
@ -544,7 +541,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Ignore_Interrupt (Interrupt); Interrupt_Manager.Ignore_Interrupt (Interrupt);
@ -602,7 +599,7 @@ package body System.Interrupts is
-- In case we have an Interrupt Entry already installed. -- In case we have an Interrupt Entry already installed.
-- raise a program error. (propagate it to the caller). -- raise a program error. (propagate it to the caller).
raise Program_Error with "An interrupt is already installed"; raise Program_Error with "an interrupt is already installed";
end if; end if;
-- Note: A null handler with Static=True will pass the following -- Note: A null handler with Static=True will pass the following
@ -618,14 +615,14 @@ package body System.Interrupts is
and then (User_Handler (Interrupt).Static and then (User_Handler (Interrupt).Static
-- The new handler is not specified as an -- The new handler is not specified as an
-- Interrupt Handler by a pragma. -- Interrupt Handler by a pragma.
or else not Is_Registered (New_Handler)) or else not Is_Registered (New_Handler))
then then
raise Program_Error with raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " & "trying to overwrite a static interrupt handler with a " &
"dynamic Handler"; "dynamic handler";
end if; end if;
-- The interrupt should no longer be ignored if it was ever ignored -- The interrupt should no longer be ignored if it was ever ignored
@ -673,11 +670,11 @@ package body System.Interrupts is
begin begin
if User_Entry (Interrupt).T /= Null_Task then if User_Entry (Interrupt).T /= Null_Task then
-- In case we have an Interrupt Entry installed. -- In case we have an Interrupt Entry installed, raise a program
-- raise a program error. (propagate it to the caller). -- error, (propagate it to the caller).
raise Program_Error with raise Program_Error with
"An interrupt entry is already installed"; "an interrupt entry is already installed";
end if; end if;
-- Note : Static = True will pass the following check. That is the -- Note : Static = True will pass the following check. That is the
@ -685,11 +682,11 @@ package body System.Interrupts is
-- status of the current_Handler. -- status of the current_Handler.
if not Static and then User_Handler (Interrupt).Static then if not Static and then User_Handler (Interrupt).Static then
-- Tries to detach a static Interrupt Handler.
-- raise a program error. -- Tries to detach a static Interrupt Handler, raise program error
raise Program_Error with raise Program_Error with
"Trying to detach a static Interrupt Handler"; "trying to detach a static interrupt handler";
end if; end if;
-- The interrupt should no longer be ignored if -- The interrupt should no longer be ignored if
@ -708,17 +705,17 @@ package body System.Interrupts is
-- Start of processing for Interrupt_Manager -- Start of processing for Interrupt_Manager
begin begin
-- By making this task independent of master, when the process -- By making this task independent of master, when the process goes
-- goes away, the Interrupt_Manager will terminate gracefully. -- away, the Interrupt_Manager will terminate gracefully.
System.Tasking.Utilities.Make_Independent; System.Tasking.Utilities.Make_Independent;
-- Environment task gets its own interrupt mask, saves it, -- Environment task gets its own interrupt mask, saves it, and then
-- and then masks all interrupts except the Keep_Unmasked set. -- masks all interrupts except the Keep_Unmasked set.
-- During rendezvous, the Interrupt_Manager receives the old -- During rendezvous, the Interrupt_Manager receives the old interrupt
-- interrupt mask of the environment task, and sets its own -- mask of the environment task, and sets its own interrupt mask to that
-- interrupt mask to that value. -- value.
-- The environment task will call the entry of Interrupt_Manager some -- The environment task will call the entry of Interrupt_Manager some
-- during elaboration of the body of this package. -- during elaboration of the body of this package.
@ -728,18 +725,18 @@ package body System.Interrupts is
null; null;
end Initialize; end Initialize;
-- Note: All tasks in RTS will have all the Reserve Interrupts -- Note: All tasks in RTS will have all the Reserve Interrupts being
-- being masked (except the Interrupt_Manager) and Keep_Unmasked -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked
-- unmasked when created. -- when created.
-- Abort_Task_Interrupt is one of the Interrupt unmasked -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
-- in all tasks. We mask the Interrupt in this particular task -- We mask the Interrupt in this particular task so that "sigwait" is
-- so that "sigwait" is possible to catch an explicitly sent -- possible to catch an explicitly sent Abort_Task_Interrupt from the
-- Abort_Task_Interrupt from the Server_Tasks. -- Server_Tasks.
-- This sigwaiting is needed so that we make sure a Server_Task is -- This sigwaiting is needed so that we make sure a Server_Task is out
-- out of its own sigwait state. This extra synchronization is -- of its own sigwait state. This extra synchronization is necessary to
-- necessary to prevent following scenarios. -- prevent following scenarios.
-- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
-- Server_Task then changes its own interrupt mask (OS level). -- Server_Task then changes its own interrupt mask (OS level).
@ -759,6 +756,7 @@ package body System.Interrupts is
declare declare
Old_Handler : Parameterless_Handler; Old_Handler : Parameterless_Handler;
begin begin
select select
@ -801,7 +799,7 @@ package body System.Interrupts is
or else User_Entry (Interrupt).T /= Null_Task or else User_Entry (Interrupt).T /= Null_Task
then then
raise Program_Error with raise Program_Error with
"A binding for this interrupt is already present"; "a binding for this interrupt is already present";
end if; end if;
-- The interrupt should no longer be ignored if -- The interrupt should no longer be ignored if
@ -877,8 +875,8 @@ package body System.Interrupts is
end select; end select;
exception exception
-- If there is a program error we just want to propagate it -- If there is a program error we just want to propagate it to the
-- to the caller and do not want to stop this task. -- caller and do not want to stop this task.
when Program_Error => when Program_Error =>
null; null;
@ -1026,7 +1024,6 @@ package body System.Interrupts is
(Object : access Dynamic_Interrupt_Protection) return Boolean (Object : access Dynamic_Interrupt_Protection) return Boolean
is is
pragma Warnings (Off, Object); pragma Warnings (Off, Object);
begin begin
return True; return True;
end Has_Interrupt_Or_Attach_Handler; end Has_Interrupt_Or_Attach_Handler;

168
gcc/ada/s-interr.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -31,26 +31,26 @@
-- Invariants: -- Invariants:
-- All user-handleable interrupts are masked at all times in all -- All user-handleable interrupts are masked at all times in all tasks/threads
-- tasks/threads except possibly for the Interrupt_Manager task. -- except possibly for the Interrupt_Manager task.
-- When a user task wants to have the effect of masking/unmasking an -- When a user task wants to achieve masking/unmasking an interrupt, it must
-- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which -- call Block_Interrupt/Unblock_Interrupt, which will have the effect of
-- will have the effect of unmasking/masking the interrupt in the -- unmasking/masking the interrupt in the Interrupt_Manager task.
-- Interrupt_Manager task.
-- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any -- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
-- other low-level interface that changes the interrupt action or -- other low-level interface that changes the interrupt action or
-- interrupt mask needs a careful thought. -- interrupt mask needs a careful thought.
-- One may achieve the effect of system calls first masking RTS blocked -- One may achieve the effect of system calls first masking RTS blocked
-- (by calling Block_Interrupt) for the interrupt under consideration. -- (by calling Block_Interrupt) for the interrupt under consideration.
-- This will make all the tasks in RTS blocked for the Interrupt. -- This will make all the tasks in RTS blocked for the Interrupt.
-- Once we associate a Server_Task with an interrupt, the task never -- Once we associate a Server_Task with an interrupt, the task never goes
-- goes away, and we never remove the association. -- away, and we never remove the association.
-- There is no more than one interrupt per Server_Task and no more than -- There is no more than one interrupt per Server_Task and no more than one
-- one Server_Task per interrupt. -- Server_Task per interrupt.
with Ada.Task_Identification; with Ada.Task_Identification;
@ -236,7 +236,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
@ -255,13 +255,13 @@ package body System.Interrupts is
E : Task_Entry_Index; E : Task_Entry_Index;
Int_Ref : System.Address) Int_Ref : System.Address)
is is
Interrupt : constant Interrupt_ID := Interrupt : constant Interrupt_ID :=
Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
@ -275,7 +275,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Block_Interrupt (Interrupt); Interrupt_Manager.Block_Interrupt (Interrupt);
@ -291,7 +291,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
-- ??? Since Parameterless_Handler is not Atomic, the current -- ??? Since Parameterless_Handler is not Atomic, the current
@ -319,7 +319,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Detach_Handler (Interrupt, Static); Interrupt_Manager.Detach_Handler (Interrupt, Static);
@ -355,7 +355,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Exchange_Handler Interrupt_Manager.Exchange_Handler
@ -385,8 +385,8 @@ package body System.Interrupts is
-- signal to the Server_Task -- signal to the Server_Task
if not Interrupt_Manager'Terminated if not Interrupt_Manager'Terminated
and then State (System.Interrupt_Management.Abort_Task_Interrupt) and then
/= Default State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then then
for N in reverse Object.Previous_Handlers'Range loop for N in reverse Object.Previous_Handlers'Range loop
Interrupt_Manager.Attach_Handler Interrupt_Manager.Attach_Handler
@ -431,7 +431,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Ignore_Interrupt (Interrupt); Interrupt_Manager.Ignore_Interrupt (Interrupt);
@ -488,7 +488,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Blocked (Interrupt); return Blocked (Interrupt);
@ -502,7 +502,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return User_Entry (Interrupt).T /= Null_Task; return User_Entry (Interrupt).T /= Null_Task;
@ -516,7 +516,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return User_Handler (Interrupt).H /= null; return User_Handler (Interrupt).H /= null;
@ -530,7 +530,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Ignored (Interrupt); return Ignored (Interrupt);
@ -561,7 +561,6 @@ package body System.Interrupts is
Fat := To_Fat_Ptr (Handler); Fat := To_Fat_Ptr (Handler);
Ptr := Registered_Handler_Head; Ptr := Registered_Handler_Head;
while Ptr /= null loop while Ptr /= null loop
if Ptr.H = Fat.Handler_Addr then if Ptr.H = Fat.Handler_Addr then
return True; return True;
@ -590,11 +589,11 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Storage_Elements.To_Address return Storage_Elements.To_Address
(Storage_Elements.Integer_Address (Interrupt)); (Storage_Elements.Integer_Address (Interrupt));
end Reference; end Reference;
--------------------------------- ---------------------------------
@ -638,7 +637,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Unblock_Interrupt (Interrupt); Interrupt_Manager.Unblock_Interrupt (Interrupt);
@ -654,7 +653,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
return Last_Unblocker (Interrupt); return Last_Unblocker (Interrupt);
@ -668,7 +667,7 @@ package body System.Interrupts is
begin begin
if Is_Reserved (Interrupt) then if Is_Reserved (Interrupt) then
raise Program_Error with raise Program_Error with
"Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if; end if;
Interrupt_Manager.Unignore_Interrupt (Interrupt); Interrupt_Manager.Unignore_Interrupt (Interrupt);
@ -743,13 +742,14 @@ package body System.Interrupts is
procedure Unbind_Handler (Interrupt : Interrupt_ID) is procedure Unbind_Handler (Interrupt : Interrupt_ID) is
Server : System.Tasking.Task_Id; Server : System.Tasking.Task_Id;
begin begin
if not Blocked (Interrupt) then if not Blocked (Interrupt) then
-- Currently, there is a Handler or an Entry attached and -- Currently, there is a Handler or an Entry attached and
-- corresponding Server_Task is waiting on "sigwait." -- corresponding Server_Task is waiting on "sigwait." We have to
-- We have to wake up the Server_Task and make it -- wake up the Server_Task and make it wait on condition variable
-- wait on condition variable by sending an -- by sending an Abort_Task_Interrupt
-- Abort_Task_Interrupt
Server := Server_ID (Interrupt); Server := Server_ID (Interrupt);
@ -803,11 +803,11 @@ package body System.Interrupts is
begin begin
if User_Entry (Interrupt).T /= Null_Task then if User_Entry (Interrupt).T /= Null_Task then
-- In case we have an Interrupt Entry installed. -- In case we have an Interrupt Entry installed, raise a program
-- raise a program error. (propagate it to the caller). -- error, (propagate it to the caller).
raise Program_Error with raise Program_Error with
"An interrupt entry is already installed"; "an interrupt entry is already installed";
end if; end if;
-- Note : Static = True will pass the following check. That is the -- Note : Static = True will pass the following check. That is the
@ -820,7 +820,7 @@ package body System.Interrupts is
-- raise a program error. -- raise a program error.
raise Program_Error with raise Program_Error with
"Trying to detach a static Interrupt Handler"; "trying to detach a static interrupt handler";
end if; end if;
-- The interrupt should no longer be ignored if -- The interrupt should no longer be ignored if
@ -854,35 +854,35 @@ package body System.Interrupts is
begin begin
if User_Entry (Interrupt).T /= Null_Task then if User_Entry (Interrupt).T /= Null_Task then
-- In case we have an Interrupt Entry already installed. -- In case we have an Interrupt Entry already installed, raise a
-- raise a program error. (propagate it to the caller). -- program error, (propagate it to the caller).
raise Program_Error with raise Program_Error with
"An interrupt is already installed"; "an interrupt is already installed";
end if; end if;
-- Note : A null handler with Static = True will pass the -- Note : A null handler with Static = True will pass the following
-- following check. That is the case when we want to Detach a -- check. That is the case when we want to Detach a handler
-- handler regardless of the Static status of the current_Handler. -- regardless of the Static status of the current_Handler.
-- We don't check anything if Restoration is True, since we -- We don't check anything if Restoration is True, since we may be
-- may be detaching a static handler to restore a dynamic one. -- detaching a static handler to restore a dynamic one.
if not Restoration and then not Static if not Restoration and then not Static
-- Tries to overwrite a static Interrupt Handler with a -- Tries to overwrite a static Interrupt Handler with a dynamic
-- dynamic Handler -- Handler
and then (User_Handler (Interrupt).Static and then (User_Handler (Interrupt).Static
-- The new handler is not specified as an -- The new handler is not specified as an
-- Interrupt Handler by a pragma. -- Interrupt Handler by a pragma.
or else not Is_Registered (New_Handler)) or else not Is_Registered (New_Handler))
then then
raise Program_Error with raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " & "trying to overwrite a static Interrupt Handler with a " &
"dynamic Handler"; "dynamic handler";
end if; end if;
-- The interrupt should no longer be ignored if -- The interrupt should no longer be ignored if
@ -945,12 +945,12 @@ package body System.Interrupts is
System.Tasking.Utilities.Make_Independent; System.Tasking.Utilities.Make_Independent;
-- Environment task gets its own interrupt mask, saves it, -- Environment task gets its own interrupt mask, saves it, and then
-- and then masks all interrupts except the Keep_Unmasked set. -- masks all interrupts except the Keep_Unmasked set.
-- During rendezvous, the Interrupt_Manager receives the old -- During rendezvous, the Interrupt_Manager receives the old interrupt
-- interrupt mask of the environment task, and sets its own -- mask of the environment task, and sets its own interrupt mask to that
-- interrupt mask to that value. -- value.
-- The environment task will call the entry of Interrupt_Manager some -- The environment task will call the entry of Interrupt_Manager some
-- during elaboration of the body of this package. -- during elaboration of the body of this package.
@ -958,25 +958,24 @@ package body System.Interrupts is
accept Initialize (Mask : IMNG.Interrupt_Mask) do accept Initialize (Mask : IMNG.Interrupt_Mask) do
declare declare
The_Mask : aliased IMNG.Interrupt_Mask; The_Mask : aliased IMNG.Interrupt_Mask;
begin begin
IMOP.Copy_Interrupt_Mask (The_Mask, Mask); IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
IMOP.Set_Interrupt_Mask (The_Mask'Access); IMOP.Set_Interrupt_Mask (The_Mask'Access);
end; end;
end Initialize; end Initialize;
-- Note: All tasks in RTS will have all the Reserve Interrupts -- Note: All tasks in RTS will have all the Reserve Interrupts being
-- being masked (except the Interrupt_Manager) and Keep_Unmasked -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked
-- unmasked when created. -- when created.
-- Abort_Task_Interrupt is one of the Interrupt unmasked -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
-- in all tasks. We mask the Interrupt in this particular task -- We mask the Interrupt in this particular task so that "sigwait" is
-- so that "sigwait" is possible to catch an explicitly sent -- possible to catch an explicitly sent Abort_Task_Interrupt from the
-- Abort_Task_Interrupt from the Server_Tasks. -- Server_Tasks.
-- This sigwaiting is needed so that we make sure a Server_Task is -- This sigwaiting is needed so that we make sure a Server_Task is out
-- out of its own sigwait state. This extra synchronization is -- of its own sigwait state. This extra synchronization is necessary to
-- necessary to prevent following scenarios. -- prevent following scenarios.
-- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the
-- Server_Task then changes its own interrupt mask (OS level). -- Server_Task then changes its own interrupt mask (OS level).
@ -1037,14 +1036,14 @@ package body System.Interrupts is
E : Task_Entry_Index; E : Task_Entry_Index;
Interrupt : Interrupt_ID) Interrupt : Interrupt_ID)
do do
-- if there is a binding already (either a procedure or an -- If there is a binding already (either a procedure or an
-- entry), raise Program_Error (propagate it to the caller). -- entry), raise Program_Error (propagate it to the caller).
if User_Handler (Interrupt).H /= null if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task or else User_Entry (Interrupt).T /= Null_Task
then then
raise Program_Error with raise Program_Error with
"A binding for this interrupt is already present"; "a binding for this interrupt is already present";
end if; end if;
-- The interrupt should no longer be ignored if -- The interrupt should no longer be ignored if
@ -1118,10 +1117,10 @@ package body System.Interrupts is
if User_Handler (Interrupt).H /= null if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task or else User_Entry (Interrupt).T /= Null_Task
then then
-- This is the case where the Server_Task is waiting -- This is the case where the Server_Task is
-- on "sigwait." Wake it up by sending an -- waiting on "sigwait." Wake it up by sending an
-- Abort_Task_Interrupt so that the Server_Task -- Abort_Task_Interrupt so that the Server_Task waits
-- waits on Cond. -- on Cond.
POP.Abort_Task (Server_ID (Interrupt)); POP.Abort_Task (Server_ID (Interrupt));
@ -1158,8 +1157,8 @@ package body System.Interrupts is
else else
-- The Server_Task must be waiting on the Cond variable -- The Server_Task must be waiting on the Cond variable
-- since it was being blocked and an Interrupt Hander or -- since it was being blocked and an Interrupt Hander or
-- an Entry was there. Wake it up and let it change -- an Entry was there. Wake it up and let it change it
-- it place of waiting according to its new state. -- place of waiting according to its new state.
POP.Wakeup (Server_ID (Interrupt), POP.Wakeup (Server_ID (Interrupt),
Interrupt_Server_Blocked_Interrupt_Sleep); Interrupt_Server_Blocked_Interrupt_Sleep);
@ -1242,8 +1241,8 @@ package body System.Interrupts is
Tmp_Entry_Index : Task_Entry_Index; Tmp_Entry_Index : Task_Entry_Index;
begin begin
-- By making this task independent of master, when the process -- By making this task independent of master, when the process goes
-- goes away, the Server_Task will terminate gracefully. -- away, the Server_Task will terminate gracefully.
System.Tasking.Utilities.Make_Independent; System.Tasking.Utilities.Make_Independent;
@ -1262,8 +1261,8 @@ package body System.Interrupts is
-- There are two Interrupt interrupts that this task catch through -- There are two Interrupt interrupts that this task catch through
-- "sigwait." One is the Interrupt this task is designated to catch -- "sigwait." One is the Interrupt this task is designated to catch
-- in order to execute user handler or entry. The other one is the -- in order to execute user handler or entry. The other one is
-- Abort_Task_Interrupt. This interrupt is being sent from the -- the Abort_Task_Interrupt. This interrupt is being sent from the
-- Interrupt_Manager to inform status changes (e.g: become Blocked, -- Interrupt_Manager to inform status changes (e.g: become Blocked,
-- Handler or Entry is to be detached). -- Handler or Entry is to be detached).
@ -1303,8 +1302,7 @@ package body System.Interrupts is
elsif Blocked (Interrupt) then elsif Blocked (Interrupt) then
-- Interrupt is blocked. Stay here, so we won't catch -- Interrupt is blocked. Stay here, so we won't catch it
-- the Interrupt.
Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);

4
gcc/ada/s-shasto.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2010, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -541,7 +541,7 @@ package body System.Shared_Storage is
when others => when others =>
raise Program_Error with raise Program_Error with
"Cannot create shared variable file for """ & S & '"'; "cannot create shared variable file for """ & S & '"';
end; end;
end; end;

14
gcc/ada/s-tasren.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -367,7 +367,8 @@ package body System.Tasking.Rendezvous is
if System.Tasking.Detect_Blocking if System.Tasking.Detect_Blocking
and then STPO.Self.Common.Protected_Action_Nesting > 0 and then STPO.Self.Common.Protected_Action_Nesting > 0
then then
raise Program_Error with "potentially blocking operation"; raise Program_Error with
"potentially blocking operation";
end if; end if;
Call_Synchronous Call_Synchronous
@ -1012,7 +1013,8 @@ package body System.Tasking.Rendezvous is
end if; end if;
Initialization.Undefer_Abort (Self_Id); Initialization.Undefer_Abort (Self_Id);
raise Program_Error with "Entry call not a delay mode"; raise Program_Error with
"entry call not a delay mode";
end if; end if;
end case; end case;
@ -1316,7 +1318,8 @@ package body System.Tasking.Rendezvous is
if System.Tasking.Detect_Blocking if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0 and then Self_Id.Common.Protected_Action_Nesting > 0
then then
raise Program_Error with "potentially blocking operation"; raise Program_Error with
"potentially blocking operation";
end if; end if;
if Parameters.Runtime_Traces then if Parameters.Runtime_Traces then
@ -1688,7 +1691,8 @@ package body System.Tasking.Rendezvous is
if System.Tasking.Detect_Blocking if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0 and then Self_Id.Common.Protected_Action_Nesting > 0
then then
raise Program_Error with "potentially blocking operation"; raise Program_Error with
"potentially blocking operation";
end if; end if;
Initialization.Defer_Abort (Self_Id); Initialization.Defer_Abort (Self_Id);

12
gcc/ada/s-tpoben.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -103,7 +103,7 @@ package body System.Tasking.Protected_Objects.Entries is
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
if Ceiling_Violation then if Ceiling_Violation then
raise Program_Error with "Ceiling Violation"; raise Program_Error with "ceiling violation";
end if; end if;
if Single_Lock then if Single_Lock then
@ -231,7 +231,7 @@ package body System.Tasking.Protected_Objects.Entries is
Lock_Entries_With_Status (Object, Ceiling_Violation); Lock_Entries_With_Status (Object, Ceiling_Violation);
if Ceiling_Violation then if Ceiling_Violation then
raise Program_Error with "Ceiling Violation"; raise Program_Error with "ceiling violation";
end if; end if;
end Lock_Entries; end Lock_Entries;
@ -245,7 +245,7 @@ package body System.Tasking.Protected_Objects.Entries is
is is
begin begin
if Object.Finalized then if Object.Finalized then
raise Program_Error with "Protected Object is finalized"; raise Program_Error with "protected object is finalized";
end if; end if;
-- If pragma Detect_Blocking is active then, as described in the ARM -- If pragma Detect_Blocking is active then, as described in the ARM
@ -305,7 +305,7 @@ package body System.Tasking.Protected_Objects.Entries is
begin begin
if Object.Finalized then if Object.Finalized then
raise Program_Error with "Protected Object is finalized"; raise Program_Error with "protected object is finalized";
end if; end if;
-- If pragma Detect_Blocking is active then, as described in the ARM -- If pragma Detect_Blocking is active then, as described in the ARM
@ -330,7 +330,7 @@ package body System.Tasking.Protected_Objects.Entries is
Read_Lock (Object.L'Access, Ceiling_Violation); Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then if Ceiling_Violation then
raise Program_Error with "Ceiling Violation"; raise Program_Error with "ceiling violation";
end if; end if;
-- We are entering in a protected action, so that we increase the -- We are entering in a protected action, so that we increase the