Skip to content

R
riscv-gcc-1
Commit 1a49cf99 by Arnaud Charlet
Options

[multiple changes] 

2005-03-08  Robert Dewar  <dewar@adacore.com>

	* s-bitops.adb, s-bitops.ads,
	s-taprop-os2.adb, s-intman-vms.ads, s-intman-vxworks.ads,
	s-taprop-vxworks.adb, a-caldel.ads, a-calend.adb, a-tasatt.adb,
	tbuild.ads, s-finimp.adb, s-imgwch.adb, s-intman.ads, s-intman.ads,
	s-memory.adb, s-soflin.ads, s-taasde.ads, s-taprob.adb, s-taprop.ads,
	s-taprop.ads, s-tasini.adb, s-tasini.ads, s-tasini.ads, s-tasini.ads,
	s-taskin.ads, s-tasren.adb, s-tassta.adb, s-tassta.ads, s-tassta.ads,
	s-tasuti.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads,
	s-tpoben.adb, s-tpoben.adb, s-tpobop.ads: Update comments. Minor
	reformatting.

2005-03-08  Eric Botcazou  <ebotcazou@adacore.com>

	* utils2.c (build_binary_op): Fix typo.

2005-03-08  Doug Rupp  <rupp@adacore.com>

	* s-crtl.ads (popen,pclose): New imports.

2005-03-08  Cyrille Comar  <comar@adacore.com>

	* comperr.adb (Compiler_Abort): remove references to obsolete
	procedures in the bug boxes for various GNAT builds.

2005-03-08  Vincent Celier  <celier@adacore.com>

	* snames.ads, snames.adb: Save as Unix text file, not as DOS text file

From-SVN: r96512
parent 728c3084
Showing with 476 additions and 496 deletions
gcc/ada/a-caldel.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -39,18 +39,17 @@ ...@@ -39,18 +39,17 @@
package Ada.Calendar.Delays is package Ada.Calendar.Delays is
procedure Delay_For (D : Duration); procedure Delay_For (D : Duration);
-- Delay until an interval of length (at least) D seconds has passed, -- Delay until an interval of length (at least) D seconds has passed, or
-- or the task is aborted to at least the current ATC nesting level. -- the task is aborted to at least the current ATC nesting level. This is
-- This is an abort completion point. -- an abort completion point. The body of this procedure must perform all
-- The body of this procedure must perform all the processing -- the processing required for an abort point.
-- required for an abortion point.
procedure Delay_Until (T : Time); procedure Delay_Until (T : Time);
-- Delay until Clock has reached (at least) time T, -- Delay until Clock has reached (at least) time T, or the task is aborted
-- or the task is aborted to at least the current ATC nesting level. -- to at least the current ATC nesting level. The body of this procedure
-- The body of this procedure must perform all the processing -- must perform all the processing required for an abort point.
-- required for an abortion point.
function To_Duration (T : Time) return Duration; function To_Duration (T : Time) return Duration;
-- Convert Time to Duration
end Ada.Calendar.Delays; end Ada.Calendar.Delays;
gcc/ada/comperr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. -- -- MA 02111-1307, USA. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by AdaCore. --
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
...@@ -78,7 +78,7 @@ package body Comperr is ...@@ -78,7 +78,7 @@ package body Comperr is
-- the cause of the compiler abort and about the preferred method -- the cause of the compiler abort and about the preferred method
-- of reporting bugs. The default is a bug box appropriate for -- of reporting bugs. The default is a bug box appropriate for
-- the FSF version of GNAT, but there are specializations for -- the FSF version of GNAT, but there are specializations for
-- the GNATPRO and Public releases by Ada Core Technologies. -- the GNATPRO and Public releases by AdaCore.
procedure End_Line; procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar -- Add blanks up to column 76, and then a final vertical bar
...@@ -95,7 +95,6 @@ package body Comperr is ...@@ -95,7 +95,6 @@ package body Comperr is
Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public; Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF; Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF;
Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
-- Start of processing for Compiler_Abort -- Start of processing for Compiler_Abort
...@@ -268,22 +267,43 @@ package body Comperr is ...@@ -268,22 +267,43 @@ package body Comperr is
" http://gcc.gnu.org/bugs.html."); " http://gcc.gnu.org/bugs.html.");
End_Line; End_Line;
elsif Is_Public_Version then
Write_Str
("| submit bug report by email " &
"to report@adacore.com.");
End_Line;
Write_Str
("| See gnatinfo.txt for full info on procedure " &
"for submitting bugs.");
End_Line;
else else
Write_Str Write_Str
("| Please submit bug report by email " & ("| Please submit a bug report using GNAT Tracker:");
"to report@gnat.com.");
End_Line; End_Line;
Write_Str Write_Str
("| Use a subject line meaningful to you" & ("| http://www.adacore.com/gnattracker/ " &
" and us to track the bug."); "section 'send a report'.");
End_Line;
Write_Str
("| alternatively submit a bug report by email " &
"to report@adacore.com.");
End_Line; End_Line;
end if; end if;
Write_Str
("| Use a subject line meaningful to you" &
" and us to track the bug.");
End_Line;
if not (Is_Public_Version or Is_FSF_Version) then if not (Is_Public_Version or Is_FSF_Version) then
Write_Str Write_Str
("| (include your customer number #nnn " & ("| Include your customer number #nnn " &
"in the subject line)."); "in the subject line.");
End_Line; End_Line;
end if; end if;
...@@ -305,35 +325,9 @@ package body Comperr is ...@@ -305,35 +325,9 @@ package body Comperr is
("| (concatenated together with no headers between files)."); ("| (concatenated together with no headers between files).");
End_Line; End_Line;
if Is_Public_Version then if not Is_FSF_Version then
Write_Str Write_Str
("| (use plain ASCII or MIME attachment)."); ("| Use plain ASCII or MIME attachment.");
End_Line;
Write_Str
("| See gnatinfo.txt for full info on procedure " &
"for submitting bugs.");
End_Line;
elsif Is_GAP_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your GAP account.).");
End_Line;
Write_Str
("| Please use your GAP account to report this.");
End_Line;
elsif not Is_FSF_Version then
Write_Str
("| (use plain ASCII or MIME attachment, or FTP "
& "to your customer directory).");
End_Line;
Write_Str
("| See README.GNATPRO for full info on procedure " &
"for submitting bugs.");
End_Line; End_Line;
end if; end if;
end if; end if;
......
gcc/ada/s-bitops.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1996-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -107,8 +107,7 @@ package body System.Bit_Ops is ...@@ -107,8 +107,7 @@ package body System.Bit_Ops is
(Left : Address; (Left : Address;
Llen : Natural; Llen : Natural;
Right : Address; Right : Address;
Rlen : Natural) Rlen : Natural) return Boolean
return Boolean
is is
LeftB : constant Bits := To_Bits (Left); LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right); RightB : constant Bits := To_Bits (Right);
......
gcc/ada/s-bitops.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,7 +40,8 @@ package System.Bit_Ops is ...@@ -40,7 +40,8 @@ package System.Bit_Ops is
-- Note: in all the following routines, the System.Address parameters -- Note: in all the following routines, the System.Address parameters
-- represent the address of the first byte of an array used to represent -- represent the address of the first byte of an array used to represent
-- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4}) -- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4})
-- The length in bits is passed as a separate parameter. -- The length in bits is passed as a separate parameter. Note that all
-- addresses must be of byte aligned arrays.
procedure Bit_And procedure Bit_And
(Left : System.Address; (Left : System.Address;
...@@ -57,8 +58,7 @@ package System.Bit_Ops is ...@@ -57,8 +58,7 @@ package System.Bit_Ops is
(Left : System.Address; (Left : System.Address;
Llen : Natural; Llen : Natural;
Right : System.Address; Right : System.Address;
Rlen : Natural) Rlen : Natural) return Boolean;
return Boolean;
-- Left and Right are the addresses of two bit packed arrays with Llen -- Left and Right are the addresses of two bit packed arrays with Llen
-- and Rlen being the respective length in bits. The routine compares the -- and Rlen being the respective length in bits. The routine compares the
-- two bit strings for equality, being careful not to include the unused -- two bit strings for equality, being careful not to include the unused
......
gcc/ada/s-crtl.ads
...@@ -139,6 +139,12 @@ pragma Preelaborate (CRTL); ...@@ -139,6 +139,12 @@ pragma Preelaborate (CRTL);
function opendir (file_name : String) return DIRs; function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "opendir"); pragma Import (C, opendir, "opendir");
function pclose (stream : System.Address) return int;
pragma Import (C, pclose, "pclose");
function popen (command, mode : System.Address) return System.Address;
pragma Import (C, popen, "popen");
function read (fd : int; buffer : chars; nbytes : int) return int; function read (fd : int; buffer : chars; nbytes : int) return int;
pragma Import (C, read, "read"); pragma Import (C, read, "read");
......
gcc/ada/s-finimp.adb
...@@ -383,19 +383,22 @@ package body System.Finalization_Implementation is ...@@ -383,19 +383,22 @@ package body System.Finalization_Implementation is
procedure Finalize_Global_List is procedure Finalize_Global_List is
begin begin
-- There are three case here: -- There are three case here:
-- a. the application uses tasks, in which case Finalize_Global_Tasks -- a. the application uses tasks, in which case Finalize_Global_Tasks
-- will defer abortion -- will defer abort.
-- b. the application doesn't use tasks but uses other tasking -- b. the application doesn't use tasks but uses other tasking
-- constructs, such as ATCs and protected objects. In this case, -- constructs, such as ATCs and protected objects. In this case,
-- the binder will call Finalize_Global_List instead of -- the binder will call Finalize_Global_List instead of
-- Finalize_Global_Tasks, letting abort undeferred, and leading -- Finalize_Global_Tasks, letting abort undeferred, and leading
-- to assertion failures in the GNULL -- to assertion failures in the GNULL
-- c. the application doesn't use any tasking construct in which case -- c. the application doesn't use any tasking construct in which case
-- deferring abort isn't necessary. -- deferring abort isn't necessary.
--
-- Until another solution is found to deal with case b, we need to -- Until another solution is found to deal with case b, we need to
-- call abort_defer here to pass the checks, but we do not need to -- call abort_defer here to pass the checks, but we do not need to
-- undefer abortion, since Finalize_Global_List is the last procedure -- undefer abort, since Finalize_Global_List is the last procedure
-- called before exiting the partition. -- called before exiting the partition.
SSL.Abort_Defer.all; SSL.Abort_Defer.all;
......
gcc/ada/s-intman-vms.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,30 +31,31 @@ ...@@ -31,30 +31,31 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is the Alpha/VMS version of this package. -- This is the Alpha/VMS version of this package
--
-- This package encapsulates and centralizes information about
-- all uses of interrupts (or signals), including the
-- target-dependent mapping of interrupts (or signals) to exceptions.
-- PLEASE DO NOT add any with-clauses to this package. -- This package encapsulates and centralizes information about all uses of
-- This is designed to work for both tasking and non-tasking systems, -- interrupts (or signals), including the target-dependent mapping of
-- without pulling in any of the tasking support. -- interrupts (or signals) to exceptions.
-- PLEASE DO NOT add any with-clauses to this package
-- This is designed to work for both tasking and non-tasking systems, without
-- pulling in any of the tasking support.
-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. -- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
-- Elaboration of this package should happen early, as most other -- Elaboration of this package should happen early, as most other
-- initializations depend on it.
-- Forcing immediate elaboration of the body also helps to enforce -- Forcing immediate elaboration of the body also helps to enforce the design
-- the design assumption that this is a second-level -- assumption that this is a second-level package, just one level above
-- package, just one level above System.OS_Interface, with no -- System.OS_Interface, with no cross-dependences.
-- cross-dependences.
-- PLEASE DO NOT put any subprogram declarations with arguments of type
-- PLEASE DO NOT put any subprogram declarations with arguments of -- Interrupt_ID into the visible part of this package.
-- type Interrupt_ID into the visible part of this package.
-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, -- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and
-- and adding more operations to that type would be illegal according -- adding more operations to that type would be illegal according to the Ada
-- to the Ada Reference Manual. (This is the reason why the signals sets -- Reference Manual. (This is the reason why the signals sets below are
-- below are implemented as visible arrays rather than functions.) -- implemented as visible arrays rather than functions.)
with System.OS_Interface; with System.OS_Interface;
-- used for Signal -- used for Signal
...@@ -70,49 +71,44 @@ package System.Interrupt_Management is ...@@ -70,49 +71,44 @@ package System.Interrupt_Management is
type Interrupt_Set is array (Interrupt_ID) of Boolean; type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized -- The following objects serve as constants, but are initialized in the
-- in the body to aid portability. This permits us -- body to aid portability. This permits us to use more portable names for
-- to use more portable names for interrupts, -- interrupts, where distinct names may map to the same interrupt ID
-- where distinct names may map to the same interrupt ID value. -- value. For example, suppose SIGRARE is a signal that is not defined on
-- For example, suppose SIGRARE is a signal that is not defined on -- all systems, but is always reserved when it is defined. If we have the
-- all systems, but is always reserved when it is defined. -- convention that ID zero is not used for any "real" signals, and SIGRARE
-- If we have the convention that ID zero is not used for any "real" -- = 0 when SIGRARE is not one of the locally supported signals, we can
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally -- write
-- supported signals, we can write
-- Reserved (SIGRARE) := true; -- Reserved (SIGRARE) := true;
-- and the initialization code will be portable.
-- Then the initialization code will be portable
Abort_Task_Interrupt : Interrupt_ID; Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abortion, -- The interrupt that is used to implement task abort, if an interrupt is
-- if an interrupt is used for that purpose. -- used for that purpose. This is one of the reserved interrupts.
-- This is one of the reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False); Keep_Unmasked : Interrupt_Set := (others => False);
-- Keep_Unmasked (I) is true iff the interrupt I is -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept
-- one that must be kept unmasked at all times, -- unmasked at all times, except (perhaps) for short critical sections.
-- except (perhaps) for short critical sections. -- This includes interrupts that are mapped to exceptions (see
-- This includes interrupts that are mapped to exceptions -- System.Interrupt_Exceptions.Is_Exception), but may also include
-- (see System.Interrupt_Exceptions.Is_Exception), but may also -- interrupts (e.g. timer) that need to be kept unmasked for other
-- include interrupts (e.g. timer) that need to be kept unmasked -- reasons. Where interrupts are implemented as OS signals, and signal
-- for other reasons. -- masking is per-task, the interrupt should be unmasked in ALL TASKS.
-- Where interrupts are implemented as OS signals, and signal masking
-- is per-task, the interrupt should be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False); Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- cannot be permitted to be attached to a user handler. -- to be attached to a user handler. The possible reasons are many. For
-- The possible reasons are many. For example, -- example it may be mapped to an exception used to implement task abort.
-- it may be mapped to an exception, used to implement task abortion,
-- or used to implement time delays.
Keep_Masked : Interrupt_Set := (others => False); Keep_Masked : Interrupt_Set := (others => False);
-- Keep_Masked (I) is true iff the interrupt I must always be masked. -- Keep_Masked (I) is true iff the interrupt I must always be masked.
-- Where interrupts are implemented as OS signals, and signal masking -- Where interrupts are implemented as OS signals, and signal masking is
-- is per-task, the interrupt should be masked in ALL TASKS. -- per-task, the interrupt should be masked in ALL TASKS. There might not
-- There might not be any interrupts in this class, depending on -- be any interrupts in this class, depending on the environment. For
-- the environment. For example, if interrupts are OS signals -- example, if interrupts are OS signals and signal masking is per-task,
-- and signal masking is per-task, use of the sigwait operation -- use of the sigwait operation requires the signal be masked in all tasks.
-- requires the signal be masked in all tasks.
procedure Initialize_Interrupts; procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g -- On systems where there is no signal inheritance between tasks (e.g
...@@ -121,7 +117,6 @@ package System.Interrupt_Management is ...@@ -121,7 +117,6 @@ package System.Interrupt_Management is
-- only be called by initialize in this package body. -- only be called by initialize in this package body.
private private
use type System.OS_Interface.unsigned_long; use type System.OS_Interface.unsigned_long;
type Interrupt_Mask is new System.OS_Interface.sigset_t; type Interrupt_Mask is new System.OS_Interface.sigset_t;
...@@ -136,7 +131,7 @@ private ...@@ -136,7 +131,7 @@ private
Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Interrupt_Mailbox : Interrupt_ID := 0; Interrupt_Mailbox : Interrupt_ID := 0;
Interrupt_Bufquo : System.OS_Interface.unsigned_long Interrupt_Bufquo : System.OS_Interface.unsigned_long :=
:= 1000 * (Interrupt_ID'Size / 8); 1000 * (Interrupt_ID'Size / 8);
end System.Interrupt_Management; end System.Interrupt_Management;
gcc/ada/s-intman-vxworks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is the VxWorks version of this package. -- This is the VxWorks version of this package
-- This package encapsulates and centralizes information about all -- This package encapsulates and centralizes information about all
-- uses of interrupts (or signals), including the target-dependent -- uses of interrupts (or signals), including the target-dependent
...@@ -76,48 +76,48 @@ package System.Interrupt_Management is ...@@ -76,48 +76,48 @@ package System.Interrupt_Management is
type Signal_Set is array (Signal_ID) of Boolean; type Signal_Set is array (Signal_ID) of Boolean;
-- The following objects serve as constants, but are initialized -- The following objects serve as constants, but are initialized in the
-- in the body to aid portability. This permits us to use more -- body to aid portability. This permits us to use more portable names for
-- portable names for interrupts, where distinct names may map to -- interrupts, where distinct names may map to the same interrupt ID
-- the same interrupt ID value. -- value.
--
-- For example, suppose SIGRARE is a signal that is not defined on -- For example, suppose SIGRARE is a signal that is not defined on all
-- all systems, but is always reserved when it is defined. If we -- systems, but is always reserved when it is defined. If we have the
-- have the convention that ID zero is not used for any "real" -- convention that ID zero is not used for any "real" signals, and SIGRARE
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally -- = 0 when SIGRARE is not one of the locally supported signals, we can
-- supported signals, we can write -- write:
-- Reserved (SIGRARE) := true; -- Reserved (SIGRARE) := true;
-- and the initialization code will be portable. -- and the initialization code will be portable.
Abort_Task_Signal : Signal_ID; Abort_Task_Signal : Signal_ID;
-- The signal that is used to implement task abortion if -- The signal that is used to implement task abort if an interrupt is used
-- an interrupt is used for that purpose. This is one of the -- for that purpose. This is one of the reserved signals.
-- reserved signals.
Keep_Unmasked : Signal_Set := (others => False); Keep_Unmasked : Signal_Set := (others => False);
-- Keep_Unmasked (I) is true iff the signal I is one that must -- Keep_Unmasked (I) is true iff the signal I is one that must that must
-- that must be kept unmasked at all times, except (perhaps) for -- be kept unmasked at all times, except (perhaps) for short critical
-- short critical sections. This includes signals that are -- sections. This includes signals that are mapped to exceptions, but may
-- mapped to exceptions, but may also include interrupts -- also include interrupts (e.g. timer) that need to be kept unmasked for
-- (e.g. timer) that need to be kept unmasked for other -- other reasons. Where signal masking is per-task, the signal should be
-- reasons. Where signal masking is per-task, the signal should be
-- unmasked in ALL TASKS. -- unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False); Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that cannot be -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- permitted to be attached to a user handler. The possible reasons -- to be attached to a user handler. The possible reasons are many. For
-- are many. For example, it may be mapped to an exception used to -- example, it may be mapped to an exception used to implement task abort,
-- implement task abortion, or used to implement time delays. -- or used to implement time delays.
procedure Initialize_Interrupts; procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g -- On systems where there is no signal inheritance between tasks (e.g
-- VxWorks, GNU/LinuxThreads), this procedure is used to initialize -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize
-- interrupts handling in each task. Otherwise this function should -- interrupts handling in each task. Otherwise this function should only
-- only be called by initialize in this package body. -- be called by initialize in this package body.
private private
type Interrupt_Mask is new System.OS_Interface.sigset_t; type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementation Interrupt_Mask can be represented -- In some implementation Interrupt_Mask can be represented as a linked
-- as a linked list. -- list.
end System.Interrupt_Management; end System.Interrupt_Management;
gcc/ada/s-intman.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,26 +31,26 @@ ...@@ -31,26 +31,26 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package encapsulates and centralizes information about all -- This package encapsulates and centralizes information about all uses of
-- uses of interrupts (or signals), including the target-dependent -- interrupts (or signals), including the target-dependent mapping of
-- mapping of interrupts (or signals) to exceptions. -- interrupts (or signals) to exceptions.
-- Unlike the original design, System.Interrupt_Management can only -- Unlike the original design, System.Interrupt_Management can only be used
-- be used for tasking systems. -- for tasking systems.
-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. -- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
-- Elaboration of this package should happen early, as most other -- Elaboration of this package should happen early, as most other
-- initializations depend on it. Forcing immediate elaboration of -- initializations depend on it. Forcing immediate elaboration of the body
-- the body also helps to enforce the design assumption that this -- also helps to enforce the design assumption that this is a second-level
-- is a second-level package, just one level above System.OS_Interface -- package, just one level above System.OS_Interface with no
-- with no cross-dependencies. -- cross-dependencies.
-- PLEASE DO NOT put any subprogram declarations with arguments of -- PLEASE DO NOT put any subprogram declarations with arguments of type
-- type Interrupt_ID into the visible part of this package. The type -- Interrupt_ID into the visible part of this package. The type Interrupt_ID
-- Interrupt_ID is used to derive the type in Ada.Interrupts, and -- is used to derive the type in Ada.Interrupts, and adding more operations
-- adding more operations to that type would be illegal according -- to that type would be illegal according to the Ada Reference Manual. This
-- to the Ada Reference Manual. This is the reason why the signals -- is the reason why the signals sets are implemeneted using visible arrays
-- sets are implemeneted using visible arrays rather than functions. -- rather than functions.
with System.OS_Interface; with System.OS_Interface;
-- used for sigset_t -- used for sigset_t
...@@ -69,49 +69,49 @@ package System.Interrupt_Management is ...@@ -69,49 +69,49 @@ package System.Interrupt_Management is
type Interrupt_Set is array (Interrupt_ID) of Boolean; type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized -- The following objects serve as constants, but are initialized in the
-- in the body to aid portability. This permits us to use more -- body to aid portability. This permits us to use more portable names for
-- portable names for interrupts, where distinct names may map to -- interrupts, where distinct names may map to the same interrupt ID
-- the same interrupt ID value. -- value.
--
-- For example, suppose SIGRARE is a signal that is not defined on -- For example, suppose SIGRARE is a signal that is not defined on all
-- all systems, but is always reserved when it is defined. If we -- systems, but is always reserved when it is defined. If we have the
-- have the convention that ID zero is not used for any "real" -- convention that ID zero is not used for any "real" signals, and SIGRARE
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally -- = 0 when SIGRARE is not one of the locally supported signals, we can
-- supported signals, we can write -- write
-- Reserved (SIGRARE) := true;
-- Reserved (SIGRARE) := True;
-- and the initialization code will be portable. -- and the initialization code will be portable.
Abort_Task_Interrupt : Interrupt_ID; Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abortion if -- The interrupt that is used to implement task abort if an interrupt is
-- an interrupt is used for that purpose. This is one of the -- used for that purpose. This is one of the reserved interrupts.
-- reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False); Keep_Unmasked : Interrupt_Set := (others => False);
-- Keep_Unmasked (I) is true iff the interrupt I is one that must -- Keep_Unmasked (I) is true iff the interrupt I is one that must that
-- that must be kept unmasked at all times, except (perhaps) for -- must be kept unmasked at all times, except (perhaps) for short critical
-- short critical sections. This includes interrupts that are -- sections. This includes interrupts that are mapped to exceptions (see
-- mapped to exceptions (see System.Interrupt_Exceptions.Is_Exception), -- System.Interrupt_Exceptions.Is_Exception), but may also include
-- but may also include interrupts (e.g. timer) that need to be kept -- interrupts (e.g. timer) that need to be kept unmasked for other
-- unmasked for other reasons. Where interrupts are implemented as -- reasons. Where interrupts are implemented as OS signals, and signal
-- OS signals, and signal masking is per-task, the interrupt should -- masking is per-task, the interrupt should be unmasked in ALL TASKS.
-- be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False); Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that cannot be -- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- permitted to be attached to a user handler. The possible reasons -- to be attached to a user handler. The possible reasons are many. For
-- are many. For example, it may be mapped to an exception used to -- example, it may be mapped to an exception used to implement task abort,
-- implement task abortion, or used to implement time delays. -- or used to implement time delays.
procedure Initialize_Interrupts; procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g -- On systems where there is no signal inheritance between tasks (e.g
-- VxWorks, GNU/LinuxThreads), this procedure is used to initialize -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize
-- interrupts handling in each task. Otherwise this function should -- interrupts handling in each task. Otherwise this function should only
-- only be called by initialize in this package body. -- be called by initialize in this package body.
private private
type Interrupt_Mask is new System.OS_Interface.sigset_t; type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- In some implementation Interrupt_Mask can be represented -- In some implementations Interrupt_Mask can be represented as a linked
-- as a linked list. -- list.
end System.Interrupt_Management; end System.Interrupt_Management;
gcc/ada/s-memory.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- -- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -35,13 +35,13 @@ ...@@ -35,13 +35,13 @@
-- This implementation assumes that the underlying malloc/free/realloc -- This implementation assumes that the underlying malloc/free/realloc
-- implementation is thread safe, and thus, no additional lock is required. -- implementation is thread safe, and thus, no additional lock is required.
-- Note that we still need to defer abortion because on most systems, -- Note that we still need to defer abort because on most systems, an
-- an asynchronous signal (as used for implementing asynchronous abortion -- asynchronous signal (as used for implementing asynchronous abort of
-- of task) cannot safely be handled while malloc is executing. -- task) cannot safely be handled while malloc is executing.
-- If you are not using Ada constructs containing the "abort" keyword, -- If you are not using Ada constructs containing the "abort" keyword, then
-- then you can remove the calls to Abort_Defer.all and Abort_Undefer.all -- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
-- from this unit. -- this unit.
with Ada.Exceptions; with Ada.Exceptions;
with System.Soft_Links; with System.Soft_Links;
......
gcc/ada/s-soflin.ads
...@@ -52,7 +52,7 @@ package System.Soft_Links is ...@@ -52,7 +52,7 @@ package System.Soft_Links is
pragma Import pragma Import
(Ada, Current_Target_Exception, (Ada, Current_Target_Exception,
"__gnat_current_target_exception"); "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions. -- Import this subprogram from the private part of Ada.Exceptions
-- First we have the access subprogram types used to establish the links. -- First we have the access subprogram types used to establish the links.
-- The approach is to establish variables containing access subprogram -- The approach is to establish variables containing access subprogram
...@@ -112,20 +112,20 @@ package System.Soft_Links is ...@@ -112,20 +112,20 @@ package System.Soft_Links is
-- Declarations for the no tasking versions of the required routines -- Declarations for the no tasking versions of the required routines
procedure Abort_Defer_NT; procedure Abort_Defer_NT;
-- Defer task abortion (non-tasking case, does nothing) -- Defer task abort (non-tasking case, does nothing)
procedure Abort_Undefer_NT; procedure Abort_Undefer_NT;
-- Undefer task abortion (non-tasking case, does nothing) -- Undefer task abort (non-tasking case, does nothing)
procedure Abort_Handler_NT; procedure Abort_Handler_NT;
-- Handle task abortion (non-tasking case, does nothing). Currently, -- Handle task abort (non-tasking case, does nothing). Currently, only VMS
-- only VMS uses this. -- uses this.
procedure Update_Exception_NT (X : EO := Current_Target_Exception); procedure Update_Exception_NT (X : EO := Current_Target_Exception);
-- Handle exception setting. This routine is provided for targets -- Handle exception setting. This routine is provided for targets which
-- which have built-in exception handling such as the Java Virtual -- have built-in exception handling such as the Java Virtual Machine.
-- Machine. Currently, only JGNAT uses this. See 4jexcept.ads for -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on
-- an explanation on how this routine is used. -- how this routine is used.
function Check_Abort_Status_NT return Integer; function Check_Abort_Status_NT return Integer;
-- Returns Boolean'Pos (True) iff abort signal should raise -- Returns Boolean'Pos (True) iff abort signal should raise
...@@ -143,14 +143,14 @@ package System.Soft_Links is ...@@ -143,14 +143,14 @@ package System.Soft_Links is
Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
pragma Suppress (Access_Check, Abort_Defer); pragma Suppress (Access_Check, Abort_Defer);
-- Defer task abortion (task/non-task case as appropriate) -- Defer task abort (task/non-task case as appropriate)
Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
pragma Suppress (Access_Check, Abort_Undefer); pragma Suppress (Access_Check, Abort_Undefer);
-- Undefer task abortion (task/non-task case as appropriate) -- Undefer task abort (task/non-task case as appropriate)
Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
-- Handle task abortion (task/non-task case as appropriate) -- Handle task abort (task/non-task case as appropriate)
Update_Exception : Special_EO_Call := Update_Exception_NT'Access; Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
-- Handle exception setting and tasking polling when appropriate -- Handle exception setting and tasking polling when appropriate
...@@ -196,7 +196,7 @@ package System.Soft_Links is ...@@ -196,7 +196,7 @@ package System.Soft_Links is
-- explicitly or implicitly during the critical locked region. -- explicitly or implicitly during the critical locked region.
Adafinal : No_Param_Proc := Null_Adafinal'Access; Adafinal : No_Param_Proc := Null_Adafinal'Access;
-- Performs the finalization of the Ada Runtime. -- Performs the finalization of the Ada Runtime
function Get_Jmpbuf_Address_NT return Address; function Get_Jmpbuf_Address_NT return Address;
procedure Set_Jmpbuf_Address_NT (Addr : Address); procedure Set_Jmpbuf_Address_NT (Addr : Address);
......
gcc/ada/s-taasde.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1998-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,8 +31,8 @@ ...@@ -31,8 +31,8 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains the procedures to implements timeouts (delays) -- This package contains the procedures to implements timeouts (delays) for
-- for asynchronous select statements. -- asynchronous select statements.
-- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes. -- Any changes to this interface may require corresponding compiler changes.
...@@ -100,8 +100,8 @@ package System.Tasking.Async_Delays is ...@@ -100,8 +100,8 @@ package System.Tasking.Async_Delays is
(T : in Duration; (T : in Duration;
D : Delay_Block_Access) return Boolean; D : Delay_Block_Access) return Boolean;
-- Enqueue the specified relative delay. Returns True if the delay has -- Enqueue the specified relative delay. Returns True if the delay has
-- been enqueued, False if it has already expired. -- been enqueued, False if it has already expired. If the delay has been
-- If the delay has been enqueued, abortion is deferred. -- enqueued, abort is deferred.
procedure Cancel_Async_Delay (D : Delay_Block_Access); procedure Cancel_Async_Delay (D : Delay_Block_Access);
-- Cancel the specified asynchronous delay -- Cancel the specified asynchronous delay
...@@ -117,10 +117,10 @@ package System.Tasking.Async_Delays is ...@@ -117,10 +117,10 @@ package System.Tasking.Async_Delays is
private private
type Delay_Block is record type Delay_Block is record
Self_Id : Task_Id; Self_Id : Task_Id;
-- ID of the calling task -- ID of the calling task
Level : ATC_Level_Base; Level : ATC_Level_Base;
-- Normally Level is the ATC nesting level of the -- Normally Level is the ATC nesting level of the
-- async. select statement to which this delay belongs, but -- async. select statement to which this delay belongs, but
-- after a call has been dequeued we set it to -- after a call has been dequeued we set it to
...@@ -130,10 +130,10 @@ private ...@@ -130,10 +130,10 @@ private
Resume_Time : Duration; Resume_Time : Duration;
-- The absolute wake up time, represented as Duration -- The absolute wake up time, represented as Duration
Timed_Out : Boolean := False; Timed_Out : Boolean := False;
-- Set to true if the delay has timed out -- Set to true if the delay has timed out
Succ, Pred : Delay_Block_Access; Succ, Pred : Delay_Block_Access;
-- A double linked list -- A double linked list
end record; end record;
......
gcc/ada/s-taprob.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies -- -- Copyright (C) 1995-2005, Ada Core Technologies --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -90,15 +90,15 @@ package body System.Tasking.Protected_Objects is ...@@ -90,15 +90,15 @@ package body System.Tasking.Protected_Objects is
Ceiling_Violation : Boolean; Ceiling_Violation : Boolean;
begin begin
-- The lock is made without defering abortion. -- The lock is made without defering abort
-- Therefore the abortion has to be deferred before calling this -- Therefore the abort has to be deferred before calling this routine.
-- routine. This means that the compiler has to generate a Defer_Abort -- This means that the compiler has to generate a Defer_Abort call
-- call before the call to Lock. -- before the call to Lock.
-- The caller is responsible for undeferring abortion, and compiler -- The caller is responsible for undeferring abort, and compiler
-- generated calls must be protected with cleanup handlers to ensure -- generated calls must be protected with cleanup handlers to ensure
-- that abortion is undeferred in all cases. -- that abort is undeferred in all cases.
Write_Lock (Object.L'Access, Ceiling_Violation); Write_Lock (Object.L'Access, Ceiling_Violation);
......
gcc/ada/s-taprop-os2.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -112,7 +112,7 @@ package body System.Task_Primitives.Operations is ...@@ -112,7 +112,7 @@ package body System.Task_Primitives.Operations is
-- Local Data -- -- Local Data --
----------------- -----------------
-- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr
-- This API reserves a small range of virtual addresses that is backed -- This API reserves a small range of virtual addresses that is backed
-- by different physical memory for each running thread. In this case we -- by different physical memory for each running thread. In this case we
...@@ -141,7 +141,7 @@ package body System.Task_Primitives.Operations is ...@@ -141,7 +141,7 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
Environment_Task_Id : Task_Id; Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task. -- A variable to hold Task_Id for the environment task
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
...@@ -223,7 +223,7 @@ package body System.Task_Primitives.Operations is ...@@ -223,7 +223,7 @@ package body System.Task_Primitives.Operations is
Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID; Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
begin begin
-- Check that the thread local data has been initialized. -- Check that the thread local data has been initialized
pragma Assert pragma Assert
((Thread_Local_Data_Ptr /= null ((Thread_Local_Data_Ptr /= null
...@@ -458,7 +458,7 @@ package body System.Task_Primitives.Operations is ...@@ -458,7 +458,7 @@ package body System.Task_Primitives.Operations is
Count : aliased ULONG; -- Used to store dummy result Count : aliased ULONG; -- Used to store dummy result
begin begin
-- Must reset Cond BEFORE L is unlocked. -- Must reset Cond BEFORE L is unlocked
Sem_Must_Not_Fail Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
...@@ -475,7 +475,7 @@ package body System.Task_Primitives.Operations is ...@@ -475,7 +475,7 @@ package body System.Task_Primitives.Operations is
Sem_Must_Not_Fail Sem_Must_Not_Fail
(DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT)); (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT));
-- Since L was previously accquired, lock operation should not fail. -- Since L was previously accquired, lock operation should not fail
if Single_Lock then if Single_Lock then
Lock_RTS; Lock_RTS;
...@@ -516,7 +516,7 @@ package body System.Task_Primitives.Operations is ...@@ -516,7 +516,7 @@ package body System.Task_Primitives.Operations is
Count : aliased ULONG; -- Used to store dummy result Count : aliased ULONG; -- Used to store dummy result
begin begin
-- Must reset Cond BEFORE Self_ID is unlocked. -- Must reset Cond BEFORE Self_ID is unlocked
Sem_Must_Not_Fail Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, (DosResetEventSem (Self_ID.Common.LL.CV,
...@@ -611,7 +611,7 @@ package body System.Task_Primitives.Operations is ...@@ -611,7 +611,7 @@ package body System.Task_Primitives.Operations is
Write_Lock (Self_ID); Write_Lock (Self_ID);
end if; end if;
-- Must reset Cond BEFORE Self_ID is unlocked. -- Must reset Cond BEFORE Self_ID is unlocked
Sem_Must_Not_Fail Sem_Must_Not_Fail
(DosResetEventSem (Self_ID.Common.LL.CV, (DosResetEventSem (Self_ID.Common.LL.CV,
...@@ -767,7 +767,7 @@ package body System.Task_Primitives.Operations is ...@@ -767,7 +767,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_Id) is procedure Enter_Task (Self_ID : Task_Id) is
begin begin
-- Initialize thread local data. Must be done first. -- Initialize thread local data. Must be done first
Thread_Local_Data_Ptr.Self_ID := Self_ID; Thread_Local_Data_Ptr.Self_ID := Self_ID;
Thread_Local_Data_Ptr.Lock_Prio_Level := 0; Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
...@@ -927,7 +927,7 @@ package body System.Task_Primitives.Operations is ...@@ -927,7 +927,7 @@ package body System.Task_Primitives.Operations is
T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper); T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper);
-- The OS implicitly gives the new task the priority of this task. -- The OS implicitly gives the new task the priority of this task
T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority; T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority;
...@@ -1007,7 +1007,7 @@ package body System.Task_Primitives.Operations is ...@@ -1007,7 +1007,7 @@ package body System.Task_Primitives.Operations is
begin begin
null; null;
-- Task abortion not implemented yet. -- Task abort not implemented yet.
-- Should perform other action ??? -- Should perform other action ???
end Abort_Task; end Abort_Task;
...@@ -1103,9 +1103,9 @@ package body System.Task_Primitives.Operations is ...@@ -1103,9 +1103,9 @@ package body System.Task_Primitives.Operations is
Environment_Task_Id := Environment_Task; Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs. -- Initialize the lock used to synchronize chain of all ATCBs
-- Set ID of environment task. -- Set ID of environment task
Thread_Local_Data_Ptr.Self_ID := Environment_Task; Thread_Local_Data_Ptr.Self_ID := Environment_Task;
Environment_Task.Common.LL.Thread := 1; -- By definition Environment_Task.Common.LL.Thread := 1; -- By definition
......
gcc/ada/s-tasini.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,30 +41,30 @@ pragma Polling (Off); ...@@ -41,30 +41,30 @@ pragma Polling (Off);
-- to poll it can cause infinite loops. -- to poll it can cause infinite loops.
with Ada.Exceptions; with Ada.Exceptions;
-- used for Exception_Occurrence_Access. -- Used for Exception_Occurrence_Access
with System.Tasking; with System.Tasking;
pragma Elaborate_All (System.Tasking); pragma Elaborate_All (System.Tasking);
-- ensure that the first step initializations have been performed -- Ensure that the first step initializations have been performed
with System.Task_Primitives; with System.Task_Primitives;
-- used for Lock -- Used for Lock
with System.Task_Primitives.Operations; with System.Task_Primitives.Operations;
-- used for Set_Priority -- Used for Set_Priority
-- Write_Lock -- Write_Lock
-- Unlock -- Unlock
-- Initialize_Lock -- Initialize_Lock
with System.Soft_Links; with System.Soft_Links;
-- used for the non-tasking routines (*_NT) that refer to global data. -- Used for the non-tasking routines (*_NT) that refer to global data.
-- They are needed here before the tasking run time has been elaborated. -- They are needed here before the tasking run time has been elaborated.
with System.Soft_Links.Tasking; with System.Soft_Links.Tasking;
-- Used for Init_Tasking_Soft_Links -- Used for Init_Tasking_Soft_Links
with System.Tasking.Debug; with System.Tasking.Debug;
-- used for Trace -- Used for Trace
with System.Stack_Checking; with System.Stack_Checking;
...@@ -88,7 +88,7 @@ package body System.Tasking.Initialization is ...@@ -88,7 +88,7 @@ package body System.Tasking.Initialization is
function Current_Target_Exception return AE.Exception_Occurrence; function Current_Target_Exception return AE.Exception_Occurrence;
pragma Import pragma Import
(Ada, Current_Target_Exception, "__gnat_current_target_exception"); (Ada, Current_Target_Exception, "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions. -- Import this subprogram from the private part of Ada.Exceptions
---------------------------------------------------------------------- ----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs -- -- Tasking versions of some services needed by non-tasking programs --
...@@ -150,7 +150,7 @@ package body System.Tasking.Initialization is ...@@ -150,7 +150,7 @@ package body System.Tasking.Initialization is
-- Change_Base_Priority -- -- Change_Base_Priority --
-------------------------- --------------------------
-- Call only with abort deferred and holding Self_ID locked. -- Call only with abort deferred and holding Self_ID locked
procedure Change_Base_Priority (T : Task_Id) is procedure Change_Base_Priority (T : Task_Id) is
begin begin
...@@ -269,7 +269,7 @@ package body System.Tasking.Initialization is ...@@ -269,7 +269,7 @@ package body System.Tasking.Initialization is
-- while we had abort deferred below. -- while we had abort deferred below.
loop loop
-- Temporarily defer abortion so that we can lock Self_ID. -- Temporarily defer abort so that we can lock Self_ID
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
...@@ -286,7 +286,7 @@ package body System.Tasking.Initialization is ...@@ -286,7 +286,7 @@ package body System.Tasking.Initialization is
Unlock_RTS; Unlock_RTS;
end if; end if;
-- Restore the original Deferral value. -- Restore the original Deferral value
Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1;
...@@ -401,11 +401,11 @@ package body System.Tasking.Initialization is ...@@ -401,11 +401,11 @@ package body System.Tasking.Initialization is
SSL.Tasking.Init_Tasking_Soft_Links; SSL.Tasking.Init_Tasking_Soft_Links;
-- Install tasking locks in the GCC runtime. -- Install tasking locks in the GCC runtime
Gnat_Install_Locks (Task_Lock'Access, Task_Unlock'Access); Gnat_Install_Locks (Task_Lock'Access, Task_Unlock'Access);
-- Abortion is deferred in a new ATCB, so we need to undefer abortion -- Abort is deferred in a new ATCB, so we need to undefer abort
-- at this stage to make the environment task abortable. -- at this stage to make the environment task abortable.
Undefer_Abort (Environment_Task); Undefer_Abort (Environment_Task);
...@@ -426,15 +426,16 @@ package body System.Tasking.Initialization is ...@@ -426,15 +426,16 @@ package body System.Tasking.Initialization is
-- hurt to uncomment the above call, until the error is corrected for -- hurt to uncomment the above call, until the error is corrected for
-- all targets. -- all targets.
-- See extended comments in package body System.Tasking.Abortion -- See extended comments in package body System.Tasking.Abort for the
-- for the overall design of the implementation of task abort. -- overall design of the implementation of task abort.
-- ??? there is no such package ???
-- If the task is sleeping it will be in an abort-deferred region, -- If the task is sleeping it will be in an abort-deferred region, and
-- and will not have Abort_Signal raised by Abort_Task. -- will not have Abort_Signal raised by Abort_Task. Such an "abort
-- Such an "abort deferral" is just to protect the RTS internals, -- deferral" is just to protect the RTS internals, and not necessarily
-- and not necessarily required to enforce Ada semantics. -- required to enforce Ada semantics. Abort_Task should wake the task up
-- Abort_Task should wake the task up and let it decide if it wants -- and let it decide if it wants to complete the aborted construct
-- to complete the aborted construct immediately. -- immediately.
-- Note that the effect of the lowl-level Abort_Task is not persistent. -- Note that the effect of the lowl-level Abort_Task is not persistent.
-- If the target task is not blocked, this wakeup will be missed. -- If the target task is not blocked, this wakeup will be missed.
...@@ -452,14 +453,13 @@ package body System.Tasking.Initialization is ...@@ -452,14 +453,13 @@ package body System.Tasking.Initialization is
-- implement delays). That still left the possibility of missed -- implement delays). That still left the possibility of missed
-- wakeups. -- wakeups.
-- We cannot safely call Vulnerable_Complete_Activation here, -- We cannot safely call Vulnerable_Complete_Activation here, since that
-- since that requires locking Self_ID.Parent. The anti-deadlock -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules
-- lock ordering rules would then require us to release the lock -- would then require us to release the lock on Self_ID first, which would
-- on Self_ID first, which would create a timing window for other -- create a timing window for other tasks to lock Self_ID. This is
-- tasks to lock Self_ID. This is significant for tasks that may be -- significant for tasks that may be aborted before their execution can
-- aborted before their execution can enter the task body, and so -- enter the task body, and so they do not get a chance to call
-- they do not get a chance to call Complete_Task. The actual work -- Complete_Task. The actual work for this case is done in Terminate_Task.
-- for this case is done in Terminate_Task.
procedure Locked_Abort_To_Level procedure Locked_Abort_To_Level
(Self_ID : Task_Id; (Self_ID : Task_Id;
...@@ -694,12 +694,12 @@ package body System.Tasking.Initialization is ...@@ -694,12 +694,12 @@ package body System.Tasking.Initialization is
-- Precondition : Self does not hold any locks! -- Precondition : Self does not hold any locks!
-- Undefer_Abort is called on any abortion completion point (aka. -- Undefer_Abort is called on any abort completion point (aka.
-- synchronization point). It performs the following actions if they -- synchronization point). It performs the following actions if they
-- are pending: (1) change the base priority, (2) abort the task. -- are pending: (1) change the base priority, (2) abort the task.
-- The priority change has to occur before abortion. Otherwise, it would -- The priority change has to occur before abort. Otherwise, it would
-- take effect no earlier than the next abortion completion point. -- take effect no earlier than the next abort completion point.
procedure Undefer_Abort (Self_ID : Task_Id) is procedure Undefer_Abort (Self_ID : Task_Id) is
begin begin
...@@ -761,8 +761,8 @@ package body System.Tasking.Initialization is ...@@ -761,8 +761,8 @@ package body System.Tasking.Initialization is
-- Undefer_Abortion -- -- Undefer_Abortion --
---------------------- ----------------------
-- Phase out RTS-internal use of Undefer_Abortion -- Phase out RTS-internal use of Undefer_Abortion to reduce overhead due
-- to reduce overhead due to multiple calls to Self. -- to multiple calls to Self.
procedure Undefer_Abortion is procedure Undefer_Abortion is
Self_ID : Task_Id; Self_ID : Task_Id;
...@@ -806,7 +806,7 @@ package body System.Tasking.Initialization is ...@@ -806,7 +806,7 @@ package body System.Tasking.Initialization is
-- Update_Exception -- -- Update_Exception --
---------------------- ----------------------
-- Call only when holding no locks. -- Call only when holding no locks
procedure Update_Exception procedure Update_Exception
(X : AE.Exception_Occurrence := Current_Target_Exception) (X : AE.Exception_Occurrence := Current_Target_Exception)
......
gcc/ada/s-tassta.adb
...@@ -36,24 +36,24 @@ pragma Polling (Off); ...@@ -36,24 +36,24 @@ pragma Polling (Off);
-- tasking operations. It causes infinite loops and other problems. -- tasking operations. It causes infinite loops and other problems.
with Ada.Exceptions; with Ada.Exceptions;
-- used for Raise_Exception -- Used for Raise_Exception
with System.Tasking.Debug; with System.Tasking.Debug;
-- used for enabling tasking facilities with gdb -- Used for enabling tasking facilities with gdb
with System.Address_Image; with System.Address_Image;
-- used for the function itself. -- Used for the function itself
with System.Parameters; with System.Parameters;
-- used for Size_Type -- Used for Size_Type
-- Single_Lock -- Single_Lock
-- Runtime_Traces -- Runtime_Traces
with System.Task_Info; with System.Task_Info;
-- used for Task_Info_Type -- Used for Task_Info_Type
with System.Task_Primitives.Operations; with System.Task_Primitives.Operations;
-- used for Finalize_Lock -- Used for Finalize_Lock
-- Enter_Task -- Enter_Task
-- Write_Lock -- Write_Lock
-- Unlock -- Unlock
...@@ -64,11 +64,11 @@ with System.Task_Primitives.Operations; ...@@ -64,11 +64,11 @@ with System.Task_Primitives.Operations;
-- New_ATCB -- New_ATCB
with System.Soft_Links; with System.Soft_Links;
-- These are procedure pointers to non-tasking routines that use -- These are procedure pointers to non-tasking routines that use task
-- task specific data. In the absence of tasking, these routines -- specific data. In the absence of tasking, these routines refer to global
-- refer to global data. In the presense of tasking, they must be -- data. In the presense of tasking, they must be replaced with pointers to
-- replaced with pointers to task-specific versions. -- task-specific versions. Also used for Create_TSD, Destroy_TSD,
-- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep -- Get_Current_Excep
with System.Tasking.Initialization; with System.Tasking.Initialization;
-- Used for Remove_From_All_Tasks_List -- Used for Remove_From_All_Tasks_List
...@@ -79,7 +79,7 @@ with System.Tasking.Initialization; ...@@ -79,7 +79,7 @@ with System.Tasking.Initialization;
-- Initialize_Attributes_Link -- Initialize_Attributes_Link
pragma Elaborate_All (System.Tasking.Initialization); pragma Elaborate_All (System.Tasking.Initialization);
-- This insures that tasking is initialized if any tasks are created. -- This insures that tasking is initialized if any tasks are created
with System.Tasking.Utilities; with System.Tasking.Utilities;
-- Used for Make_Passive -- Used for Make_Passive
...@@ -98,22 +98,22 @@ with System.Finalization_Implementation; ...@@ -98,22 +98,22 @@ with System.Finalization_Implementation;
-- Used for System.Finalization_Implementation.Finalize_Global_List -- Used for System.Finalization_Implementation.Finalize_Global_List
with System.Secondary_Stack; with System.Secondary_Stack;
-- used for SS_Init -- Used for SS_Init
with System.Storage_Elements; with System.Storage_Elements;
-- used for Storage_Array -- Used for Storage_Array
with System.Restrictions; with System.Restrictions;
-- used for Abort_Allowed -- Used for Abort_Allowed
with System.Standard_Library; with System.Standard_Library;
-- used for Exception_Trace -- Used for Exception_Trace
with System.Traces.Tasking; with System.Traces.Tasking;
-- used for Send_Trace_Info -- Used for Send_Trace_Info
with Unchecked_Deallocation; with Unchecked_Deallocation;
-- To recover from failure of ATCB initialization. -- To recover from failure of ATCB initialization
package body System.Tasking.Stages is package body System.Tasking.Stages is
...@@ -787,11 +787,11 @@ package body System.Tasking.Stages is ...@@ -787,11 +787,11 @@ package body System.Tasking.Stages is
Self_ID.Callable := False; Self_ID.Callable := False;
-- Exit level 2 master, for normal tasks in library-level packages. -- Exit level 2 master, for normal tasks in library-level packages
Complete_Master; Complete_Master;
-- Force termination of "independent" library-level server tasks. -- Force termination of "independent" library-level server tasks
Lock_RTS; Lock_RTS;
...@@ -977,7 +977,7 @@ package body System.Tasking.Stages is ...@@ -977,7 +977,7 @@ package body System.Tasking.Stages is
-- clean ups associated with the exception handler that need to -- clean ups associated with the exception handler that need to
-- access task specific data. -- access task specific data.
-- Defer abortion so that this task can't be aborted while exiting -- Defer abort so that this task can't be aborted while exiting
when Standard'Abort_Signal => when Standard'Abort_Signal =>
Initialization.Defer_Abort_Nestable (Self_ID); Initialization.Defer_Abort_Nestable (Self_ID);
...@@ -1209,7 +1209,7 @@ package body System.Tasking.Stages is ...@@ -1209,7 +1209,7 @@ package body System.Tasking.Stages is
-- The activator raises a Tasking_Error if any task it is activating -- The activator raises a Tasking_Error if any task it is activating
-- is completed before the activation is done. However, if the reason -- is completed before the activation is done. However, if the reason
-- for the task completion is an abortion, we do not raise an exception. -- for the task completion is an abort, we do not raise an exception.
-- See RM 9.2(5). -- See RM 9.2(5).
if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
...@@ -1392,7 +1392,7 @@ package body System.Tasking.Stages is ...@@ -1392,7 +1392,7 @@ package body System.Tasking.Stages is
pragma Assert (Self_ID.Common.Wait_Count = 0); pragma Assert (Self_ID.Common.Wait_Count = 0);
-- Force any remaining dependents to terminate, by aborting them. -- Force any remaining dependents to terminate by aborting them
if not Single_Lock then if not Single_Lock then
Lock_RTS; Lock_RTS;
...@@ -1461,8 +1461,8 @@ package body System.Tasking.Stages is ...@@ -1461,8 +1461,8 @@ package body System.Tasking.Stages is
Unlock (Self_ID); Unlock (Self_ID);
end if; end if;
-- We don't wake up for abortion here. We are already terminating -- We don't wake up for abort here. We are already terminating just as
-- just as fast as we can, so there is no point. -- fast as we can, so there is no point.
-- Remove terminated tasks from the list of Self_ID's dependents, but -- Remove terminated tasks from the list of Self_ID's dependents, but
-- don't free their ATCBs yet, because of lock order restrictions, -- don't free their ATCBs yet, because of lock order restrictions,
...@@ -1687,7 +1687,7 @@ package body System.Tasking.Stages is ...@@ -1687,7 +1687,7 @@ package body System.Tasking.Stages is
-- Package elaboration code -- Package elaboration code
begin begin
-- Establish the Adafinal softlink. -- Establish the Adafinal softlink
-- This is not done inside the central RTS initialization routine -- This is not done inside the central RTS initialization routine
-- to avoid with-ing this package from System.Tasking.Initialization. -- to avoid with-ing this package from System.Tasking.Initialization.
......
gcc/ada/s-tassta.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -121,9 +121,9 @@ package System.Tasking.Stages is ...@@ -121,9 +121,9 @@ package System.Tasking.Stages is
-- activate_tasks (_chain'unchecked_access); -- activate_tasks (_chain'unchecked_access);
procedure Abort_Tasks (Tasks : Task_List); procedure Abort_Tasks (Tasks : Task_List);
-- Compiler interface only. Do not call from within the RTS. -- Compiler interface only. Do not call from within the RTS. Initiate
-- Initiate abortion, however, the actual abortion is done by abortee by -- abort, however, the actual abort is done by abortee by means of
-- means of Abort_Handler and Abort_Undefer -- Abort_Handler and Abort_Undefer
-- --
-- source code: -- source code:
-- Abort T1, T2; -- Abort T1, T2;
......
gcc/ada/s-tasuti.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -72,9 +72,9 @@ package System.Tasking.Utilities is ...@@ -72,9 +72,9 @@ package System.Tasking.Utilities is
-- the environment task (because every independent task depends on it), -- the environment task (because every independent task depends on it),
-- this counter is protected by the environment task's lock. -- this counter is protected by the environment task's lock.
------------------------------------ ---------------------------------
-- Task Abortion related routines -- -- Task Abort Related Routines --
------------------------------------ ---------------------------------
procedure Cancel_Queued_Entry_Calls (T : Task_Id); procedure Cancel_Queued_Entry_Calls (T : Task_Id);
-- Cancel any entry calls queued on target task. -- Cancel any entry calls queued on target task.
...@@ -93,13 +93,13 @@ package System.Tasking.Utilities is ...@@ -93,13 +93,13 @@ package System.Tasking.Utilities is
-- (3) always aborts whole task -- (3) always aborts whole task
procedure Abort_Tasks (Tasks : Task_List); procedure Abort_Tasks (Tasks : Task_List);
-- Abort_Tasks is called to initiate abortion, however, the actual -- Abort_Tasks is called to initiate abort, however, the actual
-- abortion is done by abortee by means of Abort_Handler -- aborti is done by aborted task by means of Abort_Handler
procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean); procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean);
-- Update counts to indicate current task is either terminated -- Update counts to indicate current task is either terminated or
-- or accepting on a terminate alternative. -- accepting on a terminate alternative. Call holding no locks except
-- Call holding no locks except Global_Task_Lock when calling from -- Global_Task_Lock when calling from Terminate_Task, and RTS_Lock when
-- Terminate_Task, and RTS_Lock when Single_Lock is True. -- Single_Lock is True.
end System.Tasking.Utilities; end System.Tasking.Utilities;
gcc/ada/s-tataat.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2004, Ada Core Technologies -- -- Copyright (C) 1995-2005, Ada Core Technologies --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,13 +32,13 @@ ...@@ -32,13 +32,13 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package provides support for the body of Ada.Task_Attributes. -- This package provides support for the body of Ada.Task_Attributes
with Ada.Finalization; with Ada.Finalization;
-- used for Limited_Controlled -- Used for Limited_Controlled
with System.Storage_Elements; with System.Storage_Elements;
-- used for Integer_Address -- Used for Integer_Address
package System.Tasking.Task_Attributes is package System.Tasking.Task_Attributes is
...@@ -52,8 +52,8 @@ package System.Tasking.Task_Attributes is ...@@ -52,8 +52,8 @@ package System.Tasking.Task_Attributes is
function To_Access_Node is new Unchecked_Conversion function To_Access_Node is new Unchecked_Conversion
(Access_Address, Access_Node); (Access_Address, Access_Node);
-- Used to fetch pointer to indirect attribute list. Declaration is -- Used to fetch pointer to indirect attribute list. Declaration is in
-- in spec to avoid any problems with aliasing assumptions. -- spec to avoid any problems with aliasing assumptions.
type Dummy_Wrapper; type Dummy_Wrapper;
type Access_Dummy_Wrapper is access all Dummy_Wrapper; type Access_Dummy_Wrapper is access all Dummy_Wrapper;
...@@ -67,7 +67,7 @@ package System.Tasking.Task_Attributes is ...@@ -67,7 +67,7 @@ package System.Tasking.Task_Attributes is
-- of type Wrapper, no Dummy_Wrapper objects are ever created. -- of type Wrapper, no Dummy_Wrapper objects are ever created.
type Deallocator is access procedure (P : in out Access_Node); type Deallocator is access procedure (P : in out Access_Node);
-- Called to deallocate an Wrapper. P is a pointer to a Node within. -- Called to deallocate an Wrapper. P is a pointer to a Node within
type Instance; type Instance;
...@@ -78,11 +78,11 @@ package System.Tasking.Task_Attributes is ...@@ -78,11 +78,11 @@ package System.Tasking.Task_Attributes is
Initial_Value : aliased System.Storage_Elements.Integer_Address; Initial_Value : aliased System.Storage_Elements.Integer_Address;
Index : Direct_Index; Index : Direct_Index;
-- The index of the TCB location used by this instantiation, -- The index of the TCB location used by this instantiation, if it is
-- if it is stored in the TCB, otherwise zero. -- stored in the TCB, otherwise zero.
Next : Access_Instance; Next : Access_Instance;
-- Next instance in All_Attributes list. -- Next instance in All_Attributes list
end record; end record;
procedure Finalize (X : in out Instance); procedure Finalize (X : in out Instance);
...@@ -93,12 +93,11 @@ package System.Tasking.Task_Attributes is ...@@ -93,12 +93,11 @@ package System.Tasking.Task_Attributes is
Next : Access_Node; Next : Access_Node;
end record; end record;
-- The following type is a stand-in for the actual -- The following type is a stand-in for the actual wrapper type, which is
-- wrapper type, which is different for each instantiation -- different for each instantiation of Ada.Task_Attributes.
-- of Ada.Task_Attributes.
type Dummy_Wrapper is record type Dummy_Wrapper is record
Noed : aliased Node; Dummy_Node : aliased Node;
Value : aliased Attribute; Value : aliased Attribute;
-- The generic formal type, may be controlled -- The generic formal type, may be controlled
...@@ -110,23 +109,23 @@ package System.Tasking.Task_Attributes is ...@@ -110,23 +109,23 @@ package System.Tasking.Task_Attributes is
-- Ensure that the designated object is always strictly enough aligned. -- Ensure that the designated object is always strictly enough aligned.
In_Use : Direct_Index_Vector := 0; In_Use : Direct_Index_Vector := 0;
-- is True for direct indices that are already used. -- Set True for direct indices that are already used (True??? type???)
All_Attributes : Access_Instance; All_Attributes : Access_Instance;
-- A linked list of all indirectly access attributes, -- A linked list of all indirectly access attributes, which includes all
-- which includes all those that require finalization. -- those that require finalization.
procedure Initialize_Attributes (T : Task_Id); procedure Initialize_Attributes (T : Task_Id);
-- Initialize all attributes created via Ada.Task_Attributes for T. -- Initialize all attributes created via Ada.Task_Attributes for T. This
-- This must be called by the creator of the task, inside Create_Task, -- must be called by the creator of the task, inside Create_Task, via
-- via soft-link Initialize_Attributes_Link. On entry, abortion must -- soft-link Initialize_Attributes_Link. On entry, abort must be deferred
-- be deferred and the caller must hold no locks -- and the caller must hold no locks
procedure Finalize_Attributes (T : Task_Id); procedure Finalize_Attributes (T : Task_Id);
-- Finalize all attributes created via Ada.Task_Attributes for T. -- Finalize all attributes created via Ada.Task_Attributes for T.
-- This is to be called by the task after it is marked as terminated -- This is to be called by the task after it is marked as terminated
-- (and before it actually dies), inside Vulnerable_Free_Task, via the -- (and before it actually dies), inside Vulnerable_Free_Task, via the
-- soft-link Finalize_Attributes_Link. On entry, abortion must be deferred -- soft-link Finalize_Attributes_Link. On entry, abort must be deferred
-- and T.L must be write-locked. -- and T.L must be write-locked.
end System.Tasking.Task_Attributes; end System.Tasking.Task_Attributes;
gcc/ada/s-tpoben.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,39 +31,40 @@ ...@@ -31,39 +31,40 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains all the simple primitives related to -- This package contains all the simple primitives related to protected
-- Protected_Objects with entries (i.e init, lock, unlock). -- objects with entries (i.e init, lock, unlock).
-- The handling of protected objects with no entries is done in -- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the complex routines for protected -- System.Tasking.Protected_Objects, the complex routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Operations. -- objects with entries in System.Tasking.Protected_Objects.Operations.
-- The split between Entries and Operations is needed to break circular -- The split between Entries and Operations is needed to break circular
-- dependencies inside the run time. -- dependencies inside the run time.
-- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Note: the compiler generates direct calls to this interface, via Rtsfind
with Ada.Exceptions; with Ada.Exceptions;
-- used for Exception_Occurrence_Access -- Used for Exception_Occurrence_Access
-- Raise_Exception -- Raise_Exception
with System.Task_Primitives.Operations; with System.Task_Primitives.Operations;
-- used for Initialize_Lock -- Used for Initialize_Lock
-- Write_Lock -- Write_Lock
-- Unlock -- Unlock
-- Get_Priority -- Get_Priority
-- Wakeup -- Wakeup
with System.Tasking.Initialization; with System.Tasking.Initialization;
-- used for Defer_Abort, -- Used for Defer_Abort,
-- Undefer_Abort, -- Undefer_Abort,
-- Change_Base_Priority -- Change_Base_Priority
pragma Elaborate_All (System.Tasking.Initialization); pragma Elaborate_All (System.Tasking.Initialization);
-- this insures that tasking is initialized if any protected objects are -- This insures that tasking is initialized if any protected objects are
-- created. -- created.
with System.Parameters; with System.Parameters;
-- used for Single_Lock -- Used for Single_Lock
package body System.Tasking.Protected_Objects.Entries is package body System.Tasking.Protected_Objects.Entries is
...@@ -103,8 +104,9 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -103,8 +104,9 @@ package body System.Tasking.Protected_Objects.Entries is
end if; end if;
if Ceiling_Violation then if Ceiling_Violation then
-- Dip our own priority down to ceiling of lock.
-- See similar code in Tasking.Entry_Calls.Lock_Server. -- Dip our own priority down to ceiling of lock. See similar code in
-- Tasking.Entry_Calls.Lock_Server.
STPO.Write_Lock (Self_ID); STPO.Write_Lock (Self_ID);
Old_Base_Priority := Self_ID.Common.Base_Priority; Old_Base_Priority := Self_ID.Common.Base_Priority;
...@@ -130,7 +132,7 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -130,7 +132,7 @@ package body System.Tasking.Protected_Objects.Entries is
Object.Pending_Action := True; Object.Pending_Action := True;
end if; end if;
-- Send program_error to all tasks still queued on this object. -- Send program_error to all tasks still queued on this object
for E in Object.Entry_Queues'Range loop for E in Object.Entry_Queues'Range loop
Entry_Call := Object.Entry_Queues (E).Head; Entry_Call := Object.Entry_Queues (E).Head;
...@@ -229,10 +231,10 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -229,10 +231,10 @@ package body System.Tasking.Protected_Objects.Entries is
(Program_Error'Identity, "Protected Object is finalized"); (Program_Error'Identity, "Protected Object is finalized");
end if; end if;
-- If pragma Detect_Blocking is active then Program_Error must -- If pragma Detect_Blocking is active then Program_Error must be
-- be raised if this potentially blocking operation is called from -- raised if this potentially blocking operation is called from a
-- a protected action, and the protected object nesting level -- protected action, and the protected object nesting level must be
-- must be increased. -- increased.
if Detect_Blocking then if Detect_Blocking then
declare declare
...@@ -242,8 +244,8 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -242,8 +244,8 @@ package body System.Tasking.Protected_Objects.Entries is
Ada.Exceptions.Raise_Exception Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation"); (Program_Error'Identity, "potentially blocking operation");
else else
-- We are entering in a protected action, so that we -- We are entering in a protected action, so that we increase
-- increase the protected object nesting level. -- the protected object nesting level.
Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1; Self_Id.Common.Protected_Action_Nesting + 1;
...@@ -251,15 +253,15 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -251,15 +253,15 @@ package body System.Tasking.Protected_Objects.Entries is
end; end;
end if; end if;
-- The lock is made without defering abortion. -- The lock is made without defering abort
-- Therefore the abortion has to be deferred before calling this -- Therefore the abort has to be deferred before calling this routine.
-- routine. This means that the compiler has to generate a Defer_Abort -- This means that the compiler has to generate a Defer_Abort call
-- call before the call to Lock. -- before the call to Lock.
-- The caller is responsible for undeferring abortion, and compiler -- The caller is responsible for undeferring abort, and compiler
-- generated calls must be protected with cleanup handlers to ensure -- generated calls must be protected with cleanup handlers to ensure
-- that abortion is undeferred in all cases. -- that abort is undeferred in all cases.
pragma Assert (STPO.Self.Deferral_Level > 0); pragma Assert (STPO.Self.Deferral_Level > 0);
Write_Lock (Object.L'Access, Ceiling_Violation); Write_Lock (Object.L'Access, Ceiling_Violation);
...@@ -302,8 +304,8 @@ package body System.Tasking.Protected_Objects.Entries is ...@@ -302,8 +304,8 @@ package body System.Tasking.Protected_Objects.Entries is
Ada.Exceptions.Raise_Exception Ada.Exceptions.Raise_Exception
(Program_Error'Identity, "potentially blocking operation"); (Program_Error'Identity, "potentially blocking operation");
else else
-- We are entering in a protected action, so that we -- We are entering in a protected action, so that we increase
-- increase the protected object nesting level. -- the protected object nesting level.
Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting :=
Self_Id.Common.Protected_Action_Nesting + 1; Self_Id.Common.Protected_Action_Nesting + 1;
......
gcc/ada/s-tpobop.ads
...@@ -2,12 +2,11 @@ ...@@ -2,12 +2,11 @@
-- -- -- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- GNU ADA 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 . -- -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- O P E R A T I O N S --
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,19 +31,20 @@ ...@@ -32,19 +31,20 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains all the extended primitives related to -- This package contains all the extended primitives related to protected
-- Protected_Objects with entries. -- objects with entries.
-- The handling of protected objects with no entries is done in -- The handling of protected objects with no entries is done in
-- System.Tasking.Protected_Objects, the simple routines for protected -- System.Tasking.Protected_Objects, the simple routines for protected
-- objects with entries in System.Tasking.Protected_Objects.Entries. -- objects with entries in System.Tasking.Protected_Objects.Entries. The
-- The split between Entries and Operations is needed to break circular -- split between Entries and Operations is needed to break circular
-- dependencies inside the run time. -- dependencies inside the run time.
-- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes. -- Any changes to this interface may require corresponding compiler changes.
with Ada.Exceptions; with Ada.Exceptions;
-- used for Exception_Id -- Used for Exception_Id
with System.Tasking.Protected_Objects.Entries; with System.Tasking.Protected_Objects.Entries;
...@@ -108,7 +108,7 @@ package System.Tasking.Protected_Objects.Operations is ...@@ -108,7 +108,7 @@ package System.Tasking.Protected_Objects.Operations is
-- barriers, so this routine keeps checking barriers until all of -- barriers, so this routine keeps checking barriers until all of
-- them are closed. -- them are closed.
-- --
-- This must be called with abortion deferred and with the corresponding -- This must be called with abort deferred and with the corresponding
-- object locked. -- object locked.
-- --
-- If Unlock_Object is set True, then Object is unlocked on return, -- If Unlock_Object is set True, then Object is unlocked on return,
...@@ -173,7 +173,7 @@ package System.Tasking.Protected_Objects.Operations is ...@@ -173,7 +173,7 @@ package System.Tasking.Protected_Objects.Operations is
(Object : Entries.Protection_Entries'Class; (Object : Entries.Protection_Entries'Class;
E : Protected_Entry_Index) E : Protected_Entry_Index)
return Natural; return Natural;
-- Return the number of entry calls to E on Object. -- Return the number of entry calls to E on Object
function Protected_Entry_Caller function Protected_Entry_Caller
(Object : Entries.Protection_Entries'Class) return Task_Id; (Object : Entries.Protection_Entries'Class) return Task_Id;
...@@ -181,7 +181,7 @@ package System.Tasking.Protected_Objects.Operations is ...@@ -181,7 +181,7 @@ package System.Tasking.Protected_Objects.Operations is
-- being handled. This will only work if called from within an entry -- being handled. This will only work if called from within an entry
-- body, as required by the LRM (C.7.1(14)). -- body, as required by the LRM (C.7.1(14)).
-- For internal use only: -- For internal use only
procedure PO_Do_Or_Queue procedure PO_Do_Or_Queue
(Self_ID : Task_Id; (Self_ID : Task_Id;
...@@ -189,7 +189,7 @@ package System.Tasking.Protected_Objects.Operations is ...@@ -189,7 +189,7 @@ package System.Tasking.Protected_Objects.Operations is
Entry_Call : Entry_Call_Link; Entry_Call : Entry_Call_Link;
With_Abort : Boolean); With_Abort : Boolean);
-- This procedure either executes or queues an entry call, depending -- This procedure either executes or queues an entry call, depending
-- on the status of the corresponding barrier. It assumes that abortion -- on the status of the corresponding barrier. It assumes that abort
-- is deferred and that the specified object is locked. -- is deferred and that the specified object is locked.
private private
...@@ -201,10 +201,9 @@ private ...@@ -201,10 +201,9 @@ private
pragma Volatile (Communication_Block); pragma Volatile (Communication_Block);
-- ????? -- ?????
-- The Communication_Block seems to be a relic. -- The Communication_Block seems to be a relic. At the moment, the
-- At the moment, the compiler seems to be generating -- compiler seems to be generating unnecessary conditional code based on
-- unnecessary conditional code based on this block. -- this block. See the code generated for async. select with task entry
-- See the code generated for async. select with task entry
-- call for another way of solving this. -- call for another way of solving this.
end System.Tasking.Protected_Objects.Operations; end System.Tasking.Protected_Objects.Operations;
gcc/ada/snames.ads
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/tbuild.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -72,16 +72,16 @@ package Tbuild is ...@@ -72,16 +72,16 @@ package Tbuild is
function Make_DT_Component function Make_DT_Component
(Loc : Source_Ptr; (Loc : Source_Ptr;
Typ : Entity_Id; Typ : Entity_Id;
I : Positive) return Node_Id; N : Positive) return Node_Id;
-- Gives a reference to the Ith component of the Dispatch Table of -- Gives a reference to the Nth component of the Dispatch Table of
-- a given Tagged Type. -- a given Tagged Type.
-- --
-- I = 1 --> Inheritance_Depth -- N = 1 --> Inheritance_Depth
-- I = 2 --> Tags (array of ancestors) -- N = 2 --> Tags (array of ancestors)
-- I = 3, 4 --> predefined primitive -- N = 3, 4 --> predefined primitive
-- function _Size (X : Typ) return Long_Long_Integer; -- function _Size (X : Typ) return Long_Long_Integer;
-- function _Equality (X : Typ; Y : Typ'Class) return Boolean; -- function _Equality (X : Typ; Y : Typ'Class) return Boolean;
-- I >= 5 --> User-Defined Primitive Operations -- N >= 5 --> User-Defined Primitive Operations
function Make_DT_Access function Make_DT_Access
(Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id; (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id;
......
gcc/ada/utils2.c
...@@ -679,9 +679,9 @@ build_binary_op (enum tree_code op_code, tree result_type, ...@@ -679,9 +679,9 @@ build_binary_op (enum tree_code op_code, tree result_type,
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== ARRAY_TYPE)) == ARRAY_TYPE))
&& (0 == (best_type && (0 == (best_type
== find_common_type (right_type, = find_common_type (right_type,
TREE_TYPE (TREE_OPERAND TREE_TYPE (TREE_OPERAND
(right_operand, 0)))) (right_operand, 0))))
|| right_type != best_type)) || right_type != best_type))
{ {
right_operand = TREE_OPERAND (right_operand, 0); right_operand = TREE_OPERAND (right_operand, 0);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment