procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2004-05-17  Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	Part of function-at-a-time conversion

	* misc.c (adjust_decl_rtl): Deleted.
	(LANG_HOOKS_PUSHLEVEL, LANG_HOOKS_POPLEVEL, LANG_HOOKS_SET_BLOCK):
	Define.

	* gigi.h: (adjust_decl_rtl, kept_level_p, set_block): Deleted.
	(add_decl_stmt, add_stmt, block_has_vars): New functions.
	(gnat_pushlevel, gnat_poplevel): Renamed from pushlevel and poplevel.

	* decl.c (elaborate_expression, maybe_pad_type): Call add_decl_stmt
	when making a decl.
	(gnat_to_gnu_entity): Likewise.
	Use add_stmt to update setjmp buffer.
	Set TREE_ADDRESSABLE instead of calling put_var_into_stack and
	flush_addressof.
	No longer call adjust_decl_rtl.
	(DECL_INIT_BY_ASSIGN_P): New macro.
	(DECL_STMT_VAR): Likewise.

	* trans.c (gigi): Call start_block_stmt to make the outermost
	BLOCK_STMT.
	(gnat_to_code, gnu_to_gnu, tree_transform, process_decls, process_type):
	Call start_block_stmt and end_block_stmt temporarily.
	Use gnat_expand_stmt instead of expand_expr_stmt.
	(add_decl_stmt): New function.
	(tree_transform): Call it.
	(add_stmt): Also emit initializing assignment for DECL_STMT if needed.
	(end_block_stmt): Set type and NULL_STMT.
	(gnat_expand_stmt): Make recursize call instead of calling
	expand_expr_stmt.
	(gnat_expand_stmt, case DECL_STMT): New case.
	(set_lineno_from_sloc): Do nothing if global.
	(gnu_block_stmt_node, gnu_block_stmt_free_list): New variables.
	(start_block_stmt, add_stmt, end_block_stmt): New functions.
	(build_block_stmt): Call them.
	(gnat_to_code): Don't expand NULL_STMT.
	(build_unit_elab): Rename pushlevel and poplevel to gnat_* and change
	args.
	(tree_transform): Likewise.
	(tree_transform, case N_Null_Statement): Return NULL_STMT.
	(gnat_expand_stmt, case NULL_STMT): New case.
	(gnat_expand_stmt, case IF_STMT): Allow nested IF_STMT to have no
	IF_STMT_TRUE.

	* utils2.c (gnat_mark_addressable, case VAR_DECL): Do not set
	TREE_ADDRESSABLE.

	* utils.c (create_var_decl): Do not call expand_decl or
	expand_decl_init.
	Set TREE_ADDRESSABLE instead of calling gnat_mark_addressable.
	Set DECL_INIT_BY_ASSIGN_P when needed and do not generate MODIFY_EXPR
	here.
	(struct e_stack): Add chain_next to GTY.
	(struct binding_level): Deleted.
	(struct ada_binding_level): New struct.
	(free_block_chain): New.
	(global_binding_level, clear_binding_level): Deleted.
	(global_bindings_p): Rework to see if no chain.
	(kept_level_p, set_block): Deleted.
	(gnat_pushlevel): Renamed from pushlevel and extensive reworked to use
	new data structure and work directly on BLOCK node.
	(gnat_poplevel): Similarly.
	(get_decls): Look at BLOCK_VARS.
	(insert_block): Work directly on BLOCK node.
	(block_has_var): New function.
	(pushdecl): Rework for new binding structures.
	(gnat_init_decl_processing): Rename and rework calls to pushlevel and
	poplevel.
	(build_subprog_body): Likewise.
	(end_subprog_body): Likewise; also set up BLOCK in DECL_INITIAL.

	* ada-tree.def (DECL_STMT, NULL_STMT): New codes.

	* ada-tree.h: (DECL_INIT_BY_ASSIGN_P): New macro.
	(DECL_STMT_VAR): Likewise.

2004-05-17  Robert Dewar  <dewar@gnat.com>

	* restrict.ads, restrict.adb (Process_Restriction_Synonym): New
	procedure

	* sem_prag.adb (Analyze_Pragma, case Restrictions): Cleanup handling
	of restriction synonyums by using
	Restrict.Process_Restriction_Synonyms.

	* snames.ads, snames.adb: Add entries for Process_Restriction_Synonym

	* s-restri.ads (Tasking_Allowed): Correct missing comment

	* s-rident.ads: Add entries for restriction synonyms

	* ali.adb: Fix some problems with badly formatted ALI files that can
	result in infinite loops.

	* s-taprop-lynxos.adb, s-tpopsp-lynxos.adb, s-taprop-tru64.adb,
	s-tpopsp-posix-foreign.adb, s-taprop-irix.adb, s-interr-sigaction.adb,
	s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb,
	s-taprop-dummy.adb, s-interr-dummy.adb, s-taprop-os2.adb,
	s-taprop-solaris.adb, s-tpopsp-solaris.adb, s-asthan-vms.adb,
	s-inmaop-vms.adb, s-interr-vms.adb, s-taprop-vms.adb,
	s-tpopde-vms.adb, s-taprop-mingw.adb, s-interr-vxworks.adb,
	s-taprop-vxworks.adb, s-tpopsp-vxworks.adb, s-taprop-posix.adb,
	s-tpopsp-posix.adb, s-tratas-default.adb, a-dynpri.adb,
	a-tasatt.adb, a-taside.adb, a-taside.ads, exp_attr.adb,
	exp_ch9.adb, g-thread.adb, rtsfind.ads, sem_attr.adb,
	s-interr.adb, s-interr.ads, s-soflin.ads, s-taasde.adb,
	s-taasde.ads, s-taenca.adb, s-taenca.ads, s-taprop.ads,
	s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads,
	s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads,
	s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads,
	s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
	s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
	s-tpoben.adb, s-tpobop.adb, s-tpobop.ads, s-tporft.adb,
	s-tposen.adb, s-tposen.ads, s-tratas.adb, s-tratas.ads: Change Task_ID
	to Task_Id (minor cleanup).

2004-05-17  Vincent Celier  <celier@gnat.com>

	* g-os_lib.adb (Normalize_Pathname.Final_Value): Remove trailing
	directory separator.

	* prj-proc.adb (Recursive_Process): Inherit attribute Languages from
	project being extended, if Languages is not declared in extending
	project.

2004-05-17  Javier Miranda  <miranda@gnat.com>

	* sem_ch10.adb (Install_Limited_Withed_Unit): Do not install the
	limited view of a visible sibling.

From-SVN: r81935
This commit is contained in:
Arnaud Charlet 2004-05-17 15:20:48 +02:00
parent 646ca712a1
commit b5e792e209
91 changed files with 2149 additions and 1922 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

133
gcc/ada/ChangeLog
View file

@ -1,3 +1,136 @@
2004-05-17 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
Part of function-at-a-time conversion
* misc.c (adjust_decl_rtl): Deleted.
(LANG_HOOKS_PUSHLEVEL, LANG_HOOKS_POPLEVEL, LANG_HOOKS_SET_BLOCK):
Define.
* gigi.h: (adjust_decl_rtl, kept_level_p, set_block): Deleted.
(add_decl_stmt, add_stmt, block_has_vars): New functions.
(gnat_pushlevel, gnat_poplevel): Renamed from pushlevel and poplevel.
* decl.c (elaborate_expression, maybe_pad_type): Call add_decl_stmt
when making a decl.
(gnat_to_gnu_entity): Likewise.
Use add_stmt to update setjmp buffer.
Set TREE_ADDRESSABLE instead of calling put_var_into_stack and
flush_addressof.
No longer call adjust_decl_rtl.
(DECL_INIT_BY_ASSIGN_P): New macro.
(DECL_STMT_VAR): Likewise.
* trans.c (gigi): Call start_block_stmt to make the outermost
BLOCK_STMT.
(gnat_to_code, gnu_to_gnu, tree_transform, process_decls, process_type):
Call start_block_stmt and end_block_stmt temporarily.
Use gnat_expand_stmt instead of expand_expr_stmt.
(add_decl_stmt): New function.
(tree_transform): Call it.
(add_stmt): Also emit initializing assignment for DECL_STMT if needed.
(end_block_stmt): Set type and NULL_STMT.
(gnat_expand_stmt): Make recursize call instead of calling
expand_expr_stmt.
(gnat_expand_stmt, case DECL_STMT): New case.
(set_lineno_from_sloc): Do nothing if global.
(gnu_block_stmt_node, gnu_block_stmt_free_list): New variables.
(start_block_stmt, add_stmt, end_block_stmt): New functions.
(build_block_stmt): Call them.
(gnat_to_code): Don't expand NULL_STMT.
(build_unit_elab): Rename pushlevel and poplevel to gnat_* and change
args.
(tree_transform): Likewise.
(tree_transform, case N_Null_Statement): Return NULL_STMT.
(gnat_expand_stmt, case NULL_STMT): New case.
(gnat_expand_stmt, case IF_STMT): Allow nested IF_STMT to have no
IF_STMT_TRUE.
* utils2.c (gnat_mark_addressable, case VAR_DECL): Do not set
TREE_ADDRESSABLE.
* utils.c (create_var_decl): Do not call expand_decl or
expand_decl_init.
Set TREE_ADDRESSABLE instead of calling gnat_mark_addressable.
Set DECL_INIT_BY_ASSIGN_P when needed and do not generate MODIFY_EXPR
here.
(struct e_stack): Add chain_next to GTY.
(struct binding_level): Deleted.
(struct ada_binding_level): New struct.
(free_block_chain): New.
(global_binding_level, clear_binding_level): Deleted.
(global_bindings_p): Rework to see if no chain.
(kept_level_p, set_block): Deleted.
(gnat_pushlevel): Renamed from pushlevel and extensive reworked to use
new data structure and work directly on BLOCK node.
(gnat_poplevel): Similarly.
(get_decls): Look at BLOCK_VARS.
(insert_block): Work directly on BLOCK node.
(block_has_var): New function.
(pushdecl): Rework for new binding structures.
(gnat_init_decl_processing): Rename and rework calls to pushlevel and
poplevel.
(build_subprog_body): Likewise.
(end_subprog_body): Likewise; also set up BLOCK in DECL_INITIAL.
* ada-tree.def (DECL_STMT, NULL_STMT): New codes.
* ada-tree.h: (DECL_INIT_BY_ASSIGN_P): New macro.
(DECL_STMT_VAR): Likewise.
2004-05-17 Robert Dewar <dewar@gnat.com>
* restrict.ads, restrict.adb (Process_Restriction_Synonym): New
procedure
* sem_prag.adb (Analyze_Pragma, case Restrictions): Cleanup handling
of restriction synonyums by using
Restrict.Process_Restriction_Synonyms.
* snames.ads, snames.adb: Add entries for Process_Restriction_Synonym
* s-restri.ads (Tasking_Allowed): Correct missing comment
* s-rident.ads: Add entries for restriction synonyms
* ali.adb: Fix some problems with badly formatted ALI files that can
result in infinite loops.
* s-taprop-lynxos.adb, s-tpopsp-lynxos.adb, s-taprop-tru64.adb,
s-tpopsp-posix-foreign.adb, s-taprop-irix.adb, s-interr-sigaction.adb,
s-taprop-irix-athread.adb, s-taprop-hpux-dce.adb, s-taprop-linux.adb,
s-taprop-dummy.adb, s-interr-dummy.adb, s-taprop-os2.adb,
s-taprop-solaris.adb, s-tpopsp-solaris.adb, s-asthan-vms.adb,
s-inmaop-vms.adb, s-interr-vms.adb, s-taprop-vms.adb,
s-tpopde-vms.adb, s-taprop-mingw.adb, s-interr-vxworks.adb,
s-taprop-vxworks.adb, s-tpopsp-vxworks.adb, s-taprop-posix.adb,
s-tpopsp-posix.adb, s-tratas-default.adb, a-dynpri.adb,
a-tasatt.adb, a-taside.adb, a-taside.ads, exp_attr.adb,
exp_ch9.adb, g-thread.adb, rtsfind.ads, sem_attr.adb,
s-interr.adb, s-interr.ads, s-soflin.ads, s-taasde.adb,
s-taasde.ads, s-taenca.adb, s-taenca.ads, s-taprop.ads,
s-tarest.adb, s-tarest.ads, s-tasdeb.adb, s-tasdeb.ads,
s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads,
s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads,
s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
s-tpoben.adb, s-tpobop.adb, s-tpobop.ads, s-tporft.adb,
s-tposen.adb, s-tposen.ads, s-tratas.adb, s-tratas.ads: Change Task_ID
to Task_Id (minor cleanup).
2004-05-17 Vincent Celier <celier@gnat.com>
* g-os_lib.adb (Normalize_Pathname.Final_Value): Remove trailing
directory separator.
* prj-proc.adb (Recursive_Process): Inherit attribute Languages from
project being extended, if Languages is not declared in extending
project.
2004-05-17 Javier Miranda <miranda@gnat.com>
* sem_ch10.adb (Install_Limited_Withed_Unit): Do not install the
limited view of a visible sibling.
2004-05-14 Robert Dewar <dewar@gnat.com>
* gnat_ugn.texi: Minor change to -gnatS documentation

32
gcc/ada/a-dynpri.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -45,7 +45,7 @@ with System.Task_Primitives.Operations;
-- Self
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
@ -68,7 +68,7 @@ package body Ada.Dynamic_Priorities is
function Convert_Ids is new
Unchecked_Conversion
(Task_Identification.Task_Id, System.Tasking.Task_ID);
(Task_Identification.Task_Id, System.Tasking.Task_Id);
------------------
-- Get_Priority --
@ -78,10 +78,9 @@ package body Ada.Dynamic_Priorities is
function Get_Priority
(T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
return System.Any_Priority is
Target : constant Task_ID := Convert_Ids (T);
Ada.Task_Identification.Current_Task) return System.Any_Priority
is
Target : constant Task_Id := Convert_Ids (T);
Error_Message : constant String := "Trying to get the priority of a ";
begin
@ -106,11 +105,11 @@ package body Ada.Dynamic_Priorities is
procedure Set_Priority
(Priority : System.Any_Priority;
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
is
Target : constant Task_ID := Convert_Ids (T);
Self_ID : constant Task_ID := STPO.Self;
Target : constant Task_Id := Convert_Ids (T);
Self_ID : constant Task_Id := STPO.Self;
Error_Message : constant String := "Trying to set the priority of a ";
begin
@ -142,20 +141,23 @@ package body Ada.Dynamic_Priorities is
STPO.Unlock_RTS;
end if;
STPO.Yield;
-- Yield is needed to enforce FIFO task dispatching.
-- LL Set_Priority is made while holding the RTS lock so that
-- it is inheriting high priority until it release all the RTS
-- locks.
-- LL Set_Priority is made while holding the RTS lock so that it
-- is inheriting high priority until it release all the RTS locks.
-- If this is used in a system where Ceiling Locking is
-- not enforced we may end up getting two Yield effects.
STPO.Yield;
else
Target.New_Base_Priority := Priority;
Target.Pending_Priority_Change := True;
Target.Pending_Action := True;
STPO.Wakeup (Target, Target.Common.State);
-- If the task is suspended, wake it up to perform the change.
-- check for ceiling violations ???

20
gcc/ada/a-tasatt.adb
View file

@ -41,7 +41,7 @@
-- we settled on the present compromise. Things we do not like about
-- this implementation include:
-- - It is vulnerable to bad Task_ID values, to the extent of
-- - It is vulnerable to bad Task_Id values, to the extent of
-- possibly trashing memory and crashing the runtime system.
-- - It requires dynamic storage allocation for each new attribute value,
@ -228,7 +228,7 @@
with Ada.Task_Identification;
-- used for Task_Id
-- Null_Task_ID
-- Null_Task_Id
-- Current_Task
with System.Error_Reporting;
@ -244,7 +244,7 @@ with System.Task_Primitives.Operations;
with System.Tasking;
-- used for Access_Address
-- Task_ID
-- Task_Id
-- Direct_Index_Vector
-- Direct_Index
@ -336,8 +336,8 @@ package body Ada.Task_Attributes is
(Access_Wrapper, Access_Dummy_Wrapper);
-- To store pointer to actual wrapper of attribute node
function To_Task_ID is new Unchecked_Conversion
(Task_Identification.Task_Id, Task_ID);
function To_Task_Id is new Unchecked_Conversion
(Task_Identification.Task_Id, Task_Id);
-- To access TCB of identified task
type Local_Deallocator is access procedure (P : in out Access_Node);
@ -394,7 +394,7 @@ package body Ada.Task_Attributes is
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute_Handle
is
TT : constant Task_ID := To_Task_ID (T);
TT : constant Task_Id := To_Task_Id (T);
Error_Message : constant String := "Trying to get the reference of a ";
begin
@ -484,7 +484,7 @@ package body Ada.Task_Attributes is
procedure Reinitialize
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
TT : constant Task_ID := To_Task_ID (T);
TT : constant Task_Id := To_Task_Id (T);
Error_Message : constant String := "Trying to Reinitialize a ";
begin
@ -554,7 +554,7 @@ package body Ada.Task_Attributes is
(Val : Attribute;
T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
TT : constant Task_ID := To_Task_ID (T);
TT : constant Task_Id := To_Task_Id (T);
Error_Message : constant String := "Trying to Set the Value of a ";
begin
@ -643,7 +643,7 @@ package body Ada.Task_Attributes is
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute
is
TT : constant Task_ID := To_Task_ID (T);
TT : constant Task_Id := To_Task_Id (T);
Error_Message : constant String := "Trying to get the Value of a ";
begin
@ -782,7 +782,7 @@ begin
-- Initialize the attribute, for all tasks.
declare
C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
begin
while C /= null loop
C.Direct_Attributes (Local.Index) :=

12
gcc/ada/a-taside.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -55,8 +55,8 @@ package body Ada.Task_Identification is
-- Local Subprograms --
-----------------------
function Convert_Ids (T : Task_Id) return System.Tasking.Task_ID;
function Convert_Ids (T : System.Tasking.Task_ID) return Task_Id;
function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id;
function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id;
pragma Inline (Convert_Ids);
-- Conversion functions between different forms of Task_Id
@ -87,12 +87,12 @@ package body Ada.Task_Identification is
-- Convert_Ids --
-----------------
function Convert_Ids (T : Task_Id) return System.Tasking.Task_ID is
function Convert_Ids (T : Task_Id) return System.Tasking.Task_Id is
begin
return System.Tasking.Task_ID (T);
return System.Tasking.Task_Id (T);
end Convert_Ids;
function Convert_Ids (T : System.Tasking.Task_ID) return Task_Id is
function Convert_Ids (T : System.Tasking.Task_Id) return Task_Id is
begin
return Task_Id (T);
end Convert_Ids;

6
gcc/ada/a-taside.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -64,8 +64,8 @@ package Ada.Task_Identification is
private
type Task_Id is new System.Tasking.Task_ID;
type Task_Id is new System.Tasking.Task_Id;
Null_Task_ID : constant Task_Id := Task_Id (System.Tasking.Null_Task);
Null_Task_Id : constant Task_Id := Task_Id (System.Tasking.Null_Task);
end Ada.Task_Identification;

7
gcc/ada/ada-tree.def
View file

@ -86,6 +86,13 @@ DEFTREECODE (GNAT_LOOP_ID, "gnat_loop_id", 'x', 0)
the expression (such as a MODIFY_EXPR) and discarding its result. */
DEFTREECODE (EXPR_STMT, "expr_stmt", 's', 1)
/* This is a null statement. The intent is for it not to survive very far. */
DEFTREECODE (NULL_STMT, "null_stmt", 's', 0)
/* This defines the variable in DECL_STMT_VAR and performs any initialization
in DECL_INITIAL. */
DEFTREECODE (DECL_STMT, "decl_stmt", 's', 1)
/* This represents a list of statements. BLOCK_STMT_LIST is a list
statement tree, chained via TREE_CHAIN. */
DEFTREECODE (BLOCK_STMT, "block_stmt", 's', 1)

4
gcc/ada/ada-tree.h
View file

@ -238,6 +238,9 @@ struct lang_type GTY(())
discriminant. */
#define DECL_STUBBED_P(NODE) DECL_LANG_FLAG_0 (FUNCTION_DECL_CHECK (NODE))
/* Nonzero in a VAR_DECL if it needs to be initialized by an assignment. */
#define DECL_INIT_BY_ASSIGN_P(NODE) DECL_LANG_FLAG_0 (VAR_DECL_CHECK (NODE))
/* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF
is needed to access the object. */
#define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE)
@ -295,6 +298,7 @@ struct lang_type GTY(())
#define TREE_SLOC(NODE) TREE_COMPLEXITY (STMT_CHECK (NODE))
#define EXPR_STMT_EXPR(NODE) TREE_OPERAND_CHECK_CODE (NODE, EXPR_STMT, 0)
#define DECL_STMT_VAR(NODE) TREE_OPERAND_CHECK_CODE (NODE, DECL_STMT, 0)
#define BLOCK_STMT_LIST(NODE) TREE_OPERAND_CHECK_CODE (NODE, BLOCK_STMT, 0)
#define IF_STMT_COND(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 0)
#define IF_STMT_TRUE(NODE) TREE_OPERAND_CHECK_CODE (NODE, IF_STMT, 1)

3
gcc/ada/ali.adb
View file

@ -282,6 +282,7 @@ package body ALI is
loop
if C = CR or else C = LF then
Skip_Line;
C := Nextc;
elsif C = EOF then
return;
@ -788,6 +789,7 @@ package body ALI is
Fatal_Error;
else
Skip_Line;
C := Nextc;
end if;
else
Fatal_Error;
@ -948,6 +950,7 @@ package body ALI is
Fatal_Error;
else
Skip_Line;
C := Nextc;
end if;
else
Fatal_Error;

70
gcc/ada/decl.c
View file

@ -960,6 +960,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, gnu_expr,
0, 0, 0, 0, 0);
add_decl_stmt (gnu_new_var, gnat_entity);
if (gnu_expr != 0)
expand_expr_stmt
@ -1041,6 +1042,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (Present (Address_Clause (gnat_entity)) && used_by_ref)
DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
add_decl_stmt (gnu_decl, gnat_entity);
if (definition && DECL_SIZE (gnu_decl) != 0
&& gnu_block_stack != 0
&& TREE_VALUE (gnu_block_stack) != 0
@ -1048,11 +1051,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| (flag_stack_check && ! STACK_CHECK_BUILTIN
&& 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
STACK_CHECK_MAX_VAR_SIZE))))
expand_expr_stmt
(build_call_1_expr (update_setjmp_buf_decl,
build_unary_op
(ADDR_EXPR, NULL_TREE,
TREE_VALUE (gnu_block_stack))));
{
tree gnu_stmt
= build_nt (EXPR_STMT,
(build_call_1_expr
(update_setjmp_buf_decl,
build_unary_op
(ADDR_EXPR, NULL_TREE,
TREE_VALUE (gnu_block_stack)))));
TREE_SLOC (gnu_stmt) = Sloc (gnat_entity);
TREE_TYPE (gnu_stmt) = void_type_node;
add_stmt (gnu_stmt);
}
/* If this is a public constant or we're not optimizing and we're not
making a VAR_DECL for it, make one just for export or debugger
@ -1064,21 +1075,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
|| Is_Aliased (Etype (gnat_entity))))
SET_DECL_CONST_CORRESPONDING_VAR
(gnu_decl,
create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0));
{
tree gnu_corr_var
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0);
add_decl_stmt (gnu_corr_var, gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
/* If this is declared in a block that contains an block with an
exception handler, we must force this variable in memory to
suppress an invalid optimization. */
if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
&& Exception_Mechanism != GCC_ZCX)
{
gnat_mark_addressable (gnu_decl);
flush_addressof (gnu_decl);
}
TREE_ADDRESSABLE (gnu_decl) = 1;
/* Back-annotate the Alignment of the object if not already in the
tree. Likewise for Esize if the object is of a constant size.
@ -1152,6 +1164,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
= create_var_decl (get_entity_name (gnat_literal),
0, gnu_type, gnu_value, 1, 0, 0, 0, 0);
add_decl_stmt (gnu_literal, gnat_literal);
save_gnu_tree (gnat_literal, gnu_literal, 0);
gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
gnu_value, gnu_literal_list);
@ -3604,6 +3617,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_address, 0, Is_Public (gnat_entity),
extern_flag, 0, 0);
DECL_BY_REF_P (gnu_decl) = 1;
add_decl_stmt (gnu_decl, gnat_entity);
}
else if (kind == E_Subprogram_Type)
@ -3898,6 +3912,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
else
TREE_TYPE (gnu_decl) = gnu_type;
add_decl_stmt (gnu_decl, gnat_entity);
}
if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
@ -3959,10 +3975,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& TREE_CODE (gnu_decl) != FUNCTION_DECL)
DECL_IGNORED_P (gnu_decl) = 1;
/* If this decl is really indirect, adjust it. */
if (TREE_CODE (gnu_decl) == VAR_DECL)
adjust_decl_rtl (gnu_decl);
/* If we haven't already, associate the ..._DECL node that we just made with
the input GNAT entity node. */
if (! saved)
@ -4534,6 +4546,7 @@ elaborate_expression_1 (Node_Id gnat_expr,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
Is_Public (gnat_entity), ! definition, 0, 0);
add_decl_stmt (gnu_decl, gnat_entity);
}
/* We only need to use this variable if we are in global context since GCC
@ -4679,14 +4692,9 @@ make_packable_type (tree type)
type. */
static tree
maybe_pad_type (tree type,
tree size,
unsigned int align,
Entity_Id gnat_entity,
const char *name_trailer,
int is_user_type,
int definition,
int same_rm_size)
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, const char *name_trailer,
int is_user_type, int definition, int same_rm_size)
{
tree orig_size = TYPE_SIZE (type);
tree record;
@ -4812,9 +4820,13 @@ maybe_pad_type (tree type,
0, 0);
if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
sizetype, TYPE_SIZE (record), 0, 0, 0, 0,
0);
{
tree gnu_xvz
= create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
sizetype, TYPE_SIZE (record), 0, 0, 0, 0, 0);
add_decl_stmt (gnu_xvz, gnat_entity);
}
}
type = record;

6
gcc/ada/exp_attr.adb
View file

@ -1012,7 +1012,7 @@ package body Exp_Attr is
-- Task_Entry_Caller or the Protected_Entry_Caller function.
when Attribute_Caller => Caller : declare
Id_Kind : constant Entity_Id := RTE (RO_AT_Task_ID);
Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
Ent : constant Entity_Id := Entity (Pref);
Conctype : constant Entity_Id := Scope (Ent);
Nest_Depth : Integer := 0;
@ -1662,7 +1662,7 @@ package body Exp_Attr is
-- For a task it returns a reference to the _task_id component of
-- corresponding record:
-- taskV!(Prefix)._Task_Id, converted to the type Task_ID defined
-- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
-- in Ada.Task_Identification.
@ -1680,7 +1680,7 @@ package body Exp_Attr is
Rewrite (N,
Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
else
Id_Kind := RTE (RO_AT_Task_ID);
Id_Kind := RTE (RO_AT_Task_Id);
Rewrite (N,
Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));

4
gcc/ada/exp_ch9.adb
View file

@ -2794,7 +2794,7 @@ package body Exp_Ch9 is
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => T_Self,
Object_Definition =>
New_Occurrence_Of (RTE (RO_ST_Task_ID), Loc),
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Self), Loc)));
@ -7223,7 +7223,7 @@ package body Exp_Ch9 is
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_ID),
Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id),
Loc))));
-- Add components for entry families

22
gcc/ada/g-os_lib.adb
View file

@ -1547,6 +1547,8 @@ package body GNAT.OS_Lib is
S1 : String := S;
-- We may need to fold S to lower case, so we need a variable
Last : Natural;
begin
-- Interix has the non standard notion of disk drive
-- indicated by two '/' followed by a capital letter
@ -1566,23 +1568,37 @@ package body GNAT.OS_Lib is
begin
Result (1) := '/';
Result (2 .. Result'Last) := S;
Last := Result'Last;
if Fold_To_Lower_Case then
System.Case_Util.To_Lower (Result);
end if;
return Result;
-- Remove trailing directory separator, if any
if Result (Last) = '/' or else
Result (Last) = Directory_Separator
then
Last := Last - 1;
end if;
return Result (1 .. Last);
end;
else
if Fold_To_Lower_Case then
System.Case_Util.To_Lower (S1);
end if;
return S1;
-- Remove trailing directory separator, if any
Last := S1'Last;
if S1 (Last) = '/' or else S1 (Last) = Directory_Separator then
Last := Last - 1;
end if;
return S1 (1 .. Last);
end if;
end Final_Value;

8
gcc/ada/g-thread.adb
View file

@ -53,7 +53,7 @@ package body GNAT.Threads is
function To_Addr is new Unchecked_Conversion (Task_Id, Address);
function To_Id is new Unchecked_Conversion (Address, Task_Id);
function To_Id is new Unchecked_Conversion (Address, Tasking.Task_ID);
function To_Id is new Unchecked_Conversion (Address, Tasking.Task_Id);
function To_Tid is new Unchecked_Conversion
(Address, Ada.Task_Identification.Task_Id);
function To_Thread is new Unchecked_Conversion (Address, Thread_Id_Ptr);
@ -112,7 +112,7 @@ package body GNAT.Threads is
-----------------------
procedure Unregister_Thread is
Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
Self_Id : constant Tasking.Task_Id := Task_Primitives.Operations.Self;
begin
Self_Id.Common.State := Tasking.Terminated;
Destroy_TSD (Self_Id.Common.Compiler_Data);
@ -125,9 +125,9 @@ package body GNAT.Threads is
procedure Unregister_Thread_Id (Thread : System.Address) is
Thr : constant Thread_Id := To_Thread (Thread).all;
T : Tasking.Task_ID;
T : Tasking.Task_Id;
use type Tasking.Task_ID;
use type Tasking.Task_Id;
begin
STPO.Lock_RTS;

42
gcc/ada/gigi.h
View file

@ -36,11 +36,6 @@ extern unsigned int largest_move_alignment;
/* Declare all functions and types used by gigi. */
/* See if DECL has an RTL that is indirect via a pseudo-register or a
memory location and replace it with an indirect reference if so.
This improves the debugger's ability to display the value. */
extern void adjust_decl_rtl (tree);
/* Record the current code position in GNAT_NODE. */
extern void record_code_position (Node_Id);
@ -94,6 +89,13 @@ extern tree gnat_to_gnu_entity (Entity_Id, tree, int);
refer to an Ada type. */
extern tree gnat_to_gnu_type (Entity_Id);
/* Add GNU_STMT to the current BLOCK_STMT node. */
extern void add_stmt (tree);
/* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node.
Get SLOC from Entity_Id. */
extern void add_decl_stmt (tree, Entity_Id);
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
extern void elaborate_entity (Entity_Id);
@ -381,37 +383,17 @@ extern int global_bindings_p (void);
is in reverse order (it has to be so for back-end compatibility). */
extern tree getdecls (void);
/* Nonzero if the current level needs to have a BLOCK made. */
extern int kept_level_p (void);
/* Enter a new binding level. The input parameter is ignored, but has to be
specified for back-end compatibility. */
extern void pushlevel (int);
/* Exit a binding level.
Pop the level off, and restore the state of the identifier-decl mappings
that were in effect when this level was entered.
If KEEP is nonzero, this level had explicit declarations, so
and create a "block" (a BLOCK node) for the level
to record its declarations and subblocks for symbol table output.
If FUNCTIONBODY is nonzero, this level is the body of a function,
so create a block as if KEEP were set and also clear out all
label names.
If REVERSE is nonzero, reverse the order of decls before putting
them into the BLOCK. */
extern tree poplevel (int, int, int);
/* Enter and exit a new binding level. */
extern void gnat_pushlevel (void);
extern void gnat_poplevel (void);
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
to handle the BLOCK node inside the BIND_EXPR. */
extern void insert_block (tree);
/* Set the BLOCK node for the innermost scope
(the one we are currently in). */
extern void set_block (tree);
/* Return nonzero if the are any variables in the current block. */
extern int block_has_vars (void);
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */

66
gcc/ada/misc.c
View file

@ -121,6 +121,12 @@ static void gnat_adjust_rli (record_layout_info);
#define LANG_HOOKS_HONOR_READONLY true
#undef LANG_HOOKS_HASH_TYPES
#define LANG_HOOKS_HASH_TYPES false
#undef LANG_HOOKS_PUSHLEVEL
#define LANG_HOOKS_PUSHLEVEL lhd_do_nothing_i
#undef LANG_HOOKS_POPLEVEL
#define LANG_HOOKS_POPLEVEL lhd_do_nothing_iii_return_null_tree
#undef LANG_HOOKS_SET_BLOCK
#define LANG_HOOKS_SET_BLOCK lhd_do_nothing_t
#undef LANG_HOOKS_FINISH_INCOMPLETE_DECL
#define LANG_HOOKS_FINISH_INCOMPLETE_DECL gnat_finish_incomplete_decl
#undef LANG_HOOKS_GET_ALIAS_SET
@ -698,66 +704,6 @@ gnat_eh_type_covers (tree a, tree b)
return (a == b || a == integer_zero_node);
}
/* See if DECL has an RTL that is indirect via a pseudo-register or a
memory location and replace it with an indirect reference if so.
This improves the debugger's ability to display the value. */
void
adjust_decl_rtl (tree decl)
{
tree new_type;
/* If this decl is already indirect, don't do anything. This should
mean that the decl cannot be indirect, but there's no point in
adding an abort to check that. */
if (TREE_CODE (decl) != CONST_DECL
&& ! DECL_BY_REF_P (decl)
&& (GET_CODE (DECL_RTL (decl)) == MEM
&& (GET_CODE (XEXP (DECL_RTL (decl), 0)) == MEM
|| (GET_CODE (XEXP (DECL_RTL (decl), 0)) == REG
&& (REGNO (XEXP (DECL_RTL (decl), 0))
> LAST_VIRTUAL_REGISTER))))
/* We can't do this if the reference type's mode is not the same
as the current mode, which means this may not work on mixed 32/64
bit systems. */
&& (new_type = build_reference_type (TREE_TYPE (decl))) != 0
&& TYPE_MODE (new_type) == GET_MODE (XEXP (DECL_RTL (decl), 0))
/* If this is a PARM_DECL, we can only do it if DECL_INCOMING_RTL
is also an indirect and of the same mode and if the object is
readonly, the latter condition because we don't want to upset the
handling of CICO_LIST. */
&& (TREE_CODE (decl) != PARM_DECL
|| (GET_CODE (DECL_INCOMING_RTL (decl)) == MEM
&& (TYPE_MODE (new_type)
== GET_MODE (XEXP (DECL_INCOMING_RTL (decl), 0)))
&& TREE_READONLY (decl))))
{
new_type
= build_qualified_type (new_type,
(TYPE_QUALS (new_type) | TYPE_QUAL_CONST));
DECL_POINTS_TO_READONLY_P (decl) = TREE_READONLY (decl);
DECL_BY_REF_P (decl) = 1;
SET_DECL_RTL (decl, XEXP (DECL_RTL (decl), 0));
TREE_TYPE (decl) = new_type;
DECL_MODE (decl) = TYPE_MODE (new_type);
DECL_ALIGN (decl) = TYPE_ALIGN (new_type);
DECL_SIZE (decl) = TYPE_SIZE (new_type);
if (TREE_CODE (decl) == PARM_DECL)
set_decl_incoming_rtl (decl, XEXP (DECL_INCOMING_RTL (decl), 0));
/* If DECL_INITIAL was set, it should be updated to show that
the decl is initialized to the address of that thing.
Otherwise, just set it to the address of this decl.
It needs to be set so that GCC does not think the decl is
unused. */
DECL_INITIAL (decl)
= build1 (ADDR_EXPR, new_type,
DECL_INITIAL (decl) != 0 ? DECL_INITIAL (decl) : decl);
}
}
/* Record the current code position in GNAT_NODE. */
void

63
gcc/ada/prj-proc.adb
View file

@ -34,6 +34,7 @@ with Prj.Com; use Prj.Com;
with Prj.Err; use Prj.Err;
with Prj.Ext; use Prj.Ext;
with Prj.Nmsc; use Prj.Nmsc;
with Snames;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.HTable;
@ -1847,11 +1848,10 @@ package body Prj.Proc is
else
declare
Processed_Data : Project_Data := Empty_Project;
Imported : Project_List := Empty_Project_List;
Declaration_Node : Project_Node_Id := Empty_Node;
Name : constant Name_Id :=
Name_Of (From_Project_Node);
Processed_Data : Project_Data := Empty_Project;
Imported : Project_List := Empty_Project_List;
Declaration_Node : Project_Node_Id := Empty_Node;
Name : constant Name_Id := Name_Of (From_Project_Node);
begin
Project := Processed_Projects.Get (Name);
@ -1958,7 +1958,8 @@ package body Prj.Proc is
-- If it is an extending project, inherit all packages
-- from the extended project that are not explicitely defined
-- or renamed.
-- or renamed. Also inherit the languages, if attribute Languages
-- is not explicitely defined.
if Processed_Data.Extends /= No_Project then
Processed_Data := Projects.Table (Project);
@ -1971,6 +1972,10 @@ package body Prj.Proc is
Element : Package_Element;
First : constant Package_Id :=
Processed_Data.Decl.Packages;
Attribute1 : Variable_Id;
Attribute2 : Variable_Id;
Attr_Value1 : Variable;
Attr_Value2 : Variable;
begin
while Extended_Pkg /= No_Package loop
@ -1998,6 +2003,52 @@ package body Prj.Proc is
Extended_Pkg := Element.Next;
end loop;
-- Check if attribute Languages is declared in the
-- extending project.
Attribute1 := Processed_Data.Decl.Attributes;
while Attribute1 /= No_Variable loop
Attr_Value1 := Variable_Elements.Table (Attribute1);
exit when Attr_Value1.Name = Snames.Name_Languages;
Attribute1 := Attr_Value1.Next;
end loop;
if Attribute1 = No_Variable or else
Attr_Value1.Value.Default
then
-- Attribute Languages is not declared in the extending
-- project. Check if it is declared in the project being
-- extended.
Attribute2 :=
Projects.Table (Processed_Data.Extends).Decl.Attributes;
while Attribute2 /= No_Variable loop
Attr_Value2 := Variable_Elements.Table (Attribute2);
exit when Attr_Value2.Name = Snames.Name_Languages;
Attribute2 := Attr_Value2.Next;
end loop;
if Attribute2 /= No_Variable and then
not Attr_Value2.Value.Default
then
-- As attribute Languages is declared in the project
-- being extended, copy its value for the extending
-- project.
if Attribute1 = No_Variable then
Variable_Elements.Increment_Last;
Attribute1 := Variable_Elements.Last;
Attr_Value1.Next := Processed_Data.Decl.Attributes;
Processed_Data.Decl.Attributes := Attribute1;
end if;
Attr_Value1.Name := Snames.Name_Languages;
Attr_Value1.Value := Attr_Value2.Value;
Variable_Elements.Table (Attribute1) := Attr_Value1;
end if;
end if;
end;
Projects.Table (Project) := Processed_Data;

31
gcc/ada/restrict.adb
View file

@ -32,6 +32,7 @@ with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;
with Sinput; use Sinput;
with Snames; use Snames;
with Uname; use Uname;
package body Restrict is
@ -353,6 +354,36 @@ package body Restrict is
return Restrictions.Set (No_Exception_Handlers);
end No_Exception_Handlers_Set;
----------------------------------
-- Process_Restriction_Synonyms --
----------------------------------
-- Note: body of this function must be coordinated with list of
-- renaming declarations in System.Rident.
function Process_Restriction_Synonyms (Id : Name_Id) return Name_Id is
begin
case Id is
when Name_Boolean_Entry_Barriers =>
return Name_Simple_Barriers;
when Name_Max_Entry_Queue_Depth =>
return Name_Max_Entry_Queue_Length;
when Name_No_Dynamic_Interrupts =>
return Name_No_Dynamic_Attachment;
when Name_No_Requeue =>
return Name_No_Requeue_Statements;
when Name_No_Task_Attributes =>
return Name_No_Task_Attributes_Package;
when others =>
return Id;
end case;
end Process_Restriction_Synonyms;
------------------------
-- Restricted_Profile --
------------------------

6
gcc/ada/restrict.ads
View file

@ -200,6 +200,12 @@ package Restrict is
-- handlers are present. This function is called by Gigi when it needs to
-- expand an AT END clean up identifier with no exception handler.
function Process_Restriction_Synonyms (Id : Name_Id) return Name_Id;
-- Id is the name of a restriction. If it is one of synonyms that we
-- allow for historical purposes (for list see System.Rident), then
-- the proper official name is returned. Otherwise the argument is
-- returned unchanged.
function Restriction_Active (R : All_Restrictions) return Boolean;
pragma Inline (Restriction_Active);
-- Determines if a given restriction is active. This call should only be

8
gcc/ada/rtsfind.ads
View file

@ -489,7 +489,7 @@ package Rtsfind is
RE_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification
RO_AT_Task_ID, -- Ada.Task_Identification
RO_AT_Task_Id, -- Ada.Task_Identification
RO_CA_Time, -- Ada.Calendar
@ -1256,7 +1256,7 @@ package Rtsfind is
RE_Task_Procedure_Access, -- System.Tasking
RO_ST_Task_ID, -- System.Tasking
RO_ST_Task_Id, -- System.Tasking
RE_Call_Modes, -- System.Tasking
RE_Simple_Call, -- System.Tasking
@ -1561,7 +1561,7 @@ package Rtsfind is
RE_Abort_Task => Ada_Task_Identification,
RE_Current_Task => Ada_Task_Identification,
RO_AT_Task_ID => Ada_Task_Identification,
RO_AT_Task_Id => Ada_Task_Identification,
RO_CA_Time => Ada_Calendar,
RO_CA_Delay_For => Ada_Calendar_Delays,
@ -2326,7 +2326,7 @@ package Rtsfind is
RE_Task_Procedure_Access => System_Tasking,
RO_ST_Task_ID => System_Tasking,
RO_ST_Task_Id => System_Tasking,
RE_Call_Modes => System_Tasking,
RE_Simple_Call => System_Tasking,

16
gcc/ada/s-asthan-vms.adb
View file

@ -79,11 +79,11 @@ package body System.AST_Handling is
-- from all other AST tasks. It is only used by Lock_AST and
-- Unlock_AST.
procedure Lock_AST (Self_ID : ST.Task_ID);
procedure Lock_AST (Self_ID : ST.Task_Id);
-- Locks out other AST tasks. Preceding a section of code by Lock_AST and
-- following it by Unlock_AST creates a critical region.
procedure Unlock_AST (Self_ID : ST.Task_ID);
procedure Unlock_AST (Self_ID : ST.Task_Id);
-- Releases lock previously set by call to Lock_AST.
-- All nested locks must be released before other tasks competing for the
-- tasking lock are released.
@ -92,7 +92,7 @@ package body System.AST_Handling is
-- Lock_AST --
--------------
procedure Lock_AST (Self_ID : ST.Task_ID) is
procedure Lock_AST (Self_ID : ST.Task_Id) is
begin
STI.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
@ -102,7 +102,7 @@ package body System.AST_Handling is
-- Unlock_AST --
----------------
procedure Unlock_AST (Self_ID : ST.Task_ID) is
procedure Unlock_AST (Self_ID : ST.Task_Id) is
begin
STPO.Unlock (AST_Lock'Access, Global_Lock => True);
STI.Undefer_Abort_Nestable (Self_ID);
@ -287,7 +287,7 @@ package body System.AST_Handling is
Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
-- An array of flags showing which AST server tasks are currently waiting
AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_ID;
AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
-- Task Id's of allocated AST server tasks
task type AST_Server_Task (Num : Natural) is
@ -344,7 +344,7 @@ package body System.AST_Handling is
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : aliased Long_Integer;
Self_Id : constant ST.Task_ID := ST.Self;
Self_Id : constant ST.Task_Id := ST.Self;
pragma Volatile (Param);
@ -421,7 +421,7 @@ package body System.AST_Handling is
P : AA := Param'Unrestricted_Access;
function To_ST_Task_Id is new Ada.Unchecked_Conversion
(ATID.Task_Id, ST.Task_ID);
(ATID.Task_Id, ST.Task_Id);
begin
Unlock_AST (Self_Id);
@ -546,7 +546,7 @@ package body System.AST_Handling is
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
(ST.Task_ID, System.Address);
(ST.Task_Id, System.Address);
begin
System.Machine_Code.Asm

4
gcc/ada/s-inmaop-vms.adb
View file

@ -59,7 +59,7 @@ package body System.Interrupt_Management.Operations is
use System.Tasking;
use type unsigned_short;
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
package POP renames System.Task_Primitives.Operations;
----------------------------
@ -122,7 +122,7 @@ package body System.Interrupt_Management.Operations is
function Interrupt_Wait (Mask : access Interrupt_Mask)
return Interrupt_ID
is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
Iosb : IO_Status_Block_Type := (0, 0, 0);
Status : Cond_Value_Type;

8
gcc/ada/s-interr-dummy.adb
View file

@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- 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- --
@ -71,7 +71,7 @@ package body System.Interrupts is
-----------------------------
procedure Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
is
@ -117,7 +117,7 @@ package body System.Interrupts is
-- Detach_Interrupt_Entries --
------------------------------
procedure Detach_Interrupt_Entries (T : Task_ID) is
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
Unimplemented;
end Detach_Interrupt_Entries;
@ -278,7 +278,7 @@ package body System.Interrupts is
------------------
function Unblocked_By (Interrupt : Interrupt_ID)
return System.Tasking.Task_ID is
return System.Tasking.Task_Id is
begin
Unimplemented;
return null;

16
gcc/ada/s-interr-sigaction.adb
View file

@ -87,13 +87,13 @@ package body System.Interrupts is
subtype int is Interfaces.C.int;
function To_System is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_ID);
(Ada.Task_Identification.Task_Id, Task_Id);
type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
type Handler_Desc is record
Kind : Handler_Kind := Unknown;
T : Task_ID;
T : Task_Id;
E : Task_Entry_Index;
H : Parameterless_Handler;
Static : Boolean := False;
@ -106,7 +106,7 @@ package body System.Interrupts is
type Server_Task_Access is access Server_Task;
Attached_Interrupts : array (Interrupt_ID) of Boolean;
Handlers : array (Interrupt_ID) of Task_ID;
Handlers : array (Interrupt_ID) of Task_Id;
Descriptors : array (Interrupt_ID) of Handler_Desc;
Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
@ -150,7 +150,7 @@ package body System.Interrupts is
function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
procedure Signal_Handler (Sig : Interrupt_ID) is
Handler : Task_ID renames Handlers (Sig);
Handler : Task_Id renames Handlers (Sig);
begin
if Intr_Attach_Reset and then
intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
@ -215,7 +215,7 @@ package body System.Interrupts is
-- Unblocked_By --
------------------
function Unblocked_By (Interrupt : Interrupt_ID) return Task_ID is
function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
begin
raise Program_Error;
return Null_Task;
@ -532,7 +532,7 @@ package body System.Interrupts is
-----------------------------
procedure Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
is
@ -580,7 +580,7 @@ package body System.Interrupts is
-- Detach_Interrupt_Entries --
------------------------------
procedure Detach_Interrupt_Entries (T : Task_ID) is
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
for I in Interrupt_ID loop
if not Is_Reserved (I) then
@ -631,7 +631,7 @@ package body System.Interrupts is
task body Server_Task is
Desc : Handler_Desc renames Descriptors (Interrupt);
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Temp : Parameterless_Handler;
begin

38
gcc/ada/s-interr-vms.adb
View file

@ -49,7 +49,7 @@
-- rendezvous.
with Ada.Task_Identification;
-- used for Task_ID type
-- used for Task_Id type
with Ada.Exceptions;
-- used for Raise_Exception
@ -100,7 +100,7 @@ with System.Storage_Elements;
-- Integer_Address
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
@ -134,7 +134,7 @@ package body System.Interrupts is
package IMOP renames System.Interrupt_Management.Operations;
function To_System is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_ID);
(Ada.Task_Identification.Task_Id, Task_Id);
-----------------
-- Local Tasks --
@ -145,7 +145,7 @@ package body System.Interrupts is
-- nizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_ID);
entry Detach_Interrupt_Entries (T : Task_Id);
entry Initialize (Mask : IMNG.Interrupt_Mask);
@ -166,7 +166,7 @@ package body System.Interrupts is
Static : Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
@ -197,7 +197,7 @@ package body System.Interrupts is
--------------------------------
type Entry_Assoc is record
T : Task_ID;
T : Task_Id;
E : Task_Entry_Index;
end record;
@ -228,18 +228,18 @@ package body System.Interrupts is
pragma Volatile_Components (Ignored);
-- True iff the corresponding interrupt is blocked in the process level
Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID :=
Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
-- ??? pragma Volatile_Components (Last_Unblocker);
-- Holds the ID of the last Task which Unblocked this Interrupt.
-- It contains Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.
Server_ID : array (Interrupt_ID'Range) of Task_ID :=
Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
pragma Atomic_Components (Server_ID);
-- Holds the Task_ID of the Server_Task for each interrupt.
-- Task_ID is needed to accomplish locking per Interrupt base. Also
-- Holds the Task_Id of the Server_Task for each interrupt.
-- Task_Id is needed to accomplish locking per Interrupt base. Also
-- is needed to decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt
@ -523,7 +523,7 @@ package body System.Interrupts is
-- already bound.
procedure Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
is
@ -544,7 +544,7 @@ package body System.Interrupts is
-- Detach_Interrupt_Entries --
------------------------------
procedure Detach_Interrupt_Entries (T : Task_ID) is
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
Interrupt_Manager.Detach_Interrupt_Entries (T);
end Detach_Interrupt_Entries;
@ -582,7 +582,7 @@ package body System.Interrupts is
------------------
function Unblocked_By
(Interrupt : Interrupt_ID) return System.Tasking.Task_ID is
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@ -708,7 +708,7 @@ package body System.Interrupts is
end if;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task then
Access_Hold := new Server_Task (Interrupt);
@ -846,7 +846,7 @@ package body System.Interrupts is
end Detach_Handler;
or accept Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
@ -875,7 +875,7 @@ package body System.Interrupts is
T.Interrupt_Entry := True;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task then
@ -888,7 +888,7 @@ package body System.Interrupts is
end if;
end Bind_Interrupt_To_Entry;
or accept Detach_Interrupt_Entries (T : Task_ID)
or accept Detach_Interrupt_Entries (T : Task_Id)
do
for J in Interrupt_ID'Range loop
if not Is_Reserved (J) then
@ -951,9 +951,9 @@ package body System.Interrupts is
-----------------
task body Server_Task is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_ID : Task_Id;
Tmp_Entry_Index : Task_Entry_Index;
Intwait_Mask : aliased IMNG.Interrupt_Mask;

38
gcc/ada/s-interr-vxworks.adb
View file

@ -72,7 +72,7 @@ with System.OS_Interface; use System.OS_Interface;
with Interfaces.VxWorks;
with Ada.Task_Identification;
-- used for Task_ID type
-- used for Task_Id type
with Ada.Exceptions;
-- used for Raise_Exception
@ -94,7 +94,7 @@ with System.Storage_Elements;
-- Integer_Address
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
@ -115,10 +115,10 @@ package body System.Interrupts is
package POP renames System.Task_Primitives.Operations;
function To_Ada is new Unchecked_Conversion
(System.Tasking.Task_ID, Ada.Task_Identification.Task_Id);
(System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
function To_System is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_ID);
(Ada.Task_Identification.Task_Id, Task_Id);
-----------------
-- Local Tasks --
@ -129,7 +129,7 @@ package body System.Interrupts is
-- nizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_ID);
entry Detach_Interrupt_Entries (T : Task_Id);
entry Attach_Handler
(New_Handler : Parameterless_Handler;
@ -148,7 +148,7 @@ package body System.Interrupts is
Static : Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
@ -168,7 +168,7 @@ package body System.Interrupts is
-------------------------------
type Entry_Assoc is record
T : Task_ID;
T : Task_Id;
E : Task_Entry_Index;
end record;
@ -204,11 +204,11 @@ package body System.Interrupts is
Registered_Handler_Head : R_Link := null;
Registered_Handler_Tail : R_Link := null;
Server_ID : array (Interrupt_ID) of System.Tasking.Task_ID :=
Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
(others => System.Tasking.Null_Task);
pragma Atomic_Components (Server_ID);
-- Holds the Task_ID of the Server_Task for each interrupt / signal.
-- Task_ID is needed to accomplish locking per interrupt base. Also
-- Holds the Task_Id of the Server_Task for each interrupt / signal.
-- Task_Id is needed to accomplish locking per interrupt base. Also
-- is needed to determine whether to create a new Server_Task.
Semaphore_ID_Map : array
@ -290,7 +290,7 @@ package body System.Interrupts is
-- already bound.
procedure Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
is
@ -365,7 +365,7 @@ package body System.Interrupts is
-- Detach_Interrupt_Entries --
------------------------------
procedure Detach_Interrupt_Entries (T : Task_ID) is
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
Interrupt_Manager.Detach_Interrupt_Entries (T);
end Detach_Interrupt_Entries;
@ -727,7 +727,7 @@ package body System.Interrupts is
------------------
function Unblocked_By
(Interrupt : Interrupt_ID) return System.Tasking.Task_ID is
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id is
begin
Unimplemented ("Unblocked_By");
return Null_Task;
@ -918,7 +918,7 @@ package body System.Interrupts is
end if;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if New_Handler /= null
and then
@ -992,7 +992,7 @@ package body System.Interrupts is
end Detach_Handler;
or
accept Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
@ -1017,7 +1017,7 @@ package body System.Interrupts is
T.Interrupt_Entry := True;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task
or else
@ -1034,7 +1034,7 @@ package body System.Interrupts is
end Bind_Interrupt_To_Entry;
or
accept Detach_Interrupt_Entries (T : Task_ID) do
accept Detach_Interrupt_Entries (T : Task_Id) do
for Int in Interrupt_ID'Range loop
if not Is_Reserved (Int) then
if User_Entry (Int).T = T then
@ -1079,9 +1079,9 @@ package body System.Interrupts is
-- Server task for vectored hardware interrupt handling
task body Interrupt_Server_Task is
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_ID : Task_Id;
Tmp_Entry_Index : Task_Entry_Index;
S : STATUS;

40
gcc/ada/s-interr.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -55,7 +55,7 @@
-- one Server_Task per interrupt.
with Ada.Task_Identification;
-- used for Task_ID type
-- used for Task_Id type
with Ada.Exceptions;
-- used for Raise_Exception
@ -107,7 +107,7 @@ with System.Storage_Elements;
-- Integer_Address
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
@ -141,7 +141,7 @@ package body System.Interrupts is
package IMOP renames System.Interrupt_Management.Operations;
function To_System is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_ID);
(Ada.Task_Identification.Task_Id, Task_Id);
-----------------
-- Local Tasks --
@ -152,7 +152,7 @@ package body System.Interrupts is
-- nizing it.
task Interrupt_Manager is
entry Detach_Interrupt_Entries (T : Task_ID);
entry Detach_Interrupt_Entries (T : Task_Id);
entry Initialize (Mask : IMNG.Interrupt_Mask);
@ -173,7 +173,7 @@ package body System.Interrupts is
Static : in Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
@ -204,7 +204,7 @@ package body System.Interrupts is
-------------------------------
type Entry_Assoc is record
T : Task_ID;
T : Task_Id;
E : Task_Entry_Index;
end record;
@ -235,17 +235,17 @@ package body System.Interrupts is
-- True iff the corresponding interrupt is blocked in the process level
Last_Unblocker :
array (Interrupt_ID'Range) of Task_ID := (others => Null_Task);
array (Interrupt_ID'Range) of Task_Id := (others => Null_Task);
pragma Volatile_Components (Last_Unblocker);
-- Holds the ID of the last Task which Unblocked this Interrupt.
-- It contains Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.
Server_ID : array (Interrupt_ID'Range) of Task_ID :=
Server_ID : array (Interrupt_ID'Range) of Task_Id :=
(others => Null_Task);
pragma Atomic_Components (Server_ID);
-- Holds the Task_ID of the Server_Task for each interrupt.
-- Task_ID is needed to accomplish locking per Interrupt base. Also
-- Holds the Task_Id of the Server_Task for each interrupt.
-- Task_Id is needed to accomplish locking per Interrupt base. Also
-- is needed to decide whether to create a new Server_Task.
-- Type and Head, Tail of the list containing Registered Interrupt
@ -310,7 +310,7 @@ package body System.Interrupts is
-- already bound.
procedure Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
is
@ -390,7 +390,7 @@ package body System.Interrupts is
-- Detach_Interrupt_Entries --
------------------------------
procedure Detach_Interrupt_Entries (T : Task_ID) is
procedure Detach_Interrupt_Entries (T : Task_Id) is
begin
Interrupt_Manager.Detach_Interrupt_Entries (T);
end Detach_Interrupt_Entries;
@ -681,7 +681,7 @@ package body System.Interrupts is
------------------
function Unblocked_By
(Interrupt : Interrupt_ID) return System.Tasking.Task_ID
(Interrupt : Interrupt_ID) return System.Tasking.Task_Id
is
begin
if Is_Reserved (Interrupt) then
@ -925,7 +925,7 @@ package body System.Interrupts is
end if;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task then
@ -1050,7 +1050,7 @@ package body System.Interrupts is
or
accept Bind_Interrupt_To_Entry
(T : Task_ID;
(T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
@ -1078,7 +1078,7 @@ package body System.Interrupts is
T.Interrupt_Entry := True;
-- Invoke a corresponding Server_Task if not yet created.
-- Place Task_ID info in Server_ID array.
-- Place Task_Id info in Server_ID array.
if Server_ID (Interrupt) = Null_Task then
-- When a new Server_Task is created, it should have its
@ -1096,7 +1096,7 @@ package body System.Interrupts is
end Bind_Interrupt_To_Entry;
or
accept Detach_Interrupt_Entries (T : Task_ID) do
accept Detach_Interrupt_Entries (T : Task_Id) do
for J in Interrupt_ID'Range loop
if not Is_Reserved (J) then
if User_Entry (J).T = T then
@ -1249,9 +1249,9 @@ package body System.Interrupts is
task body Server_Task is
Intwait_Mask : aliased IMNG.Interrupt_Mask;
Ret_Interrupt : Interrupt_ID;
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
Tmp_Handler : Parameterless_Handler;
Tmp_ID : Task_ID;
Tmp_ID : Task_Id;
Tmp_Entry_Index : Task_Entry_Index;
begin

10
gcc/ada/s-interr.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -46,7 +46,7 @@
-- tasking implementation to be linked and elaborated.
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
with System.Tasking.Protected_Objects.Entries;
-- used for Protection_Entries
@ -131,11 +131,11 @@ package System.Interrupts is
-- already attached will raise a Program_Error.
procedure Bind_Interrupt_To_Entry
(T : System.Tasking.Task_ID;
(T : System.Tasking.Task_Id;
E : System.Tasking.Task_Entry_Index;
Int_Ref : System.Address);
procedure Detach_Interrupt_Entries (T : System.Tasking.Task_ID);
procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id);
-- This procedure detaches all the Interrupt Entries bound to a task.
-------------------------------
@ -151,7 +151,7 @@ package System.Interrupts is
function Unblocked_By
(Interrupt : Interrupt_ID)
return System.Tasking.Task_ID;
return System.Tasking.Task_Id;
-- It returns the ID of the last Task which Unblocked this Interrupt.
-- It returns Null_Task if no tasks have ever requested the
-- Unblocking operation or the Interrupt is currently Blocked.

3
gcc/ada/s-restri.ads
View file

@ -61,7 +61,8 @@ package System.Restrictions is
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests to see if tasking operations are allowed by the current
-- restrictions settings. For tasking to be allowed Max_Tasks must
-- restrictions settings. For taskikng to be allowed, No_Tasking
-- must be False, and Max_Tasks must not be set to zero.
end System.Restrictions;

13
gcc/ada/s-rident.ads
View file

@ -152,13 +152,14 @@ package System.Rident is
Not_A_Restriction_Id);
-- Synonyms permitted for historical purposes of compatibility
-- Synonyms permitted for historical purposes of compatibility.
-- Must be coordinated with Restrict.Process_Restriction_Synonym.
-- Boolean_Entry_Barriers synonym for Simple_Barriers
-- Max_Entry_Queue_Depth synonym for Max_Entry_Queue_Length
-- No_Dynamic_Interrupts synonym for No_Dynamic_Attachment
-- No_Requeue synonym for No_Requeue_Statements
-- No_Task_Attributes synonym for No_Task_Attributes_Package
Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers;
Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length;
No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment;
No_Requeue : Restriction_Id renames No_Requeue_Statements;
No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package;
subtype All_Restrictions is Restriction_Id range
Simple_Barriers .. Max_Storage_At_Blocking;

6
gcc/ada/s-soflin.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -221,8 +221,8 @@ package System.Soft_Links is
function Get_Exc_Stack_Addr_NT return Address;
procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
-- Self_ID is a Task_ID, but in the non-tasking case there is no
-- Task_ID type available, so make do with Address.
-- Self_ID is a Task_Id, but in the non-tasking case there is no
-- Task_Id type available, so make do with Address.
Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access;

14
gcc/ada/s-taasde.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -62,7 +62,7 @@ with System.OS_Primitives;
-- used for Max_Sensible_Delay
with Ada.Task_Identification;
-- used for Task_ID type
-- used for Task_Id type
with System.Parameters;
-- used for Single_Lock
@ -86,9 +86,9 @@ package body System.Tasking.Async_Delays is
use System.Traces.Tasking;
function To_System is new Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_ID);
(Ada.Task_Identification.Task_Id, Task_Id);
Timer_Server_ID : ST.Task_ID;
Timer_Server_ID : ST.Task_Id;
Timer_Attention : Boolean := False;
pragma Atomic (Timer_Attention);
@ -214,10 +214,10 @@ package body System.Tasking.Async_Delays is
(T : Duration;
D : Delay_Block_Access)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Q : Delay_Block_Access;
use type ST.Task_ID;
use type ST.Task_Id;
-- for visibility of operator "="
begin
@ -319,7 +319,7 @@ package body System.Tasking.Async_Delays is
Yielded : Boolean;
Now : Duration;
Dequeued : Delay_Block_Access;
Dequeued_Task : Task_ID;
Dequeued_Task : Task_Id;
begin
Timer_Server_ID := STPO.Self;

4
gcc/ada/s-taasde.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -117,7 +117,7 @@ package System.Tasking.Async_Delays is
private
type Delay_Block is record
Self_Id : Task_ID;
Self_Id : Task_Id;
-- ID of the calling task
Level : ATC_Level_Base;

32
gcc/ada/s-taenca.adb
View file

@ -113,7 +113,7 @@ package body System.Tasking.Entry_Calls is
-- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Unlock_And_Update_Server
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- Similar to Unlock_Server, but services entry calls if the
-- server is a protected object.
@ -121,7 +121,7 @@ package body System.Tasking.Entry_Calls is
-- If Single_Lock and server is a PO, take RTS_Lock on exit.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- This procedure performs priority change of a queued call and
-- dequeuing of an entry call when the call is cancelled.
@ -133,7 +133,7 @@ package body System.Tasking.Entry_Calls is
-- and to dequeue the call if the call has been aborted.
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
-- A specialized version of Poll_Base_Priority_Change,
@ -146,7 +146,7 @@ package body System.Tasking.Entry_Calls is
---------------------
procedure Check_Exception
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
@ -174,7 +174,7 @@ package body System.Tasking.Entry_Calls is
------------------------------------------
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link) is
begin
pragma Assert (Self_ID = Entry_Call.Self);
@ -213,7 +213,7 @@ package body System.Tasking.Entry_Calls is
-----------------
procedure Lock_Server (Entry_Call : Entry_Call_Link) is
Test_Task : Task_ID;
Test_Task : Task_Id;
Test_PO : Protection_Entries_Access;
Ceiling_Violation : Boolean;
Failures : Integer := 0;
@ -262,7 +262,7 @@ package body System.Tasking.Entry_Calls is
if Ceiling_Violation then
declare
Current_Task : constant Task_ID := STPO.Self;
Current_Task : constant Task_Id := STPO.Self;
Old_Base_Priority : System.Any_Priority;
begin
@ -315,7 +315,7 @@ package body System.Tasking.Entry_Calls is
---------------------------------------------
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link) is
begin
if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
@ -377,7 +377,7 @@ package body System.Tasking.Entry_Calls is
--------------------
procedure Reset_Priority
(Acceptor : Task_ID;
(Acceptor : Task_Id;
Acceptor_Prev_Priority : Rendezvous_Priority) is
begin
pragma Assert (Acceptor = STPO.Self);
@ -397,7 +397,7 @@ package body System.Tasking.Entry_Calls is
procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is
Entry_Call : Entry_Call_Link;
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
use type Ada.Exceptions.Exception_Id;
@ -459,11 +459,11 @@ package body System.Tasking.Entry_Calls is
------------------------------
procedure Unlock_And_Update_Server
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
Called_PO : Protection_Entries_Access;
Caller : Task_ID;
Caller : Task_Id;
begin
if Entry_Call.Called_Task /= null then
@ -503,7 +503,7 @@ package body System.Tasking.Entry_Calls is
-------------------
procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
Caller : Task_ID;
Caller : Task_Id;
Called_PO : Protection_Entries_Access;
begin
@ -543,7 +543,7 @@ package body System.Tasking.Entry_Calls is
-------------------------
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
Self_Id : constant Task_ID := Entry_Call.Self;
Self_Id : constant Task_Id := Entry_Call.Self;
begin
-- If this is a conditional call, it should be cancelled when it
-- becomes abortable. This is checked in the loop below.
@ -600,7 +600,7 @@ package body System.Tasking.Entry_Calls is
Mode : Delay_Modes;
Yielded : out Boolean)
is
Self_Id : constant Task_ID := Entry_Call.Self;
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean := False;
use type Ada.Exceptions.Exception_Id;
@ -699,7 +699,7 @@ package body System.Tasking.Entry_Calls is
--------------------------
procedure Wait_Until_Abortable
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Call : Entry_Call_Link) is
begin
pragma Assert (Self_ID.ATC_Nesting_Level > 0);

8
gcc/ada/s-taenca.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -59,7 +59,7 @@ package System.Tasking.Entry_Calls is
-- Check_Exception must be called after calling this procedure.
procedure Wait_Until_Abortable
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Call : Entry_Call_Link);
-- This procedure suspends the calling task until the specified entry
-- call is queued abortably or completes.
@ -75,7 +75,7 @@ package System.Tasking.Entry_Calls is
-- On return, the call is off-queue and the ATC level is reduced by one.
procedure Reset_Priority
(Acceptor : Task_ID;
(Acceptor : Task_Id;
Acceptor_Prev_Priority : Rendezvous_Priority);
pragma Inline (Reset_Priority);
-- Reset the priority of a task completing an accept statement to
@ -83,7 +83,7 @@ package System.Tasking.Entry_Calls is
-- Acceptor should always be equal to Self.
procedure Check_Exception
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Exception);
-- Raise any pending exception from the Entry_Call.

52
gcc/ada/s-taprop-dummy.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -42,7 +42,7 @@ pragma Polling (Off);
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Error_Reporting;
-- used for Shutdown
@ -59,7 +59,7 @@ package body System.Task_Primitives.Operations is
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
begin
null;
end Stack_Guard;
@ -68,7 +68,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return OSI.Thread_Id (T.Common.LL.Thread);
end Get_Thread_Id;
@ -77,7 +77,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID is
function Self return Task_Id is
begin
return Null_Task;
end Self;
@ -130,7 +130,7 @@ package body System.Task_Primitives.Operations is
null;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
begin
null;
end Write_Lock;
@ -158,7 +158,7 @@ package body System.Task_Primitives.Operations is
null;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
begin
null;
end Unlock;
@ -167,7 +167,7 @@ package body System.Task_Primitives.Operations is
-- Sleep --
-----------
procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Sleep;
@ -177,7 +177,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -193,7 +193,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes) is
begin
@ -222,7 +222,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
begin
null;
end Wakeup;
@ -232,7 +232,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False) is
begin
@ -243,7 +243,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return 0;
end Get_Priority;
@ -252,7 +252,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
null;
end Enter_Task;
@ -261,7 +261,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -279,7 +279,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
@ -288,7 +288,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
----------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Succeeded := False;
end Initialize_TCB;
@ -298,7 +298,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -311,7 +311,7 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
begin
null;
end Finalize_TCB;
@ -329,7 +329,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
begin
null;
end Abort_Task;
@ -350,7 +350,7 @@ package body System.Task_Primitives.Operations is
-- Dummy versions. The only currently working versions is for solaris
-- (native).
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
return True;
end Check_Exit;
@ -359,7 +359,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
begin
return True;
end Check_No_Locks;
@ -368,7 +368,7 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return null;
end Environment_Task;
@ -396,7 +396,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean
is
@ -409,7 +409,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean
is
@ -421,7 +421,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
begin
null;
end Initialize;

78
gcc/ada/s-taprop-hpux-dce.adb
View file

@ -65,7 +65,7 @@ with System.Task_Primitives.Interrupt_Operations;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -106,10 +106,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
@ -136,7 +136,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -144,11 +144,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does the executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -161,11 +161,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -173,7 +173,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
@ -182,7 +182,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -211,7 +211,7 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T, On);
begin
null;
@ -221,7 +221,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
-------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -230,7 +230,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -347,7 +347,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -387,7 +387,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -402,7 +402,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -426,7 +426,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -488,7 +488,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -584,7 +584,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
@ -622,7 +622,7 @@ package body System.Task_Primitives.Operations is
-- scheduling.
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -684,7 +684,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -693,7 +693,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
Specific.Set (Self_ID);
@ -715,7 +715,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -730,7 +730,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -743,7 +743,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -797,7 +797,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -861,13 +861,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -902,7 +902,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
begin
--
-- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
@ -921,7 +921,7 @@ package body System.Task_Primitives.Operations is
-- Dummy versions. The only currently working versions is for solaris
-- (native).
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
@ -931,7 +931,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
@ -941,9 +941,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -969,7 +969,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -985,7 +985,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1000,7 +1000,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1021,7 +1021,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

68
gcc/ada/s-taprop-irix-athread.adb
View file

@ -59,7 +59,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Program_Info;
-- used for Default_Task_Stack
@ -108,8 +108,8 @@ package body System.Task_Primitives.Operations is
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@ -126,9 +126,9 @@ package body System.Task_Primitives.Operations is
procedure Initialize_Athread_Library;
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Stack_Guard --
@ -138,7 +138,7 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
begin
@ -149,7 +149,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -158,9 +158,9 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID is
function Self return Task_Id is
begin
return To_Task_ID (pthread_get_current_ada_tcb);
return To_Task_Id (pthread_get_current_ada_tcb);
end Self;
---------------------
@ -285,7 +285,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -323,7 +323,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -337,7 +337,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : ST.Task_ID;
(Self_ID : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -363,7 +363,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -424,7 +424,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -529,7 +529,7 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup
(T : ST.Task_ID;
(T : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -555,7 +555,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -574,7 +574,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -583,7 +583,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
Result : Interfaces.C.int;
begin
@ -612,7 +612,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -630,7 +630,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
@ -639,7 +639,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
----------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -677,7 +677,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -773,12 +773,12 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
begin
if not Single_Lock then
@ -811,7 +811,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result :=
@ -827,7 +827,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -838,7 +838,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
@ -848,9 +848,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -876,7 +876,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -892,7 +892,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -907,9 +907,9 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.

78
gcc/ada/s-taprop-irix.adb
View file

@ -67,7 +67,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -117,10 +117,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@ -138,7 +138,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -146,11 +146,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -163,17 +163,17 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
-----------------------
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
procedure Abort_Handler (Sig : Signal);
-- Signal handler used to implement asynchronous abort.
@ -185,7 +185,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
T : constant Task_ID := Self;
T : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -219,7 +219,7 @@ package body System.Task_Primitives.Operations is
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (On);
pragma Unreferenced (T);
begin
@ -230,7 +230,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
-------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -239,7 +239,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -370,7 +370,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -409,7 +409,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -424,7 +424,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : ST.Task_ID;
(Self_ID : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -450,7 +450,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : Task_States;
@ -511,7 +511,7 @@ package body System.Task_Primitives.Operations is
-- no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -608,7 +608,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : ST.Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
@ -634,7 +634,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -668,7 +668,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -677,7 +677,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
Result : Interfaces.C.int;
function To_Int is new Unchecked_Conversion
@ -715,7 +715,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -730,7 +730,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -743,7 +743,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -781,7 +781,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -915,13 +915,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -956,7 +956,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -971,7 +971,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -982,7 +982,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -993,9 +993,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1021,7 +1021,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1037,7 +1037,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1052,7 +1052,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1072,7 +1072,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

80
gcc/ada/s-taprop-linux.adb
View file

@ -62,7 +62,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
@ -110,10 +110,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
@ -150,7 +150,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -158,11 +158,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -175,11 +175,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -199,7 +199,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (signo : Signal) is
pragma Unreferenced (signo);
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -248,7 +248,7 @@ package body System.Task_Primitives.Operations is
-- The underlying thread system extends the memory (up to 2MB) when needed
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
@ -260,7 +260,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -269,7 +269,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -348,7 +348,7 @@ package body System.Task_Primitives.Operations is
begin
if Priority_Ceiling_Emulation then
declare
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
if Self_ID.Common.LL.Active_Priority > L.Ceiling then
@ -390,7 +390,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -419,7 +419,7 @@ package body System.Task_Primitives.Operations is
begin
if Priority_Ceiling_Emulation then
declare
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
Result := pthread_mutex_unlock (L.L'Access);
@ -446,7 +446,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -461,7 +461,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -492,7 +492,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -556,7 +556,7 @@ package body System.Task_Primitives.Operations is
-- no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -652,7 +652,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
@ -678,7 +678,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -722,7 +722,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -731,7 +731,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
@ -754,7 +754,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -769,7 +769,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -782,7 +782,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int;
begin
@ -826,7 +826,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -890,13 +890,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -931,7 +931,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -946,7 +946,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -957,7 +957,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -968,9 +968,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
------------------
@ -978,7 +978,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -994,7 +994,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -1009,7 +1009,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1030,7 +1030,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);

84
gcc/ada/s-taprop-lynxos.adb
View file

@ -66,7 +66,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -105,10 +105,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@ -144,7 +144,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -152,11 +152,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does the current thread have an ATCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -169,11 +169,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -182,7 +182,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal);
-- Signal handler used to implement asynchronous abort.
procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority);
procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority);
-- This procedure calls the scheduler of the OS to set thread's priority
-------------------
@ -192,7 +192,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
T : constant Task_ID := Self;
T : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -226,7 +226,7 @@ package body System.Task_Primitives.Operations is
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
Guard_Page_Address : Address;
@ -254,7 +254,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -263,7 +263,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -349,7 +349,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
T : constant Task_ID := Self;
T : constant Task_Id := Self;
begin
if Locking_Policy = 'C' then
@ -386,7 +386,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -410,7 +410,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
T : constant Task_ID := Self;
T : constant Task_Id := Self;
begin
Result := pthread_mutex_unlock (L.Mutex'Access);
@ -432,7 +432,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -446,7 +446,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -475,7 +475,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : Task_States;
@ -554,7 +554,7 @@ package body System.Task_Primitives.Operations is
-- the caller is abort-deferred but is holding no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -672,7 +672,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
@ -697,7 +697,7 @@ package body System.Task_Primitives.Operations is
-- Set_Priority --
------------------
procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority) is
procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority) is
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
@ -726,7 +726,7 @@ package body System.Task_Primitives.Operations is
-- Comments needed for these declarations ???
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -764,7 +764,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -773,7 +773,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
@ -797,7 +797,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -812,7 +812,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -825,7 +825,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
----------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -885,7 +885,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -970,13 +970,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -1013,7 +1013,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_kill (T.Common.LL.Thread,
@ -1027,7 +1027,7 @@ package body System.Task_Primitives.Operations is
-- Dummy versions
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
@ -1037,7 +1037,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
return True;
@ -1047,9 +1047,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1075,7 +1075,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1090,7 +1090,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
@ -1103,7 +1103,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1125,7 +1125,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

72
gcc/ada/s-taprop-mingw.adb
View file

@ -58,7 +58,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -98,8 +98,8 @@ package body System.Task_Primitives.Operations is
-- Local Data --
----------------
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
@ -137,7 +137,7 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
@ -150,7 +150,7 @@ package body System.Task_Primitives.Operations is
return TlsGetValue (TlsIndex) /= System.Null_Address;
end Is_Valid_Task;
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Succeeded : BOOL;
begin
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
@ -163,11 +163,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
----------------------------------
-- Condition Variable Functions --
@ -346,7 +346,7 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Warnings (Off, T);
pragma Warnings (Off, On);
@ -358,7 +358,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -367,8 +367,8 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID is
Self_Id : constant Task_ID := To_Task_ID (TlsGetValue (TlsIndex));
function Self return Task_Id is
Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
begin
if Self_Id = null then
return Register_Foreign_Thread (GetCurrentThread);
@ -447,7 +447,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
EnterCriticalSection
@ -480,7 +480,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
LeaveCriticalSection
@ -493,7 +493,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -524,7 +524,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -585,7 +585,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -659,7 +659,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
begin
@ -692,7 +692,7 @@ package body System.Task_Primitives.Operations is
-- scheduling.
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -740,7 +740,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -762,7 +762,7 @@ package body System.Task_Primitives.Operations is
-- set in System.Task_Primitives.Operations.Create_Task during the
-- thread creation.
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for x86 systems.
@ -790,7 +790,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -805,7 +805,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -818,7 +818,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
-- Initialize thread ID to 0, this is needed to detect threads that
-- are not yet activated.
@ -839,7 +839,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -909,14 +909,14 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
Self_ID : Task_ID := T;
procedure Finalize_TCB (T : Task_Id) is
Self_ID : Task_Id := T;
Result : DWORD;
Succeeded : BOOL;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -960,7 +960,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
pragma Unreferenced (T);
begin
null;
@ -970,9 +970,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -997,12 +997,12 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
Discard : BOOL;
pragma Unreferenced (Discard);
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
@ -1053,7 +1053,7 @@ package body System.Task_Primitives.Operations is
-- Dummy versions. The only currently working versions is for solaris
-- (native).
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -1064,7 +1064,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -1076,7 +1076,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -1092,7 +1092,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin

82
gcc/ada/s-taprop-os2.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -57,7 +57,7 @@ with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
with System.Parameters;
-- used for Size_Type
@ -121,7 +121,7 @@ package body System.Task_Primitives.Operations is
-- own TCB_Ptr without destroying the TCB_Ptr of other threads.
type Thread_Local_Data is record
Self_ID : Task_ID; -- ID of the current thread
Self_ID : Task_Id; -- ID of the current thread
Lock_Prio_Level : Lock_Range; -- Nr of priority changes due to locks
-- ... room for expansion here, if we decide to make access to
@ -140,22 +140,22 @@ package body System.Task_Primitives.Operations is
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-----------------------
-- Local Subprograms --
-----------------------
function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
function To_PFNTHREAD is
new Unchecked_Conversion (System.Address, PFNTHREAD);
function To_MS (D : Duration) return ULONG;
procedure Set_Temporary_Priority
(T : in Task_ID;
(T : in Task_Id;
New_Priority : in System.Any_Priority);
-----------
@ -199,7 +199,7 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
@ -211,7 +211,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return OSI.Thread_Id (T.Common.LL.Thread);
end Get_Thread_Id;
@ -220,8 +220,8 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID is
Self_ID : Task_ID renames Thread_Local_Data_Ptr.Self_ID;
function Self return Task_Id is
Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID;
begin
-- Check that the thread local data has been initialized.
@ -287,7 +287,7 @@ package body System.Task_Primitives.Operations is
----------------
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority :=
Self_ID.Common.LL.Current_Priority;
@ -319,7 +319,7 @@ package body System.Task_Primitives.Operations is
(L : access RTS_Lock;
Global_Lock : Boolean := False)
is
Self_ID : Task_ID;
Self_ID : Task_Id;
Old_Priority : Any_Priority;
begin
@ -345,7 +345,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
begin
if not Single_Lock then
@ -369,7 +369,7 @@ package body System.Task_Primitives.Operations is
------------
procedure Unlock (L : access Lock) is
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
Self_ID : constant Task_Id := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority := L.Owner_Priority;
begin
@ -397,7 +397,7 @@ package body System.Task_Primitives.Operations is
end Unlock;
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Self_ID : Task_ID;
Self_ID : Task_Id;
Old_Priority : Any_Priority;
begin
@ -429,7 +429,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
@ -450,7 +450,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -499,7 +499,7 @@ package body System.Task_Primitives.Operations is
-- Self is locked.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -586,7 +586,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -679,7 +679,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
begin
@ -702,7 +702,7 @@ package body System.Task_Primitives.Operations is
----------------------------
procedure Set_Temporary_Priority
(T : Task_ID;
(T : Task_Id;
New_Priority : System.Any_Priority)
is
use Interfaces.C;
@ -743,7 +743,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -758,7 +758,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -767,7 +767,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
-- Initialize thread local data. Must be done first.
@ -799,7 +799,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -817,7 +817,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
return null;
end Register_Foreign_Thread;
@ -826,7 +826,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
if DosCreateEventSem (ICS.Null_Ptr,
Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
@ -883,7 +883,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -970,11 +970,11 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
Tmp : Task_ID := T;
procedure Finalize_TCB (T : Task_Id) is
Tmp : Task_Id := T;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
@ -1003,7 +1003,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
pragma Unreferenced (T);
begin
@ -1020,7 +1020,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
return Check_No_Locks (Self_ID);
end Check_Exit;
@ -1029,7 +1029,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
begin
@ -1041,9 +1041,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1069,7 +1069,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1086,7 +1086,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1102,10 +1102,10 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
Succeeded : Boolean;
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.

78
gcc/ada/s-taprop-posix.adb
View file

@ -71,7 +71,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -111,10 +111,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Locking_Policy : Character;
pragma Import (C, Locking_Policy, "__gl_locking_policy");
@ -150,7 +150,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -158,11 +158,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -175,11 +175,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -189,7 +189,7 @@ package body System.Task_Primitives.Operations is
-- Signal handler used to implement asynchronous abort.
-- See also comment before body, below.
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
@ -218,7 +218,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Warnings (Off, Sig);
T : constant Task_ID := Self;
T : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -250,7 +250,7 @@ package body System.Task_Primitives.Operations is
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
Guard_Page_Address : Address;
@ -278,7 +278,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -287,7 +287,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -431,7 +431,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -472,7 +472,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -487,7 +487,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Warnings (Off, Reason);
@ -517,7 +517,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : Task_States;
@ -597,7 +597,7 @@ package body System.Task_Primitives.Operations is
-- no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -709,7 +709,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Warnings (Off, Reason);
Result : Interfaces.C.int;
@ -737,7 +737,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -770,7 +770,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -779,7 +779,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
@ -803,7 +803,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -818,7 +818,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -831,7 +831,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -907,7 +907,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -994,13 +994,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -1038,7 +1038,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -1053,7 +1053,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Warnings (Off, Self_ID);
begin
@ -1064,7 +1064,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Warnings (Off, Self_ID);
begin
@ -1075,9 +1075,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1103,7 +1103,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1119,7 +1119,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1134,7 +1134,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1155,7 +1155,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

104
gcc/ada/s-taprop-solaris.adb
View file

@ -68,7 +68,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
-- ATCB components and types
with System.Task_Info;
@ -107,16 +107,16 @@ package body System.Task_Primitives.Operations is
-- The following are logically constants, but need to be initialized
-- at run time.
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
-- If we use this variable to get the Task_ID, we need the following
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
-- If we use this variable to get the Task_Id, we need the following
-- ATCB_Key only for non-Ada threads.
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
ATCB_Key : aliased thread_key_t;
-- Key used to find the Ada Task_ID associated with a thread,
-- Key used to find the Ada Task_Id associated with a thread,
-- at least for C threads unknown to the Ada run-time system.
Single_RTS_Lock : aliased RTS_Lock;
@ -213,7 +213,7 @@ package body System.Task_Primitives.Operations is
pragma Inline (Record_Wakeup);
function Check_Wakeup
(T : Task_ID;
(T : Task_Id;
Reason : Task_States) return Boolean;
pragma Inline (Check_Wakeup);
@ -229,7 +229,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -237,11 +237,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -254,11 +254,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
------------
-- Checks --
@ -281,7 +281,7 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (Code);
pragma Unreferenced (Context);
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
Old_Set : aliased sigset_t;
Result : Interfaces.C.int;
@ -318,7 +318,7 @@ package body System.Task_Primitives.Operations is
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
@ -330,7 +330,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -339,7 +339,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : ST.Task_ID) is
procedure Initialize (Environment_Task : ST.Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -429,7 +429,7 @@ package body System.Task_Primitives.Operations is
-- Start of processing for Initialize
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- This is done in Enter_Task, but this is too late for the
-- Environment Task, since we need to call Self in Check_Locks when
@ -557,7 +557,7 @@ package body System.Task_Primitives.Operations is
if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
declare
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
Saved_Priority : System.Any_Priority;
begin
@ -603,7 +603,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -636,7 +636,7 @@ package body System.Task_Primitives.Operations is
if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
declare
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
begin
Result := mutex_unlock (L.L'Access);
@ -663,7 +663,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
@ -729,14 +729,14 @@ package body System.Task_Primitives.Operations is
-- Self ---
-----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
------------------
-- Set_Priority --
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -789,7 +789,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -798,7 +798,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
Result : Interfaces.C.int;
Proc : processorid_t; -- User processor #
Last_Proc : processorid_t; -- Last processor #
@ -846,7 +846,7 @@ package body System.Task_Primitives.Operations is
Specific.Set (Self_ID);
-- We need the above code even if we do direct fetch of Task_ID in Self
-- We need the above code even if we do direct fetch of Task_Id in Self
-- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
Lock_RTS;
@ -866,7 +866,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -881,7 +881,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -894,7 +894,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int := 0;
begin
@ -936,7 +936,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -1008,13 +1008,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
T.Common.LL.Thread := To_thread_t (0);
@ -1055,7 +1055,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
pragma Assert (T /= Self);
@ -1072,7 +1072,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : Task_States)
is
Result : Interfaces.C.int;
@ -1178,7 +1178,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -1242,7 +1242,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -1328,7 +1328,7 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup
(T : Task_ID;
(T : Task_Id;
Reason : Task_States)
is
Result : Interfaces.C.int;
@ -1350,7 +1350,7 @@ package body System.Task_Primitives.Operations is
(L : Lock_Ptr;
Level : Lock_Level) return Boolean
is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
-- Check that caller is abort-deferred
@ -1374,7 +1374,7 @@ package body System.Task_Primitives.Operations is
----------------
function Check_Lock (L : Lock_Ptr) return Boolean is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
@ -1425,7 +1425,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Record_Lock (L : Lock_Ptr) return Boolean is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
@ -1465,7 +1465,7 @@ package body System.Task_Primitives.Operations is
function Check_Sleep (Reason : Task_States) return Boolean is
pragma Unreferenced (Reason);
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
@ -1510,7 +1510,7 @@ package body System.Task_Primitives.Operations is
is
pragma Unreferenced (Reason);
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
@ -1540,10 +1540,10 @@ package body System.Task_Primitives.Operations is
------------------
function Check_Wakeup
(T : Task_ID;
(T : Task_Id;
Reason : Task_States) return Boolean
is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
-- Is caller holding T's lock?
@ -1566,7 +1566,7 @@ package body System.Task_Primitives.Operations is
------------------
function Check_Unlock (L : Lock_Ptr) return Boolean is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
@ -1614,7 +1614,7 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
-- Check that caller is abort-deferred
@ -1637,7 +1637,7 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
function Check_Exit (Self_ID : Task_ID) return Boolean is
function Check_Exit (Self_ID : Task_Id) return Boolean is
begin
-- Check that caller is just holding Global_Task_Lock
-- and no other locks
@ -1669,7 +1669,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : Task_ID) return Boolean is
function Check_No_Locks (Self_ID : Task_Id) return Boolean is
begin
return Self_ID.Common.LL.Locks = null;
end Check_No_Locks;
@ -1678,9 +1678,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1706,7 +1706,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
@ -1722,7 +1722,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin

80
gcc/ada/s-taprop-tru64.adb
View file

@ -68,7 +68,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
-- ATCB components and types
with System.Soft_Links;
@ -108,10 +108,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
@ -139,7 +139,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -147,11 +147,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -164,11 +164,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -184,7 +184,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal) is
pragma Unreferenced (Sig);
T : constant Task_ID := Self;
T : constant Task_Id := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@ -219,7 +219,7 @@ package body System.Task_Primitives.Operations is
-- The underlying thread system sets a guard page at the
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
@ -231,7 +231,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -240,7 +240,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -334,8 +334,8 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
Self_ID : Task_ID;
All_Tasks_Link : Task_ID;
Self_ID : Task_Id;
All_Tasks_Link : Task_Id;
Current_Prio : System.Any_Priority;
begin
@ -373,7 +373,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -411,7 +411,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -425,7 +425,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -455,7 +455,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -523,7 +523,7 @@ package body System.Task_Primitives.Operations is
-- no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -621,7 +621,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
@ -647,7 +647,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -680,7 +680,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -689,7 +689,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
Specific.Set (Self_ID);
@ -711,7 +711,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -726,7 +726,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -739,7 +739,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -793,7 +793,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -920,13 +920,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -961,7 +961,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result :=
@ -977,7 +977,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -988,7 +988,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -999,9 +999,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1027,7 +1027,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
@ -1042,7 +1042,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
@ -1056,7 +1056,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
@ -1076,7 +1076,7 @@ package body System.Task_Primitives.Operations is
-- system handler)
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

86
gcc/ada/s-taprop-vms.adb
View file

@ -52,7 +52,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
@ -94,10 +94,10 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased pthread_key_t;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@ -117,7 +117,7 @@ package body System.Task_Primitives.Operations is
package Specific is
procedure Initialize (Environment_Task : Task_ID);
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
-- Initialize various data needed by this package.
@ -125,11 +125,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task
@ -142,26 +142,26 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
-----------------------
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
procedure Timer_Sleep_AST (ID : Address);
-- Signal the condition variable when AST fires.
procedure Timer_Sleep_AST (ID : Address) is
Result : Interfaces.C.int;
Self_ID : constant Task_ID := To_Task_ID (ID);
Self_ID : constant Task_Id := To_Task_Id (ID);
begin
Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
@ -176,7 +176,7 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
begin
@ -187,7 +187,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
--------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -196,7 +196,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
@ -297,8 +297,8 @@ package body System.Task_Primitives.Operations is
----------------
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Self_ID : constant Task_ID := Self;
All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link;
Self_ID : constant Task_Id := Self;
All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link;
Current_Prio : System.Any_Priority;
Result : Interfaces.C.int;
@ -335,7 +335,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -373,7 +373,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
if not Single_Lock then
@ -387,7 +387,7 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
@ -419,7 +419,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -482,7 +482,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -586,7 +586,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : Interfaces.C.int;
@ -614,7 +614,7 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -652,7 +652,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -661,7 +661,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.LL.Thread := pthread_self;
@ -684,7 +684,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -699,7 +699,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -712,7 +712,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
----------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
@ -773,7 +773,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -800,7 +800,7 @@ package body System.Task_Primitives.Operations is
-- Since the initial signal mask of a thread is inherited from the
-- creator, we need to set our local signal mask mask all signals
-- during the creation operation, to make sure the new thread is
-- not disturbed by signals before it has set its own Task_ID.
-- not disturbed by signals before it has set its own Task_Id.
Result := pthread_attr_init (Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
@ -850,13 +850,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
procedure Free is new Unchecked_Deallocation
(Exc_Stack_T, Exc_Stack_Ptr_T);
@ -896,7 +896,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
begin
-- Interrupt Server_Tasks may be waiting on an event flag
@ -911,7 +911,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -922,7 +922,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -933,9 +933,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -961,7 +961,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
@ -976,7 +976,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
@ -989,9 +989,9 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
begin
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs

78
gcc/ada/s-taprop-vxworks.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -65,7 +65,7 @@ with System.Parameters;
with System.Tasking;
-- used for Ada_Task_Control_Block
-- Task_ID
-- Task_Id
-- ATCB components and types
with Interfaces.C;
@ -100,7 +100,7 @@ package body System.Task_Primitives.Operations is
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased System.Address := System.Null_Address;
-- Key used to find the Ada Task_ID associated with a thread
-- Key used to find the Ada Task_Id associated with a thread
ATCB_Key_Addr : System.Address := ATCB_Key'Address;
pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
@ -108,8 +108,8 @@ package body System.Task_Primitives.Operations is
-- implementation. This mechanism is used to minimize impact on other
-- targets.
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task.
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
@ -143,11 +143,11 @@ package body System.Task_Primitives.Operations is
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
procedure Set (Self_Id : Task_ID);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task.
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -160,11 +160,11 @@ package body System.Task_Primitives.Operations is
-- Support for foreign threads --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
-- Allocate and Initialize a new ATCB for the current Thread.
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_ID is separate;
(Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
@ -176,7 +176,7 @@ package body System.Task_Primitives.Operations is
procedure Install_Signal_Handlers;
-- Install the default signal handlers for the current task
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
@ -185,7 +185,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (signo : Signal) is
pragma Unreferenced (signo);
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
Result : int;
Old_Set : aliased sigset_t;
@ -217,7 +217,7 @@ package body System.Task_Primitives.Operations is
-- Stack_Guard --
-----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
@ -231,7 +231,7 @@ package body System.Task_Primitives.Operations is
-- Get_Thread_Id --
-------------------
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
@ -240,7 +240,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
function Self return Task_ID renames Specific.Self;
function Self return Task_Id renames Specific.Self;
-----------------------------
-- Install_Signal_Handlers --
@ -346,7 +346,7 @@ package body System.Task_Primitives.Operations is
end if;
end Write_Lock;
procedure Write_Lock (T : Task_ID) is
procedure Write_Lock (T : Task_Id) is
Result : int;
begin
@ -387,7 +387,7 @@ package body System.Task_Primitives.Operations is
end if;
end Unlock;
procedure Unlock (T : Task_ID) is
procedure Unlock (T : Task_Id) is
Result : int;
begin
@ -401,7 +401,7 @@ package body System.Task_Primitives.Operations is
-- Sleep --
-----------
procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : int;
@ -445,7 +445,7 @@ package body System.Task_Primitives.Operations is
-- holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -562,7 +562,7 @@ package body System.Task_Primitives.Operations is
-- we assume the caller is holding no locks.
procedure Timed_Delay
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
@ -701,7 +701,7 @@ package body System.Task_Primitives.Operations is
-- Wakeup --
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : int;
@ -736,7 +736,7 @@ package body System.Task_Primitives.Operations is
-- with run-till-blocked scheduling.
procedure Set_Priority
(T : Task_ID;
(T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
@ -785,7 +785,7 @@ package body System.Task_Primitives.Operations is
-- Get_Priority --
------------------
function Get_Priority (T : Task_ID) return System.Any_Priority is
function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
@ -794,7 +794,7 @@ package body System.Task_Primitives.Operations is
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_ID) is
procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for PPC/MIPS systems.
@ -828,7 +828,7 @@ package body System.Task_Primitives.Operations is
-- New_ATCB --
--------------
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
@ -843,7 +843,7 @@ package body System.Task_Primitives.Operations is
-- Register_Foreign_Thread --
-----------------------------
function Register_Foreign_Thread return Task_ID is
function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
@ -856,7 +856,7 @@ package body System.Task_Primitives.Operations is
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
Self_ID.Common.LL.Thread := 0;
@ -877,7 +877,7 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Create_Task
(T : Task_ID;
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
@ -958,13 +958,13 @@ package body System.Task_Primitives.Operations is
-- Finalize_TCB --
------------------
procedure Finalize_TCB (T : Task_ID) is
procedure Finalize_TCB (T : Task_Id) is
Result : int;
Tmp : Task_ID := T;
Tmp : Task_Id := T;
Is_Self : constant Boolean := (T = Self);
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
@ -1002,7 +1002,7 @@ package body System.Task_Primitives.Operations is
-- Abort_Task --
----------------
procedure Abort_Task (T : Task_ID) is
procedure Abort_Task (T : Task_Id) is
Result : int;
begin
@ -1017,7 +1017,7 @@ package body System.Task_Primitives.Operations is
-- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -1028,7 +1028,7 @@ package body System.Task_Primitives.Operations is
-- Check_No_Locks --
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
begin
@ -1039,9 +1039,9 @@ package body System.Task_Primitives.Operations is
-- Environment_Task --
----------------------
function Environment_Task return Task_ID is
function Environment_Task return Task_Id is
begin
return Environment_Task_ID;
return Environment_Task_Id;
end Environment_Task;
--------------
@ -1067,7 +1067,7 @@ package body System.Task_Primitives.Operations is
------------------
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1086,7 +1086,7 @@ package body System.Task_Primitives.Operations is
-----------------
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
@ -1104,7 +1104,7 @@ package body System.Task_Primitives.Operations is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
Result : int;
begin
@ -1132,7 +1132,7 @@ package body System.Task_Primitives.Operations is
end if;
end loop;
Environment_Task_ID := Environment_Task;
Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.

60
gcc/ada/s-taprop.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -38,7 +38,7 @@ with System.Parameters;
-- used for Size_Type
with System.Tasking;
-- used for Task_ID
-- used for Task_Id
with System.OS_Interface;
-- used for Thread_Id
@ -49,19 +49,19 @@ package System.Task_Primitives.Operations is
package ST renames System.Tasking;
package OSI renames System.OS_Interface;
procedure Initialize (Environment_Task : ST.Task_ID);
procedure Initialize (Environment_Task : ST.Task_Id);
pragma Inline (Initialize);
-- This must be called once, before any other subprograms of this
-- package are called.
procedure Create_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
Succeeded : out Boolean);
pragma Inline (Create_Task);
-- Create a new low-level task with ST.Task_ID T and place other needed
-- Create a new low-level task with ST.Task_Id T and place other needed
-- information in the ATCB.
--
-- A new thread of control is created, with a stack of at least Stack_Size
@ -69,7 +69,7 @@ package System.Task_Primitives.Operations is
-- of control. If Stack_Size = Unspecified_Storage_Size, choose a default
-- stack size; this may be effectively "unbounded" on some systems.
--
-- The newly created low-level task is associated with the ST.Task_ID T
-- The newly created low-level task is associated with the ST.Task_Id T
-- such that any subsequent call to Self from within the context of the
-- low-level task returns T.
--
@ -80,7 +80,7 @@ package System.Task_Primitives.Operations is
-- Succeeded is set to true unless creation of the task failed,
-- as it may if there are insufficient resources to create another task.
procedure Enter_Task (Self_ID : ST.Task_ID);
procedure Enter_Task (Self_ID : ST.Task_Id);
pragma Inline (Enter_Task);
-- Initialize data structures specific to the calling task.
-- Self must be the ID of the calling task.
@ -96,15 +96,15 @@ package System.Task_Primitives.Operations is
-- The effects of further calls to operations defined below
-- on the task are undefined thereafter.
function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_ID;
function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id;
pragma Inline (New_ATCB);
-- Allocate a new ATCB with the specified number of entries.
procedure Initialize_TCB (Self_ID : ST.Task_ID; Succeeded : out Boolean);
procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean);
pragma Inline (Initialize_TCB);
-- Initialize all fields of the TCB
procedure Finalize_TCB (T : ST.Task_ID);
procedure Finalize_TCB (T : ST.Task_Id);
pragma Inline (Finalize_TCB);
-- Finalizes Private_Data of ATCB, and then deallocates it.
-- This is also responsible for recovering any storage or other resources
@ -113,7 +113,7 @@ package System.Task_Primitives.Operations is
-- After it is called there should be no further
-- reference to the ATCB that corresponds to T.
procedure Abort_Task (T : ST.Task_ID);
procedure Abort_Task (T : ST.Task_Id);
pragma Inline (Abort_Task);
-- Abort the task specified by T (the target task). This causes
-- the target task to asynchronously raise Abort_Signal if
@ -128,7 +128,7 @@ package System.Task_Primitives.Operations is
-- ??? modify GNARL to skip wakeup and always call Abort_Task
function Self return ST.Task_ID;
function Self return ST.Task_Id;
pragma Inline (Self);
-- Return a pointer to the Ada Task Control Block of the calling task.
@ -172,7 +172,7 @@ package System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean);
procedure Write_Lock (L : access RTS_Lock; Global_Lock : Boolean := False);
procedure Write_Lock (T : ST.Task_ID);
procedure Write_Lock (T : ST.Task_Id);
pragma Inline (Write_Lock);
-- Lock a lock object for write access. After this operation returns,
-- the calling task holds write permission for the lock object. No other
@ -188,7 +188,7 @@ package System.Task_Primitives.Operations is
-- For the operation on RTS_Lock, Global_Lock should be set to True
-- if L is a global lock (Single_RTS_Lock, Global_Task_Lock).
--
-- For the operation on ST.Task_ID, the lock is the special lock object
-- For the operation on ST.Task_Id, the lock is the special lock object
-- associated with that task's ATCB. This lock has effective ceiling
-- priority high enough that it is safe to call by a task with any
-- priority in the range System.Priority. It is implicitly initialized
@ -212,7 +212,7 @@ package System.Task_Primitives.Operations is
-- Write_Lock. This simplifies the implementation, but reduces the level
-- of concurrency that can be achieved.
--
-- Note that Read_Lock is not defined for RT_Lock and ST.Task_ID.
-- Note that Read_Lock is not defined for RT_Lock and ST.Task_Id.
-- That is because (1) so far Read_Lock has always been implemented
-- the same as Write_Lock, (2) most lock usage inside the RTS involves
-- potential write access, and (3) implementations of priority ceiling
@ -220,7 +220,7 @@ package System.Task_Primitives.Operations is
procedure Unlock (L : access Lock);
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False);
procedure Unlock (T : ST.Task_ID);
procedure Unlock (T : ST.Task_Id);
pragma Inline (Unlock);
-- Unlock a locked lock object.
--
@ -295,7 +295,7 @@ package System.Task_Primitives.Operations is
-- ones.
procedure Set_Priority
(T : ST.Task_ID;
(T : ST.Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False);
pragma Inline (Set_Priority);
@ -311,7 +311,7 @@ package System.Task_Primitives.Operations is
-- Loss_Of_Inheritance helps the underlying implementation to do it
-- right when the OS doesn't.
function Get_Priority (T : ST.Task_ID) return System.Any_Priority;
function Get_Priority (T : ST.Task_Id) return System.Any_Priority;
pragma Inline (Get_Priority);
-- Returns the priority last set by Set_Priority for this task.
@ -335,7 +335,7 @@ package System.Task_Primitives.Operations is
-- Pending priority changes are handled internally.
procedure Sleep
(Self_ID : ST.Task_ID;
(Self_ID : ST.Task_Id;
Reason : System.Tasking.Task_States);
pragma Inline (Sleep);
-- Wait until the current task, T, is signaled to wake up.
@ -358,7 +358,7 @@ package System.Task_Primitives.Operations is
-- a Wakeup operation is performed for the same task.
procedure Timed_Sleep
(Self_ID : ST.Task_ID;
(Self_ID : ST.Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
@ -367,34 +367,34 @@ package System.Task_Primitives.Operations is
-- Combination of Sleep (above) and Timed_Delay
procedure Timed_Delay
(Self_ID : ST.Task_ID;
(Self_ID : ST.Task_Id;
Time : Duration;
Mode : ST.Delay_Modes);
-- Implement the semantics of the delay statement. It is assumed that
-- the caller is not abort-deferred and does not hold any locks.
procedure Wakeup
(T : ST.Task_ID;
(T : ST.Task_Id;
Reason : System.Tasking.Task_States);
pragma Inline (Wakeup);
-- Wake up task T if it is waiting on a Sleep call (of ordinary
-- or timed variety), making it ready for execution once again.
-- If the task T is not waiting on a Sleep, the operation has no effect.
function Environment_Task return ST.Task_ID;
function Environment_Task return ST.Task_Id;
pragma Inline (Environment_Task);
-- Return the task ID of the environment task
-- Consider putting this into a variable visible directly
-- by the rest of the runtime system. ???
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id;
function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id;
-- Return the thread id of the specified task
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
-- Does the calling thread have an ATCB?
function Register_Foreign_Thread return ST.Task_ID;
function Register_Foreign_Thread return ST.Task_Id;
-- Allocate and initialize a new ATCB for the current thread
-----------------------
@ -439,7 +439,7 @@ package System.Task_Primitives.Operations is
-- the guard page ourselves, and the procedure Stack_Guard is provided
-- for this purpose.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean);
procedure Stack_Guard (T : ST.Task_Id; On : Boolean);
-- Ensure guard page is set if one is needed and the underlying thread
-- system does not provide it. The procedure is as follows:
--
@ -467,16 +467,16 @@ package System.Task_Primitives.Operations is
-- These interfaces have been added to assist in debugging the
-- tasking runtime system.
function Check_Exit (Self_ID : ST.Task_ID) return Boolean;
function Check_Exit (Self_ID : ST.Task_Id) return Boolean;
pragma Inline (Check_Exit);
-- Check that the current task is holding only Global_Task_Lock.
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean;
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean;
pragma Inline (Check_No_Locks);
-- Check that current task is holding no locks.
function Suspend_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean;
-- Suspend a specific task when the underlying thread library provides
@ -485,7 +485,7 @@ package System.Task_Primitives.Operations is
-- Return True is the operation is successful
function Resume_Task
(T : ST.Task_ID;
(T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean;
-- Resume a specific task when the underlying thread library provides

30
gcc/ada/s-tarest.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -124,13 +124,13 @@ package body System.Tasking.Restricted.Stages is
-- Local Subprograms --
------------------------
procedure Task_Wrapper (Self_ID : Task_ID);
procedure Task_Wrapper (Self_ID : Task_Id);
-- This is the procedure that is called by the GNULL from the
-- new context when a task is created. It waits for activation
-- and then calls the task body procedure. When the task body
-- procedure completes, it terminates the task.
procedure Terminate_Task (Self_ID : Task_ID);
procedure Terminate_Task (Self_ID : Task_Id);
-- Terminate the calling task.
-- This should only be called by the Task_Wrapper procedure.
@ -210,8 +210,8 @@ package body System.Tasking.Restricted.Stages is
-- of the current thread, since it should be at a fixed offset from the
-- stack base.
procedure Task_Wrapper (Self_ID : Task_ID) is
ID : Task_ID := Self_ID;
procedure Task_Wrapper (Self_ID : Task_Id) is
ID : Task_Id := Self_ID;
pragma Volatile (ID);
pragma Warnings (Off, ID);
@ -288,8 +288,8 @@ package body System.Tasking.Restricted.Stages is
procedure Activate_Restricted_Tasks
(Chain_Access : Activation_Chain_Access)
is
Self_ID : constant Task_ID := STPO.Self;
C : Task_ID;
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
Activate_Prio : System.Any_Priority;
Success : Boolean;
@ -377,8 +377,8 @@ package body System.Tasking.Restricted.Stages is
-- activator.
procedure Complete_Restricted_Activation is
Self_ID : constant Task_ID := STPO.Self;
Activator : constant Task_ID := Self_ID.Common.Activator;
Self_ID : constant Task_Id := STPO.Self;
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
if Single_Lock then
@ -443,10 +443,10 @@ package body System.Tasking.Restricted.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
Created_Task : out Task_ID)
Created_Task : out Task_Id)
is
T : Task_ID;
Self_ID : constant Task_ID := STPO.Self;
T : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
Base_Priority : System.Any_Priority;
Success : Boolean;
@ -516,7 +516,7 @@ package body System.Tasking.Restricted.Stages is
-- forever, since none of the dependent tasks are expected to terminate
procedure Finalize_Global_Tasks is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
pragma Assert (Self_ID = STPO.Environment_Task);
@ -542,7 +542,7 @@ package body System.Tasking.Restricted.Stages is
-- Restricted_Terminated --
---------------------------
function Restricted_Terminated (T : Task_ID) return Boolean is
function Restricted_Terminated (T : Task_Id) return Boolean is
begin
return T.Common.State = Terminated;
end Restricted_Terminated;
@ -551,7 +551,7 @@ package body System.Tasking.Restricted.Stages is
-- Terminate_Task --
--------------------
procedure Terminate_Task (Self_ID : Task_ID) is
procedure Terminate_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.State := Terminated;
end Terminate_Task;

6
gcc/ada/s-tarest.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -131,7 +131,7 @@ package System.Tasking.Restricted.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
Created_Task : out Task_ID);
Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
@ -189,7 +189,7 @@ package System.Tasking.Restricted.Stages is
-- If the current task have not completed activation, this should be done
-- now in order to wake up the activator (the environment task).
function Restricted_Terminated (T : Task_ID) return Boolean;
function Restricted_Terminated (T : Task_Id) return Boolean;
-- Compiler interface only. Do not call from within the RTS.
-- This is called by the compiler to implement the 'Terminated attribute.
--

18
gcc/ada/s-tasdeb.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2003 Free Software Foundation, Inc. --
-- Copyright (C) 1997-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -48,7 +48,7 @@ package body System.Tasking.Debug is
package STPO renames System.Task_Primitives.Operations;
function To_Integer is new
Unchecked_Conversion (Task_ID, System.Address);
Unchecked_Conversion (Task_Id, System.Address);
type Trace_Flag_Set is array (Character) of Boolean;
@ -80,7 +80,7 @@ package body System.Tasking.Debug is
----------------
procedure List_Tasks is
C : Task_ID;
C : Task_Id;
begin
C := All_Tasks_List;
@ -103,9 +103,9 @@ package body System.Tasking.Debug is
-- Print_Task_Info --
---------------------
procedure Print_Task_Info (T : Task_ID) is
procedure Print_Task_Info (T : Task_Id) is
Entry_Call : Entry_Call_Link;
Parent : Task_ID;
Parent : Task_Id;
begin
if T = null then
@ -191,7 +191,7 @@ package body System.Tasking.Debug is
----------------------
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
C : Task_ID;
C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
@ -230,7 +230,7 @@ package body System.Tasking.Debug is
-----------------------
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
C : Task_ID;
C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
@ -273,10 +273,10 @@ package body System.Tasking.Debug is
-----------
procedure Trace
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Msg : String;
Flag : Character;
Other_Id : Task_ID := null)
Other_Id : Task_Id := null)
is
begin
if Trace_On (Flag) then

10
gcc/ada/s-tasdeb.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -51,7 +51,7 @@ package System.Tasking.Debug is
-- Write information about current task, in hexadecimal, as one line, to
-- the standard error file.
procedure Print_Task_Info (T : Task_ID);
procedure Print_Task_Info (T : Task_Id);
-- Similar to Print_Current_Task, for a given task.
procedure Set_User_State (Value : Long_Integer);
@ -66,7 +66,7 @@ package System.Tasking.Debug is
-- General GDB support --
-------------------------
Known_Tasks : array (0 .. 999) of Task_ID;
Known_Tasks : array (0 .. 999) of Task_Id;
-- Global array of tasks read by gdb, and updated by
-- Create_Task and Finalize_TCB
@ -99,10 +99,10 @@ package System.Tasking.Debug is
-------------------------------
procedure Trace
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Msg : String;
Flag : Character;
Other_Id : Task_ID := null);
Other_Id : Task_Id := null);
-- If traces for Flag are enabled, display on Standard_Error a given
-- message for the current task. Other_Id is an optional second task id
-- to display.

56
gcc/ada/s-tasini.adb
View file

@ -116,7 +116,7 @@ package body System.Tasking.Initialization is
-- Get the exception stack for the current task
procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address);
-- Self_ID is the Task_ID of the task that gets the exception stack.
-- Self_ID is the Task_Id of the task that gets the exception stack.
-- For Self_ID = Null_Address, the current task gets the exception stack.
function Get_Machine_State_Addr return Address;
@ -143,7 +143,7 @@ package body System.Tasking.Initialization is
-- Local Subprograms --
------------------------
procedure Do_Pending_Action (Self_ID : Task_ID);
procedure Do_Pending_Action (Self_ID : Task_Id);
-- This is introduced to allow more efficient
-- in-line expansion of Undefer_Abort.
@ -171,7 +171,7 @@ package body System.Tasking.Initialization is
-- 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
if T.Common.Base_Priority /= T.New_Base_Priority then
T.Common.Base_Priority := T.New_Base_Priority;
@ -184,7 +184,7 @@ package body System.Tasking.Initialization is
------------------------
function Check_Abort_Status return Integer is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
if Self_ID /= null and then Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
@ -199,7 +199,7 @@ package body System.Tasking.Initialization is
-- Defer_Abort --
-----------------
procedure Defer_Abort (Self_ID : Task_ID) is
procedure Defer_Abort (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
return;
@ -240,7 +240,7 @@ package body System.Tasking.Initialization is
-- Defer_Abort_Nestable --
--------------------------
procedure Defer_Abort_Nestable (Self_ID : Task_ID) is
procedure Defer_Abort_Nestable (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
return;
@ -261,7 +261,7 @@ package body System.Tasking.Initialization is
--------------------
procedure Defer_Abortion is
Self_ID : Task_ID;
Self_ID : Task_Id;
begin
if No_Abort and then not Dynamic_Priority_Support then
@ -278,7 +278,7 @@ package body System.Tasking.Initialization is
-- Call only when holding no locks
procedure Do_Pending_Action (Self_ID : Task_ID) is
procedure Do_Pending_Action (Self_ID : Task_Id) is
use type Ada.Exceptions.Exception_Id;
begin
@ -353,7 +353,7 @@ package body System.Tasking.Initialization is
-- not make any reference to the ATCB after the lock is released.
-- See also comments on Terminate_Task and Unlock.
procedure Final_Task_Unlock (Self_ID : Task_ID) is
procedure Final_Task_Unlock (Self_ID : Task_Id) is
begin
pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1);
Unlock (Global_Task_Lock'Access, Global_Lock => True);
@ -364,7 +364,7 @@ package body System.Tasking.Initialization is
--------------
procedure Init_RTS is
Self_Id : Task_ID;
Self_Id : Task_Id;
begin
-- Terminate run time (regular vs restricted) specific initialization
@ -490,8 +490,8 @@ package body System.Tasking.Initialization is
-- for this case is done in Terminate_Task.
procedure Locked_Abort_To_Level
(Self_ID : Task_ID;
T : Task_ID;
(Self_ID : Task_Id;
T : Task_Id;
L : ATC_Level)
is
begin
@ -590,7 +590,7 @@ package body System.Tasking.Initialization is
-- In this version, we check if the task is held too because
-- doing this only in Do_Pending_Action is not enough.
procedure Poll_Base_Priority_Change (Self_ID : Task_ID) is
procedure Poll_Base_Priority_Change (Self_ID : Task_Id) is
begin
if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
@ -636,9 +636,9 @@ package body System.Tasking.Initialization is
-- Remove_From_All_Tasks_List --
--------------------------------
procedure Remove_From_All_Tasks_List (T : Task_ID) is
C : Task_ID;
Previous : Task_ID;
procedure Remove_From_All_Tasks_List (T : Task_Id) is
C : Task_Id;
Previous : Task_Id;
begin
pragma Debug
@ -670,7 +670,7 @@ package body System.Tasking.Initialization is
-- Task_Lock --
---------------
procedure Task_Lock (Self_ID : Task_ID) is
procedure Task_Lock (Self_ID : Task_Id) is
begin
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1;
@ -690,7 +690,7 @@ package body System.Tasking.Initialization is
---------------
function Task_Name return String is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
begin
return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len);
@ -700,7 +700,7 @@ package body System.Tasking.Initialization is
-- Task_Unlock --
-----------------
procedure Task_Unlock (Self_ID : Task_ID) is
procedure Task_Unlock (Self_ID : Task_Id) is
begin
pragma Assert (Self_ID.Global_Task_Lock_Nesting > 0);
Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1;
@ -729,7 +729,7 @@ package body System.Tasking.Initialization is
-- The priority change has to occur before abortion. Otherwise, it would
-- take effect no earlier than the next abortion completion point.
procedure Undefer_Abort (Self_ID : Task_ID) is
procedure Undefer_Abort (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
return;
@ -765,7 +765,7 @@ package body System.Tasking.Initialization is
-- as entry to the scope of a region with a finalizer and entry into the
-- body of an accept-procedure.
procedure Undefer_Abort_Nestable (Self_ID : Task_ID) is
procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
return;
@ -793,7 +793,7 @@ package body System.Tasking.Initialization is
-- to reduce overhead due to multiple calls to Self.
procedure Undefer_Abortion is
Self_ID : Task_ID;
Self_ID : Task_Id;
begin
if No_Abort and then not Dynamic_Priority_Support then
@ -823,7 +823,7 @@ package body System.Tasking.Initialization is
procedure Update_Exception
(X : AE.Exception_Occurrence := Current_Target_Exception)
is
Self_Id : constant Task_ID := Self;
Self_Id : constant Task_Id := Self;
use Ada.Exceptions;
begin
@ -885,11 +885,11 @@ package body System.Tasking.Initialization is
-- if Entry_Call.State >= Was_Abortable.
procedure Wakeup_Entry_Caller
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State)
is
Caller : constant Task_ID := Entry_Call.Self;
Caller : constant Task_Id := Entry_Call.Self;
begin
pragma Debug (Debug.Trace
@ -951,7 +951,7 @@ package body System.Tasking.Initialization is
end Get_Stack_Info;
procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is
Me : Task_ID := To_Task_ID (Self_ID);
Me : Task_Id := To_Task_Id (Self_ID);
begin
if Me = Null_Task then
Me := STPO.Self;
@ -989,14 +989,14 @@ package body System.Tasking.Initialization is
-- links will be redirected to the real subprogram by elaboration of
-- the subprogram body where the real subprogram is declared.
procedure Finalize_Attributes (T : Task_ID) is
procedure Finalize_Attributes (T : Task_Id) is
pragma Warnings (Off, T);
begin
null;
end Finalize_Attributes;
procedure Initialize_Attributes (T : Task_ID) is
procedure Initialize_Attributes (T : Task_Id) is
pragma Warnings (Off, T);
begin

34
gcc/ada/s-tasini.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -36,7 +36,7 @@
package System.Tasking.Initialization is
procedure Remove_From_All_Tasks_List (T : Task_ID);
procedure Remove_From_All_Tasks_List (T : Task_Id);
-- Remove T from All_Tasks_List.
-- Call this function with RTS_Lock taken.
@ -49,10 +49,10 @@ package System.Tasking.Initialization is
-- by the tasking run-time system.
-- So far, the only example is support for Ada.Task_Attributes.
type Proc_T is access procedure (T : Task_ID);
type Proc_T is access procedure (T : Task_Id);
procedure Finalize_Attributes (T : Task_ID);
procedure Initialize_Attributes (T : Task_ID);
procedure Finalize_Attributes (T : Task_Id);
procedure Initialize_Attributes (T : Task_Id);
Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access;
-- should be called with abortion deferred and T.L write-locked
@ -108,18 +108,18 @@ package System.Tasking.Initialization is
-- Non-nestable inline versions --
procedure Defer_Abort (Self_ID : Task_ID);
procedure Defer_Abort (Self_ID : Task_Id);
pragma Inline (Defer_Abort);
procedure Undefer_Abort (Self_ID : Task_ID);
procedure Undefer_Abort (Self_ID : Task_Id);
pragma Inline (Undefer_Abort);
-- Nestable inline versions --
procedure Defer_Abort_Nestable (Self_ID : Task_ID);
procedure Defer_Abort_Nestable (Self_ID : Task_Id);
pragma Inline (Defer_Abort_Nestable);
procedure Undefer_Abort_Nestable (Self_ID : Task_ID);
procedure Undefer_Abort_Nestable (Self_ID : Task_Id);
pragma Inline (Undefer_Abort_Nestable);
-- NON-INLINE versions without Self_ID for code generated by the
@ -139,12 +139,12 @@ package System.Tasking.Initialization is
-- Change Base Priority --
---------------------------
procedure Change_Base_Priority (T : Task_ID);
procedure Change_Base_Priority (T : Task_Id);
-- Change the base priority of T.
-- Has to be called with the affected task's ATCB write-locked.
-- May temporariliy release the lock.
procedure Poll_Base_Priority_Change (Self_ID : Task_ID);
procedure Poll_Base_Priority_Change (Self_ID : Task_Id);
-- Has to be called with Self_ID's ATCB write-locked.
-- May temporariliy release the lock.
pragma Inline (Poll_Base_Priority_Change);
@ -153,15 +153,15 @@ package System.Tasking.Initialization is
-- Task Lock/Unlock --
----------------------
procedure Task_Lock (Self_ID : Task_ID);
procedure Task_Lock (Self_ID : Task_Id);
pragma Inline (Task_Lock);
procedure Task_Unlock (Self_ID : Task_ID);
procedure Task_Unlock (Self_ID : Task_Id);
pragma Inline (Task_Unlock);
-- These are versions of Lock_Task and Unlock_Task created for use
-- within the GNARL.
procedure Final_Task_Unlock (Self_ID : Task_ID);
procedure Final_Task_Unlock (Self_ID : Task_Id);
-- This version is only for use in Terminate_Task, when the task
-- is relinquishing further rights to its own ATCB.
-- There is a very interesting potential race condition there, where
@ -171,7 +171,7 @@ package System.Tasking.Initialization is
-- See also comments on Terminate_Task and Unlock.
procedure Wakeup_Entry_Caller
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State);
pragma Inline (Wakeup_Entry_Caller);
@ -195,8 +195,8 @@ package System.Tasking.Initialization is
-- if Entry_Call.State >= Was_Abortable.
procedure Locked_Abort_To_Level
(Self_ID : Task_ID;
T : Task_ID;
(Self_ID : Task_Id;
T : Task_Id;
L : ATC_Level);
pragma Inline (Locked_Abort_To_Level);
-- Abort a task to a specified ATC level.

14
gcc/ada/s-taskin.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -52,28 +52,28 @@ package body System.Tasking is
package STPO renames System.Task_Primitives.Operations;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
----------
-- Self --
----------
function Self return Task_ID renames STPO.Self;
function Self return Task_Id renames STPO.Self;
---------------------
-- Initialize_ATCB --
---------------------
procedure Initialize_ATCB
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Task_Entry_Point : Task_Procedure_Access;
Task_Arg : System.Address;
Parent : Task_ID;
Parent : Task_Id;
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : in out Task_ID;
T : in out Task_Id;
Success : out Boolean) is
begin
T.Common.State := Unactivated;
@ -146,7 +146,7 @@ package body System.Tasking is
begin
declare
T : Task_ID;
T : Task_Id;
Success : Boolean;
Base_Priority : Any_Priority;

44
gcc/ada/s-taskin.ads
View file

@ -109,24 +109,24 @@ package System.Tasking is
-- the parent always has a lower serial number than the activator.
---------------------------------
-- Task_ID related definitions --
-- Task_Id related definitions --
---------------------------------
type Ada_Task_Control_Block;
type Task_ID is access all Ada_Task_Control_Block;
type Task_Id is access all Ada_Task_Control_Block;
Null_Task : constant Task_ID;
Null_Task : constant Task_Id;
type Task_List is array (Positive range <>) of Task_ID;
type Task_List is array (Positive range <>) of Task_Id;
function Self return Task_ID;
function Self return Task_Id;
pragma Inline (Self);
-- This is the compiler interface version of this function. Do not call
-- from the run-time system.
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
-----------------------
-- Enumeration types --
@ -301,7 +301,7 @@ package System.Tasking is
-- async. select statement does not need to lock anything.
type Restricted_Entry_Call_Record is record
Self : Task_ID;
Self : Task_Id;
-- ID of the caller
Mode : Call_Modes;
@ -388,7 +388,7 @@ package System.Tasking is
-- and whether it is terminated.
-- Protection: Self.L.
Parent : Task_ID;
Parent : Task_Id;
-- The task on which this task depends.
-- See also Master_Level and Master_Within.
@ -461,15 +461,15 @@ package System.Tasking is
-- per-task structures.
-- Protection: Only accessed by Self.
All_Tasks_Link : Task_ID;
All_Tasks_Link : Task_Id;
-- Used to link this task to the list of all tasks in the system.
-- Protection: RTS_Lock.
Activation_Link : Task_ID;
Activation_Link : Task_Id;
-- Used to link this task to a list of tasks to be activated.
-- Protection: Only used by Activator.
Activator : Task_ID;
Activator : Task_Id;
-- The task that created this task, either by declaring it as a task
-- object or by executing a task allocator.
-- The value is null iff Self has completed activation.
@ -542,16 +542,16 @@ package System.Tasking is
end record;
pragma Suppress_Initialization (Restricted_Ada_Task_Control_Block);
Interrupt_Manager_ID : Task_ID;
Interrupt_Manager_ID : Task_Id;
-- This task ID is declared here to break circular dependencies.
-- Also declare Interrupt_Manager_ID after Task_ID is known, to avoid
-- Also declare Interrupt_Manager_ID after Task_Id is known, to avoid
-- generating unneeded finalization code.
-----------------------
-- List of all Tasks --
-----------------------
All_Tasks_List : Task_ID;
All_Tasks_List : Task_Id;
-- Global linked list of all tasks.
------------------------------------------
@ -633,7 +633,7 @@ package System.Tasking is
----------------------------------
type Entry_Call_Record is record
Self : Task_ID;
Self : Task_Id;
-- ID of the caller
Mode : Call_Modes;
@ -679,7 +679,7 @@ package System.Tasking is
-- They are gathered together to allow for compilers that lay records
-- out contiguously, to allow for such packing.
Called_Task : Task_ID;
Called_Task : Task_Id;
pragma Atomic (Called_Task);
-- Use for task entry calls.
-- The value is null if the call record is not in use.
@ -953,25 +953,25 @@ package System.Tasking is
---------------------
procedure Initialize_ATCB
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Task_Entry_Point : Task_Procedure_Access;
Task_Arg : System.Address;
Parent : Task_ID;
Parent : Task_Id;
Elaborated : Access_Boolean;
Base_Priority : System.Any_Priority;
Task_Info : System.Task_Info.Task_Info_Type;
Stack_Size : System.Parameters.Size_Type;
T : in out Task_ID;
T : in out Task_Id;
Success : out Boolean);
-- Initialize fields of a TCB and link into global TCB structures
-- Call this only with abort deferred and holding RTS_Lock.
private
Null_Task : constant Task_ID := null;
Null_Task : constant Task_Id := null;
type Activation_Chain is record
T_ID : Task_ID;
T_ID : Task_Id;
end record;
pragma Volatile (Activation_Chain);

14
gcc/ada/s-tasque.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -60,7 +60,7 @@ package body System.Tasking.Queuing is
Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
procedure Send_Program_Error
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- Raise Program_Error in the caller of the specified entry call
@ -74,7 +74,7 @@ package body System.Tasking.Queuing is
-----------------------------
procedure Broadcast_Program_Error
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
Pending_Call : Entry_Call_Link;
RTS_Locked : Boolean := False)
@ -469,7 +469,7 @@ package body System.Tasking.Queuing is
-- queuing policy being used.
procedure Select_Protected_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
Call : out Entry_Call_Link)
is
@ -547,7 +547,7 @@ package body System.Tasking.Queuing is
-- being used.
procedure Select_Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
Open_Accepts : Accept_List_Access;
Call : out Entry_Call_Link;
Selection : out Select_Index;
@ -618,10 +618,10 @@ package body System.Tasking.Queuing is
------------------------
procedure Send_Program_Error
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
Caller : Task_ID;
Caller : Task_Id;
begin
Caller := Entry_Call.Self;
Entry_Call.Exception_To_Raise := Program_Error'Identity;

8
gcc/ada/s-tasque.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -38,7 +38,7 @@ package System.Tasking.Queuing is
package POE renames System.Tasking.Protected_Objects.Entries;
procedure Broadcast_Program_Error
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : POE.Protection_Entries_Access;
Pending_Call : Entry_Call_Link;
RTS_Locked : Boolean := False);
@ -71,7 +71,7 @@ package System.Tasking.Queuing is
-- Return number of calls on the waiting queue of E
procedure Select_Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
Open_Accepts : Accept_List_Access;
Call : out Entry_Call_Link;
Selection : out Select_Index;
@ -82,7 +82,7 @@ package System.Tasking.Queuing is
-- Open_Alternative will be True if there were any open alternatives
procedure Select_Protected_Entry_Call
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : POE.Protection_Entries_Access;
Call : out Entry_Call_Link);
-- Select an entry of a protected object

76
gcc/ada/s-tasren.adb
View file

@ -130,10 +130,10 @@ package body System.Tasking.Rendezvous is
-- Local Subprograms --
-----------------------
procedure Local_Defer_Abort (Self_Id : Task_ID) renames
procedure Local_Defer_Abort (Self_Id : Task_Id) renames
System.Tasking.Initialization.Defer_Abort_Nestable;
procedure Local_Undefer_Abort (Self_Id : Task_ID) renames
procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
System.Tasking.Initialization.Undefer_Abort_Nestable;
-- Florist defers abort around critical sections that
@ -147,12 +147,12 @@ package body System.Tasking.Rendezvous is
-- an earlier abort deferral. Thus, for debugging it may be
-- wise to modify the above renamings to the non-nestable forms.
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID);
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
pragma Inline (Boost_Priority);
-- Call this only with abort deferred and holding lock of Acceptor.
procedure Call_Synchronous
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
@ -163,7 +163,7 @@ package body System.Tasking.Rendezvous is
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
Acceptor : Task_ID);
Acceptor : Task_Id);
pragma Inline (Setup_For_Rendezvous_With_Body);
-- Call this only with abort deferred and holding lock of Acceptor.
-- When a rendezvous selected (ready for rendezvous) we need to save
@ -171,7 +171,7 @@ package body System.Tasking.Rendezvous is
-- this call not Abortable (Cancellable) since the rendezvous has
-- already been started.
procedure Wait_For_Call (Self_Id : Task_ID);
procedure Wait_For_Call (Self_Id : Task_Id);
pragma Inline (Wait_For_Call);
-- Call this only with abort deferred and holding lock of Self_Id.
-- An accepting task goes into Sleep by calling this routine
@ -186,8 +186,8 @@ package body System.Tasking.Rendezvous is
(E : Task_Entry_Index;
Uninterpreted_Data : out System.Address)
is
Self_Id : constant Task_ID := STPO.Self;
Caller : Task_ID := null;
Self_Id : constant Task_Id := STPO.Self;
Caller : Task_Id := null;
Open_Accepts : aliased Accept_List (1 .. 1);
Entry_Call : Entry_Call_Link;
@ -277,8 +277,8 @@ package body System.Tasking.Rendezvous is
--------------------
procedure Accept_Trivial (E : Task_Entry_Index) is
Self_Id : constant Task_ID := STPO.Self;
Caller : Task_ID := null;
Self_Id : constant Task_Id := STPO.Self;
Caller : Task_Id := null;
Open_Accepts : aliased Accept_List (1 .. 1);
Entry_Call : Entry_Call_Link;
@ -366,8 +366,8 @@ package body System.Tasking.Rendezvous is
-- Boost_Priority --
--------------------
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is
Caller : constant Task_ID := Call.Self;
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
Caller : constant Task_Id := Call.Self;
Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
@ -386,7 +386,7 @@ package body System.Tasking.Rendezvous is
-----------------
procedure Call_Simple
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address)
is
@ -401,13 +401,13 @@ package body System.Tasking.Rendezvous is
----------------------
procedure Call_Synchronous
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
Rendezvous_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Level : ATC_Level;
Entry_Call : Entry_Call_Link;
@ -490,9 +490,9 @@ package body System.Tasking.Rendezvous is
-- Callable --
--------------
function Callable (T : Task_ID) return Boolean is
function Callable (T : Task_Id) return Boolean is
Result : Boolean;
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
begin
Initialization.Defer_Abort (Self_Id);
@ -538,9 +538,9 @@ package body System.Tasking.Rendezvous is
procedure Exceptional_Complete_Rendezvous
(Ex : Ada.Exceptions.Exception_Id)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link := Self_Id.Common.Call;
Caller : Task_ID;
Caller : Task_Id;
Called_PO : STPE.Protection_Entries_Access;
Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
@ -732,7 +732,7 @@ package body System.Tasking.Rendezvous is
procedure Requeue_Protected_To_Task_Entry
(Object : STPE.Protection_Entries_Access;
Acceptor : Task_ID;
Acceptor : Task_Id;
E : Task_Entry_Index;
With_Abort : Boolean)
is
@ -752,11 +752,11 @@ package body System.Tasking.Rendezvous is
------------------------
procedure Requeue_Task_Entry
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
With_Abort : Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
begin
@ -778,10 +778,10 @@ package body System.Tasking.Rendezvous is
Uninterpreted_Data : out System.Address;
Index : out Select_Index)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
Treatment : Select_Treatment;
Caller : Task_ID;
Caller : Task_Id;
Selection : Select_Index;
Open_Alternative : Boolean;
@ -1035,7 +1035,7 @@ package body System.Tasking.Rendezvous is
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
Acceptor : Task_ID) is
Acceptor : Task_Id) is
begin
Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
Acceptor.Common.Call := Entry_Call;
@ -1052,7 +1052,7 @@ package body System.Tasking.Rendezvous is
----------------
function Task_Count (E : Task_Entry_Index) return Natural is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Return_Count : Natural;
begin
@ -1079,15 +1079,15 @@ package body System.Tasking.Rendezvous is
----------------------
function Task_Do_Or_Queue
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean) return Boolean
is
E : constant Task_Entry_Index :=
Task_Entry_Index (Entry_Call.E);
Old_State : constant Entry_Call_State := Entry_Call.State;
Acceptor : constant Task_ID := Entry_Call.Called_Task;
Parent : constant Task_ID := Acceptor.Common.Parent;
Acceptor : constant Task_Id := Entry_Call.Called_Task;
Parent : constant Task_Id := Acceptor.Common.Parent;
Parent_Locked : Boolean := False;
Null_Body : Boolean;
@ -1299,13 +1299,13 @@ package body System.Tasking.Rendezvous is
---------------------
procedure Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
Rendezvous_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
begin
@ -1391,8 +1391,8 @@ package body System.Tasking.Rendezvous is
-- Task_Entry_Caller --
-----------------------
function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID is
Self_Id : constant Task_ID := STPO.Self;
function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
begin
@ -1418,10 +1418,10 @@ package body System.Tasking.Rendezvous is
Mode : Delay_Modes;
Index : out Select_Index)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Treatment : Select_Treatment;
Entry_Call : Entry_Call_Link;
Caller : Task_ID;
Caller : Task_Id;
Selection : Select_Index;
Open_Alternative : Boolean;
Timedout : Boolean := False;
@ -1655,14 +1655,14 @@ package body System.Tasking.Rendezvous is
---------------------------
procedure Timed_Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Timeout : Duration;
Mode : Delay_Modes;
Rendezvous_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Level : ATC_Level;
Entry_Call : Entry_Call_Link;
Yielded : Boolean;
@ -1747,7 +1747,7 @@ package body System.Tasking.Rendezvous is
-- Wait_For_Call --
-------------------
procedure Wait_For_Call (Self_Id : Task_ID) is
procedure Wait_For_Call (Self_Id : Task_Id) is
begin
-- Try to remove calls to Sleep in the loop below by letting the caller
-- a chance of getting ready immediately, using Unlock & Yield.

18
gcc/ada/s-tasren.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -45,7 +45,7 @@ package System.Tasking.Rendezvous is
package STPE renames System.Tasking.Protected_Objects.Entries;
procedure Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Mode : Call_Modes;
@ -61,7 +61,7 @@ package System.Tasking.Rendezvous is
-- Rendezvous_Successful is set to True on return if the call was serviced.
procedure Timed_Task_Entry_Call
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address;
Timeout : Duration;
@ -74,7 +74,7 @@ package System.Tasking.Rendezvous is
-- Mode determines whether the delay is relative or absolute.
procedure Call_Simple
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address);
-- Simple entry call.
@ -100,7 +100,7 @@ package System.Tasking.Rendezvous is
-- See Exp_Ch9.Expand_N_Asynchronous_Select for code expansion.
procedure Requeue_Task_Entry
(Acceptor : Task_ID;
(Acceptor : Task_Id;
E : Task_Entry_Index;
With_Abort : Boolean);
-- Requeue from a task entry to a task entry.
@ -136,7 +136,7 @@ package System.Tasking.Rendezvous is
procedure Requeue_Protected_To_Task_Entry
(Object : STPE.Protection_Entries_Access;
Acceptor : Task_ID;
Acceptor : Task_Id;
E : Task_Entry_Index;
With_Abort : Boolean);
-- Requeue from a protected entry to a task entry.
@ -294,7 +294,7 @@ package System.Tasking.Rendezvous is
-- Return number of tasks waiting on the entry E (of current task)
-- Compiler interface only. Do not call from within the RTS.
function Callable (T : Task_ID) return Boolean;
function Callable (T : Task_Id) return Boolean;
-- Return T'Callable
-- Compiler interface. Do not call from within the RTS, except for body of
-- Ada.Task_Identification.
@ -302,7 +302,7 @@ package System.Tasking.Rendezvous is
type Task_Entry_Nesting_Depth is new Task_Entry_Index
range 0 .. Max_Task_Entry;
function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID;
function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id;
-- Return E'Caller. This will only work if called from within an
-- accept statement that is handling E, as required by the LRM (C.7.1(14)).
-- Compiler interface only. Do not call from within the RTS.
@ -318,7 +318,7 @@ package System.Tasking.Rendezvous is
-- For internal use only:
function Task_Do_Or_Queue
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean) return Boolean;
-- Call this only with abort deferred and holding no locks, except

88
gcc/ada/s-tassta.adb
View file

@ -130,40 +130,40 @@ package body System.Tasking.Stages is
-- Local Subprograms --
-----------------------
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID);
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
-- This procedure outputs the task specific message for exception
-- tracing purposes.
procedure Task_Wrapper (Self_ID : Task_ID);
procedure Task_Wrapper (Self_ID : Task_Id);
-- This is the procedure that is called by the GNULL from the
-- new context when a task is created. It waits for activation
-- and then calls the task body procedure. When the task body
-- procedure completes, it terminates the task.
procedure Vulnerable_Complete_Task (Self_ID : Task_ID);
procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
-- Complete the calling task.
-- This procedure must be called with abort deferred.
-- It should only be called by Complete_Task and
-- Finalizate_Global_Tasks (for the environment task).
procedure Vulnerable_Complete_Master (Self_ID : Task_ID);
procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
-- Complete the current master of the calling task.
-- This procedure must be called with abort deferred.
-- It should only be called by Vulnerable_Complete_Task and
-- Complete_Master.
procedure Vulnerable_Complete_Activation (Self_ID : Task_ID);
procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
-- Signal to Self_ID's activator that Self_ID has
-- completed activation.
--
-- Call this procedure with abort deferred.
procedure Abort_Dependents (Self_ID : Task_ID);
procedure Abort_Dependents (Self_ID : Task_Id);
-- Abort all the direct dependents of Self at its current master
-- nesting level, plus all of their dependents, transitively.
-- RTS_Lock should be locked by the caller.
procedure Vulnerable_Free_Task (T : Task_ID);
procedure Vulnerable_Free_Task (T : Task_Id);
-- Recover all runtime system storage associated with the task T.
-- This should only be called after T has terminated and will no
-- longer be referenced.
@ -181,9 +181,9 @@ package body System.Tasking.Stages is
-- Abort_Dependents --
----------------------
procedure Abort_Dependents (Self_ID : Task_ID) is
C : Task_ID;
P : Task_ID;
procedure Abort_Dependents (Self_ID : Task_Id) is
C : Task_Id;
P : Task_Id;
begin
C := All_Tasks_List;
@ -251,10 +251,10 @@ package body System.Tasking.Stages is
-- operation is done in a separate pass over the activation chain.
procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
Self_ID : constant Task_ID := STPO.Self;
P : Task_ID;
C : Task_ID;
Next_C, Last_C : Task_ID;
Self_ID : constant Task_Id := STPO.Self;
P : Task_Id;
C : Task_Id;
Next_C, Last_C : Task_Id;
Activate_Prio : System.Any_Priority;
Success : Boolean;
All_Elaborated : Boolean := True;
@ -426,7 +426,7 @@ package body System.Tasking.Stages is
-------------------------
procedure Complete_Activation is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
@ -455,7 +455,7 @@ package body System.Tasking.Stages is
---------------------
procedure Complete_Master is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
pragma Assert (Self_ID.Deferral_Level > 0);
@ -470,7 +470,7 @@ package body System.Tasking.Stages is
-- See comments on Vulnerable_Complete_Task for details
procedure Complete_Task is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
pragma Assert (Self_ID.Deferral_Level > 0);
@ -498,10 +498,10 @@ package body System.Tasking.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
Created_Task : out Task_ID)
Created_Task : out Task_Id)
is
T, P : Task_ID;
Self_ID : constant Task_ID := STPO.Self;
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
Success : Boolean;
Base_Priority : System.Any_Priority;
Len : Natural;
@ -639,7 +639,7 @@ package body System.Tasking.Stages is
------------------
procedure Enter_Master is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
Self_ID.Master_Within := Self_ID.Master_Within + 1;
@ -652,10 +652,10 @@ package body System.Tasking.Stages is
-- See procedure Close_Entries for the general case.
procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
Self_ID : constant Task_ID := STPO.Self;
C : Task_ID;
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
Call : Entry_Call_Link;
Temp : Task_ID;
Temp : Task_Id;
begin
pragma Debug
@ -714,7 +714,7 @@ package body System.Tasking.Stages is
-- using the global finalization chain.
procedure Finalize_Global_Tasks is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
Ignore : Boolean;
begin
@ -813,8 +813,8 @@ package body System.Tasking.Stages is
-- Free_Task --
---------------
procedure Free_Task (T : Task_ID) is
Self_Id : constant Task_ID := Self;
procedure Free_Task (T : Task_Id) is
Self_Id : constant Task_Id := Self;
begin
if T.Common.State = Terminated then
@ -851,7 +851,7 @@ package body System.Tasking.Stages is
-- data. Task finalization is done by Complete_Task, which is called from
-- an at-end handler that the compiler generates.
procedure Task_Wrapper (Self_ID : Task_ID) is
procedure Task_Wrapper (Self_ID : Task_Id) is
use type System.Parameters.Size_Type;
use type SSE.Storage_Offset;
use System.Standard_Library;
@ -973,8 +973,8 @@ package body System.Tasking.Stages is
-- overwriting the data of the new task that reused the ATCB! To solve
-- this problem, we introduced the new operation Final_Task_Unlock.
procedure Terminate_Task (Self_ID : Task_ID) is
Environment_Task : constant Task_ID := STPO.Environment_Task;
procedure Terminate_Task (Self_ID : Task_Id) is
Environment_Task : constant Task_Id := STPO.Environment_Task;
Master_of_Task : Integer;
begin
@ -1045,8 +1045,8 @@ package body System.Tasking.Stages is
-- Terminated --
----------------
function Terminated (T : Task_ID) return Boolean is
Self_ID : constant Task_ID := STPO.Self;
function Terminated (T : Task_Id) return Boolean is
Self_ID : constant Task_Id := STPO.Self;
Result : Boolean;
begin
@ -1072,7 +1072,7 @@ package body System.Tasking.Stages is
-- Trace_Unhandled_Exception_In_Task --
----------------------------------------
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID) is
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
procedure To_Stderr (S : String);
pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
@ -1081,7 +1081,7 @@ package body System.Tasking.Stages is
use System.Standard_Library;
function To_Address is new
Unchecked_Conversion (Task_ID, System.Address);
Unchecked_Conversion (Task_Id, System.Address);
function Tailored_Exception_Information
(E : Exception_Occurrence) return String;
@ -1121,8 +1121,8 @@ package body System.Tasking.Stages is
-- ordering policy, since the activated task must be created after the
-- activator.
procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is
Activator : constant Task_ID := Self_ID.Common.Activator;
procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
Activator : constant Task_Id := Self_ID.Common.Activator;
begin
pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
@ -1175,13 +1175,13 @@ package body System.Tasking.Stages is
-- Vulnerable_Complete_Master --
--------------------------------
procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is
C : Task_ID;
P : Task_ID;
procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
C : Task_Id;
P : Task_Id;
CM : constant Master_Level := Self_ID.Master_Within;
T : aliased Task_ID;
T : aliased Task_Id;
To_Be_Freed : Task_ID;
To_Be_Freed : Task_Id;
-- This is a list of ATCBs to be freed, after we have released
-- all RTS locks. This is necessary because of the locking order
-- rules, since the storage manager uses Global_Task_Lock.
@ -1478,7 +1478,7 @@ package body System.Tasking.Stages is
-- Be sure to update this value when changing
-- Interrupt_Manager specs.
type Param_Type is access all Task_ID;
type Param_Type is access all Task_Id;
Param : aliased Param_Type := T'Access;
@ -1546,7 +1546,7 @@ package body System.Tasking.Stages is
-- to test Self_ID.Common.Activator. That value should only be read and
-- modified by Self.
procedure Vulnerable_Complete_Task (Self_ID : Task_ID) is
procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
begin
pragma Assert (Self_ID.Deferral_Level > 0);
pragma Assert (Self_ID = Self);
@ -1607,7 +1607,7 @@ package body System.Tasking.Stages is
-- It is also called from Unchecked_Deallocation, for objects that
-- are or contain tasks.
procedure Vulnerable_Free_Task (T : Task_ID) is
procedure Vulnerable_Free_Task (T : Task_Id) is
begin
pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));

10
gcc/ada/s-tassta.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -177,7 +177,7 @@ package System.Tasking.Stages is
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
Task_Image : String;
Created_Task : out Task_ID);
Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
@ -250,12 +250,12 @@ package System.Tasking.Stages is
-- It currently also executes the global finalization list, and then resets
-- the "soft links".
procedure Free_Task (T : Task_ID);
procedure Free_Task (T : Task_Id);
-- Recover all runtime system storage associated with the task T, but only
-- if T has terminated. Do nothing in the other case. It is called from
-- Unchecked_Deallocation, for objects that are or contain tasks.
function Terminated (T : Task_ID) return Boolean;
function Terminated (T : Task_Id) return Boolean;
-- This is called by the compiler to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to synchronize
-- with the task's ATCB, so that this is more useful for polling the state
@ -268,7 +268,7 @@ package System.Tasking.Stages is
-- code expansion:
-- terminated (t1._task_id)
procedure Terminate_Task (Self_ID : Task_ID);
procedure Terminate_Task (Self_ID : Task_Id);
-- Terminate the calling task.
-- This should only be called by the Task_Wrapper procedure, and to
-- deallocate storage associate with foreign tasks.

30
gcc/ada/s-tasuti.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -92,7 +92,7 @@ package body System.Tasking.Utilities is
-- (2) may be called for tasks that have not yet been activated
-- (3) always aborts whole task
procedure Abort_One_Task (Self_ID : Task_ID; T : Task_ID) is
procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is
begin
if Parameters.Runtime_Traces then
Send_Trace_Info (T_Abort, Self_ID, T);
@ -126,9 +126,9 @@ package body System.Tasking.Utilities is
-- Abort_Signal special exception.
procedure Abort_Tasks (Tasks : Task_List) is
Self_Id : constant Task_ID := STPO.Self;
C : Task_ID;
P : Task_ID;
Self_Id : constant Task_Id := STPO.Self;
C : Task_Id;
P : Task_Id;
begin
Initialization.Defer_Abort_Nestable (Self_Id);
@ -178,12 +178,12 @@ package body System.Tasking.Utilities is
-- This should only be called by T, unless T is a terminated previously
-- unactivated task.
procedure Cancel_Queued_Entry_Calls (T : Task_ID) is
procedure Cancel_Queued_Entry_Calls (T : Task_Id) is
Next_Entry_Call : Entry_Call_Link;
Entry_Call : Entry_Call_Link;
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Caller : Task_ID;
Caller : Task_Id;
pragma Unreferenced (Caller);
-- Should this be removed ???
@ -230,7 +230,7 @@ package body System.Tasking.Utilities is
-- In any case, reset Self_Id.Aborting, to allow re-raising of
-- Abort_Signal.
procedure Exit_One_ATC_Level (Self_ID : Task_ID) is
procedure Exit_One_ATC_Level (Self_ID : Task_Id) is
begin
Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
@ -263,9 +263,9 @@ package body System.Tasking.Utilities is
----------------------
procedure Make_Independent is
Self_Id : constant Task_ID := STPO.Self;
Environment_Task : constant Task_ID := STPO.Environment_Task;
Parent : constant Task_ID := Self_Id.Common.Parent;
Self_Id : constant Task_Id := STPO.Self;
Environment_Task : constant Task_Id := STPO.Environment_Task;
Parent : constant Task_Id := Self_Id.Common.Parent;
Parent_Needs_Updating : Boolean := False;
Master_of_Task : Integer;
@ -347,9 +347,9 @@ package body System.Tasking.Utilities is
-- Make_Passive --
------------------
procedure Make_Passive (Self_ID : Task_ID; Task_Completed : Boolean) is
C : Task_ID := Self_ID;
P : Task_ID := C.Common.Parent;
procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is
C : Task_Id := Self_ID;
P : Task_Id := C.Common.Parent;
Master_Completion_Phase : Integer;

12
gcc/ada/s-tasuti.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -39,7 +39,7 @@ with Unchecked_Conversion;
package System.Tasking.Utilities is
function ATCB_To_Address is new
Unchecked_Conversion (Task_ID, System.Address);
Unchecked_Conversion (Task_Id, System.Address);
---------------------------------
-- Task_Stage Related routines --
@ -76,17 +76,17 @@ package System.Tasking.Utilities is
-- Task Abortion 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.
-- Call this while holding T's lock (or RTS_Lock in Single_Lock mode).
procedure Exit_One_ATC_Level (Self_ID : Task_ID);
procedure Exit_One_ATC_Level (Self_ID : Task_Id);
pragma Inline (Exit_One_ATC_Level);
-- Call only with abort deferred and holding lock of Self_ID.
-- This is a bit of common code for all entry calls.
-- The effect is to exit one level of ATC nesting.
procedure Abort_One_Task (Self_ID : Task_ID; T : Task_ID);
procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id);
-- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
-- (1) caller should be holding no locks
-- (2) may be called for tasks that have not yet been activated
@ -96,7 +96,7 @@ package System.Tasking.Utilities is
-- Abort_Tasks is called to initiate abortion, however, the actual
-- abortion is done by abortee 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
-- or accepting on a terminate alternative.
-- Call holding no locks except Global_Task_Lock when calling from

6
gcc/ada/s-tataat.adb
View file

@ -100,7 +100,7 @@ package body System.Tasking.Task_Attributes is
-- Deallocation does finalization, if necessary.
declare
C : System.Tasking.Task_ID := All_Tasks_List;
C : System.Tasking.Task_Id := All_Tasks_List;
P : Access_Node;
begin
@ -158,7 +158,7 @@ package body System.Tasking.Task_Attributes is
-- This is to be called just before the ATCB is deallocated.
-- It relies on the caller holding T.L write-lock on entry.
procedure Finalize_Attributes (T : Task_ID) is
procedure Finalize_Attributes (T : Task_Id) is
P : Access_Node;
Q : Access_Node := To_Access_Node (T.Indirect_Attributes);
@ -185,7 +185,7 @@ package body System.Tasking.Task_Attributes is
-- This is to be called by System.Tasking.Stages.Create_Task.
procedure Initialize_Attributes (T : Task_ID) is
procedure Initialize_Attributes (T : Task_Id) is
P : Access_Instance;
begin
Defer_Abortion;

4
gcc/ada/s-tataat.ads
View file

@ -116,13 +116,13 @@ package System.Tasking.Task_Attributes is
-- A linked list of all indirectly access attributes,
-- which includes all 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.
-- This must be called by the creator of the task, inside Create_Task,
-- via soft-link Initialize_Attributes_Link. On entry, abortion must
-- be deferred 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.
-- 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

16
gcc/ada/s-tpinop.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -38,7 +38,7 @@ package body System.Task_Primitives.Interrupt_Operations is
-- this array, but due to elaboration problems, it can't with this
-- package directly, so we export this variable for now.
Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_ID;
Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_Id;
pragma Export (Ada, Interrupt_ID_Map,
"system__task_primitives__interrupt_operations__interrupt_id_map");
@ -46,8 +46,8 @@ package body System.Task_Primitives.Interrupt_Operations is
-- Get_Interrupt_ID --
----------------------
function Get_Interrupt_ID (T : ST.Task_ID) return IM.Interrupt_ID is
use type ST.Task_ID;
function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID is
use type ST.Task_Id;
begin
for Interrupt in IM.Interrupt_ID loop
@ -60,19 +60,19 @@ package body System.Task_Primitives.Interrupt_Operations is
end Get_Interrupt_ID;
-----------------
-- Get_Task_ID --
-- Get_Task_Id --
-----------------
function Get_Task_ID (Interrupt : IM.Interrupt_ID) return ST.Task_ID is
function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id is
begin
return Interrupt_ID_Map (Interrupt);
end Get_Task_ID;
end Get_Task_Id;
----------------------
-- Set_Interrupt_ID --
----------------------
procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_ID) is
procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id) is
begin
Interrupt_ID_Map (Interrupt) := T;
end Set_Interrupt_ID;

10
gcc/ada/s-tpinop.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -38,13 +38,13 @@ package System.Task_Primitives.Interrupt_Operations is
package IM renames System.Interrupt_Management;
package ST renames System.Tasking;
procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_ID);
procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_Id);
-- Associate an Interrupt_ID with a task.
function Get_Interrupt_ID (T : ST.Task_ID) return IM.Interrupt_ID;
function Get_Interrupt_ID (T : ST.Task_Id) return IM.Interrupt_ID;
-- Return the Interrupt_ID associated with a task.
function Get_Task_ID (Interrupt : IM.Interrupt_ID) return ST.Task_ID;
-- Return the Task_ID associated with an Interrupt.
function Get_Task_Id (Interrupt : IM.Interrupt_ID) return ST.Task_Id;
-- Return the Task_Id associated with an Interrupt.
end System.Task_Primitives.Interrupt_Operations;

8
gcc/ada/s-tpoben.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2001, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -81,9 +81,9 @@ package body System.Tasking.Protected_Objects.Entries is
procedure Finalize (Object : in out Protection_Entries) is
Entry_Call : Entry_Call_Link;
Caller : Task_ID;
Caller : Task_Id;
Ceiling_Violation : Boolean;
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
Old_Base_Priority : System.Any_Priority;
begin
@ -179,7 +179,7 @@ package body System.Tasking.Protected_Objects.Entries is
Find_Body_Index : Find_Body_Index_Access)
is
Init_Priority : Integer := Ceiling_Priority;
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
if Init_Priority = Unspecified_Priority then

20
gcc/ada/s-tpobop.adb
View file

@ -120,7 +120,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- It returns with the PO's lock still held.
procedure Requeue_Call
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
@ -292,7 +292,7 @@ package body System.Tasking.Protected_Objects.Operations is
--------------------
procedure PO_Do_Or_Queue
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
@ -382,12 +382,12 @@ package body System.Tasking.Protected_Objects.Operations is
------------------------
procedure PO_Service_Entries
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Entries.Protection_Entries_Access;
Unlock_Object : Boolean := True)
is
E : Protected_Entry_Index;
Caller : Task_ID;
Caller : Task_Id;
Entry_Call : Entry_Call_Link;
begin
@ -519,7 +519,7 @@ package body System.Tasking.Protected_Objects.Operations is
Mode : Call_Modes;
Block : out Communication_Block)
is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
Initially_Abortable : Boolean;
Ceiling_Violation : Boolean;
@ -653,7 +653,7 @@ package body System.Tasking.Protected_Objects.Operations is
------------------
procedure Requeue_Call
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
@ -739,7 +739,7 @@ package body System.Tasking.Protected_Objects.Operations is
----------------------------
function Protected_Entry_Caller
(Object : Protection_Entries'Class) return Task_ID is
(Object : Protection_Entries'Class) return Task_Id is
begin
return Object.Call_In_Progress.Self;
end Protected_Entry_Caller;
@ -837,7 +837,7 @@ package body System.Tasking.Protected_Objects.Operations is
E : Protected_Entry_Index;
With_Abort : Boolean)
is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
begin
@ -859,7 +859,7 @@ package body System.Tasking.Protected_Objects.Operations is
---------------------
procedure Service_Entries (Object : Protection_Entries_Access) is
Self_ID : constant Task_ID := STPO.Self;
Self_ID : constant Task_Id := STPO.Self;
begin
PO_Service_Entries (Self_ID, Object);
end Service_Entries;
@ -878,7 +878,7 @@ package body System.Tasking.Protected_Objects.Operations is
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Link;
Ceiling_Violation : Boolean;
Yielded : Boolean;

8
gcc/ada/s-tpobop.ads
View file

@ -95,7 +95,7 @@ package System.Tasking.Protected_Objects.Operations is
pragma Inline (Service_Entries);
procedure PO_Service_Entries
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Entries.Protection_Entries_Access;
Unlock_Object : Boolean := True);
-- Service all entry queues of the specified object, executing the
@ -176,7 +176,7 @@ package System.Tasking.Protected_Objects.Operations is
-- Return the number of entry calls to E on Object.
function Protected_Entry_Caller
(Object : Entries.Protection_Entries'Class) return Task_ID;
(Object : Entries.Protection_Entries'Class) return Task_Id;
-- Return value of E'Caller, where E is the protected entry currently
-- being handled. This will only work if called from within an entry
-- body, as required by the LRM (C.7.1(14)).
@ -184,7 +184,7 @@ package System.Tasking.Protected_Objects.Operations is
-- For internal use only:
procedure PO_Do_Or_Queue
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Object : Entries.Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean);
@ -194,7 +194,7 @@ package System.Tasking.Protected_Objects.Operations is
private
type Communication_Block is record
Self : Task_ID;
Self : Task_Id;
Enqueued : Boolean := True;
Cancelled : Boolean := False;
end record;

14
gcc/ada/s-tpopde-vms.adb
View file

@ -70,10 +70,10 @@ package body System.Task_Primitives.Operations.DEC is
-----------------------
function To_Unsigned_Longword is new
Unchecked_Conversion (Task_ID, Unsigned_Longword);
Unchecked_Conversion (Task_Id, Unsigned_Longword);
function To_Task_Id is new
Unchecked_Conversion (Unsigned_Longword, Task_ID);
Unchecked_Conversion (Unsigned_Longword, Task_Id);
function To_FAB_RAB is new
Unchecked_Conversion (Address, FAB_RAB_Access_Type);
@ -84,7 +84,7 @@ package body System.Task_Primitives.Operations.DEC is
procedure Interrupt_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : constant Task_ID := To_Task_ID (ID);
AST_Self_ID : constant Task_Id := To_Task_Id (ID);
begin
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
@ -95,7 +95,7 @@ package body System.Task_Primitives.Operations.DEC is
---------------------
procedure RMS_AST_Handler (ID : Address) is
AST_Self_ID : constant Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX);
Result : Interfaces.C.int;
begin
@ -109,7 +109,7 @@ package body System.Task_Primitives.Operations.DEC is
----------
function Self return Unsigned_Longword is
Self_ID : constant Task_ID := Self;
Self_ID : constant Task_Id := Self;
begin
Self_ID.Common.LL.AST_Pending := True;
return To_Unsigned_Longword (Self);
@ -121,7 +121,7 @@ package body System.Task_Primitives.Operations.DEC is
procedure Starlet_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : constant Task_ID := To_Task_ID (ID);
AST_Self_ID : constant Task_Id := To_Task_Id (ID);
begin
AST_Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
@ -133,7 +133,7 @@ package body System.Task_Primitives.Operations.DEC is
----------------
procedure Task_Synch is
Synch_Self_ID : constant Task_ID := Self;
Synch_Self_ID : constant Task_Id := Self;
begin
if Single_Lock then

8
gcc/ada/s-tpopsp-lynxos.adb
View file

@ -40,7 +40,7 @@ package body Specific is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
@ -66,7 +66,7 @@ package body Specific is
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
@ -91,7 +91,7 @@ package body Specific is
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_ID is
function Self return Task_Id is
Value : aliased System.Address;
Result : Interfaces.C.int;
@ -104,7 +104,7 @@ package body Specific is
-- If the key value is Null, then it is a non-Ada task.
if Value /= System.Null_Address then
return To_Task_ID (Value);
return To_Task_Id (Value);
else
return Register_Foreign_Thread;
end if;

8
gcc/ada/s-tpopsp-posix-foreign.adb
View file

@ -44,7 +44,7 @@ package body Specific is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
@ -66,7 +66,7 @@ package body Specific is
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
@ -90,7 +90,7 @@ package body Specific is
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_ID is
function Self return Task_Id is
Result : System.Address;
begin
@ -99,7 +99,7 @@ package body Specific is
-- If the key value is Null, then it is a non-Ada task.
if Result /= System.Null_Address then
return To_Task_ID (Result);
return To_Task_Id (Result);
else
return Register_Foreign_Thread;
end if;

8
gcc/ada/s-tpopsp-posix.adb
View file

@ -40,7 +40,7 @@ package body Specific is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
begin
@ -61,7 +61,7 @@ package body Specific is
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
@ -72,9 +72,9 @@ package body Specific is
-- Self --
----------
function Self return Task_ID is
function Self return Task_Id is
begin
return To_Task_ID (pthread_getspecific (ATCB_Key));
return To_Task_Id (pthread_getspecific (ATCB_Key));
end Self;
end Specific;

10
gcc/ada/s-tpopsp-solaris.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -40,7 +40,7 @@ package body Specific is
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
procedure Initialize (Environment_Task : Task_Id) is
Result : Interfaces.C.int;
begin
Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
@ -64,7 +64,7 @@ package body Specific is
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
@ -90,7 +90,7 @@ package body Specific is
-- master hierarchy, much like the existing implicitly created
-- signal-server tasks.
function Self return Task_ID is
function Self return Task_Id is
Result : Interfaces.C.int;
Self_Id : aliased System.Address;
begin
@ -100,7 +100,7 @@ package body Specific is
if Self_Id = System.Null_Address then
return Register_Foreign_Thread;
else
return To_Task_ID (Self_Id);
return To_Task_Id (Self_Id);
end if;
end Self;

6
gcc/ada/s-tpopsp-vxworks.adb
View file

@ -50,7 +50,7 @@ package body Specific is
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
procedure Set (Self_Id : Task_Id) is
Result : STATUS;
begin
@ -66,9 +66,9 @@ package body Specific is
-- Self --
----------
function Self return Task_ID is
function Self return Task_Id is
begin
return To_Task_ID (ATCB_Key);
return To_Task_Id (ATCB_Key);
end Self;
end Specific;

8
gcc/ada/s-tporft.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
-- Copyright (C) 2002-2004, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -38,9 +38,9 @@ with System.Soft_Links;
-- used to initialize TSD for a C thread, in function Self
separate (System.Task_Primitives.Operations)
function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is
Local_ATCB : aliased Ada_Task_Control_Block (0);
Self_Id : Task_ID;
Self_Id : Task_Id;
Succeeded : Boolean;
use type Interfaces.C.unsigned;
@ -51,7 +51,7 @@ begin
-- immediately, we fake one, so that it is then possible to e.g allocate
-- memory (which might require accessing self).
-- Record this as the Task_ID for the thread
-- Record this as the Task_Id for the thread
Local_ATCB.Common.LL.Thread := Thread;
Local_ATCB.Common.Current_Priority := System.Priority'First;

34
gcc/ada/s-tposen.adb
View file

@ -83,7 +83,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-----------------------
procedure Send_Program_Error
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Send_Program_Error);
-- Raise Program_Error in the caller of the specified entry call
@ -93,7 +93,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
--------------------------
procedure Wakeup_Entry_Caller
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State);
pragma Inline (Wakeup_Entry_Caller);
@ -121,7 +121,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- specified in Wakeup_Time as well.
procedure Check_Exception
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Check_Exception);
-- Raise any pending exception from the Entry_Call.
@ -130,7 +130,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- The caller should not be holding any locks, or there will be deadlock.
procedure PO_Do_Or_Queue
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
-- This procedure executes or queues an entry call, depending
@ -142,7 +142,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
---------------------
procedure Check_Exception
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
@ -166,10 +166,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
------------------------
procedure Send_Program_Error
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Entry_Call : Entry_Call_Link)
is
Caller : constant Task_ID := Entry_Call.Self;
Caller : constant Task_Id := Entry_Call.Self;
begin
Entry_Call.Exception_To_Raise := Program_Error'Identity;
@ -191,7 +191,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-------------------------
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
Self_Id : constant Task_ID := Entry_Call.Self;
Self_Id : constant Task_Id := Entry_Call.Self;
begin
Self_Id.Common.State := Entry_Caller_Sleep;
STPO.Sleep (Self_Id, Entry_Caller_Sleep);
@ -207,7 +207,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Wakeup_Time : Duration;
Mode : Delay_Modes)
is
Self_Id : constant Task_ID := Entry_Call.Self;
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean;
Yielded : Boolean;
@ -267,13 +267,13 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-- to complete.
procedure Wakeup_Entry_Caller
(Self_ID : Task_ID;
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link;
New_State : Entry_Call_State)
is
pragma Warnings (Off, Self_ID);
Caller : constant Task_ID := Entry_Call.Self;
Caller : constant Task_Id := Entry_Call.Self;
begin
pragma Assert (New_State = Done or else New_State = Cancelled);
@ -377,7 +377,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
--------------------
procedure PO_Do_Or_Queue
(Self_Id : Task_ID;
(Self_Id : Task_Id;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link)
is
@ -460,7 +460,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Uninterpreted_Data : System.Address;
Mode : Call_Modes)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
Ceiling_Violation : Boolean;
@ -506,7 +506,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-----------------------------------
function Protected_Single_Entry_Caller
(Object : Protection_Entry) return Task_ID is
(Object : Protection_Entry) return Task_Id is
begin
return Object.Call_In_Progress.Self;
end Protected_Single_Entry_Caller;
@ -516,9 +516,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
-------------------
procedure Service_Entry (Object : Protection_Entry_Access) is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_ID;
Caller : Task_Id;
begin
if Entry_Call /= null then
@ -574,7 +574,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Mode : Delay_Modes;
Entry_Call_Successful : out Boolean)
is
Self_Id : constant Task_ID := STPO.Self;
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
Ceiling_Violation : Boolean;

2
gcc/ada/s-tposen.ads
View file

@ -270,7 +270,7 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- Return the number of entry calls on Object (0 or 1).
function Protected_Single_Entry_Caller (Object : Protection_Entry)
return Task_ID;
return Task_Id;
-- Return value of E'Caller, where E is the protected entry currently
-- being handled. This will only work if called from within an
-- entry body, as required by the LRM (C.7.1(14)).

24
gcc/ada/s-tratas-default.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -45,7 +45,7 @@ package body System.Traces.Tasking is
package SSL renames System.Soft_Links;
function Extract_Accepts (Task_Name : Task_ID) return String_Trace;
function Extract_Accepts (Task_Name : Task_Id) return String_Trace;
-- This function is used to extract data joined with
-- W_Select, WT_Select, W_Accept events
@ -53,7 +53,7 @@ package body System.Traces.Tasking is
-- Send_Trace_Info --
---------------------
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_Id) is
Task_S : constant String := SSL.Task_Name.all;
Task2_S : constant String :=
Task_Name2.Common.Task_Image
@ -101,7 +101,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : Task_ID;
Task_Name2 : Task_Id;
Entry_Number : Entry_Index)
is
Task_S : constant String := SSL.Task_Name.all;
@ -146,8 +146,8 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID;
Task_Name : Task_Id;
Task_Name2 : Task_Id;
Entry_Number : Entry_Index)
is
Task_S : constant String :=
@ -201,8 +201,8 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID)
Task_Name : Task_Id;
Task_Name2 : Task_Id)
is
Task_S : constant String :=
Task_Name.Common.Task_Image
@ -226,7 +226,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Acceptor : Task_ID;
Acceptor : Task_Id;
Entry_Number : Entry_Index;
Timeout : Duration)
is
@ -285,7 +285,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name : Task_Id;
Number : Integer)
is
Task_S : String := SSL.Task_Name.all;
@ -311,7 +311,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name : Task_Id;
Number : Integer;
Timeout : Duration)
is
@ -347,7 +347,7 @@ package body System.Traces.Tasking is
-- This function returns a string in which all opened
-- Accepts or Selects are given, separated by semi-colons.
function Extract_Accepts (Task_Name : Task_ID) return String_Trace is
function Extract_Accepts (Task_Name : Task_Id) return String_Trace is
Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
begin

20
gcc/ada/s-tratas.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -39,14 +39,14 @@ package body System.Traces.Tasking is
-- Send_Trace_Info --
---------------------
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : ST.Task_ID) is
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : ST.Task_Id) is
begin
null;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : ST.Task_ID;
Task_Name2 : ST.Task_Id;
Entry_Number : ST.Entry_Index)
is
begin
@ -55,8 +55,8 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name2 : ST.Task_ID;
Task_Name : ST.Task_Id;
Task_Name2 : ST.Task_Id;
Entry_Number : ST.Entry_Index)
is
begin
@ -65,8 +65,8 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name2 : ST.Task_ID)
Task_Name : ST.Task_Id;
Task_Name2 : ST.Task_Id)
is
begin
null;
@ -82,7 +82,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Acceptor : ST.Task_ID;
Acceptor : ST.Task_Id;
Entry_Number : ST.Entry_Index;
Timeout : Duration)
is
@ -101,7 +101,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name : ST.Task_Id;
Number : Integer)
is
begin
@ -110,7 +110,7 @@ package body System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name : ST.Task_Id;
Number : Integer;
Timeout : Duration)
is

20
gcc/ada/s-tratas.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -50,23 +50,23 @@ package System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : ST.Task_ID);
Task_Name2 : ST.Task_Id);
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : ST.Task_ID;
Task_Name2 : ST.Task_Id;
Entry_Number : ST.Entry_Index);
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name2 : ST.Task_ID;
Task_Name : ST.Task_Id;
Task_Name2 : ST.Task_Id;
Entry_Number : ST.Entry_Index);
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name2 : ST.Task_ID);
Task_Name : ST.Task_Id;
Task_Name2 : ST.Task_Id);
procedure Send_Trace_Info
(Id : Trace_T;
@ -74,7 +74,7 @@ package System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Acceptor : ST.Task_ID;
Acceptor : ST.Task_Id;
Entry_Number : ST.Entry_Index;
Timeout : Duration);
@ -85,12 +85,12 @@ package System.Traces.Tasking is
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name : ST.Task_Id;
Number : Integer);
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : ST.Task_ID;
Task_Name : ST.Task_Id;
Number : Integer;
Timeout : Duration);
end System.Traces.Tasking;

4
gcc/ada/sem_attr.adb
View file

@ -2090,7 +2090,7 @@ package body Sem_Attr is
end if;
end loop;
Set_Etype (N, RTE (RO_AT_Task_ID));
Set_Etype (N, RTE (RO_AT_Task_Id));
end Caller;
-------------
@ -2627,7 +2627,7 @@ package body Sem_Attr is
and then Is_Task_Type (Designated_Type (Etype (P))))
then
Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_ID));
Set_Etype (N, RTE (RO_AT_Task_Id));
else
Error_Attr ("prefix of % attribute must be a task or an "

4
gcc/ada/sem_ch10.adb
View file

@ -3352,7 +3352,9 @@ package body Sem_Ch10 is
-- view because the full view of X supersedes its limited view.
if Analyzed (Cunit (Unum))
and then Is_Immediately_Visible (P)
and then (Is_Immediately_Visible (P)
or else (Is_Child_Package
and then Is_Visible_Child_Unit (P)))
then
return;
end if;

138
gcc/ada/sem_prag.adb
View file

@ -3250,6 +3250,10 @@ package body Sem_Prag is
procedure Set_Warning (R : All_Restrictions);
-- If this is a Restriction_Warnings pragma, set warning flag
-----------------
-- Set_Warning --
-----------------
procedure Set_Warning (R : All_Restrictions) is
begin
if Prag_Id = Pragma_Restriction_Warnings then
@ -3269,119 +3273,45 @@ package body Sem_Prag is
Id := Chars (Arg);
Expr := Expression (Arg);
-- Case of no restriction identifier
-- Case of no restriction identifier present
if Id = No_Name then
if Nkind (Expr) /= N_Identifier then
Error_Pragma_Arg
("invalid form for restriction", Arg);
-- Deal with synonyms. This should be done more cleanly ???
else
-- Boolean_Entry_Barriers is a synonym of Simple_Barriers
if Chars (Expr) = Name_Boolean_Entry_Barriers then
Check_Restriction
(No_Implementation_Restrictions, Arg);
Set_Restriction (Simple_Barriers, N);
Set_Warning (Simple_Barriers);
-- Max_Entry_Queue_Depth is a synonym of
-- Max_Entry_Queue_Length
elsif Chars (Expr) = Name_Max_Entry_Queue_Depth then
Analyze_And_Resolve (Expr, Any_Integer);
if not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("value must be static expression!", Expr);
raise Pragma_Exit;
elsif not Is_Integer_Type (Etype (Expr))
or else Expr_Value (Expr) < 0
then
Error_Pragma_Arg
("value must be non-negative integer", Arg);
-- Restriction pragma is active
else
Val := Expr_Value (Expr);
if not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg
("pragma ignored, value too large?", Arg);
else
Set_Restriction (Max_Entry_Queue_Length, N,
Integer (UI_To_Int (Val)));
Set_Warning (Max_Entry_Queue_Length);
end if;
end if;
-- No_Dynamic_Interrupts is a synonym for
-- No_Dynamic_Attachment
elsif Chars (Expr) = Name_No_Dynamic_Interrupts then
Check_Restriction
(No_Implementation_Restrictions, Arg);
Set_Restriction (No_Dynamic_Attachment, N);
Set_Warning (No_Dynamic_Attachment);
-- No_Requeue is a synonym for No_Requeue_Statements
elsif Chars (Expr) = Name_No_Requeue then
Check_Restriction
(No_Implementation_Restrictions, Arg);
Set_Restriction (No_Requeue_Statements, N);
Set_Warning (No_Requeue_Statements);
-- No_Task_Attributes is a synonym for
-- No_Task_Attributes_Package
elsif Chars (Expr) = Name_No_Task_Attributes then
Check_Restriction
(No_Implementation_Restrictions, Arg);
Set_Restriction (No_Task_Attributes_Package, N);
Set_Warning (No_Task_Attributes_Package);
-- Normal processing for all other cases
else
R_Id := Get_Restriction_Id (Chars (Expr));
if R_Id not in All_Boolean_Restrictions then
Error_Pragma_Arg
("invalid restriction identifier", Arg);
-- Restriction is active
else
if Implementation_Restriction (R_Id) then
Check_Restriction
(No_Implementation_Restrictions, Arg);
end if;
Set_Restriction (R_Id, N);
Set_Warning (R_Id);
-- A very special case that must be processed here:
-- pragma Restrictions (No_Exceptions) turns off
-- all run-time checking. This is a bit dubious in
-- terms of the formal language definition, but it
-- is what is intended by RM H.4(12).
if R_Id = No_Exceptions then
Scope_Suppress := (others => True);
end if;
end if;
end if;
end if;
-- Case of restriction identifier present
R_Id :=
Get_Restriction_Id
(Process_Restriction_Synonyms (Chars (Expr)));
if R_Id not in All_Boolean_Restrictions then
Error_Pragma_Arg
("invalid restriction identifier", Arg);
end if;
if Implementation_Restriction (R_Id) then
Check_Restriction
(No_Implementation_Restrictions, Arg);
end if;
Set_Restriction (R_Id, N);
Set_Warning (R_Id);
-- A very special case that must be processed here:
-- pragma Restrictions (No_Exceptions) turns off
-- all run-time checking. This is a bit dubious in
-- terms of the formal language definition, but it
-- is what is intended by RM H.4(12).
if R_Id = No_Exceptions then
Scope_Suppress := (others => True);
end if;
-- Case of restriction identifier present
else
R_Id := Get_Restriction_Id (Id);
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Id));
Analyze_And_Resolve (Expr, Any_Integer);
if R_Id not in All_Parameter_Restrictions then

5
gcc/ada/snames.adb
View file

@ -342,6 +342,7 @@ package body Snames is
"link_name#" &
"lowercase#" &
"max_entry_queue_depth#" &
"max_entry_queue_length#" &
"max_size#" &
"mechanism#" &
"mixedcase#" &
@ -352,9 +353,12 @@ package body Snames is
"on#" &
"parameter_types#" &
"reference#" &
"no_dynamic_attachment#" &
"no_dynamic_interrupts#" &
"no_requeue#" &
"no_requeue_statements#" &
"no_task_attributes#" &
"no_task_attributes_package#" &
"restricted#" &
"result_mechanism#" &
"result_type#" &
@ -363,6 +367,7 @@ package body Snames is
"secondary_stack_size#" &
"section#" &
"semaphore#" &
"simple_barriers#" &
"spec_file_name#" &
"static#" &
"stack_size#" &

691
gcc/ada/snames.ads
View file

@ -540,46 +540,51 @@ package Snames is
Name_Link_Name : constant Name_Id := N + 282;
Name_Lowercase : constant Name_Id := N + 283;
Name_Max_Entry_Queue_Depth : constant Name_Id := N + 284;
Name_Max_Size : constant Name_Id := N + 285;
Name_Mechanism : constant Name_Id := N + 286;
Name_Mixedcase : constant Name_Id := N + 287;
Name_Modified_GPL : constant Name_Id := N + 288;
Name_Name : constant Name_Id := N + 289;
Name_NCA : constant Name_Id := N + 290;
Name_No : constant Name_Id := N + 291;
Name_On : constant Name_Id := N + 292;
Name_Parameter_Types : constant Name_Id := N + 293;
Name_Reference : constant Name_Id := N + 294;
Name_No_Dynamic_Interrupts : constant Name_Id := N + 295;
Name_No_Requeue : constant Name_Id := N + 296;
Name_No_Task_Attributes : constant Name_Id := N + 297;
Name_Restricted : constant Name_Id := N + 298;
Name_Result_Mechanism : constant Name_Id := N + 299;
Name_Result_Type : constant Name_Id := N + 300;
Name_Runtime : constant Name_Id := N + 301;
Name_SB : constant Name_Id := N + 302;
Name_Secondary_Stack_Size : constant Name_Id := N + 303;
Name_Section : constant Name_Id := N + 304;
Name_Semaphore : constant Name_Id := N + 305;
Name_Spec_File_Name : constant Name_Id := N + 306;
Name_Static : constant Name_Id := N + 307;
Name_Stack_Size : constant Name_Id := N + 308;
Name_Subunit_File_Name : constant Name_Id := N + 309;
Name_Task_Stack_Size_Default : constant Name_Id := N + 310;
Name_Task_Type : constant Name_Id := N + 311;
Name_Time_Slicing_Enabled : constant Name_Id := N + 312;
Name_Top_Guard : constant Name_Id := N + 313;
Name_UBA : constant Name_Id := N + 314;
Name_UBS : constant Name_Id := N + 315;
Name_UBSB : constant Name_Id := N + 316;
Name_Unit_Name : constant Name_Id := N + 317;
Name_Unknown : constant Name_Id := N + 318;
Name_Unrestricted : constant Name_Id := N + 319;
Name_Uppercase : constant Name_Id := N + 320;
Name_User : constant Name_Id := N + 321;
Name_VAX_Float : constant Name_Id := N + 322;
Name_VMS : constant Name_Id := N + 323;
Name_Working_Storage : constant Name_Id := N + 324;
Name_Max_Entry_Queue_Length : constant Name_Id := N + 285;
Name_Max_Size : constant Name_Id := N + 286;
Name_Mechanism : constant Name_Id := N + 287;
Name_Mixedcase : constant Name_Id := N + 288;
Name_Modified_GPL : constant Name_Id := N + 289;
Name_Name : constant Name_Id := N + 290;
Name_NCA : constant Name_Id := N + 291;
Name_No : constant Name_Id := N + 292;
Name_On : constant Name_Id := N + 293;
Name_Parameter_Types : constant Name_Id := N + 294;
Name_Reference : constant Name_Id := N + 295;
Name_No_Dynamic_Attachment : constant Name_Id := N + 296;
Name_No_Dynamic_Interrupts : constant Name_Id := N + 297;
Name_No_Requeue : constant Name_Id := N + 298;
Name_No_Requeue_Statements : constant Name_Id := N + 299;
Name_No_Task_Attributes : constant Name_Id := N + 300;
Name_No_Task_Attributes_Package : constant Name_Id := N + 301;
Name_Restricted : constant Name_Id := N + 302;
Name_Result_Mechanism : constant Name_Id := N + 303;
Name_Result_Type : constant Name_Id := N + 304;
Name_Runtime : constant Name_Id := N + 305;
Name_SB : constant Name_Id := N + 306;
Name_Secondary_Stack_Size : constant Name_Id := N + 307;
Name_Section : constant Name_Id := N + 308;
Name_Semaphore : constant Name_Id := N + 309;
Name_Simple_Barriers : constant Name_Id := N + 310;
Name_Spec_File_Name : constant Name_Id := N + 311;
Name_Static : constant Name_Id := N + 312;
Name_Stack_Size : constant Name_Id := N + 313;
Name_Subunit_File_Name : constant Name_Id := N + 314;
Name_Task_Stack_Size_Default : constant Name_Id := N + 315;
Name_Task_Type : constant Name_Id := N + 316;
Name_Time_Slicing_Enabled : constant Name_Id := N + 317;
Name_Top_Guard : constant Name_Id := N + 318;
Name_UBA : constant Name_Id := N + 319;
Name_UBS : constant Name_Id := N + 320;
Name_UBSB : constant Name_Id := N + 321;
Name_Unit_Name : constant Name_Id := N + 322;
Name_Unknown : constant Name_Id := N + 323;
Name_Unrestricted : constant Name_Id := N + 324;
Name_Uppercase : constant Name_Id := N + 325;
Name_User : constant Name_Id := N + 326;
Name_VAX_Float : constant Name_Id := N + 327;
Name_VMS : constant Name_Id := N + 328;
Name_Working_Storage : constant Name_Id := N + 329;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
@ -593,158 +598,158 @@ package Snames is
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
First_Attribute_Name : constant Name_Id := N + 325;
Name_Abort_Signal : constant Name_Id := N + 325; -- GNAT
Name_Access : constant Name_Id := N + 326;
Name_Address : constant Name_Id := N + 327;
Name_Address_Size : constant Name_Id := N + 328; -- GNAT
Name_Aft : constant Name_Id := N + 329;
Name_Alignment : constant Name_Id := N + 330;
Name_Asm_Input : constant Name_Id := N + 331; -- GNAT
Name_Asm_Output : constant Name_Id := N + 332; -- GNAT
Name_AST_Entry : constant Name_Id := N + 333; -- VMS
Name_Bit : constant Name_Id := N + 334; -- GNAT
Name_Bit_Order : constant Name_Id := N + 335;
Name_Bit_Position : constant Name_Id := N + 336; -- GNAT
Name_Body_Version : constant Name_Id := N + 337;
Name_Callable : constant Name_Id := N + 338;
Name_Caller : constant Name_Id := N + 339;
Name_Code_Address : constant Name_Id := N + 340; -- GNAT
Name_Component_Size : constant Name_Id := N + 341;
Name_Compose : constant Name_Id := N + 342;
Name_Constrained : constant Name_Id := N + 343;
Name_Count : constant Name_Id := N + 344;
Name_Default_Bit_Order : constant Name_Id := N + 345; -- GNAT
Name_Definite : constant Name_Id := N + 346;
Name_Delta : constant Name_Id := N + 347;
Name_Denorm : constant Name_Id := N + 348;
Name_Digits : constant Name_Id := N + 349;
Name_Elaborated : constant Name_Id := N + 350; -- GNAT
Name_Emax : constant Name_Id := N + 351; -- Ada 83
Name_Enum_Rep : constant Name_Id := N + 352; -- GNAT
Name_Epsilon : constant Name_Id := N + 353; -- Ada 83
Name_Exponent : constant Name_Id := N + 354;
Name_External_Tag : constant Name_Id := N + 355;
Name_First : constant Name_Id := N + 356;
Name_First_Bit : constant Name_Id := N + 357;
Name_Fixed_Value : constant Name_Id := N + 358; -- GNAT
Name_Fore : constant Name_Id := N + 359;
Name_Has_Discriminants : constant Name_Id := N + 360; -- GNAT
Name_Identity : constant Name_Id := N + 361;
Name_Img : constant Name_Id := N + 362; -- GNAT
Name_Integer_Value : constant Name_Id := N + 363; -- GNAT
Name_Large : constant Name_Id := N + 364; -- Ada 83
Name_Last : constant Name_Id := N + 365;
Name_Last_Bit : constant Name_Id := N + 366;
Name_Leading_Part : constant Name_Id := N + 367;
Name_Length : constant Name_Id := N + 368;
Name_Machine_Emax : constant Name_Id := N + 369;
Name_Machine_Emin : constant Name_Id := N + 370;
Name_Machine_Mantissa : constant Name_Id := N + 371;
Name_Machine_Overflows : constant Name_Id := N + 372;
Name_Machine_Radix : constant Name_Id := N + 373;
Name_Machine_Rounds : constant Name_Id := N + 374;
Name_Machine_Size : constant Name_Id := N + 375; -- GNAT
Name_Mantissa : constant Name_Id := N + 376; -- Ada 83
Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 377;
Name_Maximum_Alignment : constant Name_Id := N + 378; -- GNAT
Name_Mechanism_Code : constant Name_Id := N + 379; -- GNAT
Name_Model_Emin : constant Name_Id := N + 380;
Name_Model_Epsilon : constant Name_Id := N + 381;
Name_Model_Mantissa : constant Name_Id := N + 382;
Name_Model_Small : constant Name_Id := N + 383;
Name_Modulus : constant Name_Id := N + 384;
Name_Null_Parameter : constant Name_Id := N + 385; -- GNAT
Name_Object_Size : constant Name_Id := N + 386; -- GNAT
Name_Partition_ID : constant Name_Id := N + 387;
Name_Passed_By_Reference : constant Name_Id := N + 388; -- GNAT
Name_Pool_Address : constant Name_Id := N + 389;
Name_Pos : constant Name_Id := N + 390;
Name_Position : constant Name_Id := N + 391;
Name_Range : constant Name_Id := N + 392;
Name_Range_Length : constant Name_Id := N + 393; -- GNAT
Name_Round : constant Name_Id := N + 394;
Name_Safe_Emax : constant Name_Id := N + 395; -- Ada 83
Name_Safe_First : constant Name_Id := N + 396;
Name_Safe_Large : constant Name_Id := N + 397; -- Ada 83
Name_Safe_Last : constant Name_Id := N + 398;
Name_Safe_Small : constant Name_Id := N + 399; -- Ada 83
Name_Scale : constant Name_Id := N + 400;
Name_Scaling : constant Name_Id := N + 401;
Name_Signed_Zeros : constant Name_Id := N + 402;
Name_Size : constant Name_Id := N + 403;
Name_Small : constant Name_Id := N + 404;
Name_Storage_Size : constant Name_Id := N + 405;
Name_Storage_Unit : constant Name_Id := N + 406; -- GNAT
Name_Tag : constant Name_Id := N + 407;
Name_Target_Name : constant Name_Id := N + 408; -- GNAT
Name_Terminated : constant Name_Id := N + 409;
Name_To_Address : constant Name_Id := N + 410; -- GNAT
Name_Type_Class : constant Name_Id := N + 411; -- GNAT
Name_UET_Address : constant Name_Id := N + 412; -- GNAT
Name_Unbiased_Rounding : constant Name_Id := N + 413;
Name_Unchecked_Access : constant Name_Id := N + 414;
Name_Unconstrained_Array : constant Name_Id := N + 415;
Name_Universal_Literal_String : constant Name_Id := N + 416; -- GNAT
Name_Unrestricted_Access : constant Name_Id := N + 417; -- GNAT
Name_VADS_Size : constant Name_Id := N + 418; -- GNAT
Name_Val : constant Name_Id := N + 419;
Name_Valid : constant Name_Id := N + 420;
Name_Value_Size : constant Name_Id := N + 421; -- GNAT
Name_Version : constant Name_Id := N + 422;
Name_Wchar_T_Size : constant Name_Id := N + 423; -- GNAT
Name_Wide_Width : constant Name_Id := N + 424;
Name_Width : constant Name_Id := N + 425;
Name_Word_Size : constant Name_Id := N + 426; -- GNAT
First_Attribute_Name : constant Name_Id := N + 330;
Name_Abort_Signal : constant Name_Id := N + 330; -- GNAT
Name_Access : constant Name_Id := N + 331;
Name_Address : constant Name_Id := N + 332;
Name_Address_Size : constant Name_Id := N + 333; -- GNAT
Name_Aft : constant Name_Id := N + 334;
Name_Alignment : constant Name_Id := N + 335;
Name_Asm_Input : constant Name_Id := N + 336; -- GNAT
Name_Asm_Output : constant Name_Id := N + 337; -- GNAT
Name_AST_Entry : constant Name_Id := N + 338; -- VMS
Name_Bit : constant Name_Id := N + 339; -- GNAT
Name_Bit_Order : constant Name_Id := N + 340;
Name_Bit_Position : constant Name_Id := N + 341; -- GNAT
Name_Body_Version : constant Name_Id := N + 342;
Name_Callable : constant Name_Id := N + 343;
Name_Caller : constant Name_Id := N + 344;
Name_Code_Address : constant Name_Id := N + 345; -- GNAT
Name_Component_Size : constant Name_Id := N + 346;
Name_Compose : constant Name_Id := N + 347;
Name_Constrained : constant Name_Id := N + 348;
Name_Count : constant Name_Id := N + 349;
Name_Default_Bit_Order : constant Name_Id := N + 350; -- GNAT
Name_Definite : constant Name_Id := N + 351;
Name_Delta : constant Name_Id := N + 352;
Name_Denorm : constant Name_Id := N + 353;
Name_Digits : constant Name_Id := N + 354;
Name_Elaborated : constant Name_Id := N + 355; -- GNAT
Name_Emax : constant Name_Id := N + 356; -- Ada 83
Name_Enum_Rep : constant Name_Id := N + 357; -- GNAT
Name_Epsilon : constant Name_Id := N + 358; -- Ada 83
Name_Exponent : constant Name_Id := N + 359;
Name_External_Tag : constant Name_Id := N + 360;
Name_First : constant Name_Id := N + 361;
Name_First_Bit : constant Name_Id := N + 362;
Name_Fixed_Value : constant Name_Id := N + 363; -- GNAT
Name_Fore : constant Name_Id := N + 364;
Name_Has_Discriminants : constant Name_Id := N + 365; -- GNAT
Name_Identity : constant Name_Id := N + 366;
Name_Img : constant Name_Id := N + 367; -- GNAT
Name_Integer_Value : constant Name_Id := N + 368; -- GNAT
Name_Large : constant Name_Id := N + 369; -- Ada 83
Name_Last : constant Name_Id := N + 370;
Name_Last_Bit : constant Name_Id := N + 371;
Name_Leading_Part : constant Name_Id := N + 372;
Name_Length : constant Name_Id := N + 373;
Name_Machine_Emax : constant Name_Id := N + 374;
Name_Machine_Emin : constant Name_Id := N + 375;
Name_Machine_Mantissa : constant Name_Id := N + 376;
Name_Machine_Overflows : constant Name_Id := N + 377;
Name_Machine_Radix : constant Name_Id := N + 378;
Name_Machine_Rounds : constant Name_Id := N + 379;
Name_Machine_Size : constant Name_Id := N + 380; -- GNAT
Name_Mantissa : constant Name_Id := N + 381; -- Ada 83
Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 382;
Name_Maximum_Alignment : constant Name_Id := N + 383; -- GNAT
Name_Mechanism_Code : constant Name_Id := N + 384; -- GNAT
Name_Model_Emin : constant Name_Id := N + 385;
Name_Model_Epsilon : constant Name_Id := N + 386;
Name_Model_Mantissa : constant Name_Id := N + 387;
Name_Model_Small : constant Name_Id := N + 388;
Name_Modulus : constant Name_Id := N + 389;
Name_Null_Parameter : constant Name_Id := N + 390; -- GNAT
Name_Object_Size : constant Name_Id := N + 391; -- GNAT
Name_Partition_ID : constant Name_Id := N + 392;
Name_Passed_By_Reference : constant Name_Id := N + 393; -- GNAT
Name_Pool_Address : constant Name_Id := N + 394;
Name_Pos : constant Name_Id := N + 395;
Name_Position : constant Name_Id := N + 396;
Name_Range : constant Name_Id := N + 397;
Name_Range_Length : constant Name_Id := N + 398; -- GNAT
Name_Round : constant Name_Id := N + 399;
Name_Safe_Emax : constant Name_Id := N + 400; -- Ada 83
Name_Safe_First : constant Name_Id := N + 401;
Name_Safe_Large : constant Name_Id := N + 402; -- Ada 83
Name_Safe_Last : constant Name_Id := N + 403;
Name_Safe_Small : constant Name_Id := N + 404; -- Ada 83
Name_Scale : constant Name_Id := N + 405;
Name_Scaling : constant Name_Id := N + 406;
Name_Signed_Zeros : constant Name_Id := N + 407;
Name_Size : constant Name_Id := N + 408;
Name_Small : constant Name_Id := N + 409;
Name_Storage_Size : constant Name_Id := N + 410;
Name_Storage_Unit : constant Name_Id := N + 411; -- GNAT
Name_Tag : constant Name_Id := N + 412;
Name_Target_Name : constant Name_Id := N + 413; -- GNAT
Name_Terminated : constant Name_Id := N + 414;
Name_To_Address : constant Name_Id := N + 415; -- GNAT
Name_Type_Class : constant Name_Id := N + 416; -- GNAT
Name_UET_Address : constant Name_Id := N + 417; -- GNAT
Name_Unbiased_Rounding : constant Name_Id := N + 418;
Name_Unchecked_Access : constant Name_Id := N + 419;
Name_Unconstrained_Array : constant Name_Id := N + 420;
Name_Universal_Literal_String : constant Name_Id := N + 421; -- GNAT
Name_Unrestricted_Access : constant Name_Id := N + 422; -- GNAT
Name_VADS_Size : constant Name_Id := N + 423; -- GNAT
Name_Val : constant Name_Id := N + 424;
Name_Valid : constant Name_Id := N + 425;
Name_Value_Size : constant Name_Id := N + 426; -- GNAT
Name_Version : constant Name_Id := N + 427;
Name_Wchar_T_Size : constant Name_Id := N + 428; -- GNAT
Name_Wide_Width : constant Name_Id := N + 429;
Name_Width : constant Name_Id := N + 430;
Name_Word_Size : constant Name_Id := N + 431; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value.
First_Renamable_Function_Attribute : constant Name_Id := N + 427;
Name_Adjacent : constant Name_Id := N + 427;
Name_Ceiling : constant Name_Id := N + 428;
Name_Copy_Sign : constant Name_Id := N + 429;
Name_Floor : constant Name_Id := N + 430;
Name_Fraction : constant Name_Id := N + 431;
Name_Image : constant Name_Id := N + 432;
Name_Input : constant Name_Id := N + 433;
Name_Machine : constant Name_Id := N + 434;
Name_Max : constant Name_Id := N + 435;
Name_Min : constant Name_Id := N + 436;
Name_Model : constant Name_Id := N + 437;
Name_Pred : constant Name_Id := N + 438;
Name_Remainder : constant Name_Id := N + 439;
Name_Rounding : constant Name_Id := N + 440;
Name_Succ : constant Name_Id := N + 441;
Name_Truncation : constant Name_Id := N + 442;
Name_Value : constant Name_Id := N + 443;
Name_Wide_Image : constant Name_Id := N + 444;
Name_Wide_Value : constant Name_Id := N + 445;
Last_Renamable_Function_Attribute : constant Name_Id := N + 445;
First_Renamable_Function_Attribute : constant Name_Id := N + 432;
Name_Adjacent : constant Name_Id := N + 432;
Name_Ceiling : constant Name_Id := N + 433;
Name_Copy_Sign : constant Name_Id := N + 434;
Name_Floor : constant Name_Id := N + 435;
Name_Fraction : constant Name_Id := N + 436;
Name_Image : constant Name_Id := N + 437;
Name_Input : constant Name_Id := N + 438;
Name_Machine : constant Name_Id := N + 439;
Name_Max : constant Name_Id := N + 440;
Name_Min : constant Name_Id := N + 441;
Name_Model : constant Name_Id := N + 442;
Name_Pred : constant Name_Id := N + 443;
Name_Remainder : constant Name_Id := N + 444;
Name_Rounding : constant Name_Id := N + 445;
Name_Succ : constant Name_Id := N + 446;
Name_Truncation : constant Name_Id := N + 447;
Name_Value : constant Name_Id := N + 448;
Name_Wide_Image : constant Name_Id := N + 449;
Name_Wide_Value : constant Name_Id := N + 450;
Last_Renamable_Function_Attribute : constant Name_Id := N + 450;
-- Attributes that designate procedures
First_Procedure_Attribute : constant Name_Id := N + 446;
Name_Output : constant Name_Id := N + 446;
Name_Read : constant Name_Id := N + 447;
Name_Write : constant Name_Id := N + 448;
Last_Procedure_Attribute : constant Name_Id := N + 448;
First_Procedure_Attribute : constant Name_Id := N + 451;
Name_Output : constant Name_Id := N + 451;
Name_Read : constant Name_Id := N + 452;
Name_Write : constant Name_Id := N + 453;
Last_Procedure_Attribute : constant Name_Id := N + 453;
-- Remaining attributes are ones that return entities
First_Entity_Attribute_Name : constant Name_Id := N + 449;
Name_Elab_Body : constant Name_Id := N + 449; -- GNAT
Name_Elab_Spec : constant Name_Id := N + 450; -- GNAT
Name_Storage_Pool : constant Name_Id := N + 451;
First_Entity_Attribute_Name : constant Name_Id := N + 454;
Name_Elab_Body : constant Name_Id := N + 454; -- GNAT
Name_Elab_Spec : constant Name_Id := N + 455; -- GNAT
Name_Storage_Pool : constant Name_Id := N + 456;
-- These attributes are the ones that return types
First_Type_Attribute_Name : constant Name_Id := N + 452;
Name_Base : constant Name_Id := N + 452;
Name_Class : constant Name_Id := N + 453;
Last_Type_Attribute_Name : constant Name_Id := N + 453;
Last_Entity_Attribute_Name : constant Name_Id := N + 453;
Last_Attribute_Name : constant Name_Id := N + 453;
First_Type_Attribute_Name : constant Name_Id := N + 457;
Name_Base : constant Name_Id := N + 457;
Name_Class : constant Name_Id := N + 458;
Last_Type_Attribute_Name : constant Name_Id := N + 458;
Last_Entity_Attribute_Name : constant Name_Id := N + 458;
Last_Attribute_Name : constant Name_Id := N + 458;
-- Names of recognized locking policy identifiers
@ -752,10 +757,10 @@ package Snames is
-- name (e.g. C for Ceiling_Locking). If new policy names are added,
-- the first character must be distinct.
First_Locking_Policy_Name : constant Name_Id := N + 454;
Name_Ceiling_Locking : constant Name_Id := N + 454;
Name_Inheritance_Locking : constant Name_Id := N + 455;
Last_Locking_Policy_Name : constant Name_Id := N + 455;
First_Locking_Policy_Name : constant Name_Id := N + 459;
Name_Ceiling_Locking : constant Name_Id := N + 459;
Name_Inheritance_Locking : constant Name_Id := N + 460;
Last_Locking_Policy_Name : constant Name_Id := N + 460;
-- Names of recognized queuing policy identifiers.
@ -763,10 +768,10 @@ package Snames is
-- name (e.g. F for FIFO_Queuing). If new policy names are added,
-- the first character must be distinct.
First_Queuing_Policy_Name : constant Name_Id := N + 456;
Name_FIFO_Queuing : constant Name_Id := N + 456;
Name_Priority_Queuing : constant Name_Id := N + 457;
Last_Queuing_Policy_Name : constant Name_Id := N + 457;
First_Queuing_Policy_Name : constant Name_Id := N + 461;
Name_FIFO_Queuing : constant Name_Id := N + 461;
Name_Priority_Queuing : constant Name_Id := N + 462;
Last_Queuing_Policy_Name : constant Name_Id := N + 462;
-- Names of recognized task dispatching policy identifiers
@ -774,193 +779,193 @@ package Snames is
-- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
-- are added, the first character must be distinct.
First_Task_Dispatching_Policy_Name : constant Name_Id := N + 458;
Name_FIFO_Within_Priorities : constant Name_Id := N + 458;
Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 458;
First_Task_Dispatching_Policy_Name : constant Name_Id := N + 463;
Name_FIFO_Within_Priorities : constant Name_Id := N + 463;
Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 463;
-- Names of recognized checks for pragma Suppress
First_Check_Name : constant Name_Id := N + 459;
Name_Access_Check : constant Name_Id := N + 459;
Name_Accessibility_Check : constant Name_Id := N + 460;
Name_Discriminant_Check : constant Name_Id := N + 461;
Name_Division_Check : constant Name_Id := N + 462;
Name_Elaboration_Check : constant Name_Id := N + 463;
Name_Index_Check : constant Name_Id := N + 464;
Name_Length_Check : constant Name_Id := N + 465;
Name_Overflow_Check : constant Name_Id := N + 466;
Name_Range_Check : constant Name_Id := N + 467;
Name_Storage_Check : constant Name_Id := N + 468;
Name_Tag_Check : constant Name_Id := N + 469;
Name_All_Checks : constant Name_Id := N + 470;
Last_Check_Name : constant Name_Id := N + 470;
First_Check_Name : constant Name_Id := N + 464;
Name_Access_Check : constant Name_Id := N + 464;
Name_Accessibility_Check : constant Name_Id := N + 465;
Name_Discriminant_Check : constant Name_Id := N + 466;
Name_Division_Check : constant Name_Id := N + 467;
Name_Elaboration_Check : constant Name_Id := N + 468;
Name_Index_Check : constant Name_Id := N + 469;
Name_Length_Check : constant Name_Id := N + 470;
Name_Overflow_Check : constant Name_Id := N + 471;
Name_Range_Check : constant Name_Id := N + 472;
Name_Storage_Check : constant Name_Id := N + 473;
Name_Tag_Check : constant Name_Id := N + 474;
Name_All_Checks : constant Name_Id := N + 475;
Last_Check_Name : constant Name_Id := N + 475;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
Name_Abort : constant Name_Id := N + 471;
Name_Abs : constant Name_Id := N + 472;
Name_Accept : constant Name_Id := N + 473;
Name_And : constant Name_Id := N + 474;
Name_All : constant Name_Id := N + 475;
Name_Array : constant Name_Id := N + 476;
Name_At : constant Name_Id := N + 477;
Name_Begin : constant Name_Id := N + 478;
Name_Body : constant Name_Id := N + 479;
Name_Case : constant Name_Id := N + 480;
Name_Constant : constant Name_Id := N + 481;
Name_Declare : constant Name_Id := N + 482;
Name_Delay : constant Name_Id := N + 483;
Name_Do : constant Name_Id := N + 484;
Name_Else : constant Name_Id := N + 485;
Name_Elsif : constant Name_Id := N + 486;
Name_End : constant Name_Id := N + 487;
Name_Entry : constant Name_Id := N + 488;
Name_Exception : constant Name_Id := N + 489;
Name_Exit : constant Name_Id := N + 490;
Name_For : constant Name_Id := N + 491;
Name_Function : constant Name_Id := N + 492;
Name_Generic : constant Name_Id := N + 493;
Name_Goto : constant Name_Id := N + 494;
Name_If : constant Name_Id := N + 495;
Name_In : constant Name_Id := N + 496;
Name_Is : constant Name_Id := N + 497;
Name_Limited : constant Name_Id := N + 498;
Name_Loop : constant Name_Id := N + 499;
Name_Mod : constant Name_Id := N + 500;
Name_New : constant Name_Id := N + 501;
Name_Not : constant Name_Id := N + 502;
Name_Null : constant Name_Id := N + 503;
Name_Of : constant Name_Id := N + 504;
Name_Or : constant Name_Id := N + 505;
Name_Others : constant Name_Id := N + 506;
Name_Out : constant Name_Id := N + 507;
Name_Package : constant Name_Id := N + 508;
Name_Pragma : constant Name_Id := N + 509;
Name_Private : constant Name_Id := N + 510;
Name_Procedure : constant Name_Id := N + 511;
Name_Raise : constant Name_Id := N + 512;
Name_Record : constant Name_Id := N + 513;
Name_Rem : constant Name_Id := N + 514;
Name_Renames : constant Name_Id := N + 515;
Name_Return : constant Name_Id := N + 516;
Name_Reverse : constant Name_Id := N + 517;
Name_Select : constant Name_Id := N + 518;
Name_Separate : constant Name_Id := N + 519;
Name_Subtype : constant Name_Id := N + 520;
Name_Task : constant Name_Id := N + 521;
Name_Terminate : constant Name_Id := N + 522;
Name_Then : constant Name_Id := N + 523;
Name_Type : constant Name_Id := N + 524;
Name_Use : constant Name_Id := N + 525;
Name_When : constant Name_Id := N + 526;
Name_While : constant Name_Id := N + 527;
Name_With : constant Name_Id := N + 528;
Name_Xor : constant Name_Id := N + 529;
Name_Abort : constant Name_Id := N + 476;
Name_Abs : constant Name_Id := N + 477;
Name_Accept : constant Name_Id := N + 478;
Name_And : constant Name_Id := N + 479;
Name_All : constant Name_Id := N + 480;
Name_Array : constant Name_Id := N + 481;
Name_At : constant Name_Id := N + 482;
Name_Begin : constant Name_Id := N + 483;
Name_Body : constant Name_Id := N + 484;
Name_Case : constant Name_Id := N + 485;
Name_Constant : constant Name_Id := N + 486;
Name_Declare : constant Name_Id := N + 487;
Name_Delay : constant Name_Id := N + 488;
Name_Do : constant Name_Id := N + 489;
Name_Else : constant Name_Id := N + 490;
Name_Elsif : constant Name_Id := N + 491;
Name_End : constant Name_Id := N + 492;
Name_Entry : constant Name_Id := N + 493;
Name_Exception : constant Name_Id := N + 494;
Name_Exit : constant Name_Id := N + 495;
Name_For : constant Name_Id := N + 496;
Name_Function : constant Name_Id := N + 497;
Name_Generic : constant Name_Id := N + 498;
Name_Goto : constant Name_Id := N + 499;
Name_If : constant Name_Id := N + 500;
Name_In : constant Name_Id := N + 501;
Name_Is : constant Name_Id := N + 502;
Name_Limited : constant Name_Id := N + 503;
Name_Loop : constant Name_Id := N + 504;
Name_Mod : constant Name_Id := N + 505;
Name_New : constant Name_Id := N + 506;
Name_Not : constant Name_Id := N + 507;
Name_Null : constant Name_Id := N + 508;
Name_Of : constant Name_Id := N + 509;
Name_Or : constant Name_Id := N + 510;
Name_Others : constant Name_Id := N + 511;
Name_Out : constant Name_Id := N + 512;
Name_Package : constant Name_Id := N + 513;
Name_Pragma : constant Name_Id := N + 514;
Name_Private : constant Name_Id := N + 515;
Name_Procedure : constant Name_Id := N + 516;
Name_Raise : constant Name_Id := N + 517;
Name_Record : constant Name_Id := N + 518;
Name_Rem : constant Name_Id := N + 519;
Name_Renames : constant Name_Id := N + 520;
Name_Return : constant Name_Id := N + 521;
Name_Reverse : constant Name_Id := N + 522;
Name_Select : constant Name_Id := N + 523;
Name_Separate : constant Name_Id := N + 524;
Name_Subtype : constant Name_Id := N + 525;
Name_Task : constant Name_Id := N + 526;
Name_Terminate : constant Name_Id := N + 527;
Name_Then : constant Name_Id := N + 528;
Name_Type : constant Name_Id := N + 529;
Name_Use : constant Name_Id := N + 530;
Name_When : constant Name_Id := N + 531;
Name_While : constant Name_Id := N + 532;
Name_With : constant Name_Id := N + 533;
Name_Xor : constant Name_Id := N + 534;
-- Names of intrinsic subprograms
-- Note: Asm is missing from this list, since Asm is a legitimate
-- convention name. So is To_Adress, which is a GNAT attribute.
First_Intrinsic_Name : constant Name_Id := N + 530;
Name_Divide : constant Name_Id := N + 530;
Name_Enclosing_Entity : constant Name_Id := N + 531;
Name_Exception_Information : constant Name_Id := N + 532;
Name_Exception_Message : constant Name_Id := N + 533;
Name_Exception_Name : constant Name_Id := N + 534;
Name_File : constant Name_Id := N + 535;
Name_Import_Address : constant Name_Id := N + 536;
Name_Import_Largest_Value : constant Name_Id := N + 537;
Name_Import_Value : constant Name_Id := N + 538;
Name_Is_Negative : constant Name_Id := N + 539;
Name_Line : constant Name_Id := N + 540;
Name_Rotate_Left : constant Name_Id := N + 541;
Name_Rotate_Right : constant Name_Id := N + 542;
Name_Shift_Left : constant Name_Id := N + 543;
Name_Shift_Right : constant Name_Id := N + 544;
Name_Shift_Right_Arithmetic : constant Name_Id := N + 545;
Name_Source_Location : constant Name_Id := N + 546;
Name_Unchecked_Conversion : constant Name_Id := N + 547;
Name_Unchecked_Deallocation : constant Name_Id := N + 548;
Name_To_Pointer : constant Name_Id := N + 549;
Last_Intrinsic_Name : constant Name_Id := N + 549;
First_Intrinsic_Name : constant Name_Id := N + 535;
Name_Divide : constant Name_Id := N + 535;
Name_Enclosing_Entity : constant Name_Id := N + 536;
Name_Exception_Information : constant Name_Id := N + 537;
Name_Exception_Message : constant Name_Id := N + 538;
Name_Exception_Name : constant Name_Id := N + 539;
Name_File : constant Name_Id := N + 540;
Name_Import_Address : constant Name_Id := N + 541;
Name_Import_Largest_Value : constant Name_Id := N + 542;
Name_Import_Value : constant Name_Id := N + 543;
Name_Is_Negative : constant Name_Id := N + 544;
Name_Line : constant Name_Id := N + 545;
Name_Rotate_Left : constant Name_Id := N + 546;
Name_Rotate_Right : constant Name_Id := N + 547;
Name_Shift_Left : constant Name_Id := N + 548;
Name_Shift_Right : constant Name_Id := N + 549;
Name_Shift_Right_Arithmetic : constant Name_Id := N + 550;
Name_Source_Location : constant Name_Id := N + 551;
Name_Unchecked_Conversion : constant Name_Id := N + 552;
Name_Unchecked_Deallocation : constant Name_Id := N + 553;
Name_To_Pointer : constant Name_Id := N + 554;
Last_Intrinsic_Name : constant Name_Id := N + 554;
-- Reserved words used only in Ada 95
First_95_Reserved_Word : constant Name_Id := N + 550;
Name_Abstract : constant Name_Id := N + 550;
Name_Aliased : constant Name_Id := N + 551;
Name_Protected : constant Name_Id := N + 552;
Name_Until : constant Name_Id := N + 553;
Name_Requeue : constant Name_Id := N + 554;
Name_Tagged : constant Name_Id := N + 555;
Last_95_Reserved_Word : constant Name_Id := N + 555;
First_95_Reserved_Word : constant Name_Id := N + 555;
Name_Abstract : constant Name_Id := N + 555;
Name_Aliased : constant Name_Id := N + 556;
Name_Protected : constant Name_Id := N + 557;
Name_Until : constant Name_Id := N + 558;
Name_Requeue : constant Name_Id := N + 559;
Name_Tagged : constant Name_Id := N + 560;
Last_95_Reserved_Word : constant Name_Id := N + 560;
subtype Ada_95_Reserved_Words is
Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
Name_Raise_Exception : constant Name_Id := N + 556;
Name_Raise_Exception : constant Name_Id := N + 561;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
Name_Binder : constant Name_Id := N + 557;
Name_Body_Suffix : constant Name_Id := N + 558;
Name_Builder : constant Name_Id := N + 559;
Name_Compiler : constant Name_Id := N + 560;
Name_Cross_Reference : constant Name_Id := N + 561;
Name_Default_Switches : constant Name_Id := N + 562;
Name_Exec_Dir : constant Name_Id := N + 563;
Name_Executable : constant Name_Id := N + 564;
Name_Executable_Suffix : constant Name_Id := N + 565;
Name_Extends : constant Name_Id := N + 566;
Name_Finder : constant Name_Id := N + 567;
Name_Global_Configuration_Pragmas : constant Name_Id := N + 568;
Name_Gnatls : constant Name_Id := N + 569;
Name_Gnatstub : constant Name_Id := N + 570;
Name_Implementation : constant Name_Id := N + 571;
Name_Implementation_Exceptions : constant Name_Id := N + 572;
Name_Implementation_Suffix : constant Name_Id := N + 573;
Name_Languages : constant Name_Id := N + 574;
Name_Library_Dir : constant Name_Id := N + 575;
Name_Library_Auto_Init : constant Name_Id := N + 576;
Name_Library_GCC : constant Name_Id := N + 577;
Name_Library_Interface : constant Name_Id := N + 578;
Name_Library_Kind : constant Name_Id := N + 579;
Name_Library_Name : constant Name_Id := N + 580;
Name_Library_Options : constant Name_Id := N + 581;
Name_Library_Reference_Symbol_File : constant Name_Id := N + 582;
Name_Library_Src_Dir : constant Name_Id := N + 583;
Name_Library_Symbol_File : constant Name_Id := N + 584;
Name_Library_Symbol_Policy : constant Name_Id := N + 585;
Name_Library_Version : constant Name_Id := N + 586;
Name_Linker : constant Name_Id := N + 587;
Name_Local_Configuration_Pragmas : constant Name_Id := N + 588;
Name_Locally_Removed_Files : constant Name_Id := N + 589;
Name_Naming : constant Name_Id := N + 590;
Name_Object_Dir : constant Name_Id := N + 591;
Name_Pretty_Printer : constant Name_Id := N + 592;
Name_Project : constant Name_Id := N + 593;
Name_Separate_Suffix : constant Name_Id := N + 594;
Name_Source_Dirs : constant Name_Id := N + 595;
Name_Source_Files : constant Name_Id := N + 596;
Name_Source_List_File : constant Name_Id := N + 597;
Name_Spec : constant Name_Id := N + 598;
Name_Spec_Suffix : constant Name_Id := N + 599;
Name_Specification : constant Name_Id := N + 600;
Name_Specification_Exceptions : constant Name_Id := N + 601;
Name_Specification_Suffix : constant Name_Id := N + 602;
Name_Switches : constant Name_Id := N + 603;
Name_Binder : constant Name_Id := N + 562;
Name_Body_Suffix : constant Name_Id := N + 563;
Name_Builder : constant Name_Id := N + 564;
Name_Compiler : constant Name_Id := N + 565;
Name_Cross_Reference : constant Name_Id := N + 566;
Name_Default_Switches : constant Name_Id := N + 567;
Name_Exec_Dir : constant Name_Id := N + 568;
Name_Executable : constant Name_Id := N + 569;
Name_Executable_Suffix : constant Name_Id := N + 570;
Name_Extends : constant Name_Id := N + 571;
Name_Finder : constant Name_Id := N + 572;
Name_Global_Configuration_Pragmas : constant Name_Id := N + 573;
Name_Gnatls : constant Name_Id := N + 574;
Name_Gnatstub : constant Name_Id := N + 575;
Name_Implementation : constant Name_Id := N + 576;
Name_Implementation_Exceptions : constant Name_Id := N + 577;
Name_Implementation_Suffix : constant Name_Id := N + 578;
Name_Languages : constant Name_Id := N + 579;
Name_Library_Dir : constant Name_Id := N + 580;
Name_Library_Auto_Init : constant Name_Id := N + 581;
Name_Library_GCC : constant Name_Id := N + 582;
Name_Library_Interface : constant Name_Id := N + 583;
Name_Library_Kind : constant Name_Id := N + 584;
Name_Library_Name : constant Name_Id := N + 585;
Name_Library_Options : constant Name_Id := N + 586;
Name_Library_Reference_Symbol_File : constant Name_Id := N + 587;
Name_Library_Src_Dir : constant Name_Id := N + 588;
Name_Library_Symbol_File : constant Name_Id := N + 589;
Name_Library_Symbol_Policy : constant Name_Id := N + 590;
Name_Library_Version : constant Name_Id := N + 591;
Name_Linker : constant Name_Id := N + 592;
Name_Local_Configuration_Pragmas : constant Name_Id := N + 593;
Name_Locally_Removed_Files : constant Name_Id := N + 594;
Name_Naming : constant Name_Id := N + 595;
Name_Object_Dir : constant Name_Id := N + 596;
Name_Pretty_Printer : constant Name_Id := N + 597;
Name_Project : constant Name_Id := N + 598;
Name_Separate_Suffix : constant Name_Id := N + 599;
Name_Source_Dirs : constant Name_Id := N + 600;
Name_Source_Files : constant Name_Id := N + 601;
Name_Source_List_File : constant Name_Id := N + 602;
Name_Spec : constant Name_Id := N + 603;
Name_Spec_Suffix : constant Name_Id := N + 604;
Name_Specification : constant Name_Id := N + 605;
Name_Specification_Exceptions : constant Name_Id := N + 606;
Name_Specification_Suffix : constant Name_Id := N + 607;
Name_Switches : constant Name_Id := N + 608;
-- Other miscellaneous names used in front end
Name_Unaligned_Valid : constant Name_Id := N + 604;
Name_Unaligned_Valid : constant Name_Id := N + 609;
-- Mark last defined name for consistency check in Snames body
Last_Predefined_Name : constant Name_Id := N + 604;
Last_Predefined_Name : constant Name_Id := N + 609;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;

347
gcc/ada/trans.c
View file

@ -83,6 +83,13 @@ int type_annotate_only;
over GC. */
tree gnu_block_stack;
/* The current BLOCK_STMT node. TREE_CHAIN points to the previous
BLOCK_STMT node. */
static GTY(()) tree gnu_block_stmt_node;
/* List of unused BLOCK_STMT nodes. */
static GTY((deletable)) tree gnu_block_stmt_free_list;
/* List of TREE_LIST nodes representing a stack of exception pointer
variables. TREE_VALUE is the VAR_DECL that stores the address of
the raised exception. Nonzero means we are in an exception
@ -105,6 +112,8 @@ static GTY(()) tree gnu_return_label_stack;
static tree tree_transform (Node_Id);
static rtx first_nondeleted_insn (rtx);
static tree start_block_stmt (void);
static tree end_block_stmt (void);
static tree build_block_stmt (List_Id);
static tree make_expr_stmt_from_rtl (rtx, Node_Id);
static void elaborate_all_entities (Node_Id);
@ -186,6 +195,7 @@ gigi (Node_Id gnat_root,
init_dummy_type ();
init_code_table ();
gnat_compute_largest_alignment ();
start_block_stmt ();
/* Enable GNAT stack checking method if needed */
if (!Stack_Check_Probes_On_Target)
@ -237,12 +247,16 @@ gnat_to_code (Node_Id gnat_node)
/* Save node number in case error */
error_gnat_node = gnat_node;
start_block_stmt ();
gnu_root = tree_transform (gnat_node);
gnat_expand_stmt (end_block_stmt ());
/* If we return a statement, generate code for it. */
if (IS_STMT (gnu_root))
expand_expr_stmt (gnu_root);
{
if (TREE_CODE (gnu_root) != NULL_STMT)
gnat_expand_stmt (gnu_root);
}
/* This should just generate code, not return a value. If it returns
a value, something is wrong. */
else if (gnu_root != error_mark_node)
@ -275,7 +289,9 @@ gnat_to_gnu (Node_Id gnat_node)
/* Save node number in case error */
error_gnat_node = gnat_node;
start_block_stmt ();
gnu_root = tree_transform (gnat_node);
gnat_expand_stmt (end_block_stmt ());
if (gnu_root == error_mark_node)
{
@ -808,10 +824,14 @@ tree_transform (Node_Id gnat_node)
{
if ((Is_Public (gnat_temp) || global_bindings_p ())
&& ! TREE_CONSTANT (gnu_expr))
gnu_expr
= create_var_decl (create_concat_name (gnat_temp, "init"),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
0, Is_Public (gnat_temp), 0, 0, 0);
{
gnu_expr
= create_var_decl (create_concat_name (gnat_temp, "init"),
NULL_TREE, TREE_TYPE (gnu_expr),
gnu_expr, 0, Is_Public (gnat_temp), 0,
0, 0);
add_decl_stmt (gnu_expr, gnat_temp);
}
else
gnu_expr = maybe_variable (gnu_expr, Expression (gnat_node));
@ -841,10 +861,8 @@ tree_transform (Node_Id gnat_node)
&& (Is_Array_Type (Etype (gnat_temp))
|| Is_Record_Type (Etype (gnat_temp))
|| Is_Concurrent_Type (Etype (gnat_temp)))))
{
gnu_expr = gnat_to_gnu (Renamed_Object (gnat_temp));
gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
}
gnat_to_gnu_entity (gnat_temp,
gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
break;
case N_Implicit_Label_Declaration:
@ -2083,6 +2101,7 @@ tree_transform (Node_Id gnat_node)
break;
case N_Null_Statement:
gnu_result = build_nt (NULL_STMT);
break;
case N_Assignment_Statement:
@ -2255,7 +2274,7 @@ tree_transform (Node_Id gnat_node)
variables are declared since we want them to be local to this
set of statements instead of the block containing the Case
statement. */
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (0);
for (gnat_statement = First (Statements (gnat_when));
Present (gnat_statement);
@ -2265,8 +2284,8 @@ tree_transform (Node_Id gnat_node)
/* Communicate to GCC that we are done with the current WHEN,
i.e. insert a "break" statement. */
expand_exit_something ();
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
}
expand_end_case (gnu_expr);
@ -2334,11 +2353,13 @@ tree_transform (Node_Id gnat_node)
/* Open a new nesting level that will surround the loop to declare
the loop index variable. */
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (0);
/* Declare the loop index and set it to its initial value. */
start_block_stmt ();
gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
expand_expr_stmt (end_block_stmt ());
if (DECL_BY_REF_P (gnu_loop_var))
gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE,
gnu_loop_var);
@ -2394,7 +2415,7 @@ tree_transform (Node_Id gnat_node)
storage will be released every iteration. This is needed
for stack allocation. */
pushlevel (0);
gnat_pushlevel ();
gnu_block_stack
= tree_cons (gnu_bottom_condition, NULL_TREE, gnu_block_stack);
expand_start_bindings (0);
@ -2404,8 +2425,8 @@ tree_transform (Node_Id gnat_node)
gnat_statement = Next (gnat_statement))
gnat_to_code (gnat_statement);
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
set_lineno (gnat_node, 1);
@ -2430,8 +2451,8 @@ tree_transform (Node_Id gnat_node)
/* Close the nesting level that sourround the loop that was used to
declare the loop index variable. */
set_lineno (gnat_node, 1);
expand_end_bindings (NULL_TREE, 1, -1);
poplevel (1, 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
}
if (enclosing_if_p)
@ -2443,13 +2464,15 @@ tree_transform (Node_Id gnat_node)
break;
case N_Block_Statement:
pushlevel (0);
gnat_pushlevel ();
gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
expand_start_bindings (0);
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
gnat_to_code (Handled_Statement_Sequence (gnat_node));
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
if (Present (Identifier (gnat_node)))
mark_out_of_scope (Entity (Identifier (gnat_node)));
@ -2678,9 +2701,10 @@ tree_transform (Node_Id gnat_node)
result in having the first line of the subprogram counted twice by
gcov. */
pushlevel (0);
gnat_pushlevel ();
gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
expand_start_bindings (0);
start_block_stmt ();
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
@ -2695,7 +2719,7 @@ tree_transform (Node_Id gnat_node)
= tree_cons (NULL_TREE,
build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
gnu_return_label_stack);
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (0);
}
else
@ -2712,38 +2736,39 @@ tree_transform (Node_Id gnat_node)
for (gnat_param = First_Formal (gnat_subprog_id);
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param))
if (present_gnu_tree (gnat_param))
adjust_decl_rtl (get_gnu_tree (gnat_param));
else
if (!present_gnu_tree (gnat_param))
{
/* Skip any entries that have been already filled in; they
must correspond to IN OUT parameters. */
for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
gnu_cico_list = TREE_CHAIN (gnu_cico_list))
;
for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0;
gnu_cico_list = TREE_CHAIN (gnu_cico_list))
;
/* Do any needed references for padded types. */
TREE_VALUE (gnu_cico_list)
= convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
}
/* Do any needed references for padded types. */
TREE_VALUE (gnu_cico_list)
= convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_list)),
gnat_to_gnu_entity (gnat_param, NULL_TREE, 1));
}
gnat_expand_stmt (end_block_stmt());
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
/* Generate the code of the subprogram itself. A return statement
will be present and any OUT parameters will be handled there. */
gnat_to_code (Handled_Statement_Sequence (gnat_node));
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
if (TREE_VALUE (gnu_return_label_stack) != 0)
{
tree gnu_retval;
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
expand_label (TREE_VALUE (gnu_return_label_stack));
gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
@ -3270,8 +3295,10 @@ tree_transform (Node_Id gnat_node)
case N_Package_Specification:
start_block_stmt ();
process_decls (Visible_Declarations (gnat_node),
Private_Declarations (gnat_node), Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
break;
case N_Package_Body:
@ -3280,7 +3307,9 @@ tree_transform (Node_Id gnat_node)
if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
break;
start_block_stmt ();
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
if (Present (Handled_Statement_Sequence (gnat_node)))
{
@ -3334,8 +3363,10 @@ tree_transform (Node_Id gnat_node)
break;
};
start_block_stmt();
process_decls (Declarations (Aux_Decls_Node (gnat_node)),
Empty, Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
gnat_to_code (Unit (gnat_node));
@ -3440,7 +3471,7 @@ tree_transform (Node_Id gnat_node)
/* Make a binding level that we can exit if we need one. */
if (exitable_binding_for_block)
{
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (1);
}
@ -3457,6 +3488,9 @@ tree_transform (Node_Id gnat_node)
integer_type_node, NULL_TREE, 0, 0, 0, 0,
0);
start_block_stmt ();
add_decl_stmt (gnu_cleanup_decl, gnat_node);
gnat_expand_stmt (end_block_stmt ());
expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
}
@ -3487,6 +3521,11 @@ tree_transform (Node_Id gnat_node)
NULL_TREE, 0, 0, 0, 0,
0);
start_block_stmt ();
add_decl_stmt (gnu_jmpsave_decl, gnat_node);
add_decl_stmt (gnu_jmpbuf_decl, gnat_node);
gnat_expand_stmt (end_block_stmt ());
TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
/* When we exit this block, restore the saved value. */
@ -3509,7 +3548,7 @@ tree_transform (Node_Id gnat_node)
/* Make a binding level for the exception handling declarations
and code. Don't assign it an exit label, since this is the
outer block we want to exit at the end of each handler. */
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (0);
gnu_except_ptr_stack
@ -3520,6 +3559,9 @@ tree_transform (Node_Id gnat_node)
build_call_0_expr (get_excptr_decl),
0, 0, 0, 0, 0),
gnu_except_ptr_stack);
start_block_stmt ();
add_decl_stmt (TREE_VALUE (gnu_except_ptr_stack), gnat_node);
gnat_expand_stmt (end_block_stmt ());
/* Generate code for each handler. The N_Exception_Handler case
below does the real work. We ignore the dummy exception handler
@ -3540,8 +3582,8 @@ tree_transform (Node_Id gnat_node)
gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
/* End the binding level dedicated to the exception handlers. */
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
/* End the "if" on setjmp. Note that we have arranged things so
control never returns here. */
@ -3566,9 +3608,11 @@ tree_transform (Node_Id gnat_node)
/* Generate code and declarations for the prefix of this block,
if any. */
start_block_stmt ();
if (Present (First_Real_Statement (gnat_node)))
process_decls (Statements (gnat_node), Empty,
First_Real_Statement (gnat_node), 1, 1);
gnat_expand_stmt (end_block_stmt ());
/* Generate code for each statement in the block. */
for (gnat_temp = (Present (First_Real_Statement (gnat_node))
@ -3603,8 +3647,8 @@ tree_transform (Node_Id gnat_node)
/* Close the binding level we made, if any. */
if (exitable_binding_for_block)
{
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
}
}
@ -3766,7 +3810,7 @@ tree_transform (Node_Id gnat_node)
expand_start_catch (gnu_etypes_list);
pushlevel (0);
gnat_pushlevel ();
expand_start_bindings (0);
{
@ -3797,6 +3841,9 @@ tree_transform (Node_Id gnat_node)
ptr_type_node, gnu_current_exc_ptr,
0, 0, 0, 0, 0);
start_block_stmt ();
add_decl_stmt (gnu_incoming_exc_ptr, gnat_node);
gnat_expand_stmt (end_block_stmt ());
expand_expr_stmt
(build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
expand_decl_cleanup
@ -3811,9 +3858,8 @@ tree_transform (Node_Id gnat_node)
if (Exception_Mechanism == GCC_ZCX)
{
/* Tell the back end that we're done with the current handler. */
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
expand_end_catch ();
}
else
@ -3927,7 +3973,9 @@ tree_transform (Node_Id gnat_node)
case N_Freeze_Entity:
process_freeze_entity (gnat_node);
start_block_stmt ();
process_decls (Actions (gnat_node), Empty, Empty, 1, 1);
gnat_expand_stmt (end_block_stmt ());
break;
case N_Itype_Reference:
@ -4196,6 +4244,136 @@ first_nondeleted_insn (rtx insns)
return insns;
}
/* Push the BLOCK_STMT stack and allocate a new BLOCK_STMT. */
static tree
start_block_stmt ()
{
tree gnu_block_stmt;
/* First see if we can get one from the free list. */
if (gnu_block_stmt_free_list)
{
gnu_block_stmt = gnu_block_stmt_free_list;
gnu_block_stmt_free_list = TREE_CHAIN (gnu_block_stmt_free_list);
}
else
{
gnu_block_stmt = make_node (BLOCK_STMT);
TREE_TYPE (gnu_block_stmt) = void_type_node;
}
BLOCK_STMT_LIST (gnu_block_stmt) = 0;
TREE_CHAIN (gnu_block_stmt) = gnu_block_stmt_node;
gnu_block_stmt_node = gnu_block_stmt;
return gnu_block_stmt;
}
/* Add GNU_STMT to the current BLOCK_STMT node. We add them backwards
order and the reverse in end_block_stmt. */
void
add_stmt (tree gnu_stmt)
{
if (TREE_CODE_CLASS (TREE_CODE (gnu_stmt)) != 's')
gigi_abort (340);
if (TREE_CODE (gnu_stmt) != NULL_STMT)
{
TREE_CHAIN (gnu_stmt) = BLOCK_STMT_LIST (gnu_block_stmt_node);
BLOCK_STMT_LIST (gnu_block_stmt_node) = gnu_stmt;
}
/* If this is a DECL_STMT for a variable with DECL_INIT_BY_ASSIGN_P set,
generate the assignment statement too. */
if (TREE_CODE (gnu_stmt) == DECL_STMT
&& TREE_CODE (DECL_STMT_VAR (gnu_stmt)) == VAR_DECL
&& DECL_INIT_BY_ASSIGN_P (DECL_STMT_VAR (gnu_stmt)))
{
tree gnu_decl = DECL_STMT_VAR (gnu_stmt);
tree gnu_lhs = gnu_decl;
tree gnu_assign_stmt;
/* If decl has a padded type, convert it to the unpadded type so the
assignment is done properly. */
if (TREE_CODE (TREE_TYPE (gnu_lhs)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_lhs)))
gnu_lhs
= convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_lhs))), gnu_lhs);
gnu_assign_stmt
= build_nt (EXPR_STMT,
build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_lhs, DECL_INITIAL (gnu_decl)));
DECL_INITIAL (gnu_decl) = 0;
DECL_INIT_BY_ASSIGN_P (gnu_decl) = 0;
TREE_SLOC (gnu_assign_stmt) = TREE_SLOC (gnu_stmt);
TREE_TYPE (gnu_assign_stmt) = void_type_node;
add_stmt (gnu_assign_stmt);
}
}
/* Add a declaration statement for GNU_DECL to the current BLOCK_STMT node.
Get SLOC from Entity_Id. */
void
add_decl_stmt (tree gnu_decl, Entity_Id gnat_entity)
{
tree gnu_stmt;
/* If this is a variable that Gigi is to ignore, we may have been given
an ERROR_MARK. So test for it. We also might have been given a
reference for a renaming. So only do something for a decl. */
if (!DECL_P (gnu_decl))
return;
gnu_stmt = build_nt (DECL_STMT, gnu_decl);
TREE_TYPE (gnu_stmt) = void_type_node;
TREE_SLOC (gnu_stmt) = Sloc (gnat_entity);
add_stmt (gnu_stmt);
}
/* Return the BLOCK_STMT that corresponds to the statement that add_stmt
has been emitting or just a single statement if only one. */
static tree
end_block_stmt ()
{
tree gnu_block_stmt = gnu_block_stmt_node;
tree gnu_retval = gnu_block_stmt;
gnu_block_stmt_node = TREE_CHAIN (gnu_block_stmt);
TREE_CHAIN (gnu_block_stmt) = 0;
/* If we have only one statement, return it and free this node. Otherwise,
finish setting up this node and return it. If we have no statements,
return a NULL_STMT. */
if (BLOCK_STMT_LIST (gnu_block_stmt) == 0)
{
gnu_retval = build_nt (NULL_STMT);
TREE_TYPE (gnu_retval) = void_type_node;
}
else if (TREE_CHAIN (BLOCK_STMT_LIST (gnu_block_stmt)) == 0)
gnu_retval = BLOCK_STMT_LIST (gnu_block_stmt);
else
{
BLOCK_STMT_LIST (gnu_block_stmt)
= nreverse (BLOCK_STMT_LIST (gnu_block_stmt));
TREE_SLOC (gnu_block_stmt)
= TREE_SLOC (BLOCK_STMT_LIST (gnu_block_stmt));
}
if (gnu_retval != gnu_block_stmt)
{
TREE_CHAIN (gnu_block_stmt) = gnu_block_stmt_free_list;
gnu_block_stmt_free_list = gnu_block_stmt;
}
return gnu_retval;
}
/* Build a BLOCK_STMT from GNAT_LIST, a possibly-empty list of statements. */
static tree
@ -4207,15 +4385,15 @@ build_block_stmt (List_Id gnat_list)
if (No (gnat_list) || Is_Empty_List (gnat_list))
return NULL_TREE;
start_block_stmt ();
for (gnat_node = First (gnat_list);
Present (gnat_node);
gnat_node = Next (gnat_node))
gnu_result = chainon (gnat_to_gnu (gnat_node), gnu_result);
add_stmt (gnat_to_gnu (gnat_node));
gnu_result = build_nt (BLOCK_STMT, nreverse (gnu_result));
TREE_SLOC (gnu_result) = TREE_SLOC (BLOCK_STMT_LIST (gnu_result));
TREE_TYPE (gnu_result) = void_type_node;
return gnu_result;
gnu_result = end_block_stmt ();
return TREE_CODE (gnu_result) == NULL_STMT ? NULL_TREE : gnu_result;
}
/* Build an EXPR_STMT to evaluate INSNS. Use Sloc from GNAT_NODE. */
@ -4253,17 +4431,37 @@ gnat_expand_stmt (tree gnu_stmt)
expand_expr_stmt (EXPR_STMT_EXPR (gnu_stmt));
break;
case NULL_STMT:
break;
case DECL_STMT:
if (TREE_CODE (DECL_STMT_VAR (gnu_stmt)) == TYPE_DECL)
force_type_save_exprs (TREE_TYPE (DECL_STMT_VAR (gnu_stmt)));
else
{
expand_decl (DECL_STMT_VAR (gnu_stmt));
if (DECL_CONTEXT (DECL_STMT_VAR (gnu_stmt)))
expand_decl_init (DECL_STMT_VAR (gnu_stmt));
if (TREE_ADDRESSABLE (DECL_STMT_VAR (gnu_stmt)))
{
put_var_into_stack (DECL_STMT_VAR (gnu_stmt), true);
flush_addressof (DECL_STMT_VAR (gnu_stmt));
}
}
break;
case BLOCK_STMT:
for (gnu_elmt = BLOCK_STMT_LIST (gnu_stmt); gnu_elmt;
gnu_elmt = TREE_CHAIN (gnu_elmt))
expand_expr_stmt (gnu_elmt);
gnat_expand_stmt (gnu_elmt);
break;
case IF_STMT:
expand_start_cond (IF_STMT_COND (gnu_stmt), 0);
if (IF_STMT_TRUE (gnu_stmt))
expand_expr_stmt (IF_STMT_TRUE (gnu_stmt));
gnat_expand_stmt (IF_STMT_TRUE (gnu_stmt));
for (gnu_elmt = IF_STMT_ELSEIF (gnu_stmt); gnu_elmt;
gnu_elmt = TREE_CHAIN (gnu_elmt))
@ -4271,13 +4469,14 @@ gnat_expand_stmt (tree gnu_stmt)
expand_start_else ();
set_lineno_from_sloc (TREE_SLOC (gnu_elmt), 1);
expand_elseif (IF_STMT_COND (gnu_elmt));
expand_expr_stmt (IF_STMT_TRUE (gnu_elmt));
if (IF_STMT_TRUE (gnu_elmt))
gnat_expand_stmt (IF_STMT_TRUE (gnu_elmt));
}
if (IF_STMT_ELSE (gnu_stmt))
{
expand_start_else ();
expand_expr_stmt (IF_STMT_ELSE (gnu_stmt));
gnat_expand_stmt (IF_STMT_ELSE (gnu_stmt));
}
expand_end_cond ();
@ -4324,8 +4523,8 @@ gnat_expand_stmt (tree gnu_stmt)
}
break;
default:
abort ();
default:
abort ();
}
}
@ -4570,11 +4769,8 @@ process_inlined_subprograms (Node_Id gnat_node)
correspond to the public and private parts of a package. */
static void
process_decls (List_Id gnat_decls,
List_Id gnat_decls2,
Node_Id gnat_end_list,
int pass1p,
int pass2p)
process_decls (List_Id gnat_decls, List_Id gnat_decls2,
Node_Id gnat_end_list, int pass1p, int pass2p)
{
List_Id gnat_decl_array[2];
Node_Id gnat_decl;
@ -4603,7 +4799,9 @@ process_decls (List_Id gnat_decls,
freeze node. */
else if (Nkind (gnat_decl) == N_Freeze_Entity)
{
start_block_stmt ();
process_freeze_entity (gnat_decl);
gnat_expand_stmt (end_block_stmt ());
process_decls (Actions (gnat_decl), Empty, Empty, 1, 0);
}
@ -4643,7 +4841,7 @@ process_decls (List_Id gnat_decls,
Node_Id gnat_subprog_id =
Defining_Entity (Specification (gnat_decl));
if (Ekind (gnat_subprog_id) != E_Subprogram_Body
if (Ekind (gnat_subprog_id) != E_Subprogram_Body
&& Ekind (gnat_subprog_id) != E_Generic_Procedure
&& Ekind (gnat_subprog_id) != E_Generic_Function)
gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
@ -4656,7 +4854,11 @@ process_decls (List_Id gnat_decls,
;
else
gnat_to_code (gnat_decl);
{
start_block_stmt ();
gnat_to_code (gnat_decl);
gnat_expand_stmt (end_block_stmt ());
}
}
/* Here we elaborate everything we deferred above except for package bodies,
@ -5082,6 +5284,7 @@ process_type (Entity_Id gnat_entity)
}
/* Now fully elaborate the type. */
start_block_stmt ();
gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
if (TREE_CODE (gnu_new) != TYPE_DECL)
gigi_abort (324);
@ -5112,6 +5315,8 @@ process_type (Entity_Id gnat_entity)
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
TREE_TYPE (gnu_new));
}
gnat_expand_stmt (end_block_stmt ());
}
/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
@ -5499,7 +5704,7 @@ build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
begin_subprog_body (gnu_decl);
set_lineno (gnat_unit, 1);
pushlevel (0);
gnat_pushlevel ();
gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
expand_start_bindings (0);
@ -5542,8 +5747,8 @@ build_unit_elab (Entity_Id gnat_unit, int body_p, tree gnu_elab_list)
break;
}
expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_end_bindings (NULL_TREE, block_has_vars (), -1);
gnat_poplevel ();
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
end_subprog_body ();
@ -5599,7 +5804,7 @@ set_lineno_from_sloc (Source_Ptr source_location, int write_note_p)
(Debug_Source_Name (Get_Source_File_Index (source_location)))));;
input_line = Get_Logical_Line_Number (source_location);
if (write_note_p)
if (! global_bindings_p () && write_note_p)
emit_line_note (input_location);
}

306
gcc/ada/utils.c
View file

@ -84,7 +84,7 @@ static GTY(()) tree pending_elaborations;
/* This stack allows us to momentarily switch to generating elaboration
lists for an inner context. */
struct e_stack GTY(()) {
struct e_stack GTY((chain_next ("%h.next"))) {
struct e_stack *next;
tree elab_list;
};
@ -110,36 +110,22 @@ static GTY(()) tree float_types[NUM_MACHINE_MODES];
Binding contours are used to create GCC tree BLOCK nodes. */
struct binding_level GTY(())
struct ada_binding_level GTY((chain_next ("%h.chain")))
{
/* A chain of ..._DECL nodes for all variables, constants, functions,
parameters and type declarations. These ..._DECL nodes are chained
through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
in the reverse of the order supplied to be compatible with the
back-end. */
tree names;
/* For each level (except the global one), a chain of BLOCK nodes for all
the levels that were entered and exited one level down from this one. */
tree blocks;
/* The BLOCK node for this level, if one has been preallocated.
If 0, the BLOCK is allocated (if needed) when the level is popped. */
tree this_block;
/* The binding level containing this one (the enclosing binding level). */
struct binding_level *level_chain;
struct ada_binding_level *chain;
/* The BLOCK node for this level. */
tree block;
};
/* The binding level currently in effect. */
static GTY(()) struct binding_level *current_binding_level;
static GTY(()) struct ada_binding_level *current_binding_level;
/* A chain of binding_level structures awaiting reuse. */
static GTY((deletable (""))) struct binding_level *free_binding_level;
/* A chain of ada_binding_level structures awaiting reuse. */
static GTY((deletable)) struct ada_binding_level *free_binding_level;
/* The outermost binding level. This binding level is created when the
compiler is started and it will exist through the entire compilation. */
static struct binding_level *global_binding_level;
/* Binding level structures are initialized by copying this one. */
static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
struct language_function GTY(())
{
@ -219,8 +205,7 @@ present_gnu_tree (Entity_Id gnat_entity)
int
global_bindings_p (void)
{
return (force_global != 0 || current_binding_level == global_binding_level
? -1 : 0);
return (force_global != 0 || current_binding_level->chain == 0 ? -1 : 0);
}
/* Return the list of declarations in the current level. Note that this list
@ -229,163 +214,102 @@ global_bindings_p (void)
tree
getdecls (void)
{
return current_binding_level->names;
return BLOCK_VARS (current_binding_level->block);
}
/* Nonzero if the current level needs to have a BLOCK made. */
int
kept_level_p (void)
{
return (current_binding_level->names != 0);
}
/* Enter a new binding level. The input parameter is ignored, but has to be
specified for back-end compatibility. */
/* Enter a new binding level. */
void
pushlevel (int ignore ATTRIBUTE_UNUSED)
gnat_pushlevel ()
{
struct binding_level *newlevel = NULL;
struct ada_binding_level *newlevel = NULL;
/* Reuse a struct for this binding level, if there is one. */
if (free_binding_level)
{
newlevel = free_binding_level;
free_binding_level = free_binding_level->level_chain;
free_binding_level = free_binding_level->chain;
}
else
newlevel
= (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
= (struct ada_binding_level *)
ggc_alloc (sizeof (struct ada_binding_level));
*newlevel = clear_binding_level;
/* Use a free BLOCK, if any; otherwise, allocate one. */
if (free_block_chain)
{
newlevel->block = free_block_chain;
free_block_chain = TREE_CHAIN (free_block_chain);
TREE_CHAIN (newlevel->block) = NULL_TREE;
}
else
newlevel->block = make_node (BLOCK);
/* Point the BLOCK we just made to its parent. */
if (current_binding_level)
BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
/* Add this level to the front of the chain (stack) of levels that are
active. */
newlevel->level_chain = current_binding_level;
newlevel->chain = current_binding_level;
current_binding_level = newlevel;
}
/* Exit a binding level.
Pop the level off, and restore the state of the identifier-decl mappings
that were in effect when this level was entered.
/* Exit a binding level. */
If KEEP is nonzero, this level had explicit declarations, so
and create a "block" (a BLOCK node) for the level
to record its declarations and subblocks for symbol table output.
If FUNCTIONBODY is nonzero, this level is the body of a function,
so create a block as if KEEP were set and also clear out all
label names.
If REVERSE is nonzero, reverse the order of decls before putting
them into the BLOCK. */
tree
poplevel (int keep, int reverse, int functionbody)
void
gnat_poplevel ()
{
/* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
binding level that we are about to exit and which is returned by this
routine. */
tree block = NULL_TREE;
tree decl_chain;
tree decl_node;
tree subblock_chain = current_binding_level->blocks;
tree subblock_node;
int block_previously_created;
struct ada_binding_level *level = current_binding_level;
tree block = level->block;
tree decl;
/* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL
nodes chained through the `names' field of current_binding_level are in
reverse order except for PARM_DECL node, which are explicitly stored in
the right order. */
current_binding_level->names
= decl_chain = (reverse) ? nreverse (current_binding_level->names)
: current_binding_level->names;
BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block));
/* Output any nested inline functions within this block which must be
compiled because their address is needed. */
for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node))
if (TREE_CODE (decl_node) == FUNCTION_DECL
&& ! TREE_ASM_WRITTEN (decl_node) && TREE_ADDRESSABLE (decl_node)
&& DECL_INITIAL (decl_node) != 0)
for (decl = BLOCK_VARS (block); decl; decl = TREE_CHAIN (decl))
if (TREE_CODE (decl) == FUNCTION_DECL
&& ! TREE_ASM_WRITTEN (decl) && TREE_ADDRESSABLE (decl)
&& DECL_INITIAL (decl) != 0)
{
push_function_context ();
/* ??? This is temporary. */
ggc_push_context ();
output_inline_function (decl_node);
output_inline_function (decl);
ggc_pop_context ();
pop_function_context ();
}
block = 0;
block_previously_created = (current_binding_level->this_block != 0);
if (block_previously_created)
block = current_binding_level->this_block;
else if (keep || functionbody)
block = make_node (BLOCK);
if (block != 0)
/* If this is a function-level BLOCK don't do anything. Otherwise, if there
are no variables free the block and merge its subblocks into those of its
parent block. Otherwise, add it to the list of its parent. */
if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
;
else if (BLOCK_VARS (block) == 0)
{
BLOCK_VARS (block) = keep ? decl_chain : 0;
BLOCK_SUBBLOCKS (block) = subblock_chain;
BLOCK_SUBBLOCKS (level->chain->block)
= chainon (BLOCK_SUBBLOCKS (block),
BLOCK_SUBBLOCKS (level->chain->block));
TREE_CHAIN (block) = free_block_chain;
free_block_chain = block;
}
else
{
TREE_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
BLOCK_SUBBLOCKS (level->chain->block) = block;
TREE_USED (block) = 1;
}
/* Record the BLOCK node just built as the subblock its enclosing scope. */
for (subblock_node = subblock_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
BLOCK_SUPERCONTEXT (subblock_node) = block;
/* Clear out the meanings of the local variables of this level. */
for (subblock_node = decl_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
if (DECL_NAME (subblock_node) != 0)
/* If the identifier was used or addressed via a local extern decl,
don't forget that fact. */
if (DECL_EXTERNAL (subblock_node))
{
if (TREE_USED (subblock_node))
TREE_USED (DECL_NAME (subblock_node)) = 1;
if (TREE_ADDRESSABLE (subblock_node))
TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
}
{
/* Pop the current level, and free the structure for reuse. */
struct binding_level *level = current_binding_level;
current_binding_level = current_binding_level->level_chain;
level->level_chain = free_binding_level;
free_binding_level = level;
}
if (functionbody)
{
/* This is the top level block of a function. The ..._DECL chain stored
in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
leave them in the BLOCK because they are found in the FUNCTION_DECL
instead. */
DECL_INITIAL (current_function_decl) = block;
BLOCK_VARS (block) = 0;
}
else if (block)
{
if (!block_previously_created)
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
}
/* If we did not make a block for the level just exited, any blocks made for
inner levels (since they cannot be recorded as subblocks in that level)
must be carried forward so they will later become subblocks of something
else. */
else if (subblock_chain)
current_binding_level->blocks
= chainon (current_binding_level->blocks, subblock_chain);
if (block)
TREE_USED (block) = 1;
return block;
/* Free this binding structure. */
current_binding_level = level->chain;
level->chain = free_binding_level;
free_binding_level = level;
}
/* Insert BLOCK at the end of the list of subblocks of the
current binding level. This is used when a BIND_EXPR is expanded,
to handle the BLOCK node inside the BIND_EXPR. */
@ -394,55 +318,42 @@ void
insert_block (tree block)
{
TREE_USED (block) = 1;
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
TREE_CHAIN (block) = BLOCK_SUBBLOCKS (current_binding_level->block);
BLOCK_SUBBLOCKS (current_binding_level->block) = block;
}
/* Set the BLOCK node for the innermost scope
(the one we are currently in). */
/* Return nonzero if the current binding has any variables. This means
it will have a BLOCK node. */
void
set_block (tree block)
int
block_has_vars ()
{
current_binding_level->this_block = block;
current_binding_level->names = chainon (current_binding_level->names,
BLOCK_VARS (block));
current_binding_level->blocks = chainon (current_binding_level->blocks,
BLOCK_SUBBLOCKS (block));
return BLOCK_VARS (current_binding_level->block) != 0;
}
/* Records a ..._DECL node DECL as belonging to the current lexical scope.
Returns the ..._DECL node. */
tree
pushdecl (tree decl)
{
struct binding_level *b;
/* If at top level, there is no context. But PARM_DECLs always go in the
level of its function. */
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
{
b = global_binding_level;
DECL_CONTEXT (decl) = 0;
}
DECL_CONTEXT (decl) = 0;
else
{
b = current_binding_level;
DECL_CONTEXT (decl) = current_function_decl;
}
DECL_CONTEXT (decl) = current_function_decl;
/* Put the declaration on the list. The list of declarations is in reverse
order. The list will be reversed later if necessary. This needs to be
this way for compatibility with the back-end.
order. The list will be reversed later.
Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They
will cause trouble with the debugger and aren't needed anyway. */
if (TREE_CODE (decl) != TYPE_DECL
|| TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
{
TREE_CHAIN (decl) = b->names;
b->names = decl;
TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
BLOCK_VARS (current_binding_level->block) = decl;
}
/* For the declaration of a type, set its name if it either is not already
@ -478,8 +389,7 @@ gnat_init_decl_processing (void)
current_function_decl = 0;
current_binding_level = 0;
free_binding_level = 0;
pushlevel (0);
global_binding_level = current_binding_level;
gnat_pushlevel ();
build_common_tree_nodes (0);
@ -1294,15 +1204,9 @@ create_type_decl (tree type_name,
it indicates whether to always allocate storage to the variable. */
tree
create_var_decl (tree var_name,
tree asm_name,
tree type,
tree var_init,
int const_flag,
int public_flag,
int extern_flag,
int static_flag,
struct attrib *attr_list)
create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
int const_flag, int public_flag, int extern_flag,
int static_flag, struct attrib *attr_list)
{
int init_const
= (var_init == 0
@ -1321,7 +1225,6 @@ create_var_decl (tree var_name,
&& 0 >= compare_tree_int (TYPE_SIZE_UNIT (type),
GET_MODE_SIZE (DCmode)))
? CONST_DECL : VAR_DECL, var_name, type);
tree assign_init = 0;
/* If this is external, throw away any initializations unless this is a
CONST_DECL (meaning we have a constant); they will be done elsewhere. If
@ -1346,7 +1249,7 @@ create_var_decl (tree var_name,
&& ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
!= TYPE_MAIN_VARIANT (type))
|| (static_flag && ! init_const)))
assign_init = var_init, var_init = 0;
DECL_INIT_BY_ASSIGN_P (var_decl) = 1;
DECL_INITIAL (var_decl) = var_init;
TREE_READONLY (var_decl) = const_flag;
@ -1369,32 +1272,13 @@ create_var_decl (tree var_name,
/* Add this decl to the current binding level and generate any
needed code and RTL. */
var_decl = pushdecl (var_decl);
expand_decl (var_decl);
if (DECL_CONTEXT (var_decl) != 0)
expand_decl_init (var_decl);
/* If this is volatile, force it into memory. */
if (TREE_SIDE_EFFECTS (var_decl))
gnat_mark_addressable (var_decl);
TREE_ADDRESSABLE (var_decl) = 1;
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0);
if (assign_init != 0)
{
/* If VAR_DECL has a padded type, convert it to the unpadded
type so the assignment is done properly. */
tree lhs = var_decl;
if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, lhs,
assign_init));
}
return var_decl;
}
@ -1859,8 +1743,7 @@ begin_subprog_body (tree subprog_decl)
announce_function (subprog_decl);
/* Make this field nonzero so further routines know that this is not
tentative. error_mark_node is replaced below (in poplevel) with the
adequate BLOCK. */
tentative. error_mark_node is replaced below with the adequate BLOCK. */
DECL_INITIAL (subprog_decl) = error_mark_node;
/* This function exists in static storage. This does not mean `static' in
@ -1870,7 +1753,7 @@ begin_subprog_body (tree subprog_decl)
/* Enter a new binding level and show that all the parameters belong to
this function. */
current_function_decl = subprog_decl;
pushlevel (0);
gnat_pushlevel ();
for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
param_decl = TREE_CHAIN (param_decl))
@ -1896,9 +1779,12 @@ end_subprog_body (void)
tree decl;
tree cico_list;
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl))
= current_function_decl;
/* Mark the BLOCK for this level as being for this function and pop the
level. Since the vars in it are the parameters, clear them. */
BLOCK_VARS (current_binding_level->block) = 0;
BLOCK_SUPERCONTEXT (current_binding_level->block) = current_function_decl;
DECL_INITIAL (current_function_decl) = current_binding_level->block;
gnat_poplevel ();
/* Mark the RESULT_DECL as being in this subprogram. */
DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;

1
gcc/ada/utils2.c
View file

@ -1990,7 +1990,6 @@ gnat_mark_addressable (tree expr_node)
case PARM_DECL:
case RESULT_DECL:
put_var_into_stack (expr_node, true);
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case FUNCTION_DECL: