+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
-- --
-- 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- --
-- Self
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
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 --
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
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
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 ???
-- 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,
with Ada.Task_Identification;
-- used for Task_Id
--- Null_Task_ID
+-- Null_Task_Id
-- Current_Task
with System.Error_Reporting;
with System.Tasking;
-- used for Access_Address
--- Task_ID
+-- Task_Id
-- Direct_Index_Vector
-- Direct_Index
(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);
(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
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
(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
(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
-- 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) :=
-- --
-- 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- --
-- 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
-- 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;
-- --
-- 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 --
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;
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)
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)
#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)
loop
if C = CR or else C = LF then
Skip_Line;
+ C := Nextc;
elsif C = EOF then
return;
Fatal_Error;
else
Skip_Line;
+ C := Nextc;
end if;
else
Fatal_Error;
Fatal_Error;
else
Skip_Line;
+ C := Nextc;
end if;
else
Fatal_Error;
= 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
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
|| (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
|| 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.
= 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);
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)
}
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)))
&& 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)
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
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;
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;
-- 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;
-- 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.
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)));
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)));
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
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
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;
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);
-----------------------
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);
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;
/* 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);
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);
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. */
#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
return (a == b || a == integer_zero_node);
}
\f
-/* 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);
- }
-}
-\f
/* Record the current code position in GNAT_NODE. */
void
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;
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);
-- 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);
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
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;
with Lib; use Lib;
with Namet; use Namet;
with Sinput; use Sinput;
+with Snames; use Snames;
with Uname; use Uname;
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 --
------------------------
-- 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
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
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
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,
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,
-- 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.
-- 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);
-- 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);
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
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);
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);
-- 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
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;
----------------------------
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;
-- 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- --
-----------------------------
procedure Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
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;
------------------
function Unblocked_By (Interrupt : Interrupt_ID)
- return System.Tasking.Task_ID is
+ return System.Tasking.Task_Id is
begin
Unimplemented;
return null;
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;
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);
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
-- 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;
-----------------------------
procedure Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
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
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
-- rendezvous.
with Ada.Task_Identification;
--- used for Task_ID type
+-- used for Task_Id type
with Ada.Exceptions;
-- used for Raise_Exception
-- Integer_Address
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
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 --
-- 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);
Static : Boolean);
entry Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
--------------------------------
type Entry_Assoc is record
- T : Task_ID;
+ T : Task_Id;
E : Task_Entry_Index;
end record;
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
-- already bound.
procedure Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
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;
------------------
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" &
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);
end Detach_Handler;
or accept Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
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
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
-----------------
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;
with Interfaces.VxWorks;
with Ada.Task_Identification;
--- used for Task_ID type
+-- used for Task_Id type
with Ada.Exceptions;
-- used for Raise_Exception
-- Integer_Address
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
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 --
-- 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;
Static : Boolean);
entry Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
-------------------------------
type Entry_Assoc is record
- T : Task_ID;
+ T : Task_Id;
E : Task_Entry_Index;
end record;
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
-- already bound.
procedure Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
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;
------------------
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;
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
end Detach_Handler;
or
accept Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
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
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
-- 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;
-- --
-- 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- --
-- 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
-- Integer_Address
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
-- Task_Entry_Index
-- Null_Task
-- Self
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 --
-- 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);
Static : in Boolean);
entry Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID);
-------------------------------
type Entry_Assoc is record
- T : Task_ID;
+ T : Task_Id;
E : Task_Entry_Index;
end record;
-- 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
-- already bound.
procedure Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Int_Ref : System.Address)
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;
------------------
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
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
or
accept Bind_Interrupt_To_Entry
- (T : Task_ID;
+ (T : Task_Id;
E : Task_Entry_Index;
Interrupt : Interrupt_ID)
do
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
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
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
-- --
-- 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- --
-- 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
-- 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.
-------------------------------
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.
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;
Not_A_Restriction_Id);
- -- Synonyms permitted for historical purposes of compatibility
-
- -- 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
+ -- Synonyms permitted for historical purposes of compatibility.
+ -- Must be coordinated with Restrict.Process_Restriction_Synonym.
+
+ 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;
-- --
-- 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- --
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;
-- --
-- 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- --
-- 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
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);
(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
Yielded : Boolean;
Now : Duration;
Dequeued : Delay_Block_Access;
- Dequeued_Task : Task_ID;
+ Dequeued_Task : Task_Id;
begin
Timer_Server_ID := STPO.Self;
-- --
-- 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- --
private
type Delay_Block is record
- Self_Id : Task_ID;
+ Self_Id : Task_Id;
-- ID of the calling task
Level : ATC_Level_Base;
-- 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.
-- 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.
-- 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,
---------------------
procedure Check_Exception
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
------------------------------------------
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);
-----------------
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;
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
---------------------------------------------
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
--------------------
procedure Reset_Priority
- (Acceptor : Task_ID;
+ (Acceptor : Task_Id;
Acceptor_Prev_Priority : Rendezvous_Priority) is
begin
pragma Assert (Acceptor = STPO.Self);
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;
------------------------------
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
-------------------
procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
- Caller : Task_ID;
+ Caller : Task_Id;
Called_PO : Protection_Entries_Access;
begin
-------------------------
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.
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;
--------------------------
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);
-- --
-- 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- --
-- 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.
-- 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
-- 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.
-- --
-- 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- --
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Error_Reporting;
-- used for Shutdown
-- 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;
-- 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;
-- Self --
----------
- function Self return Task_ID is
+ function Self return Task_Id is
begin
return Null_Task;
end Self;
null;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
begin
null;
end Write_Lock;
null;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
begin
null;
end Unlock;
-- 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;
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes) is
begin
-- 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;
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False) is
begin
-- 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;
-- Enter_Task --
----------------
- procedure Enter_Task (Self_ID : Task_ID) is
+ procedure Enter_Task (Self_ID : Task_Id) is
begin
null;
end Enter_Task;
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- Finalize_TCB --
------------------
- procedure Finalize_TCB (T : Task_ID) is
+ procedure Finalize_TCB (T : Task_Id) is
begin
null;
end Finalize_TCB;
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
begin
null;
end Abort_Task;
-- 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;
-- 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;
-- Environment_Task --
----------------------
- function Environment_Task return Task_ID is
+ function Environment_Task return Task_Id is
begin
return null;
end Environment_Task;
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : OSI.Thread_Id)
return Boolean
is
-- Initialize --
----------------
- procedure Initialize (Environment_Task : Task_ID) is
+ procedure Initialize (Environment_Task : Task_Id) is
begin
null;
end Initialize;
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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
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.
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.
-- 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 --
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 --
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;
-- 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;
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
end if;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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;
-- scheduling.
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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);
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- 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)
-- 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;
-- 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;
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Program_Info;
-- used for Default_Task_Stack
-- 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");
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 --
-- 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
-- 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;
-- 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;
---------------------
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
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
-----------
procedure Sleep
- (Self_ID : ST.Task_ID;
+ (Self_ID : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
------------
procedure Wakeup
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- Enter_Task --
----------------
- procedure Enter_Task (Self_ID : Task_ID) is
+ procedure Enter_Task (Self_ID : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result :=
-- 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
-- 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;
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-- 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.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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");
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.
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.
-- 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.
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;
-- 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
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
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
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
-----------
procedure Sleep
- (Self_ID : ST.Task_ID;
+ (Self_ID : ST.Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : Task_States;
-- no locks.
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with Ada.Exceptions;
-- used for Raise_Exception
-- 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
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.
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.
-- 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 --
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;
-- 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);
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
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
end if;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
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);
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-- 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;
-- no locks.
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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;
-- 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;
-- 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;
-- 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
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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
-- 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
-- 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;
------------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-- 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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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");
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.
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.
-- 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 --
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
-------------------
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;
-- 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;
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
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
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
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);
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
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-- 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;
-- 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
-- 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
-- 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;
-- Comments needed for these declarations ???
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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;
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- 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,
-- 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;
-- 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;
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
-- 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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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
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.
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));
-- 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 --
-- 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);
-- 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;
-- 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);
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
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
LeaveCriticalSection
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-- 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;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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
-- scheduling.
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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.
-- 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;
-- 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;
-- 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.
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
pragma Unreferenced (T);
begin
null;
-- 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;
--------------
-- 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
-- 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
-- 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
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-- --
-- 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- --
-- used for Size_Type
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
with System.Parameters;
-- used for Size_Type
-- 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
-- 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);
-----------
-- 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);
-- 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;
-- 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.
----------------
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;
(L : access RTS_Lock;
Global_Lock : Boolean := False)
is
- Self_ID : Task_ID;
+ Self_ID : Task_Id;
Old_Priority : Any_Priority;
begin
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
------------
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
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
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
begin
if not Single_Lock then
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-- 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;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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
----------------------------
procedure Set_Temporary_Priority
- (T : Task_ID;
+ (T : Task_Id;
New_Priority : System.Any_Priority)
is
use Interfaces.C;
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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.
-- 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;
-- 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;
-- 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
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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));
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
pragma Unreferenced (T);
begin
-- 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;
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
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.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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");
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.
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.
-- 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 --
-- 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 --
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;
-- 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;
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
end if;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Warnings (Off, Reason);
-- 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;
-- no locks.
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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;
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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;
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
-- ATCB components and types
with System.Task_Info;
-- 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;
pragma Inline (Record_Wakeup);
function Check_Wakeup
- (T : Task_ID;
+ (T : Task_Id;
Reason : Task_States) return Boolean;
pragma Inline (Check_Wakeup);
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.
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.
-- 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 --
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;
-- 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);
-- 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;
-- 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;
-- 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
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
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 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);
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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
-- 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;
-- 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 #
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;
-- 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;
-- 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;
-- 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
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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);
-- 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);
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : Task_States)
is
Result : Interfaces.C.int;
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
------------
procedure Wakeup
- (T : Task_ID;
+ (T : Task_Id;
Reason : Task_States)
is
Result : Interfaces.C.int;
(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
----------------
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
-----------------
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
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
is
pragma Unreferenced (Reason);
- Self_ID : constant Task_ID := Self;
+ Self_ID : constant Task_Id := Self;
P : Lock_Ptr;
begin
------------------
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?
------------------
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
--------------------
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
-- 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
-- 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;
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
begin
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
-- ATCB components and types
with System.Soft_Links;
-- 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
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.
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.
-- 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 --
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;
-- 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);
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
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
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
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
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-- 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;
-- no locks.
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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);
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
Result :=
-- 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
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Warnings (Off, T);
-- 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;
-- system handler)
begin
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
with System.Soft_Links;
-- used for Defer/Undefer_Abort
-- 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");
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.
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
-- 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);
-- 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
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
---------------------
-- Initialize_Lock --
----------------
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;
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
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
-----------
procedure Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-----------------
procedure Timed_Sleep
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
-----------------
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
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;
------------------
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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;
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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);
-- 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);
-- 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
-- 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
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
-- 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
-- --
-- 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- --
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
-- ATCB components and types
with Interfaces.C;
-- 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");
-- 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
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.
-- 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 --
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 --
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;
-- 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);
-- 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;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
-----------------------------
-- Install_Signal_Handlers --
end if;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
Result : int;
begin
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : int;
begin
-- 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;
-- 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;
-- 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
-- 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;
-- with run-till-blocked scheduling.
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
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;
-- 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.
-- 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;
-- 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;
-- 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;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
-- 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
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : int;
begin
-- 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
-- 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
-- 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;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-----------------
function Resume_Task
- (T : ST.Task_ID;
+ (T : ST.Task_Id;
Thread_Self : Thread_Id)
return Boolean
is
-- Initialize --
----------------
- procedure Initialize (Environment_Task : Task_ID) is
+ procedure Initialize (Environment_Task : Task_Id) is
Result : int;
begin
end if;
end loop;
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
-- --
-- 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- --
-- used for Size_Type
with System.Tasking;
--- used for Task_ID
+-- used for Task_Id
with System.OS_Interface;
-- used for Thread_Id
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
-- 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.
--
-- 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.
-- 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
-- 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
-- ??? 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.
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
-- 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
-- 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
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.
--
-- 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);
-- 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.
-- 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.
-- 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;
-- 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
-----------------------
-- 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:
--
-- 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
-- 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
-- --
-- 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- --
-- 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.
-- 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);
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;
-- 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
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;
-- 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);
-- 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;
-- 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;
-- --
-- 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- --
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.
--
-- 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.
--
-- --
-- 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- --
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;
----------------
procedure List_Tasks is
- C : Task_ID;
+ C : Task_Id;
begin
C := All_Tasks_List;
-- 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
----------------------
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
- C : Task_ID;
+ C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
-----------------------
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
- C : Task_ID;
+ C : Task_Id;
Dummy : Boolean;
pragma Unreferenced (Dummy);
-----------
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
-- --
-- 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- --
-- 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);
-- 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
-------------------------------
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.
-- 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;
-- 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.
-- 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;
------------------------
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
-- 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;
-- 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;
--------------------
procedure Defer_Abortion is
- Self_ID : Task_ID;
+ Self_ID : Task_Id;
begin
if No_Abort and then not Dynamic_Priority_Support then
-- 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
-- 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);
--------------
procedure Init_RTS is
- Self_Id : Task_ID;
+ Self_Id : Task_Id;
begin
-- Terminate run time (regular vs restricted) specific initialization
-- 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
-- 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
-- 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
-- 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;
---------------
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);
-- 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;
-- 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;
-- 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;
-- 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
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
-- 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
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;
-- 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
-- --
-- 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- --
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.
-- 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
-- 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
-- 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);
-- 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
-- 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);
-- 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.
-- --
-- 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- --
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;
begin
declare
- T : Task_ID;
+ T : Task_Id;
Success : Boolean;
Base_Priority : Any_Priority;
-- 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 --
-- 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;
-- 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.
-- 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.
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.
------------------------------------------
----------------------------------
type Entry_Call_Record is record
- Self : Task_ID;
+ Self : Task_Id;
-- ID of the caller
Mode : Call_Modes;
-- 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.
---------------------
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);
-- --
-- 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- --
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
-----------------------------
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)
-- 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
-- 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;
------------------------
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;
-- --
-- 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- --
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);
-- 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;
-- 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
-- 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
-- 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;
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
-- 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
(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;
--------------------
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;
-- 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);
-----------------
procedure Call_Simple
- (Acceptor : Task_ID;
+ (Acceptor : Task_Id;
E : Task_Entry_Index;
Uninterpreted_Data : System.Address)
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;
-- 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);
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;
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
------------------------
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
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;
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;
----------------
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
----------------------
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;
---------------------
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
-- 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
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;
---------------------------
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;
-- 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.
-- --
-- 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- --
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;
-- 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;
-- 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.
-- 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.
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.
-- 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.
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.
-- 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
-- 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.
-- 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;
-- 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;
-------------------------
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);
---------------------
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);
-- 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);
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;
------------------
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;
-- 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
-- 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
-- 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
-- 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;
-- 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
-- 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
-- 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");
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;
-- 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'));
-- 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.
-- 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;
-- 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);
-- 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));
-- --
-- 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- --
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.
--
-- 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
-- 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.
-- --
-- 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- --
-- (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);
-- 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);
-- 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 ???
-- 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;
----------------------
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;
-- 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;
-- --
-- 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- --
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 --
-- 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
-- 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
-- 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
-- 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);
-- 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;
-- 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
-- --
-- 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- --
-- 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");
-- 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
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;
-- --
-- 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- --
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;
-- --
-- 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- --
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
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
-- 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);
--------------------
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)
------------------------
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
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;
------------------
procedure Requeue_Call
- (Self_Id : Task_ID;
+ (Self_Id : Task_Id;
Object : Protection_Entries_Access;
Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
----------------------------
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;
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
---------------------
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;
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;
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
-- 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)).
-- 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);
private
type Communication_Block is record
- Self : Task_ID;
+ Self : Task_Id;
Enqueued : Boolean := True;
Cancelled : Boolean := False;
end record;
-----------------------
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);
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);
---------------------
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
----------
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);
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);
----------------
procedure Task_Synch is
- Synch_Self_ID : constant Task_ID := Self;
+ Synch_Self_ID : constant Task_Id := Self;
begin
if Single_Lock then
-- Initialize --
----------------
- procedure Initialize (Environment_Task : Task_ID) is
+ procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
-- Set --
---------
- procedure Set (Self_Id : Task_ID) is
+ procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
-- 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;
-- 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;
-- Initialize --
----------------
- procedure Initialize (Environment_Task : Task_ID) is
+ procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
-- 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));
-- 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
-- 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;
-- 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
-- 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));
-- 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;
-- --
-- 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- --
-- 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));
-- 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));
-- 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
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;
-- Set --
---------
- procedure Set (Self_Id : Task_ID) is
+ procedure Set (Self_Id : Task_Id) is
Result : STATUS;
begin
-- 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;
-- --
-- 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- --
-- 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;
-- 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;
-----------------------
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
--------------------------
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);
-- 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.
-- 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
---------------------
procedure Check_Exception
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Entry_Call : Entry_Call_Link)
is
pragma Warnings (Off, Self_ID);
------------------------
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;
-------------------------
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);
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;
-- 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);
--------------------
procedure PO_Do_Or_Queue
- (Self_Id : Task_ID;
+ (Self_Id : Task_Id;
Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link)
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;
-----------------------------------
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;
-------------------
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
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;
-- 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)).
-- --
-- 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- --
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
-- 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
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;
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 :=
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
procedure Send_Trace_Info
(Id : Trace_T;
- Acceptor : Task_ID;
+ Acceptor : Task_Id;
Entry_Number : Entry_Index;
Timeout : Duration)
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;
procedure Send_Trace_Info
(Id : Trace_T;
- Task_Name : Task_ID;
+ Task_Name : Task_Id;
Number : Integer;
Timeout : Duration)
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
-- --
-- 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- --
-- 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
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
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;
procedure Send_Trace_Info
(Id : Trace_T;
- Acceptor : ST.Task_ID;
+ Acceptor : ST.Task_Id;
Entry_Number : ST.Entry_Index;
Timeout : Duration)
is
procedure Send_Trace_Info
(Id : Trace_T;
- Task_Name : ST.Task_ID;
+ Task_Name : ST.Task_Id;
Number : Integer)
is
begin
procedure Send_Trace_Info
(Id : Trace_T;
- Task_Name : ST.Task_ID;
+ Task_Name : ST.Task_Id;
Number : Integer;
Timeout : Duration)
is
-- --
-- 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- --
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;
procedure Send_Trace_Info
(Id : Trace_T;
- Acceptor : ST.Task_ID;
+ Acceptor : ST.Task_Id;
Entry_Number : ST.Entry_Index;
Timeout : Duration);
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;
end if;
end loop;
- Set_Etype (N, RTE (RO_AT_Task_ID));
+ Set_Etype (N, RTE (RO_AT_Task_Id));
end Caller;
-------------
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 "
-- 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;
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
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);
+ end if;
- -- 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);
+ R_Id :=
+ Get_Restriction_Id
+ (Process_Restriction_Synonyms (Chars (Expr)));
- -- Restriction is active
+ if R_Id not in All_Boolean_Restrictions then
+ Error_Pragma_Arg
+ ("invalid restriction identifier", Arg);
+ end if;
- else
- if Implementation_Restriction (R_Id) then
- Check_Restriction
- (No_Implementation_Restrictions, 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);
+ 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).
+ -- 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;
+ if R_Id = No_Exceptions then
+ Scope_Suppress := (others => True);
end if;
- -- Case of restriction identifier present
+ -- 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
"link_name#" &
"lowercase#" &
"max_entry_queue_depth#" &
+ "max_entry_queue_length#" &
"max_size#" &
"mechanism#" &
"mixedcase#" &
"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#" &
"secondary_stack_size#" &
"section#" &
"semaphore#" &
+ "simple_barriers#" &
"spec_file_name#" &
"static#" &
"stack_size#" &
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
-- 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
-- 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.
-- 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
-- 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;
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
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);
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)
/* 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)
/* 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)
{
{
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));
&& (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:
break;
case N_Null_Statement:
+ gnu_result = build_nt (NULL_STMT);
break;
case N_Assignment_Statement:
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);
/* 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);
/* 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);
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);
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);
/* 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)
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)));
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);
= 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
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))
- ;
-
- /* 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));
- }
+ 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));
+ }
+ 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);
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:
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)))
{
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));
/* 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);
}
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);
}
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. */
/* 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
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
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. */
/* 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))
/* 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 ();
}
}
expand_start_catch (gnu_etypes_list);
- pushlevel (0);
+ gnat_pushlevel ();
expand_start_bindings (0);
{
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
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
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:
return insns;
}
\f
+/* 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
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. */
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))
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 ();
}
break;
- default:
- abort ();
+ default:
+ abort ();
}
}
\f
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;
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);
}
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);
;
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,
}
/* 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);
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
TREE_TYPE (gnu_new));
}
+
+ gnat_expand_stmt (end_block_stmt ());
}
\f
/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
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);
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 ();
(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);
}
\f
/* 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;
};
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(())
{
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
tree
getdecls (void)
{
- return current_binding_level->names;
-}
-
-/* Nonzero if the current level needs to have a BLOCK made. */
-
-int
-kept_level_p (void)
-{
- return (current_binding_level->names != 0);
+ return BLOCK_VARS (current_binding_level->block);
}
-/* 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.
-
- 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.
+/* Exit a binding level. */
- 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;
-
- /* 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;
+ struct ada_binding_level *level = current_binding_level;
+ tree block = level->block;
+ tree decl;
+
+ 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)
- {
- BLOCK_VARS (block) = keep ? decl_chain : 0;
- BLOCK_SUBBLOCKS (block) = subblock_chain;
- }
-
- /* 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)
+ /* 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)
{
- /* 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;
+ 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 if (block)
+ else
{
- if (!block_previously_created)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
+ TREE_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
+ BLOCK_SUBBLOCKS (level->chain->block) = block;
+ TREE_USED (block) = 1;
}
- /* 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;
}
-\f
+
/* 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. */
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;
}
-
+\f
/* 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
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);
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
&& 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
&& ((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;
/* 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;
}
\f
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
/* 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))
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;
case PARM_DECL:
case RESULT_DECL:
put_var_into_stack (expr_node, true);
- TREE_ADDRESSABLE (expr_node) = 1;
return true;
case FUNCTION_DECL:
projects / gcc.git / commitdiff