-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2003, Ada Core Technologies --
+-- Copyright (C) 1995-2005 AdaCore --
-- --
-- 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- --
---------------------
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
return To_Ada (SI.Current_Handler (SI.Interrupt_ID (Interrupt)));
-- Detach_Handler --
--------------------
- procedure Detach_Handler (Interrupt : in Interrupt_ID) is
+ procedure Detach_Handler (Interrupt : Interrupt_ID) is
begin
SI.Detach_Handler (SI.Interrupt_ID (Interrupt), False);
end Detach_Handler;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function Is_Attached (Interrupt : Interrupt_ID) return Boolean;
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler;
+ (Interrupt : Interrupt_ID) return Parameterless_Handler;
procedure Attach_Handler
(New_Handler : Parameterless_Handler;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Ptr := 1;
while Ptr <= Name_Len loop
+
+ -- Wide character. Note that we do nothing with casing in this case.
+ -- In Ada 2005 mode, required folding of lower case letters happened
+ -- as the identifier was scanned, and we do not attempt any further
+ -- messing with case (note that in any case we do not know how to
+ -- fold upper case to lower case in wide character mode). We also
+ -- do not bother with recognizing punctuation as equivalent to an
+ -- underscore. There is nothing functional at this stage in doing
+ -- the requested casing operation, beyond folding to upper case
+ -- when it is mandatory, which does not involve underscores.
+
if Name_Buffer (Ptr) = ASCII.ESC
or else Name_Buffer (Ptr) = '['
or else (Upper_Half_Encoding
Skip_Wide (Name_Buffer, Ptr);
After_Und := False;
+ -- Underscore, or non-identifer character (error case)
+
elsif Name_Buffer (Ptr) = '_'
or else not Identifier_Char (Name_Buffer (Ptr))
then
After_Und := True;
Ptr := Ptr + 1;
+ -- Lower case letter
+
elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
if Actual_Casing = All_Upper_Case
or else (After_Und and then Actual_Casing = Mixed_Case)
After_Und := False;
Ptr := Ptr + 1;
+ -- Upper case letter
+
elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
if Actual_Casing = All_Lower_Case
or else (not After_Und and then Actual_Casing = Mixed_Case)
After_Und := False;
Ptr := Ptr + 1;
- else -- all other characters
+ -- Other identifier character (must be digit)
+
+ else
After_Und := False;
Ptr := Ptr + 1;
end if;
-- --
------------------------------------------------------------------------------
-with System; use System;
-with Ada.Calendar; use Ada.Calendar;
+with System; use System;
+with Ada.Calendar; use Ada.Calendar;
with GNAT.IO;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Regpat; use GNAT.Regpat;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Regpat; use GNAT.Regpat;
with Unchecked_Deallocation;
------------------
function Get_Error_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
- is
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Error_Fd;
end Get_Error_Fd;
------------------
function Get_Input_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
- is
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Input_Fd;
end Get_Input_Fd;
-------------------
function Get_Output_Fd
- (Descriptor : Process_Descriptor)
- return GNAT.OS_Lib.File_Descriptor
- is
+ (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is
begin
return Descriptor.Output_Fd;
end Get_Output_Fd;
-------------
function Get_Pid
- (Descriptor : Process_Descriptor)
- return Process_Id
- is
+ (Descriptor : Process_Descriptor) return Process_Id is
begin
return Descriptor.Pid;
end Get_Pid;
Arg : String_Access;
Arg_List : String_List (1 .. Args'Length + 2);
- C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
+ C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
Command_With_Path : String_Access;
----------
procedure Send
- (Descriptor : in out Process_Descriptor;
- Str : String;
- Add_LF : Boolean := True;
+ (Descriptor : in out Process_Descriptor;
+ Str : String;
+ Add_LF : Boolean := True;
Empty_Buffer : Boolean := False)
is
Full_Str : constant String := Str & ASCII.LF;
allows to obtain accurate dynamic memory usage history at a minimal cost to
the execution speed. Note however, that @code{gnatmem} is not supported on
all platforms (currently, it is supported on AIX, HP-UX, GNU/Linux x86,
-Solaris (sparc and x86) and Windows NT/2000/XP (x86).
+32-bit Solaris (sparc and x86) and Windows NT/2000/XP (x86).
@noindent
The @code{gnatmem} command has the form
end Set;
procedure Set
- (Language_Processing : in Language_Processing_Data;
+ (Language_Processing : Language_Processing_Data;
For_Language : Language_Index;
In_Project : in out Project_Data;
In_Tree : Project_Tree_Ref)
begin
while Supp_Index /= No_Supp_Language_Index loop
- Supp := In_Tree.Supp_Languages.Table
- (Supp_Index);
+ Supp := In_Tree.Supp_Languages.Table (Supp_Index);
if Supp.Index = For_Language then
In_Tree.Supp_Languages.Table
-- Standard_Naming_Data --
--------------------------
- function Standard_Naming_Data (Tree : Project_Tree_Ref := No_Project_Tree)
- return Naming_Data
+ function Standard_Naming_Data
+ (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
is
begin
if Tree = No_Project_Tree then
begin
while Supp_Index /= No_Supp_Language_Index loop
- Supp := In_Tree.Supp_Suffixes.Table
- (Supp_Index);
+ Supp := In_Tree.Supp_Suffixes.Table (Supp_Index);
if Supp.Index = Language then
return Supp.Suffix;
end record;
- function Standard_Naming_Data (Tree : Project_Tree_Ref := No_Project_Tree)
- return Naming_Data;
+ function Standard_Naming_Data
+ (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data;
pragma Inline (Standard_Naming_Data);
-- The standard GNAT naming scheme when Tree is No_Project_Tree.
-- Otherwise, return the default naming scheme for the project tree Tree,
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2004, Ada Core Technologies --
+-- Copyright (C) 1995-2005 AdaCore --
-- --
-- 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 an OS/2 version of this package.
-
--- This version is a stub, for systems that
--- do not support interrupts (or signals).
+-- This version is for systems that do not support interrupts (or signals)
with Ada.Exceptions;
---------------------
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
is
begin
Unimplemented;
return Boolean
is
pragma Warnings (Off, Object);
-
begin
Unimplemented;
return True;
return Boolean
is
pragma Warnings (Off, Object);
-
begin
Unimplemented;
return True;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2004 Free Software Fundation --
+-- Copyright (C) 1998-2005 Free Software Fundation --
-- --
-- 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 IRIX & NT version of this package.
+-- This is the IRIX & NT version of this package
with Ada.Task_Identification;
-- used for Task_Id
-- that contain interrupt handlers.
procedure Signal_Handler (Sig : Interrupt_ID);
- -- This procedure is used to handle all the signals.
+ -- This procedure is used to handle all the signals
-- Type and Head, Tail of the list containing Registered Interrupt
-- Handlers. These definitions are used to register the handlers
-- specified by the pragma Interrupt_Handler.
- --
- -- Handler Registration:
- --
+ --------------------------
+ -- Handler Registration --
+ --------------------------
type Registered_Handler;
type R_Link is access all Registered_Handler;
if not Restoration and then not Static
- -- Tries to overwrite a static Interrupt Handler with a
- -- dynamic Handler
+ -- Tries to overwrite a static Interrupt Handler with dynamic handle
- and then (Descriptors (Interrupt).Static
+ and then
+ (Descriptors (Interrupt).Static
- -- The new handler is not specified as an
- -- Interrupt Handler by a pragma.
+ -- New handler not specified as an Interrupt Handler by a pragma
- or else not Is_Registered (New_Handler))
+ or else not Is_Registered (New_Handler))
then
Raise_Exception (Program_Error'Identity,
"Trying to overwrite a static Interrupt Handler with a " &
Descriptors (Interrupt).T := T;
Descriptors (Interrupt).E := E;
- -- Indicate the attachment of Interrupt Entry in ATCB.
- -- This is need so that when an Interrupt Entry task terminates
- -- the binding can be cleaned. The call to unbinding must be
- -- make by the task before it terminates.
+ -- Indicate the attachment of Interrupt Entry in ATCB. This is needed so
+ -- that when an Interrupt Entry task terminates the binding can be
+ -- cleaned up. The call to unbinding must be make by the task before it
+ -- terminates.
T.Interrupt_Entry := True;
end Bind_Interrupt_To_Entry;
end if;
end loop;
- -- Indicate in ATCB that no Interrupt Entries are attached.
+ -- Indicate in ATCB that no Interrupt Entries are attached
T.Interrupt_Entry := True;
end Detach_Interrupt_Entries;
Initialization.Undefer_Abort (Self_Id);
- -- Undefer abort here to allow a window for this task
- -- to be aborted at the time of system shutdown.
+ -- Undefer abort here to allow a window for this task to be aborted
+ -- at the time of system shutdown.
end loop;
end Server_Task;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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 an OpenVMS/Alpha version of this package.
+-- This is an OpenVMS/Alpha version of this package
-- Invariants:
-- Local Tasks --
-----------------
- -- WARNING: System.Tasking.Stages performs calls to this task
- -- with low-level constructs. Do not change this spec without synchro-
- -- nizing it.
+ -- WARNING: System.Tasking.Stages performs calls to this task with
+ -- low-level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id);
task type Server_Task (Interrupt : Interrupt_ID) is
pragma Priority (System.Interrupt_Priority'Last);
- -- Note: the above pragma Priority is strictly speaking improper
- -- since it is outside the range of allowed priorities, but the
- -- compiler treats system units specially and does not apply
- -- this range checking rule to system units.
+ -- Note: the above pragma Priority is strictly speaking improper since
+ -- it is outside the range of allowed priorities, but the compiler
+ -- treats system units specially and does not apply this range checking
+ -- rule to system units.
end Server_Task;
(others => (null, Static => False));
pragma Volatile_Components (User_Handler);
-- Holds the protected procedure handler (if any) and its Static
- -- information for each interrupt. A handler is a Static one if
- -- it is specified through the pragma Attach_Handler.
- -- Attach_Handler. Otherwise, not static)
+ -- information for each interrupt. A handler is a Static one if it is
+ -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise,
+ -- not static)
User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
(others => (T => Null_Task, E => Null_Task_Entry));
Blocked : constant array (Interrupt_ID'Range) of Boolean :=
(others => False);
--- ??? pragma Volatile_Components (Blocked);
+ -- ??? pragma Volatile_Components (Blocked);
-- True iff the corresponding interrupt is blocked in the process level
Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
pragma Atomic_Components (Server_ID);
- -- Holds the Task_Id of the Server_Task for each interrupt.
- -- Task_Id is needed to accomplish locking per Interrupt base. Also
- -- is needed to decide whether to create a new Server_Task.
+ -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is
+ -- needed to accomplish locking per Interrupt base. Also is needed to
+ -- decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt
- -- Handlers. These definitions are used to register the handlers
- -- specified by the pragma Interrupt_Handler.
+ -- Handlers. These definitions are used to register the handlers specified
+ -- by the pragma Interrupt_Handler.
type Registered_Handler;
type R_Link is access all Registered_Handler;
end loop;
return False;
-
end Is_Registered;
-----------------
Interrupt_ID'Image (Interrupt) & " is reserved");
end if;
- -- ??? Since Parameterless_Handler is not Atomic, the
- -- current implementation is wrong. We need a new service in
- -- Interrupt_Manager to ensure atomicity.
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
return User_Handler (Interrupt).H;
end Current_Handler;
-- Exchange_Handler --
----------------------
- -- Calling this procedure with New_Handler = null and Static = True
- -- means we want to detach the current handler regardless of the
- -- previous handler's binding status (ie. do not care if it is a
- -- dynamic or static handler).
+ -- Calling this procedure with New_Handler = null and Static = True means
+ -- we want to detach the current handler regardless of the previous
+ -- handler's binding status (ie. do not care if it is dynamic or static
+ -- handler).
- -- This option is needed so that during the finalization of a PO, we
- -- can detach handlers attached through pragma Attach_Handler.
+ -- This option is needed so that during the finalization of a PO, we can
+ -- detach handlers attached through pragma Attach_Handler.
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
- Static : Boolean := False) is
+ Static : Boolean := False)
+ is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
end Install_Handlers;
-- Elaboration code for package System.Interrupts
+
begin
-- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
- -- During the elaboration of this package body we want RTS to
- -- inherit the interrupt mask from the Environment Task.
+ -- During the elaboration of this package body we want RTS to inherit the
+ -- interrupt mask from the Environment Task.
- -- The Environment Task should have gotten its mask from
- -- the enclosing process during the RTS start up. (See
- -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
- -- task to the Interrupt_Manager.
+ -- The Environment Task should have gotten its mask from the enclosing
+ -- process during the RTS start up. (See in s-inmaop.adb). Pass the
+ -- Interrupt_Mask of the Environment task to the Interrupt_Manager.
- -- Note : At this point we know that all tasks (including
- -- RTS internal servers) are masked for non-reserved signals
- -- (see s-taprop.adb). Only the Interrupt_Manager will have
- -- masks set up differently inheriting the original Environment
- -- Task's mask.
+ -- Note : At this point we know that all tasks (including RTS internal
+ -- servers) are masked for non-reserved signals (see s-taprop.adb). Only
+ -- the Interrupt_Manager will have masks set up differently inheriting the
+ -- original Environment Task's mask.
Interrupt_Manager.Initialize (IMOP.Environment_Mask);
end System.Interrupts;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- Invariants:
--- All user-handleable signals are masked at all times in all
--- tasks/threads except possibly for the Interrupt_Manager task.
+-- All user-handleable signals are masked at all times in all tasks/threads
+-- except possibly for the Interrupt_Manager task.
--- When a user task wants to have the effect of masking/unmasking an
--- signal, it must call Block_Interrupt/Unblock_Interrupt, which
--- will have the effect of unmasking/masking the signal in the
--- Interrupt_Manager task. These comments do not apply to vectored
--- hardware interrupts, which may be masked or unmasked using routined
--- interfaced to the relevant VxWorks system calls.
+-- When a user task wants to have the effect of masking/unmasking an signal,
+-- it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
+-- of unmasking/masking the signal in the Interrupt_Manager task. These
+-- comments do not apply to vectored hardware interrupts, which may be masked
+-- or unmasked using routined interfaced to the relevant VxWorks system
+-- calls.
--- Once we associate a Signal_Server_Task with an signal, the task never
--- goes away, and we never remove the association. On the other hand, it
--- is more convenient to terminate an associated Interrupt_Server_Task
--- for a vectored hardware interrupt (since we use a binary semaphore
--- for synchronization with the umbrella handler).
+-- Once we associate a Signal_Server_Task with an signal, the task never goes
+-- away, and we never remove the association. On the other hand, it is more
+-- convenient to terminate an associated Interrupt_Server_Task for a vectored
+-- hardware interrupt (since we use a binary semaphore for synchronization
+-- with the umbrella handler).
-- There is no more than one signal per Signal_Server_Task and no more than
--- one Signal_Server_Task per signal. The same relation holds for hardware
--- interrupts and Interrupt_Server_Task's at any given time. That is,
--- only one non-terminated Interrupt_Server_Task exists for a give
--- interrupt at any time.
+-- one Signal_Server_Task per signal. The same relation holds for hardware
+-- interrupts and Interrupt_Server_Task's at any given time. That is, only
+-- one non-terminated Interrupt_Server_Task exists for a give interrupt at
+-- any time.
-- 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,
-- Local Tasks --
-----------------
- -- WARNING: System.Tasking.Stages performs calls to this task
- -- with low-level constructs. Do not change this spec without synchro-
- -- nizing it.
+ -- WARNING: System.Tasking.Stages performs calls to this task with
+ -- low-level constructs. Do not change this spec without synchronizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_Id);
---------------------
function Current_Handler
- (Interrupt : Interrupt_ID) return Parameterless_Handler is
+ (Interrupt : Interrupt_ID) return Parameterless_Handler
+ is
begin
Check_Reserved_Interrupt (Interrupt);
(Old_Handler : out Parameterless_Handler;
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
- Static : Boolean := False) is
+ Static : Boolean := False)
+ is
begin
Check_Reserved_Interrupt (Interrupt);
Interrupt_Manager.Exchange_Handler
-- Finalize_Interrupt_Servers --
--------------------------------
- -- Restore default handlers for interrupt servers.
+ -- Restore default handlers for interrupt servers
-- This is called by the Interrupt_Manager task when it receives the abort
-- signal during program finalization.
return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
return Boolean
is
pragma Unreferenced (Object);
-
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
- New_Handlers : New_Handler_Array) is
+ New_Handlers : New_Handler_Array)
+ is
begin
for N in New_Handlers'Range loop
+
-- We need a lock around this ???
Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
New_Node_Ptr : R_Link;
+
begin
-- This routine registers a handler as usable for dynamic
-- interrupt handler association. Routines attaching and detaching
------------------
function Unblocked_By
- (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
+ is
begin
Unimplemented ("Unblocked_By");
return Null_Task;
-- status of the Current_Handler.
if not Static and then User_Handler (Interrupt).Static then
- -- Trying to detach a static Interrupt Handler.
- -- raise Program_Error.
+
+ -- Trying to detach a static Interrupt Handler. raise
+ -- Program_Error.
Raise_Exception (Program_Error'Identity,
"Trying to detach a static Interrupt Handler");
New_Handler : Parameterless_Handler;
Interrupt : Interrupt_ID;
Static : Boolean;
- Restoration : Boolean := False) is
+ Restoration : Boolean := False)
+ is
begin
if User_Entry (Interrupt).T /= Null_Task then
+
-- If an interrupt entry is already installed, raise
-- Program_Error. (propagate it to the caller).
if New_Handler = null then
- -- The null handler means we are detaching the handler.
+ -- The null handler means we are detaching the handler
User_Handler (Interrupt).Static := False;
end if;
if (New_Handler = null) and then Old_Handler /= null then
+
-- Restore default handler
Unbind_Handler (Interrupt);
elsif Old_Handler = null then
+
-- Save default handler
Bind_Handler (Interrupt);
end if;
end loop;
- -- Indicate in ATCB that no interrupt entries are attached.
+ -- Indicate in ATCB that no interrupt entries are attached
T.Interrupt_Entry := False;
end Detach_Interrupt_Entries;
end Interrupt_Server_Task;
begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
end System.Interrupts;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
entry Initialize (Mask : IMNG.Interrupt_Mask);
entry Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False);
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
entry Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
entry Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_Id;
type R_Link is access all Registered_Handler;
type Registered_Handler is record
- H : System.Address := System.Null_Address;
+ H : System.Address := System.Null_Address;
Next : R_Link := null;
end record;
-- can detach handlers attached through pragma Attach_Handler.
procedure Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean := False)
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
is
begin
if Is_Reserved (Interrupt) then
Interrupt_ID'Image (Interrupt) & " is reserved");
end if;
- -- ??? Since Parameterless_Handler is not Atomic, the
- -- current implementation is wrong. We need a new service in
- -- Interrupt_Manager to ensure atomicity.
+ -- ??? Since Parameterless_Handler is not Atomic, the current
+ -- implementation is wrong. We need a new service in Interrupt_Manager
+ -- to ensure atomicity.
return User_Handler (Interrupt).H;
end Current_Handler;
New_Node_Ptr : R_Link;
begin
- -- This routine registers the Handler as usable for Dynamic
- -- Interrupt Handler. Routines attaching and detaching Handler
- -- dynamically should first consult if the Handler is rgistered.
- -- A Program Error should be raised if it is not registered.
+ -- This routine registers the Handler as usable for Dynamic Interrupt
+ -- Handler. Routines attaching and detaching Handler dynamically should
+ -- first consult if the Handler is registered. A Program Error should
+ -- be raised if it is not registered.
- -- The pragma Interrupt_Handler can only appear in the library
- -- level PO definition and instantiation. Therefore, we do not need
- -- to implement Unregistering operation. Neither we need to
- -- protect the queue structure using a Lock.
+ -- The pragma Interrupt_Handler can only appear in the library level PO
+ -- definition and instantiation. Therefore, we do not need to implement
+ -- Unregistering operation. Neither we need to protect the queue
+ -- structure using a Lock.
pragma Assert (Handler_Addr /= System.Null_Address);
begin
select
accept Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False)
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static, Restoration);
or
accept Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static);
or
accept Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
do
Unprotected_Detach_Handler (Interrupt, Static);
end Detach_Handler;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- It is made a child of System to allow visibility of various
-- runtime system internal data and operations.
--- See System.Interrupt_Management for core interrupt/signal interfaces.
+-- See System.Interrupt_Management for core interrupt/signal interfaces
-- These two packages are separated in order to allow
-- System.Interrupt_Management to be used without requiring the whole
function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean;
function Current_Handler
- (Interrupt : Interrupt_ID)
- return Parameterless_Handler;
+ (Interrupt : Interrupt_ID) return Parameterless_Handler;
-- Calling the following procedures with New_Handler = null
-- and Static = true means that we want to modify the current handler
Static : Boolean := False);
function Reference
- (Interrupt : Interrupt_ID)
- return System.Address;
+ (Interrupt : Interrupt_ID) return System.Address;
--------------------------------
-- Interrupt Entries Services --
procedure Unblock_Interrupt (Interrupt : Interrupt_ID);
function Unblocked_By
- (Interrupt : Interrupt_ID)
- return System.Tasking.Task_Id;
+ (Interrupt : Interrupt_ID) return System.Tasking.Task_Id;
-- It returns the ID of the last Task which Unblocked this Interrupt.
-- It returns Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.
-- There are two kinds of protected objects that deal with interrupts:
- -- (1) Only Interrupt_Handler pragmas are used. We need to be able to
- -- tell if an Interrupt_Handler applies to a given procedure, so
+ -- (1) Only Interrupt_Handler pragmas are used. We need to be able to tell
+ -- if an Interrupt_Handler applies to a given procedure, so
-- Register_Interrupt_Handler has to be called for all the potential
- -- handlers, it should be done by calling Register_Interrupt_Handler
- -- with the handler code address. On finalization, which can happen only
- -- has part of library level finalization since PO with
- -- Interrupt_Handler pragmas can only be declared at library level,
- -- nothing special needs to be done since the default handlers have been
- -- restored as part of task completion which is done just before global
- -- finalization. Dynamic_Interrupt_Protection should be used in this
- -- case.
+ -- handlers, it should be done by calling Register_Interrupt_Handler with
+ -- the handler code address. On finalization, which can happen only has
+ -- part of library level finalization since PO with Interrupt_Handler
+ -- pragmas can only be declared at library level, nothing special needs to
+ -- be done since the default handlers have been restored as part of task
+ -- completion which is done just before global finalization.
+ -- Dynamic_Interrupt_Protection should be used in this case.
-- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler
- -- pragma. We need to attach the handlers to the given interrupts when
- -- the objet is elaborated. This should be done by constructing an array
- -- of pairs (interrupt, handler) from the pragmas and calling
- -- Install_Handlers with it (types to be used are New_Handler_Item and
- -- New_Handler_Array). On finalization, we need to restore the handlers
- -- that were installed before the elaboration of the PO, so we need to
- -- store these previous handlers. This is also done by Install_Handlers,
- -- the room for these informations is provided by adding a discriminant
- -- which is the number of Attach_Handler pragmas and an array of this
- -- size in the protection type, Static_Interrupt_Protection.
+ -- pragma. We need to attach the handlers to the given interrupts when the
+ -- objet is elaborated. This should be done by constructing an array of
+ -- pairs (interrupt, handler) from the pragmas and calling Install_Handlers
+ -- with it (types to be used are New_Handler_Item and New_Handler_Array).
+ -- On finalization, we need to restore the handlers that were installed
+ -- before the elaboration of the PO, so we need to store these previous
+ -- handlers. This is also done by Install_Handlers, the room for these
+ -- informations is provided by adding a discriminant which is the number
+ -- of Attach_Handler pragmas and an array of this size in the protection
+ -- type, Static_Interrupt_Protection.
procedure Register_Interrupt_Handler
(Handler_Addr : System.Address);
- -- This routine should be called by the compiler to allow the
- -- handler be used as an Interrupt Handler. That means call this
- -- procedure for each pragma Interrup_Handler providing the
- -- address of the handler (not including the pointer to the
- -- actual PO, this way this routine is called only once for
- -- each type definition of PO).
+ -- This routine should be called by the compiler to allow the handler be
+ -- used as an Interrupt Handler. That means call this procedure for each
+ -- pragma Interrup_Handler providing the address of the handler (not
+ -- including the pointer to the actual PO, this way this routine is called
+ -- only once for each type definition of PO).
type Static_Handler_Index is range 0 .. Integer'Last;
subtype Positive_Static_Handler_Index is
Handler : Parameterless_Handler;
Static : Boolean;
end record;
- -- Contains all the information needed to restore a previous handler.
+ -- Contains all the information needed to restore a previous handler
type Previous_Handler_Array is array
(Positive_Static_Handler_Index range <>) of Previous_Handler_Item;
Interrupt : Interrupt_ID;
Handler : Parameterless_Handler;
end record;
- -- Contains all the information from an Attach_Handler pragma.
+ -- Contains all the information from an Attach_Handler pragma
type New_Handler_Array is
array (Positive_Static_Handler_Index range <>) of New_Handler_Item;
function Has_Interrupt_Or_Attach_Handler
(Object : access Dynamic_Interrupt_Protection) return Boolean;
- -- Returns True.
+ -- Returns True
-- Case (2)
end record;
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection)
- return Boolean;
- -- Returns True.
+ (Object : access Static_Interrupt_Protection) return Boolean;
+ -- Returns True
procedure Finalize (Object : in out Static_Interrupt_Protection);
-- Restore previous handlers as required by C.3.1(12) then call
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
- New_Handlers : in New_Handler_Array);
+ New_Handlers : New_Handler_Array);
-- Store the old handlers in Object.Previous_Handlers and install
-- the new static handlers.
end if;
end Comes_From_Generic;
+ -- Start of processing for Derived_Type_Declaration
+
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
if Parent_Type = Any_Type
or else Etype (Parent_Type) = Any_Type
or else (Is_Class_Wide_Type (Parent_Type)
- and then Etype (Parent_Type) = T)
+ and then Etype (Parent_Type) = T)
then
-- If Parent_Type is undefined or illegal, make new type into a
-- subtype of Any_Type, and set a few attributes to prevent cascaded
-- xxxDF deep finalize routine for type xxx (Exp_TSS)
-- xxxDI deep initialize routine for type xxx (Exp_TSS)
-- xxxEQ composite equality routine for record type xxx (Exp_TSS)
+ -- xxxFA PolyORB/DSA From_Any converter for type xxx (Exp_TSS)
-- xxxIP initialization procedure for type xxx (Exp_TSS)
- -- xxxRA RAs type access routine for type xxx (Exp_TSS)
- -- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
+ -- xxxRA RAS type access routine for type xxx (Exp_TSS)
+ -- xxxRD RAS type dereference routine for type xxx (Exp_TSS)
-- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
-- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
-- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
-- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
-- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
-- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
+ -- xxxTA PolyORB/DSA To_Any converter for type xxx (Exp_TSS)
+ -- xxxTC PolyORB/DSA Typecode for type xxx (Exp_TSS)
-- Implicit type names
projects / gcc.git / commitdiff