-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2008, 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 the Alpha/VMS version
with System.OS_Primitives;
--- Used for Max_Sensible_Delay
-
with System.Soft_Links;
--- Used for Timed_Delay
package body Ada.Calendar.Delays is
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2006, AdaCore --
+-- Copyright (C) 1995-2008, 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- --
------------------------------------------------------------------------------
with System.OS_Primitives;
--- Used for Delay_Modes
--- Max_Sensible_Delay
-
with System.Soft_Links;
--- Used for Timed_Delay
-
with System.Traces;
--- Used for Send_Trace_Info
-
with System.Parameters;
--- used for Runtime_Traces
package body Ada.Calendar.Delays is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
with Ada.Unchecked_Conversion;
with System.OS_Primitives;
--- used for Clock
package body Ada.Calendar is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Set_Priority
--- Wakeup
--- Self
-
with System.Tasking;
--- used for Task_Id
-
with System.Parameters;
--- used for Single_Lock
-
with System.Soft_Links;
--- use for Abort_Defer
--- Abort_Undefer
with Ada.Unchecked_Conversion;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2008, 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- --
pragma Warnings (On);
with System.Standard_Library; use System.Standard_Library;
--- Used for Adafinal
-
with System.Soft_Links;
--- Used for Task_Termination_Handler
--- Task_Termination_NT
procedure Ada.Exceptions.Last_Chance_Handler
(Except : Exception_Occurrence)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- --
------------------------------------------------------------------------------
--- This version is used for all Ada 2005 builds. It differs from a-except.ads
--- only with respect to the addition of Wide_[Wide]Exception_Name functions.
+-- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005.
+-- It is used in all situations except for the build of the compiler and
+-- other basic tools. For these latter builds, we use an Ada 95-only version.
-- The reason for this splitting off of a separate version is that bootstrap
-- compilers often will be used that do not support Ada 2005 features, and
-- Ada.Exceptions is part of the compiler sources.
--- The base version of this unit Ada.Exceptions omits the Wide version of
--- Exception_Name and is used to build the compiler and other basic tools.
-
pragma Style_Checks (All_Checks);
-- No subprogram ordering check, due to logical grouping
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 --
-- --
------------------------------------------------------------------------------
--- This version is used for all Ada 2005 builds. It differs from a-except.ads
--- only with respect to the addition of Wide_[Wide]Exception_Name functions.
--- The additional entities are marked with pragma Ada_05, so this extended
--- unit is also perfectly suitable for use in Ada 95 or Ada 83 mode.
+-- This version of Ada.Exceptions fully supports both Ada 95 and Ada 2005.
+-- It is used in all situations except for the build of the compiler and
+-- other basic tools. For these latter builds, we use an Ada 95-only version.
-- The reason for this splitting off of a separate version is that bootstrap
-- compilers often will be used that do not support Ada 2005 features, and
-- Ada.Exceptions is part of the compiler sources.
--- The base version of this unit Ada.Exceptions omits the Wide version of
--- Exception_Name and is used to build the compiler and other basic tools.
-
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with ourself.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 safe in the context of the run-time to violate the rules!
with System.Soft_Links;
--- used for Check_Abort_Status
pragma Warnings (On);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 --
------------------------------------------------------------------------------
with System.Interrupts;
--- used for Ada_Interrupt_ID
package Ada.Interrupts is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- Beware that the mapping of names to signals may be many-to-one. There
- -- may be aliases. Also, for all signal names that are not supported on the
- -- current system the value of the corresponding constant will be zero.
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- may be aliases. Also, for all signal names that are not supported on the
-- current system the value of the corresponding constant will be zero.
- SIGHUP : constant Interrupt_ID :=
+ SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
- SIGINT : constant Interrupt_ID :=
+ SIGINT : constant Interrupt_ID :=
System.OS_Interface.SIGINT; -- interrupt (rubout)
- SIGQUIT : constant Interrupt_ID :=
+ SIGQUIT : constant Interrupt_ID :=
System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
- SIGILL : constant Interrupt_ID :=
+ SIGILL : constant Interrupt_ID :=
System.OS_Interface.SIGILL; -- illegal instruction (not reset)
- SIGTRAP : constant Interrupt_ID :=
+ SIGTRAP : constant Interrupt_ID :=
System.OS_Interface.SIGTRAP; -- trace trap (not reset)
- SIGIOT : constant Interrupt_ID :=
+ SIGIOT : constant Interrupt_ID :=
System.OS_Interface.SIGIOT; -- IOT instruction
- SIGABRT : constant Interrupt_ID := -- used by abort,
+ SIGABRT : constant Interrupt_ID := -- used by abort,
System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
- SIGEMT : constant Interrupt_ID :=
+ SIGEMT : constant Interrupt_ID :=
System.OS_Interface.SIGEMT; -- EMT instruction
- SIGFPE : constant Interrupt_ID :=
+ SIGFPE : constant Interrupt_ID :=
System.OS_Interface.SIGFPE; -- floating point exception
- SIGKILL : constant Interrupt_ID :=
+ SIGKILL : constant Interrupt_ID :=
System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
- SIGBUS : constant Interrupt_ID :=
+ SIGBUS : constant Interrupt_ID :=
System.OS_Interface.SIGBUS; -- bus error
- SIGSEGV : constant Interrupt_ID :=
+ SIGSEGV : constant Interrupt_ID :=
System.OS_Interface.SIGSEGV; -- segmentation violation
- SIGSYS : constant Interrupt_ID :=
+ SIGSYS : constant Interrupt_ID :=
System.OS_Interface.SIGSYS; -- bad argument to system call
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
+ SIGPIPE : constant Interrupt_ID := -- write on a pipe with
System.OS_Interface.SIGPIPE; -- no one to read it
- SIGALRM : constant Interrupt_ID :=
+ SIGALRM : constant Interrupt_ID :=
System.OS_Interface.SIGALRM; -- alarm clock
- SIGTERM : constant Interrupt_ID :=
+ SIGTERM : constant Interrupt_ID :=
System.OS_Interface.SIGTERM; -- software termination signal from kill
- SIGURG : constant Interrupt_ID :=
+ SIGURG : constant Interrupt_ID :=
System.OS_Interface.SIGURG; -- urgent condition on IO channel
- SIGSTOP : constant Interrupt_ID :=
+ SIGSTOP : constant Interrupt_ID :=
System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
- SIGTSTP : constant Interrupt_ID :=
+ SIGTSTP : constant Interrupt_ID :=
System.OS_Interface.SIGTSTP; -- user stop requested from tty
- SIGCONT : constant Interrupt_ID :=
+ SIGCONT : constant Interrupt_ID :=
System.OS_Interface.SIGCONT; -- stopped process has been continued
- SIGCHLD : constant Interrupt_ID :=
+ SIGCHLD : constant Interrupt_ID :=
System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
- SIGTTIN : constant Interrupt_ID :=
+ SIGTTIN : constant Interrupt_ID :=
System.OS_Interface.SIGTTIN; -- background tty read attempted
- SIGTTOU : constant Interrupt_ID :=
+ SIGTTOU : constant Interrupt_ID :=
System.OS_Interface.SIGTTOU; -- background tty write attempted
- SIGIO : constant Interrupt_ID := -- input/output possible,
+ SIGIO : constant Interrupt_ID := -- input/output possible,
System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
- SIGXCPU : constant Interrupt_ID :=
+ SIGXCPU : constant Interrupt_ID :=
System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
- SIGXFSZ : constant Interrupt_ID :=
+ SIGXFSZ : constant Interrupt_ID :=
System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
SIGVTALRM : constant Interrupt_ID :=
System.OS_Interface.SIGVTALRM; -- virtual timer expired
- SIGPROF : constant Interrupt_ID :=
+ SIGPROF : constant Interrupt_ID :=
System.OS_Interface.SIGPROF; -- profiling timer expired
- SIGWINCH : constant Interrupt_ID :=
+ SIGWINCH : constant Interrupt_ID :=
System.OS_Interface.SIGWINCH; -- window size change
- SIGINFO : constant Interrupt_ID :=
+ SIGINFO : constant Interrupt_ID :=
System.OS_Interface.SIGINFO; -- information request
- SIGUSR1 : constant Interrupt_ID :=
+ SIGUSR1 : constant Interrupt_ID :=
System.OS_Interface.SIGUSR1; -- user defined signal 1
- SIGUSR2 : constant Interrupt_ID :=
+ SIGUSR2 : constant Interrupt_ID :=
System.OS_Interface.SIGUSR2; -- user defined signal 2
end Ada.Interrupts.Names;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the FreeBSD THREADS version of this package
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
+
SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
SIGUSR2 : constant Interrupt_ID :=
System.OS_Interface.SIGUSR2; -- user defined signal 2
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
-
end Ada.Interrupts.Names;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1991-2008, 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- --
-- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1991-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU Library General Public License as published by the --
-- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
+ -- Beware that the mapping of names to signals may be many-to-one. There
+ -- may be aliases. Also, for all signal names that are not supported on
+ -- the current system the value of the corresponding constant will be zero.
SIGHUP : constant Interrupt_ID :=
System.OS_Interface.SIGHUP; -- hangup
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- supported by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- SIGINT: made available for Ada handler
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2008, 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- --
-- by the local system.
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- may be aliases. Also, for all signal names that are not supported on the
-- current system the value of the corresponding constant will be zero.
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
+ SIGINT : constant Interrupt_ID := -- interrupt (rubout)
+ System.OS_Interface.SIGINT;
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
+ SIGILL : constant Interrupt_ID := -- illegal instruction (not reset)
+ System.OS_Interface.SIGILL;
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
+ SIGABRT : constant Interrupt_ID := -- used by abort (use SIGIOT in future)
+ System.OS_Interface.SIGABRT;
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
+ SIGFPE : constant Interrupt_ID := -- floating point exception
+ System.OS_Interface.SIGFPE;
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
+ SIGSEGV : constant Interrupt_ID := -- segmentation violation
+ System.OS_Interface.SIGSEGV;
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
+ SIGTERM : constant Interrupt_ID := -- software termination signal from kill
+ System.OS_Interface.SIGTERM;
end Ada.Interrupts.Names;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- SIGINT: made available for Ada handlers
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- SIGINT: made available for Ada handler
with System.OS_Interface;
--- used for names of interrupts
package Ada.Interrupts.Names is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- supported by the local system.
with System.OS_Interface;
+
package Ada.Interrupts.Names is
package OS renames System.OS_Interface;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
with Ada.Exceptions;
--- Used for Raise_Exception
with System.Tasking;
--- Used for Task_Id
--- Initialize
-
with System.Task_Primitives.Operations;
--- Used for Timed_Delay
--- Self
package body Ada.Real_Time.Delays is
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2008, 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- --
with System.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Soft_Links;
--- used for Abort_Defer/Undefer
with Ada.Containers.Doubly_Linked_Lists;
pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
package body Ada.Real_Time.Timing_Events is
use System.Task_Primitives.Operations;
- -- for Write_Lock and Unlock
package SSL renames System.Soft_Links;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- --
------------------------------------------------------------------------------
-with System.Tasking;
--- Used for Detect_Blocking
--- Self
-
with Ada.Exceptions;
--- Used for Raise_Exception
+with System.Tasking;
with System.Task_Primitives.Operations;
--- Used for Initialize
--- Finalize
--- Current_State
--- Set_False
--- Set_True
--- Suspend_Until_True
package body Ada.Synchronous_Task_Control is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 --
------------------------------------------------------------------------------
with System.Task_Primitives;
--- Used for Suspension_Object
with Ada.Finalization;
--- Used for Limited_Controlled
package Ada.Synchronous_Task_Control is
pragma Preelaborate_05;
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, AdaCore --
+-- Copyright (C) 1995-2008, 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- --
-- instantiated from within a local context.
with System.Error_Reporting;
--- Used for Shutdown;
-
with System.Storage_Elements;
--- Used for Integer_Address
-
with System.Task_Primitives.Operations;
--- Used for Write_Lock
--- Unlock
--- Lock/Unlock_RTS
-
with System.Tasking;
--- Used for Access_Address
--- Task_Id
--- Direct_Index_Vector
--- Direct_Index
-
with System.Tasking.Initialization;
--- Used for Defer_Abort
--- Undefer_Abort
--- Initialize_Attributes_Link
--- Finalize_Attributes_Link
-
with System.Tasking.Task_Attributes;
--- Used for Access_Node
--- Access_Dummy_Wrapper
--- Deallocator
--- Instance
--- Node
--- Access_Instance
with Ada.Exceptions;
--- Used for Raise_Exception
-
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- It is safe in the context of the run-time to violate the rules!
with System.Tasking.Utilities;
--- Used for Abort_Tasks
pragma Warnings (On);
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2008, 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- --
------------------------------------------------------------------------------
with System.Tasking;
--- used for Task_Id
-
with System.Task_Primitives.Operations;
--- used for Self
--- Write_Lock
--- Unlock
--- Lock_RTS
--- Unlock_RTS
-
with System.Parameters;
--- used for Single_Lock
-
with System.Soft_Links;
--- use for Abort_Defer
--- Abort_Undefer
with Ada.Unchecked_Conversion;
Item := ASCII.NUL;
-- If we are before an upper half character just return it (this can
- -- happen if there are two calls to Look_Ahead in a row.
+ -- happen if there are two calls to Look_Ahead in a row).
elsif File.Before_Upper_Half_Character then
End_Of_Line := False;
Standard_In.Is_Text_File := True;
Standard_In.Access_Method := 'T';
Standard_In.Self := Standard_In;
- Standard_In.WC_Method := Default_WCEM;
+ Standard_In.WC_Method := Default_WCEM;
Standard_Out.Stream := stdout;
Standard_Out.Name := Out_Name'Access;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
procedure String_Skip (Str : String; Ptr : out Integer);
-- Used in the Get from string procedures to skip leading blanks in the
-- string. Ptr is set to the index of the first non-blank. If the string
- -- is all blanks, then the excption End_Error is raised, Note that blank
+ -- is all blanks, then the exception End_Error is raised, Note that blank
-- is defined as a space or horizontal tab (RM A.10.6(5)).
procedure Ungetc (ch : Integer; File : File_Type);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
-- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO
--- that are shared among separate instantiations of this package. The
--- routines in this package are identical semantically to those in Integer_IO
--- itself, except that the generic parameter Num has been replaced by Integer
--- or Long_Long_Integer, and the default parameters have been removed because
+-- that are shared among separate instantiations of this package. The routines
+-- in this package are identical semantically to those in Integer_IO itself,
+-- except that the generic parameter Num has been replaced by Integer or
+-- Long_Long_Integer, and the default parameters have been removed because
-- they are supplied explicitly by the calls from within the generic template.
private package Ada.Wide_Wide_Text_IO.Integer_Aux is
if Field2 (Cur_Node) not in Node_Range then
return Traverse_Field (Cur_Node, Field2 (Cur_Node), 2);
- elsif Is_Syntactic_Field (Nkind (Cur_Node), 2) and then
- Field2 (Cur_Node) /= Empty_List_Or_Node
+
+ elsif Is_Syntactic_Field (Nkind (Cur_Node), 2)
+ and then Field2 (Cur_Node) /= Empty_List_Or_Node
then
- -- Here is the tail recursion step, we reset Cur_Node and jump
- -- back to the start of the procedure, which has the same
- -- semantic effect as a call.
+ -- Here is the tail recursion step, we reset Cur_Node and jump back
+ -- to the start of the procedure, which has the same semantic effect
+ -- as a call.
Cur_Node := Node_Id (Field2 (Cur_Node));
goto Tail_Recurse;
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2008, 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- --
------------------------------------------------------------------------------
with System.Soft_Links;
--- used for Lock_Task, Unlock_Task
package body System.Global_Locks is
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . --
--- O P E R A T I O N S --
+-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, AdaCore --
+-- Copyright (C) 1995-2008, 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 a POSIX-like version of this package.
--- Note: this file can only be used for POSIX compliant systems.
+-- This is a POSIX-like version of this package
+
+-- Note: this file can only be used for POSIX compliant systems
with Interfaces.C;
--- used for int
--- size_t
--- unsigned
with System.OS_Interface;
--- used for various type, constant, and operations
-
with System.Storage_Elements;
--- used for To_Address
--- Integer_Address
package body System.Interrupt_Management.Operations is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 a OpenVMS/Alpha version of this package
with System.OS_Interface;
--- used for various type, constant, and operations
-
with System.Aux_DEC;
--- used for Short_Address
-
with System.Parameters;
-
with System.Tasking;
-
with System.Tasking.Initialization;
-
with System.Task_Primitives.Operations;
-
with System.Task_Primitives.Operations.DEC;
with Ada.Unchecked_Conversion;
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2007, 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 version is for systems that do not support interrupts (or signals)
-with Ada.Exceptions;
-
package body System.Interrupts is
pragma Warnings (Off); -- kill warnings on unreferenced formals
procedure Unimplemented is
begin
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "interrupts/signals not implemented");
- raise Program_Error;
+ raise Program_Error with "interrupts/signals not implemented";
end Unimplemented;
end System.Interrupts;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the IRIX & NT version of this package
with Ada.Task_Identification;
--- used for Task_Id
+with Ada.Unchecked_Conversion;
-with Ada.Exceptions;
--- used for Raise_Exception
+with Interfaces.C;
with System.Storage_Elements;
--- used for To_Address
--- To_Integer
-
with System.Task_Primitives.Operations;
--- used for Self
--- Sleep
--- Wakeup
--- Write_Lock
--- Unlock
-
with System.Tasking.Utilities;
--- used for Make_Independent
-
with System.Tasking.Rendezvous;
--- used for Call_Simple
-
with System.Tasking.Initialization;
--- used for Defer_Abort
--- Undefer_Abort
-
with System.Interrupt_Management;
-
with System.Parameters;
--- used for Single_Lock
-
-with Interfaces.C;
--- used for int
-
-with Ada.Unchecked_Conversion;
package body System.Interrupts is
use Parameters;
use Tasking;
- use Ada.Exceptions;
use System.OS_Interface;
use Interfaces.C;
function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Descriptors (Interrupt).T /= Null_Task;
function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
+ else
+ return Descriptors (Interrupt).Kind /= Unknown;
end if;
-
- return Descriptors (Interrupt).Kind /= Unknown;
end Is_Handler_Attached;
----------------
or else not Is_Registered (New_Handler))
then
- Raise_Exception (Program_Error'Identity,
+ raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " &
- "dynamic Handler");
+ "dynamic Handler";
end if;
if Handlers (Interrupt) = null then
-- In case we have an Interrupt Entry already installed.
-- raise a program error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt is already installed");
- end if;
+ raise Program_Error with "An interrupt is already installed";
- Old_Handler := Current_Handler (Interrupt);
- Attach_Handler (New_Handler, Interrupt, Static);
+ else
+ Old_Handler := Current_Handler (Interrupt);
+ Attach_Handler (New_Handler, Interrupt, Static);
+ end if;
end Exchange_Handler;
--------------------
end if;
if Descriptors (Interrupt).Kind = Task_Entry then
- Raise_Exception (Program_Error'Identity,
- "Trying to detach an Interrupt Entry");
+ raise Program_Error with "Trying to detach an Interrupt Entry";
end if;
if not Static and then Descriptors (Interrupt).Static then
- Raise_Exception (Program_Error'Identity,
- "Trying to detach a static Interrupt Handler");
+ raise Program_Error with
+ "Trying to detach a static Interrupt Handler";
end if;
Descriptors (Interrupt) :=
end if;
if Descriptors (Interrupt).Kind /= Unknown then
- Raise_Exception (Program_Error'Identity,
- "A binding for this interrupt is already present");
+ raise Program_Error with
+ "A binding for this interrupt is already present";
end if;
if Handlers (Interrupt) = null then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- rendezvous.
with Ada.Task_Identification;
--- used for Task_Id type
-
-with Ada.Exceptions;
--- used for Raise_Exception
+with Ada.Unchecked_Conversion;
with System.Task_Primitives;
--- used for RTS_Lock
--- Self
-
with System.Interrupt_Management;
--- used for Reserve
--- Interrupt_ID
--- Interrupt_Mask
--- Abort_Task_Interrupt
with System.Interrupt_Management.Operations;
--- used for Thread_Block_Interrupt
--- Thread_Unblock_Interrupt
--- Install_Default_Action
--- Install_Ignore_Action
--- Copy_Interrupt_Mask
--- Set_Interrupt_Mask
--- Empty_Interrupt_Mask
--- Fill_Interrupt_Mask
--- Add_To_Interrupt_Mask
--- Delete_From_Interrupt_Mask
--- Interrupt_Wait
--- Interrupt_Self_Process
--- Get_Interrupt_Mask
--- Set_Interrupt_Mask
--- IS_Member
--- Environment_Mask
pragma Elaborate_All (System.Interrupt_Management.Operations);
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Abort
--- Wakeup_Task
--- Sleep
--- Initialize_Lock
-
with System.Task_Primitives.Interrupt_Operations;
--- used for Set_Interrupt_ID
-
with System.Storage_Elements;
--- used for To_Address
--- To_Integer
--- Integer_Address
-
with System.Tasking.Utilities;
--- used for Make_Independent
with System.Tasking.Rendezvous;
--- used for Call_Simple
pragma Elaborate_All (System.Tasking.Rendezvous);
with System.Tasking.Initialization;
--- used for Defer_Abort
--- Undefer_Abort
-
with System.Parameters;
--- used for Single_Lock
-
-with Ada.Unchecked_Conversion;
package body System.Interrupts is
use Tasking;
use System.Parameters;
- use Ada.Exceptions;
package POP renames System.Task_Primitives.Operations;
package PIO renames System.Task_Primitives.Interrupt_Operations;
function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return User_Entry (Interrupt).T /= Null_Task;
function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return User_Handler (Interrupt).H /= null;
function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Blocked (Interrupt);
function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Ignored (Interrupt);
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
-- ??? Since Parameterless_Handler is not Atomic, the current
Static : Boolean := False) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Exchange_Handler
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Detach_Handler (Interrupt, Static);
function Reference (Interrupt : Interrupt_ID) return System.Address is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Storage_Elements.To_Address
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
procedure Block_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Block_Interrupt (Interrupt);
procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Unblock_Interrupt (Interrupt);
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Last_Unblocker (Interrupt);
procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Ignore_Interrupt (Interrupt);
procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Unignore_Interrupt (Interrupt);
is
begin
if User_Entry (Interrupt).T /= Null_Task then
+
-- In case we have an Interrupt Entry already installed.
-- raise a program error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt is already installed");
+ raise Program_Error with "An interrupt is already installed";
end if;
- -- Note : A null handler with Static = True will
- -- pass the following check. That is the case when we want to
- -- Detach a handler regardless of the Static status
- -- of the current_Handler.
- -- We don't check anything if Restoration is True, since we
- -- may be detaching a static handler to restore a dynamic one.
+ -- Note: A null handler with Static=True will pass the following
+ -- check. That is the case when we want to Detach a handler
+ -- regardless of the Static status of the current_Handler. We don't
+ -- check anything if Restoration is True, since we may be detaching
+ -- a static handler to restore a dynamic one.
if not Restoration and then not Static
+
-- Tries to overwrite a static Interrupt Handler with a
-- dynamic Handler
or else not Is_Registered (New_Handler))
then
- Raise_Exception (Program_Error'Identity,
+ raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " &
- "dynamic Handler");
+ "dynamic Handler";
end if;
-- The interrupt should no longer be ingnored if it was ever ignored
is
begin
if User_Entry (Interrupt).T /= Null_Task then
+
-- In case we have an Interrupt Entry installed.
-- raise a program error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt entry is already installed");
+ raise Program_Error with
+ "An interrupt entry is already installed";
end if;
-- Note : Static = True will pass the following check. That is the
-- Tries to detach a static Interrupt Handler.
-- raise a program error.
- Raise_Exception (Program_Error'Identity,
- "Trying to detach a static Interrupt Handler");
+ raise Program_Error with
+ "Trying to detach a static Interrupt Handler";
end if;
-- The interrupt should no longer be ignored if
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
- Raise_Exception (Program_Error'Identity,
- "A binding for this interrupt is already present");
+ raise Program_Error with
+ "A binding for this interrupt is already present";
end if;
-- The interrupt should no longer be ingnored if
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- 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,
--- 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 requests are ensured via user calls to the Interrupt_Manager
--- entries.
+-- tables. If there is a Server_Task associated with a signal or interrupt, 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
+-- requests are ensured via user calls to the Interrupt_Manager entries.
-- This is the VxWorks version of this package, supporting vectored hardware
-- interrupts.
with Ada.Unchecked_Conversion;
-
-with System.OS_Interface; use System.OS_Interface;
-
-with Interfaces.VxWorks;
-
with Ada.Task_Identification;
--- used for Task_Id type
-with Ada.Exceptions;
--- used for Raise_Exception
+with Interfaces.VxWorks;
+with System.OS_Interface; use System.OS_Interface;
with System.Interrupt_Management;
--- used for Reserve
-
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Abort
--- Wakeup_Task
--- Sleep
--- Initialize_Lock
-
with System.Storage_Elements;
--- used for To_Address
--- To_Integer
--- Integer_Address
-
with System.Tasking.Utilities;
--- used for Make_Independent
with System.Tasking.Rendezvous;
--- used for Call_Simple
pragma Elaborate_All (System.Tasking.Rendezvous);
package body System.Interrupts is
use Tasking;
- use Ada.Exceptions;
package POP renames System.Task_Primitives.Operations;
procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception
- (Program_Error'Identity,
- "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
else
return;
end if;
procedure Unimplemented (Feature : String) is
begin
- Raise_Exception
- (Program_Error'Identity,
- Feature & " not implemented on VxWorks");
+ raise Program_Error with Feature & " not implemented on VxWorks";
end Unimplemented;
-----------------------
-- If an interrupt entry is installed raise
-- Program_Error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt entry is already installed");
+ raise Program_Error with
+ "An interrupt entry is already installed";
end if;
-- Note : Static = True will pass the following check. This is the
-- Trying to detach a static Interrupt Handler. raise
-- Program_Error.
- Raise_Exception (Program_Error'Identity,
- "Trying to detach a static Interrupt Handler");
+ raise Program_Error with
+ "Trying to detach a static Interrupt Handler";
end if;
Old_Handler := User_Handler (Interrupt).H;
-- If an interrupt entry is already installed, raise
-- Program_Error. (propagate it to the caller).
- Raise_Exception
- (Program_Error'Identity,
- "An interrupt is already installed");
+ raise Program_Error with "An interrupt is already installed";
end if;
-- Note : A null handler with Static = True will
or else not Is_Registered (New_Handler))
then
- Raise_Exception
- (Program_Error'Identity,
+ raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " &
- "dynamic Handler");
+ "dynamic Handler";
end if;
-- Save the old handler
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
- Raise_Exception
- (Program_Error'Identity,
- "A binding for this interrupt is already present");
+ raise Program_Error with
+ "A binding for this interrupt is already present";
end if;
User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- one Server_Task per interrupt.
with Ada.Task_Identification;
--- used for Task_Id type
-
-with Ada.Exceptions;
--- used for Raise_Exception
with System.Task_Primitives;
--- used for RTS_Lock
--- Self
-
with System.Interrupt_Management;
--- used for Reserve
--- Interrupt_ID
--- Interrupt_Mask
--- Abort_Task_Interrupt
with System.Interrupt_Management.Operations;
--- used for Thread_Block_Interrupt
--- Thread_Unblock_Interrupt
--- Install_Default_Action
--- Install_Ignore_Action
--- Copy_Interrupt_Mask
--- Set_Interrupt_Mask
--- Empty_Interrupt_Mask
--- Fill_Interrupt_Mask
--- Add_To_Interrupt_Mask
--- Delete_From_Interrupt_Mask
--- Interrupt_Wait
--- Interrupt_Self_Process
--- Get_Interrupt_Mask
--- Set_Interrupt_Mask
--- IS_Member
--- Environment_Mask
--- All_Tasks_Mask
pragma Elaborate_All (System.Interrupt_Management.Operations);
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Abort
--- Wakeup_Task
--- Sleep
--- Initialize_Lock
-
with System.Task_Primitives.Interrupt_Operations;
--- used for Set_Interrupt_ID
-
with System.Storage_Elements;
--- used for To_Address
--- To_Integer
--- Integer_Address
-
with System.Tasking.Utilities;
--- used for Make_Independent
with System.Tasking.Rendezvous;
--- used for Call_Simple
pragma Elaborate_All (System.Tasking.Rendezvous);
with System.Tasking.Initialization;
--- used for Defer_Abort
--- Undefer_Abort
-
with System.Parameters;
--- used for Single_Lock
with Ada.Unchecked_Conversion;
use Parameters;
use Tasking;
- use Ada.Exceptions;
package POP renames System.Task_Primitives.Operations;
package PIO renames System.Task_Primitives.Interrupt_Operations;
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
procedure Block_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Block_Interrupt (Interrupt);
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
-- ??? Since Parameterless_Handler is not Atomic, the current
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Detach_Handler (Interrupt, Static);
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Exchange_Handler
procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Ignore_Interrupt (Interrupt);
function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Blocked (Interrupt);
function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return User_Entry (Interrupt).T /= Null_Task;
function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return User_Handler (Interrupt).H /= null;
function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Ignored (Interrupt);
function Reference (Interrupt : Interrupt_ID) return System.Address is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Storage_Elements.To_Address
procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Unblock_Interrupt (Interrupt);
is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
return Last_Unblocker (Interrupt);
procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
begin
if Is_Reserved (Interrupt) then
- Raise_Exception (Program_Error'Identity, "Interrupt" &
- Interrupt_ID'Image (Interrupt) & " is reserved");
+ raise Program_Error with
+ "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
end if;
Interrupt_Manager.Unignore_Interrupt (Interrupt);
-- In case we have an Interrupt Entry installed.
-- raise a program error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt entry is already installed");
+ raise Program_Error with
+ "An interrupt entry is already installed";
end if;
-- Note : Static = True will pass the following check. That is the
-- Tries to detach a static Interrupt Handler.
-- raise a program error.
- Raise_Exception (Program_Error'Identity,
- "Trying to detach a static Interrupt Handler");
+ raise Program_Error with
+ "Trying to detach a static Interrupt Handler";
end if;
-- The interrupt should no longer be ignored if
-- In case we have an Interrupt Entry already installed.
-- raise a program error. (propagate it to the caller).
- Raise_Exception (Program_Error'Identity,
- "An interrupt is already installed");
+ raise Program_Error with
+ "An interrupt is already installed";
end if;
-- Note : A null handler with Static = True will pass the
or else not Is_Registered (New_Handler))
then
- Raise_Exception (Program_Error'Identity,
+ raise Program_Error with
"Trying to overwrite a static Interrupt Handler with a " &
- "dynamic Handler");
+ "dynamic Handler";
end if;
-- The interrupt should no longer be ingnored if
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
- Raise_Exception (Program_Error'Identity,
- "A binding for this interrupt is already present");
+ raise Program_Error with
+ "A binding for this interrupt is already present";
end if;
-- The interrupt should no longer be ingnored if
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Any changes to this interface may require corresponding compiler changes.
-- This package encapsulates the implementation of interrupt or signal
--- handlers. It is logically an extension of the body of Ada.Interrupts.
--- It is made a child of System to allow visibility of various
--- runtime system internal data and operations.
+-- handlers. It is logically an extension of the body of Ada.Interrupts. 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
--- These two packages are separated in order to allow
--- System.Interrupt_Management to be used without requiring the whole
--- tasking implementation to be linked and elaborated.
+-- These two packages are separated to allow System.Interrupt_Management to be
+-- used without requiring the whole tasking implementation to be linked and
+-- elaborated.
with System.Tasking;
--- used for Task_Id
-
with System.Tasking.Protected_Objects.Entries;
--- used for Protection_Entries
-
with System.OS_Interface;
--- used for Max_Interrupt
package System.Interrupts is
type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt;
- -- The following renaming is introduced so that the type is accessible
- -- through rtsfind, otherwise the name clashes with its homonym in
- -- ada.interrupts.
-
subtype System_Interrupt_Id is Interrupt_ID;
+ -- This synonym is introduced so that the type is accessible through
+ -- rtsfind, otherwise the name clashes with its homonym in Ada.Interrupts.
type Parameterless_Handler is access protected procedure;
function Current_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
- -- regardless of the previous handler's binding status.
- -- (i.e. we do not care whether it is a dynamic or static handler)
+ -- Calling the following procedures with New_Handler = null and Static =
+ -- true means that we want to modify the current handler regardless of the
+ -- previous handler's binding status. (i.e. we do not care whether it is a
+ -- dynamic or static handler)
procedure Attach_Handler
(New_Handler : Parameterless_Handler;
function Unblocked_By
(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.
+ -- It returns Null_Task if no tasks have ever requested the Unblocking
+ -- operation or the Interrupt is currently Blocked.
function Is_Blocked (Interrupt : Interrupt_ID) return Boolean;
-- Comment needed ???
-- other low-level interface that changes the signal action or signal mask
-- needs a careful thought.
- -- One may acheive the effect of system calls first making RTS blocked
- -- (by calling Block_Interrupt) for the signal under consideration.
- -- This will make all the tasks in RTS blocked for the Interrupt.
+ -- One may acheive the effect of system calls first making RTS blocked (by
+ -- calling Block_Interrupt) for the signal under consideration. This will
+ -- make all the tasks in RTS blocked for the Interrupt.
----------------------
-- Protection Types --
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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- --
-- implemented as visible arrays rather than functions.)
with System.OS_Interface;
--- used for Signal
--- sigset_t
package System.Interrupt_Management is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- sets are implemeneted using visible arrays rather than functions.
with System.OS_Interface;
--- used for sigset_t
with Interfaces.C;
--- used for int
package System.Interrupt_Management is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- rather than functions.
with System.OS_Interface;
--- used for sigset_t
with Interfaces.C;
--- used for int
package System.Interrupt_Management is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a AIX (Native THREADS) version of this package
-- This package encapsulates all direct interfaces to OS services that are
--- needed by children of System.
+-- needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 Darwin pthreads version of this package
-- This package includes all direct interfaces to OS services that are needed
--- by children of System.
+-- by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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- --
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the FreeBSD PTHREADS version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the HP-UX version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a HPUX 11.0 (Native THREADS) version of this package
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the SGI Pthreads version of this package
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- (GNU/Linux-HPPA Version) --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a GNU/Linux (GNU/LinuxThreads) version of this package
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a GNU/Linux (GNU/LinuxThreads) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a LynxOS (Native) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a LynxOS (POSIX Threads) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-with Interfaces.C;
with Ada.Unchecked_Conversion;
+with Interfaces.C;
+
package System.OS_Interface is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a NT (native) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with Interfaces.C.Strings;
+
with Ada.Unchecked_Conversion;
package System.OS_Interface is
type PLONG is access all Interfaces.C.long;
type PDWORD is access all DWORD;
+ type BYTE is new Interfaces.C.unsigned_char;
+ subtype CHAR is Interfaces.C.char;
type BOOL is new Boolean;
for BOOL'Size use Interfaces.C.unsigned_long'Size;
NO_ERROR : constant := 0;
FUNC_ERR : constant := -1;
+ -----------
+ -- Files --
+ -----------
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
------------------------
-- System Information --
------------------------
function To_PTHREAD_START_ROUTINE is new
Ada.Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE);
- type SECURITY_ATTRIBUTES is record
- nLength : DWORD;
- pSecurityDescriptor : PVOID;
- bInheritHandle : BOOL;
- end record;
-
- type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES;
-
function CreateThread
- (pThreadAttributes : PSECURITY_ATTRIBUTES;
- dwStackSize : DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : PVOID;
- dwCreationFlags : DWORD;
- pThreadId : PDWORD) return HANDLE;
+ (pThreadAttributes : access SECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
pragma Import (Stdcall, CreateThread, "CreateThread");
function BeginThreadEx
- (pThreadAttributes : PSECURITY_ATTRIBUTES;
- dwStackSize : DWORD;
- pStartAddress : PTHREAD_START_ROUTINE;
- pParameter : PVOID;
- dwCreationFlags : DWORD;
- pThreadId : PDWORD) return HANDLE;
+ (pThreadAttributes : access SECURITY_ATTRIBUTES;
+ dwStackSize : DWORD;
+ pStartAddress : PTHREAD_START_ROUTINE;
+ pParameter : PVOID;
+ dwCreationFlags : DWORD;
+ pThreadId : PDWORD) return HANDLE;
pragma Import (C, BeginThreadEx, "_beginthreadex");
Debug_Process : constant := 16#00000001#;
-- Semaphores, Events and Mutexes --
------------------------------------
- function CloseHandle (hObject : HANDLE) return BOOL;
- pragma Import (Stdcall, CloseHandle, "CloseHandle");
-
function CreateSemaphore
- (pSemaphoreAttributes : PSECURITY_ATTRIBUTES;
+ (pSemaphoreAttributes : access SECURITY_ATTRIBUTES;
lInitialCount : Interfaces.C.long;
lMaximumCount : Interfaces.C.long;
pName : PSZ) return HANDLE;
pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore");
function CreateEvent
- (pEventAttributes : PSECURITY_ATTRIBUTES;
+ (pEventAttributes : access SECURITY_ATTRIBUTES;
bManualReset : BOOL;
bInitialState : BOOL;
pName : PSZ) return HANDLE;
pragma Import (Stdcall, PulseEvent, "PulseEvent");
function CreateMutex
- (pMutexAttributes : PSECURITY_ATTRIBUTES;
+ (pMutexAttributes : access SECURITY_ATTRIBUTES;
bInitialOwner : BOOL;
pName : PSZ) return HANDLE;
pragma Import (Stdcall, CreateMutex, "CreateMutexA");
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a Solaris (POSIX Threads) version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with Ada.Unchecked_Conversion;
package System.OS_Interface is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a Solaris (native) version of this package
-- This package includes all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with Ada.Unchecked_Conversion;
package System.OS_Interface is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is the DEC Unix 4.0/5.1 version of this package
+-- This is the Tru64 version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with Ada.Unchecked_Conversion;
package System.OS_Interface is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, 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 a OpenVMS/Alpha version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with Ada.Unchecked_Conversion;
+
with System.Aux_DEC;
package System.OS_Interface is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the VxWorks version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
+
with System.VxWorks;
package System.OS_Interface is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2008, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This is the VxWorks 6.x version of this package
-- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
-- Signal processing definitions --
-----------------------------------
- -- The how in sigprocmask().
+ -- The how in sigprocmask()
SIG_BLOCK : constant := 1;
SIG_UNBLOCK : constant := 2;
SIG_SETMASK : constant := 3;
- -- The sa_flags in struct sigaction.
+ -- The sa_flags in struct sigaction
SA_SIGINFO : constant := 16#0002#;
SA_ONSTACK : constant := 16#0004#;
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, 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- --
-- create a dependency on libgnarl in libgnat, which is not desirable.
with Interfaces.C;
--- used for type int
package body System.OS_Primitives is
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Streams;
-- Error if we cannot create the file
when others =>
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity,
- "Cannot create shared variable file for """ &
- S & '"'); -- "
+ raise Program_Error with
+ "Cannot create shared variable file for """ & S & '"';
end;
end;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
pragma Warnings (On);
pragma Polling (Off);
--- We must turn polling off for this unit, because otherwise we get
--- an infinite loop from the code within the Poll routine itself.
+-- We must turn polling off for this unit, because otherwise we get an
+-- infinite loop from the code within the Poll routine itself.
with System.Parameters;
--- Used for Sec_Stack_Ratio
pragma Warnings (Off);
--- Disable warnings since System.Secondary_Stack is currently not
--- Preelaborate
+-- Disable warnings since System.Secondary_Stack is currently not Preelaborate
with System.Secondary_Stack;
pragma Warnings (On);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2008, 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- --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram alpha ordering check, since we group soft link
--- bodies and dummy soft link bodies together separately in this unit.
+-- Turn off subprogram alpha ordering check, since we group soft link bodies
+-- and dummy soft link bodies together separately in this unit.
pragma Polling (Off);
--- Turn polling off for this package. We don't need polling during any
--- of the routines in this package, and more to the point, if we try
--- to poll it can cause infinite loops.
+-- Turn polling off for this package. We don't need polling during any of the
+-- routines in this package, and more to the point, if we try to poll it can
+-- cause infinite loops.
-with System.Task_Primitives.Operations;
--- Used for Self
--- Timed_Delay
+with Ada.Exceptions;
+with Ada.Exceptions.Is_Null_Occurrence;
+with System.Task_Primitives.Operations;
with System.Tasking;
--- Used for Task_Id
--- Cause_Of_Termination
-
with System.Stack_Checking;
--- Used for Stack_Access
-
-with Ada.Exceptions;
--- Used for Exception_Id
--- Exception_Occurrence
--- Save_Occurrence
-
-with Ada.Exceptions.Is_Null_Occurrence;
package body System.Soft_Links.Tasking is
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, 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- --
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
-with Ada.Exceptions;
--- Used for Raise_Exception
+with Ada.Unchecked_Conversion;
+with Ada.Task_Identification;
with System.Task_Primitives.Operations;
--- Used for Write_Lock,
--- Unlock,
--- Self,
--- Monotonic_Clock,
--- Self,
--- Timed_Sleep,
--- Wakeup,
--- Yield
-
with System.Tasking.Utilities;
--- Used for Make_Independent
-
with System.Tasking.Initialization;
--- Used for Defer_Abort
--- Undefer_Abort
-
with System.Tasking.Debug;
--- Used for Trace
-
with System.OS_Primitives;
--- used for Max_Sensible_Delay
-
-with Ada.Task_Identification;
--- used for Task_Id type
-
with System.Interrupt_Management.Operations;
--- used for Setup_Interrupt_Mask
-
with System.Parameters;
--- used for Single_Lock
--- Runtime_Traces
-
with System.Traces.Tasking;
--- used for Send_Trace_Info
-
-with Ada.Unchecked_Conversion;
package body System.Tasking.Async_Delays is
"async delay from within abort-deferred region");
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
- Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
- "not enough ATC nesting levels");
+ raise Storage_Error with "not enough ATC nesting levels";
end if;
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
--- used for STPO.Write_Lock
--- Unlock
--- STPO.Get_Priority
--- Sleep
--- Timed_Sleep
-
with System.Tasking.Initialization;
--- used for Change_Base_Priority
--- Defer_Abort/Undefer_Abort
-
with System.Tasking.Protected_Objects.Entries;
--- used for To_Protection
-
with System.Tasking.Protected_Objects.Operations;
--- used for PO_Service_Entries
-
with System.Tasking.Queuing;
--- used for Requeue_Call_With_New_Prio
--- Onqueue
--- Dequeue_Call
-
with System.Tasking.Utilities;
--- used for Exit_One_ATC_Level
-
with System.Parameters;
--- used for Single_Lock
--- Runtime_Traces
-
with System.Traces;
--- used for Send_Trace_Info
package body System.Tasking.Entry_Calls is
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2006, AdaCore --
+-- Copyright (C) 1995-2008, 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- --
-- tasking operations. It causes infinite loops and other problems.
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Self
--- Set_Ceiling
-
with System.Parameters;
--- used for Runtime_Traces
-
with System.Traces;
--- used for Send_Trace_Info
-
with System.Soft_Links.Tasking;
--- Used for Init_Tasking_Soft_Links
package body System.Tasking.Protected_Objects is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 a no tasking version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.Error_Reporting;
--- used for Shutdown
package body System.Task_Primitives.Operations is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 a HP-UX DCE threads (HPUX 10) version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.Tasking.Debug;
--- used for Known_Tasks
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+with Interfaces.C;
+with System.Tasking.Debug;
with System.Interrupt_Management;
--- used for Keep_Unmasked
--- Abort_Task_Interrupt
--- Interrupt_ID
+with System.OS_Primitives;
+with System.Task_Primitives.Interrupt_Operations;
pragma Warnings (Off);
with System.Interrupt_Management.Operations;
--- used for Set_Interrupt_Mask
--- All_Tasks_Mask
pragma Elaborate_All (System.Interrupt_Management.Operations);
-
pragma Warnings (On);
-with System.OS_Primitives;
--- used for Delay_Modes
-
-with Interfaces.C;
--- used for int
--- size_t
-
-with System.Task_Primitives.Interrupt_Operations;
--- used for Get_Interrupt_ID
-
with System.Soft_Links;
--- used for Defer/Undefer_Abort
-
-- We use System.Soft_Links instead of System.Tasking.Initialization
-- because the later is a higher level package that we shouldn't depend on.
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
-
package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 a Solaris (native) version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.Tasking.Debug;
--- used for Known_Tasks
+with Ada.Unchecked_Deallocation;
-with System.Interrupt_Management;
--- used for Keep_Unmasked
--- Abort_Task_Interrupt
--- Interrupt_ID
+with Interfaces.C;
+with System.Tasking.Debug;
+with System.Interrupt_Management;
with System.OS_Primitives;
--- used for Delay_Modes
+with System.Task_Info;
pragma Warnings (Off);
with System.OS_Lib;
--- used for String_Access, Getenv
-
pragma Warnings (On);
-with Interfaces.C;
--- used for int
--- size_t
-
-with System.Task_Info;
--- to initialize Task_Info for a C thread, in function Self
-
with System.Soft_Links;
--- used for Defer/Undefer_Abort
-
-- We use System.Soft_Links instead of System.Tasking.Initialization
-- because the later is a higher level package that we shouldn't depend on.
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Ada.Unchecked_Deallocation;
-
package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 a OpenVMS/Alpha version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.Tasking.Debug;
--- used for Known_Tasks
-
-with System.OS_Primitives;
--- used for Delay_Modes
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Interfaces.C;
--- used for int
--- size_t
+with System.Tasking.Debug;
+with System.OS_Primitives;
with System.Soft_Links;
--- used for Get_Exc_Stack_Addr
--- Abort_Defer/Undefer
-
with System.Aux_DEC;
--- used for Short_Address
-
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
with System.Parameters;
--- used for Size_Type
-
with System.Tasking;
--- used for Task_Id
-
with System.OS_Interface;
--- used for Thread_Id
package System.Task_Primitives.Operations is
pragma Preelaborate;
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2008, 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- --
-- tasking operations. It causes infinite loops and other problems.
with Ada.Exceptions;
--- used for Exception_Occurrence
with System.Task_Primitives.Operations;
--- used for Enter_Task
--- Write_Lock
--- Unlock
--- Wakeup
--- Get_Priority
-
-with System.Soft_Links;
--- used for the non-tasking routines (*_NT) that refer to global data.
--- They are needed here before the tasking run time has been elaborated.
--- used for Create_TSD
--- This package also provides initialization routines for task specific data.
--- The GNARL must call these to be sure that all non-tasking
--- Ada constructs will work.
-
with System.Soft_Links.Tasking;
--- Used for Init_Tasking_Soft_Links
-
with System.Secondary_Stack;
--- used for SS_Init;
-
with System.Storage_Elements;
--- used for Storage_Array;
+
+with System.Soft_Links;
+-- Used for the non-tasking routines (*_NT) that refer to global data. They
+-- are needed here before the tasking run time has been elaborated. used for
+-- Create_TSD This package also provides initialization routines for task
+-- specific data. The GNARL must call these to be sure that all non-tasking
+-- Ada constructs will work.
package body System.Tasking.Restricted.Stages is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- System.Protected_Objects.Single_Entry
with System.Task_Info;
--- used for Task_Info_Type
-
with System.Parameters;
--- used for Size_Type
package System.Tasking.Restricted.Stages is
pragma Elaborate_Body;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram alpha ordering check, since we group soft link
--- bodies and dummy soft link bodies together separately in this unit.
+-- Turn off subprogram alpha ordering check, since we group soft link bodies
+-- and dummy soft link bodies together separately in this unit.
pragma Polling (Off);
--- Turn polling off for this package. We don't need polling during any
--- of the routines in this package, and more to the point, if we try
--- to poll it can cause infinite loops.
+-- Turn polling off for this package. We don't need polling during any of the
+-- routines in this package, and more to the point, if we try to poll it can
+-- cause infinite loops.
with Ada.Exceptions;
--- Used for Exception_Occurrence_Access
with System.Task_Primitives;
--- Used for Lock
-
with System.Task_Primitives.Operations;
--- Used for Set_Priority
--- Write_Lock
--- Unlock
--- Initialize_Lock
-
with System.Soft_Links;
--- Used for the non-tasking routines (*_NT) that refer to global data.
--- They are needed here before the tasking run time has been elaborated.
-
with System.Soft_Links.Tasking;
--- Used for Init_Tasking_Soft_Links
-
with System.Tasking.Debug;
--- Used for Trace
-
with System.Parameters;
--- used for Single_Lock
package body System.Tasking.Initialization is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.Task_Primitives.Operations;
--- used for Self
-
with System.Storage_Elements;
--- Needed for initializing Stack_Info.Size
package body System.Tasking is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions;
--- Used for Exception_Id
--- Exception_Occurrence
+with Ada.Unchecked_Conversion;
with System.Parameters;
--- used for Size_Type
-
with System.Task_Info;
--- used for Task_Info_Type
-
with System.Soft_Links;
--- used for TSD
-
with System.Task_Primitives;
--- used for Private_Data
-
with System.Stack_Usage;
--- used for Stack_Analyzer
-
-with Ada.Unchecked_Conversion;
package System.Tasking is
pragma Preelaborate;
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2007, AdaCore --
+-- Copyright (C) 1997-2008, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with System.Soft_Links;
--- used for Lock_Task, Unlock_Task
package body System.Task_Lock is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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 a no tasking version of this package
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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 package provides low-level support for most tasking features
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2008, 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 a LynxOS version of this package, derived from s-taspri-posix.ads
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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 a NT (native) version of this package
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2008, 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- --
-- Note: this file can only be used for POSIX compliant systems
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 package provides low-level support for most tasking features
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with System.OS_Interface;
--- used for mutex_t
--- cond_t
--- thread_t
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
+with System.OS_Interface;
+
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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 package provides low-level support for most tasking features
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with Interfaces.C;
--- used for int
--- size_t
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2008, 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 package provides low-level support for most tasking features
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with Interfaces.C;
--- used for int
--- size_t
with System.OS_Interface;
--- used for pthread_mutex_t
--- pthread_cond_t
--- pthread_t
package System.Task_Primitives is
pragma Preelaborate;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2006 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2008, 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 a VxWorks version of this package
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.OS_Interface;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 version of the body implements queueing policy according to the
--- policy specified by the pragma Queuing_Policy. When no such pragma
--- is specified FIFO policy is used as default.
+-- This version of the body implements queueing policy according to the policy
+-- specified by the pragma Queuing_Policy. When no such pragma is specified
+-- FIFO policy is used as default.
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
-
with System.Tasking.Initialization;
--- used for Wakeup_Entry_Caller
-
with System.Parameters;
--- used for Single_Lock
package body System.Tasking.Queuing is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
--- used for Get_Priority
--- Set_Priority
--- Write_Lock
--- Unlock
--- Sleep
--- Wakeup
--- Timed_Sleep
-
with System.Tasking.Entry_Calls;
--- Used for Wait_For_Completion
--- Wait_For_Completion_With_Timeout
--- Wait_Until_Abortable
-
with System.Tasking.Initialization;
--- used for Defer_Abort
--- Undefer_Abort
--- Do_Pending_Action
-
with System.Tasking.Queuing;
--- used for Enqueue
--- Dequeue_Head
--- Select_Task_Entry_Call
--- Count_Waiting
-
with System.Tasking.Utilities;
--- used for Check_Exception
--- Make_Passive
--- Wakeup_Entry_Caller
--- Exit_One_ATC_Level
-
with System.Tasking.Protected_Objects.Operations;
--- used for PO_Do_Or_Queue
--- PO_Service_Entries
--- Lock_Entries
-
with System.Tasking.Debug;
--- used for Trace
-
with System.Restrictions;
--- used for Abort_Allowed
-
with System.Parameters;
--- used for Single_Lock
--- Runtime_Traces
-
with System.Traces.Tasking;
--- used for Send_Trace_Info
package body System.Tasking.Rendezvous is
if System.Tasking.Detect_Blocking
and then STPO.Self.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
Call_Synchronous
end if;
Initialization.Undefer_Abort (Self_Id);
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "Entry call not a delay mode");
+ raise Program_Error with "Entry call not a delay mode";
end if;
end case;
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
if Parameters.Runtime_Traces then
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
Initialization.Defer_Abort (Self_Id);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions;
--- Used for, Exception_Id
with System.Tasking.Protected_Objects.Entries;
--- used for Protection_Entries
package System.Tasking.Rendezvous is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
------------------------------------------------------------------------------
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with Ada.Exceptions;
--- Used for Raise_Exception
+with Ada.Unchecked_Deallocation;
with System.Tasking.Debug;
--- Used for enabling tasking facilities with gdb
-
with System.Address_Image;
--- Used for the function itself
-
with System.Task_Primitives.Operations;
--- Used for Finalize_Lock
--- Enter_Task
--- Write_Lock
--- Unlock
--- Sleep
--- Wakeup
--- Get_Priority
--- Lock/Unlock_RTS
--- New_ATCB
-
-with System.Soft_Links;
--- These are procedure pointers to non-tasking routines that use task
--- specific data. In the absence of tasking, these routines refer to global
--- data. In the presense of tasking, they must be replaced with pointers to
--- task-specific versions. Also used for Create_TSD, Destroy_TSD,
--- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
-
-with System.Tasking.Initialization;
--- Used for Remove_From_All_Tasks_List
--- Defer_Abort
--- Undefer_Abort
--- Finalize_Attributes_Link
--- Initialize_Attributes_Link
-
-pragma Elaborate_All (System.Tasking.Initialization);
--- This insures that tasking is initialized if any tasks are created
-
with System.Tasking.Utilities;
--- Used for Make_Passive
--- Abort_One_Task
--- Abort_Tasks
-
with System.Tasking.Queuing;
--- Used for Dequeue_Head
-
with System.Tasking.Rendezvous;
--- Used for Call_Simple
-
with System.OS_Primitives;
--- Used for Delay_Modes
-
with System.Secondary_Stack;
--- Used for SS_Init
-
with System.Storage_Elements;
--- Used for Storage_Array
-
with System.Restrictions;
--- Used for Abort_Allowed
-
with System.Standard_Library;
--- Used for Exception_Trace
-
with System.Traces.Tasking;
--- Used for Send_Trace_Info
+with System.Stack_Usage;
-with Ada.Unchecked_Deallocation;
--- To recover from failure of ATCB initialization
+with System.Soft_Links;
+-- These are procedure pointers to non-tasking routines that use task
+-- specific data. In the absence of tasking, these routines refer to global
+-- data. In the presense of tasking, they must be replaced with pointers to
+-- task-specific versions. Also used for Create_TSD, Destroy_TSD,
+-- Get_Current_Excep, Finalize_Global_List, Task_Termination, Handler.
-with System.Stack_Usage;
+with System.Tasking.Initialization;
+pragma Elaborate_All (System.Tasking.Initialization);
+-- This insures that tasking is initialized if any tasks are created
package body System.Tasking.Stages is
-- This procedure must be called with abort deferred.
procedure Abort_Dependents (Self_ID : Task_Id);
- -- Abort all the direct dependents of Self at its current master
- -- nesting level, plus all of their dependents, transitively.
- -- RTS_Lock should be locked by the caller.
+ -- Abort all the direct dependents of Self at its current master nesting
+ -- level, plus all of their dependents, transitively. RTS_Lock should be
+ -- locked by the caller.
procedure Vulnerable_Free_Task (T : Task_Id);
- -- Recover all runtime system storage associated with the task T.
- -- This should only be called after T has terminated and will no
- -- longer be referenced.
+ -- Recover all runtime system storage associated with the task T. This
+ -- should only be called after T has terminated and will no longer be
+ -- referenced.
--
- -- For tasks created by an allocator that fails, due to an exception,
- -- it is called from Expunge_Unactivated_Tasks.
+ -- For tasks created by an allocator that fails, due to an exception, it is
+ -- called from Expunge_Unactivated_Tasks.
--
- -- It is also called from Ada.Unchecked_Deallocation, for objects that
- -- are or contain tasks.
+ -- It is also called from Ada.Unchecked_Deallocation, for objects that are
+ -- or contain tasks.
--
-- Different code is used at master completion, in Terminate_Dependents,
-- due to a need for tighter synchronization with the master.
-- Activate_Tasks --
--------------------
- -- Note that locks of activator and activated task are both locked
- -- here. This is necessary because C.Common.State and
- -- Self.Common.Wait_Count have to be synchronized. This is safe from
- -- deadlock because the activator is always created before the activated
- -- task. That satisfies our in-order-of-creation ATCB locking policy.
-
- -- At one point, we may also lock the parent, if the parent is
- -- different from the activator. That is also consistent with the
- -- lock ordering policy, since the activator cannot be created
- -- before the parent.
-
- -- Since we are holding both the activator's lock, and Task_Wrapper
- -- locks that before it does anything more than initialize the
- -- low-level ATCB components, it should be safe to wait to update
- -- the counts until we see that the thread creation is successful.
-
- -- If the thread creation fails, we do need to close the entries
- -- of the task. The first phase, of dequeuing calls, only requires
- -- locking the acceptor's ATCB, but the waking up of the callers
- -- requires locking the caller's ATCB. We cannot safely do this
- -- while we are holding other locks. Therefore, the queue-clearing
- -- operation is done in a separate pass over the activation chain.
+ -- Note that locks of activator and activated task are both locked here.
+ -- This is necessary because C.Common.State and Self.Common.Wait_Count have
+ -- to be synchronized. This is safe from deadlock because the activator is
+ -- always created before the activated task. That satisfies our
+ -- in-order-of-creation ATCB locking policy.
+
+ -- At one point, we may also lock the parent, if the parent is different
+ -- from the activator. That is also consistent with the lock ordering
+ -- policy, since the activator cannot be created before the parent.
+
+ -- Since we are holding both the activator's lock, and Task_Wrapper locks
+ -- that before it does anything more than initialize the low-level ATCB
+ -- components, it should be safe to wait to update the counts until we see
+ -- that the thread creation is successful.
+
+ -- If the thread creation fails, we do need to close the entries of the
+ -- task. The first phase, of dequeuing calls, only requires locking the
+ -- acceptor's ATCB, but the waking up of the callers requires locking the
+ -- caller's ATCB. We cannot safely do this while we are holding other
+ -- locks. Therefore, the queue-clearing operation is done in a separate
+ -- pass over the activation chain.
procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
Self_ID : constant Task_Id := STPO.Self;
if System.Tasking.Detect_Blocking
and then Self_ID.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
pragma Debug
All_Elaborated := False;
end if;
- -- Reverse the activation chain so that tasks are
- -- activated in the same order they're declared.
+ -- Reverse the activation chain so that tasks are activated in the
+ -- same order they're declared.
Next_C := C.Common.Activation_Link;
C.Common.Activation_Link := Last_C;
if not All_Elaborated then
Unlock_RTS;
Initialization.Undefer_Abort_Nestable (Self_ID);
- Raise_Exception
- (Program_Error'Identity, "Some tasks have not been elaborated");
+ raise Program_Error with "Some tasks have not been elaborated";
end if;
-- Activate all the tasks in the chain. Creation of the thread of
(C.Common.Compiler_Data.Pri_Stack_Info.Size),
Activate_Prio, Success);
- -- There would be a race between the created task and the
- -- creator to do the following initialization, if we did not
- -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
- -- it from racing ahead.
+ -- There would be a race between the created task and the creator
+ -- to do the following initialization, if we did not have a
+ -- Lock/Unlock_RTS pair in the task wrapper to prevent it from
+ -- racing ahead.
if Success then
C.Common.State := Runnable;
Unlock_RTS;
end if;
- -- Close the entries of any tasks that failed thread creation,
- -- and count those that have not finished activation.
+ -- Close the entries of any tasks that failed thread creation, and count
+ -- those that have not finished activation.
Write_Lock (Self_ID);
Self_ID.Common.State := Activator_Sleep;
if Self_ID.Common.Activation_Failed then
Self_ID.Common.Activation_Failed := False;
- Raise_Exception (Tasking_Error'Identity,
- "Failure during activation");
+ raise Tasking_Error with "Failure during activation";
end if;
end Activate_Tasks;
-- Create_Task --
-----------------
- -- Compiler interface only. Do not call from within the RTS.
- -- This must be called to create a new task.
+ -- Compiler interface only. Do not call from within the RTS. This must be
+ -- called to create a new task.
procedure Create_Task
(Priority : Integer;
"create task after awaiting termination";
end if;
- -- If pragma Detect_Blocking is active must be checked whether
- -- this potentially blocking operation is called from a
- -- protected action.
+ -- If pragma Detect_Blocking is active must be checked whether this
+ -- potentially blocking operation is called from a protected action.
if System.Tasking.Detect_Blocking
and then Self_ID.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
pragma Debug
exception
when others =>
Initialization.Undefer_Abort_Nestable (Self_ID);
- Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
+ raise Storage_Error with "Cannot allocate task";
end;
- -- RTS_Lock is used by Abort_Dependents and Abort_Tasks.
- -- Up to this point, it is possible that we may be part of
- -- a family of tasks that is being aborted.
+ -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
+ -- point, it is possible that we may be part of a family of tasks that
+ -- is being aborted.
Lock_RTS;
Write_Lock (Self_ID);
- -- Now, we must check that we have not been aborted.
- -- If so, we should give up on creating this task,
- -- and simply return.
+ -- Now, we must check that we have not been aborted. If so, we should
+ -- give up on creating this task, and simply return.
if not Self_ID.Callable then
pragma Assert (Self_ID.Pending_ATC_Level = 0);
Unlock (Self_ID);
Unlock_RTS;
Initialization.Undefer_Abort_Nestable (Self_ID);
- Raise_Exception
- (Storage_Error'Identity, "Failed to initialize task");
+ raise Storage_Error with "Failed to initialize task";
end if;
if Master = Foreign_Task_Level + 2 then
Initialization.Defer_Abort_Nestable (Self_ID);
-- ???
- -- Experimentation has shown that abort is sometimes (but not
- -- always) already deferred when this is called.
+ -- Experimentation has shown that abort is sometimes (but not always)
+ -- already deferred when this is called.
-- That may indicate an error. Find out what is going on
---------------------------
-- ???
- -- We have a potential problem here if finalization of global
- -- objects does anything with signals or the timer server, since
- -- by that time those servers have terminated.
+ -- We have a potential problem here if finalization of global objects does
+ -- anything with signals or the timer server, since by that time those
+ -- servers have terminated.
-- It is hard to see how that would occur
begin
if Self_ID.Deferral_Level = 0 then
-- ???
- -- In principle, we should be able to predict whether
- -- abort is already deferred here (and it should not be deferred
- -- yet but in practice it seems Finalize_Global_Tasks is being
- -- called sometimes, from RTS code for exceptions, with abort already
- -- deferred.
+ -- In principle, we should be able to predict whether abort is
+ -- already deferred here (and it should not be deferred yet but in
+ -- practice it seems Finalize_Global_Tasks is being called sometimes,
+ -- from RTS code for exceptions, with abort already deferred.
Initialization.Defer_Abort_Nestable (Self_ID);
end if;
-- We need to explicitely wait for the task to be terminated here
- -- because on true concurrent system, we may end this procedure
- -- before the tasks are really terminated.
+ -- because on true concurrent system, we may end this procedure before
+ -- the tasks are really terminated.
Write_Lock (Self_ID);
loop
exit when Utilities.Independent_Task_Count = 0;
- -- We used to yield here, but this did not take into account
- -- low priority tasks that would cause dead lock in some cases
- -- (true FIFO scheduling).
+ -- We used to yield here, but this did not take into account low
+ -- priority tasks that would cause dead lock in some cases (true
+ -- FIFO scheduling).
Timed_Sleep
(Self_ID, 0.01, System.OS_Primitives.Relative,
Stack_Guard (Self_ID, True);
- -- Initialize low-level TCB components, that cannot be initialized
- -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
- -- also Self_ID.LL.Thread
+ -- Initialize low-level TCB components, that cannot be initialized by
+ -- the creator. Enter_Task sets Self_ID.Known_Tasks_Index and also
+ -- Self_ID.LL.Thread
Enter_Task (Self_ID);
Cause := Abnormal;
end if;
when others =>
- -- ??? Using an E : others here causes CD2C11A to fail on Tru64.
+ -- ??? Using an E : others here causes CD2C11A to fail on Tru64
Initialization.Defer_Abort_Nestable (Self_ID);
-- Terminate_Task --
--------------------
- -- Before we allow the thread to exit, we must clean up. This is a
- -- a delicate job. We must wake up the task's master, who may immediately
- -- try to deallocate the ATCB out from under the current task WHILE IT IS
- -- STILL EXECUTING.
+ -- Before we allow the thread to exit, we must clean up. This is a a
+ -- delicate job. We must wake up the task's master, who may immediately try
+ -- to deallocate the ATCB out from under the current task WHILE IT IS STILL
+ -- EXECUTING.
-- To avoid this, the parent task must be blocked up to the latest
-- statement executed. The trouble is that we have another step that we
SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
Initialization.Final_Task_Unlock (Self_ID);
- -- WARNING: past this point, this thread must assume that the ATCB
- -- has been deallocated. It should not be accessed again.
+ -- WARNING: past this point, this thread must assume that the ATCB has
+ -- been deallocated. It should not be accessed again.
if Master_of_Task > 0 then
STPO.Exit_Task;
Unlock (Self_ID);
Unlock (Activator);
- -- After the activation, active priority should be the same
- -- as base priority. We must unlock the Activator first,
- -- though, since it should not wait if we have lower priority.
+ -- After the activation, active priority should be the same as base
+ -- priority. We must unlock the Activator first, though, since it
+ -- should not wait if we have lower priority.
if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
Write_Lock (Self_ID);
(Self_ID.Deferral_Level > 0
or else not System.Restrictions.Abort_Allowed);
- -- Count how many active dependent tasks this master currently
- -- has, and record this in Wait_Count.
+ -- Count how many active dependent tasks this master currently has, and
+ -- record this in Wait_Count.
- -- This count should start at zero, since it is initialized to
- -- zero for new tasks, and the task should not exit the
- -- sleep-loops that use this count until the count reaches zero.
+ -- This count should start at zero, since it is initialized to zero for
+ -- new tasks, and the task should not exit the sleep-loops that use this
+ -- count until the count reaches zero.
-- While we're counting, if we run across any unactivated tasks that
-- belong to this master, we summarily terminate them as required by
-- Terminate unactivated (never-to-be activated) tasks
if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
+
pragma Assert (C.Common.State = Unactivated);
-- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
-- = CM. The only case where C is pending activation by this
-- Wait until dependent tasks are all terminated or ready to terminate.
-- While waiting, the task may be awakened if the task's priority needs
- -- changing, or this master is aborted. In the latter case, we want
- -- to abort the dependents, and resume waiting until Wait_Count goes
- -- to zero.
+ -- changing, or this master is aborted. In the latter case, we abort the
+ -- dependents, and resume waiting until Wait_Count goes to zero.
Write_Lock (Self_ID);
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
- -- Dependents are all terminated or on terminate alternatives.
- -- Now, force those on terminate alternatives to terminate, by
- -- aborting them.
+ -- Dependents are all terminated or on terminate alternatives. Now,
+ -- force those on terminate alternatives to terminate, by aborting them.
pragma Assert (Check_Unactivated_Tasks);
-- rules prevent us from doing that without releasing the locks on C
-- and Self_ID. Releasing and retaking those locks would be wasteful
-- at best, and should not be considered further without more
- -- detailed analysis of potential concurrent accesses to the
- -- ATCBs of C and Self_ID.
+ -- detailed analysis of potential concurrent accesses to the ATCBs
+ -- of C and Self_ID.
- -- Count how many "alive" dependent tasks this master currently
- -- has, and record this in Wait_Count. This count should start at
- -- zero, since it is initialized to zero for new tasks, and the
- -- task should not exit the sleep-loops that use this count until
- -- the count reaches zero.
+ -- Count how many "alive" dependent tasks this master currently has,
+ -- and record this in Wait_Count. This count should start at zero,
+ -- since it is initialized to zero for new tasks, and the task should
+ -- not exit the sleep-loops that use this count until the count
+ -- reaches zero.
pragma Assert (Self_ID.Common.Wait_Count = 0);
-- fast as we can, so there is no point.
-- Remove terminated tasks from the list of Self_ID's dependents, but
- -- don't free their ATCBs yet, because of lock order restrictions,
- -- which don't allow us to call "free" or "malloc" while holding any
- -- other locks. Instead, we put those ATCBs to be freed onto a
- -- temporary list, called To_Be_Freed.
+ -- don't free their ATCBs yet, because of lock order restrictions, which
+ -- don't allow us to call "free" or "malloc" while holding any other
+ -- locks. Instead, we put those ATCBs to be freed onto a temporary list,
+ -- called To_Be_Freed.
if not Single_Lock then
Lock_RTS;
-- ???
-- The check "T.Common.Parent /= null ..." below is to prevent dangling
- -- references to terminated library-level tasks, which could
- -- otherwise occur during finalization of library-level objects.
- -- A better solution might be to hook task objects into the
- -- finalization chain and deallocate the ATCB when the task
- -- object is deallocated. However, this change is not likely
- -- to gain anything significant, since all this storage should
- -- be recovered en-masse when the process exits.
+ -- references to terminated library-level tasks, which could otherwise
+ -- occur during finalization of library-level objects. A better solution
+ -- might be to hook task objects into the finalization chain and
+ -- deallocate the ATCB when the task object is deallocated. However,
+ -- this change is not likely to gain anything significant, since all
+ -- this storage should be recovered en-masse when the process exits.
while To_Be_Freed /= null loop
T := To_Be_Freed;
-- ATCB. That would not cover the case of unactivated tasks. It also
-- would force us to keep the underlying thread around past termination,
-- since references to the ATCB are possible past termination.
+
-- Currently, we get rid of the thread as soon as the task terminates,
-- and let the parent recover the ATCB later.
-- that no longer have ATCBs. It is not clear how much this would gain,
-- since the user-level task object would still be occupying storage.
- -- Make next master level up active.
- -- We don't need to lock the ATCB, since the value is only updated by
- -- each task for itself.
+ -- Make next master level up active. We don't need to lock the ATCB,
+ -- since the value is only updated by each task for itself.
Self_ID.Master_Within := CM - 1;
end Vulnerable_Complete_Master;
Unlock_RTS;
end if;
- -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
- -- we may have dependent tasks for which we need to wait.
- -- Otherwise, we can just exit.
+ -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have
+ -- dependent tasks for which we need to wait. Otherwise we just exit.
if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
Vulnerable_Complete_Master (Self_ID);
-- Vulnerable_Free_Task --
--------------------------
- -- Recover all runtime system storage associated with the task T.
- -- This should only be called after T has terminated and will no
- -- longer be referenced.
+ -- Recover all runtime system storage associated with the task T. This
+ -- should only be called after T has terminated and will no longer be
+ -- referenced.
- -- For tasks created by an allocator that fails, due to an exception,
- -- it is called from Expunge_Unactivated_Tasks.
+ -- For tasks created by an allocator that fails, due to an exception, it
+ -- is called from Expunge_Unactivated_Tasks.
- -- For tasks created by elaboration of task object declarations it
- -- is called from the finalization code of the Task_Wrapper procedure.
- -- It is also called from Ada.Unchecked_Deallocation, for objects that
- -- are or contain tasks.
+ -- For tasks created by elaboration of task object declarations it is
+ -- called from the finalization code of the Task_Wrapper procedure. It is
+ -- also called from Ada.Unchecked_Deallocation, for objects that are or
+ -- contain tasks.
procedure Vulnerable_Free_Task (T : Task_Id) is
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Note: Only the compiler is allowed to use this interface, by generating
-- direct calls to it, via Rtsfind.
+
-- Any changes to this interface may require corresponding compiler changes
-- in exp_ch9.adb and possibly exp_ch7.adb
with System.Task_Info;
--- used for Task_Info_Type
-
with System.Parameters;
--- used for Size_Type
package System.Tasking.Stages is
pragma Elaborate_Body;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 package provides RTS Internal Declarations.
+-- This package provides RTS Internal Declarations
+
-- These declarations are not part of the GNARLI
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with System.Tasking.Debug;
--- used for Known_Tasks
-
with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Wakeup
--- Unlock
--- Sleep
--- Abort_Task
--- Lock/Unlock_RTS
-
with System.Tasking.Initialization;
--- Used for Defer_Abort
--- Undefer_Abort
--- Locked_Abort_To_Level
-
with System.Tasking.Queuing;
--- used for Dequeue_Call
--- Dequeue_Head
-
with System.Parameters;
--- used for Single_Lock
--- Runtime_Traces
-
with System.Traces.Tasking;
--- used for Send_Trace_Info
package body System.Tasking.Utilities is
if System.Tasking.Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
Initialization.Defer_Abort_Nestable (Self_Id);
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, AdaCore --
+-- Copyright (C) 1995-2008, 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- --
-- --
------------------------------------------------------------------------------
-with System.Task_Primitives.Operations;
--- used for Write_Lock
--- Unlock
--- Lock/Unlock_RTS
+with Ada.Unchecked_Conversion;
+with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
--- used for Defer_Abort
--- Undefer_Abort
-
-with Ada.Unchecked_Conversion;
package body System.Tasking.Task_Attributes is
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, AdaCore --
+-- Copyright (C) 1995-2008, 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 package provides support for the body of Ada.Task_Attributes
with Ada.Finalization;
--- Used for Limited_Controlled
with System.Storage_Elements;
--- Used for Integer_Address
package System.Tasking.Task_Attributes is
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- E N T R I E S --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
-- --
--- B o d y --
+-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, 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- --
-- Note: the compiler generates direct calls to this interface, via Rtsfind
-with Ada.Exceptions;
--- Used for Exception_Occurrence_Access
--- Raise_Exception
-
with System.Task_Primitives.Operations;
--- Used for Initialize_Lock
--- Write_Lock
--- Unlock
--- Get_Priority
--- Wakeup
--- Set_Ceiling
+with System.Restrictions;
+with System.Parameters;
with System.Tasking.Initialization;
--- Used for Defer_Abort,
--- Undefer_Abort,
--- Change_Base_Priority
-
pragma Elaborate_All (System.Tasking.Initialization);
--- This insures that tasking is initialized if any protected objects are
--- created.
-
-with System.Restrictions;
--- Used for Abort_Allowed
-
-with System.Parameters;
--- Used for Single_Lock
+-- To insure that tasking is initialized if any protected objects are created
package body System.Tasking.Protected_Objects.Entries is
use Parameters;
use Task_Primitives.Operations;
- use Ada.Exceptions;
----------------
-- Local Data --
STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
if Ceiling_Violation then
- Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ raise Program_Error with "Ceiling Violation";
end if;
if Single_Lock then
is
begin
if Object.Finalized then
- Raise_Exception
- (Program_Error'Identity, "Protected Object is finalized");
+ raise Program_Error with "Protected Object is finalized";
end if;
-- If pragma Detect_Blocking is active then, as described in the ARM
Lock_Entries (Object, Ceiling_Violation);
if Ceiling_Violation then
- Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ raise Program_Error with "Ceiling Violation";
end if;
end Lock_Entries;
begin
if Object.Finalized then
- Raise_Exception
- (Program_Error'Identity, "Protected Object is finalized");
+ raise Program_Error with "Protected Object is finalized";
end if;
-- If pragma Detect_Blocking is active then, as described in the ARM
Read_Lock (Object.L'Access, Ceiling_Violation);
if Ceiling_Violation then
- Raise_Exception (Program_Error'Identity, "Ceiling Violation");
+ raise Program_Error with "Ceiling Violation";
end if;
-- We are entering in a protected action, so that we increase the
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- E N T R I E S --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 package contains all the simple primitives related to
--- Protected_Objects with entries (i.e init, lock, unlock).
+-- This package contains all simple primitives related to Protected_Objects
+-- with entries (i.e init, lock, unlock).
+
-- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the complex routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Operations.
+
-- The split between Entries and Operations is needed to break circular
-- dependencies inside the run time.
-- Any changes to this interface may require corresponding compiler changes.
with Ada.Finalization;
--- used for Limited_Controlled
-
with Ada.Unchecked_Conversion;
package System.Tasking.Protected_Objects.Entries is
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- O P E R A T I O N S --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, 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 package contains all the extended primitives related to
--- Protected_Objects with entries.
+-- This package contains all extended primitives related to Protected_Objects
+-- with entries.
-- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the simple routines for protected
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
with System.Task_Primitives.Operations;
--- used for Initialize_Lock
--- Write_Lock
--- Unlock
--- Get_Priority
--- Wakeup
-
with System.Tasking.Entry_Calls;
--- used for Wait_For_Completion
--- Wait_Until_Abortable
--- Wait_For_Completion_With_Timeout
-
-with System.Tasking.Initialization;
--- Used for Defer_Abort,
--- Undefer_Abort,
--- Change_Base_Priority
-
-pragma Elaborate_All (System.Tasking.Initialization);
--- This insures that tasking is initialized if any protected objects are
--- created.
-
with System.Tasking.Queuing;
--- used for Enqueue
--- Broadcast_Program_Error
--- Select_Protected_Entry_Call
--- Onqueue
--- Count_Waiting
-
with System.Tasking.Rendezvous;
--- used for Task_Do_Or_Queue
-
with System.Tasking.Utilities;
--- used for Exit_One_ATC_Level
-
with System.Tasking.Debug;
--- used for Trace
-
with System.Parameters;
--- used for Single_Lock
--- Runtime_Traces
-
with System.Traces.Tasking;
--- used for Send_Trace_Info
-
with System.Restrictions;
--- used for Run_Time_Restrictions
+
+with System.Tasking.Initialization;
+pragma Elaborate_All (System.Tasking.Initialization);
+-- Insures that tasking is initialized if any protected objects are created
package body System.Tasking.Protected_Objects.Operations is
end if;
if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
- Raise_Exception
- (Storage_Error'Identity, "not enough ATC nesting levels");
+ raise Storage_Error with "not enough ATC nesting levels";
end if;
-- If pragma Detect_Blocking is active then Program_Error must be
if Detect_Blocking
and then Self_ID.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
-- Self_ID.Deferral_Level should be 0, except when called from Finalize,
begin
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
- Raise_Exception (Storage_Error'Identity,
- "not enough ATC nesting levels");
+ raise Storage_Error with "not enough ATC nesting levels";
end if;
-- If pragma Detect_Blocking is active then Program_Error must be
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
if Runtime_Traces then
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- O P E R A T I O N S --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
-- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions;
--- Used for Exception_Id
with System.Tasking.Protected_Objects.Entries;
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- S I N G L E _ E N T R Y --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2008, 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- --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram ordering check, since restricted GNARLI
--- subprograms are gathered together at end.
+-- Turn off subprogram ordering check, since restricted GNARLI subprograms are
+-- gathered together at end.
-- This package provides an optimized version of Protected_Objects.Operations
-- and Protected_Objects.Entries making the following assumptions:
-- operations. It can cause infinite loops and other problems.
pragma Suppress (All_Checks);
-
-with System.Task_Primitives.Operations;
--- used for Self
--- Finalize_Lock
--- Write_Lock
--- Unlock
+-- Why is this required ???
with Ada.Exceptions;
--- used for Exception_Id
--- Raise_Exception
+with System.Task_Primitives.Operations;
with System.Parameters;
--- used for Single_Lock
package body System.Tasking.Protected_Objects.Single_Entry is
use type Ada.Exceptions.Exception_Id;
E : constant Ada.Exceptions.Exception_Id :=
- Entry_Call.Exception_To_Raise;
+ Entry_Call.Exception_To_Raise;
begin
if E /= Ada.Exceptions.Null_Id then
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
Lock_Entry (Object);
if Detect_Blocking
and then Self_Id.Common.Protected_Action_Nesting > 0
then
- Ada.Exceptions.Raise_Exception
- (Program_Error'Identity, "potentially blocking operation");
+ raise Program_Error with "potentially blocking operation";
end if;
STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- S I N G L E _ E N T R Y --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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 package provides an optimized version of Protected_Objects.Operations
-- and Protected_Objects.Entries making the following assumptions:
--
--- PO have only one entry
--- There is only one caller at a time (No_Entry_Queue)
--- There is no dynamic priority support (No_Dynamic_Priorities)
--- No Abort Statements
--- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
--- PO are at library level
--- None of the tasks will terminate (no need for finalization)
+-- PO have only one entry
+-- There is only one caller at a time (No_Entry_Queue)
+-- There is no dynamic priority support (No_Dynamic_Priorities)
+-- No Abort Statements
+-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
+-- PO are at library level
+-- None of the tasks will terminate (no need for finalization)
--
-- This interface is intended to be used in the ravenscar profile, the
-- compiler is responsible for ensuring that the conditions mentioned above
function Protected_Count_Entry (Object : Protection_Entry)
return Natural;
- -- Return the number of entry calls on Object (0 or 1).
+ -- Return the number of entry calls on Object (0 or 1)
function Protected_Single_Entry_Caller (Object : Protection_Entry)
return Task_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
P : Integer;
-- Local copy of string pointer
- Base : Long_Long_Float;
+ Base : Long_Long_Float;
-- Base value
Uval : Long_Long_Float;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
S (J) := To_Upper (S (J));
end loop;
end if;
-
end Normalize_String;
-------------------
Ptr.all := P;
return X;
-
end Scan_Exponent;
--------------------
projects / gcc.git / commitdiff