diff options
32 files changed, 3654 insertions, 3664 deletions
diff --git a/gcc/ada/a-caldel.ads b/gcc/ada/a-caldel.ads index c2ea1a8aa3a..f69634b341d 100644 --- a/gcc/ada/a-caldel.ads +++ b/gcc/ada/a-caldel.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-1998, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,18 +39,17 @@ package Ada.Calendar.Delays is procedure Delay_For (D : Duration); - -- Delay until an interval of length (at least) D seconds has passed, - -- or the task is aborted to at least the current ATC nesting level. - -- This is an abort completion point. - -- The body of this procedure must perform all the processing - -- required for an abortion point. + -- Delay until an interval of length (at least) D seconds has passed, or + -- the task is aborted to at least the current ATC nesting level. This is + -- an abort completion point. The body of this procedure must perform all + -- the processing required for an abort point. procedure Delay_Until (T : Time); - -- Delay until Clock has reached (at least) time T, - -- or the task is aborted to at least the current ATC nesting level. - -- The body of this procedure must perform all the processing - -- required for an abortion point. + -- Delay until Clock has reached (at least) time T, or the task is aborted + -- to at least the current ATC nesting level. The body of this procedure + -- must perform all the processing required for an abort point. function To_Duration (T : Time) return Duration; + -- Convert Time to Duration end Ada.Calendar.Delays; diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb index e5788a473e2..f5dd5013399 100644 --- a/gcc/ada/a-calend.adb +++ b/gcc/ada/a-calend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -91,15 +91,16 @@ package body Ada.Calendar is -- The following constants are used in adjusting Ada dates so that they -- fit into a 56 year range that can be handled by Unix (1970 included - -- 2026 excluded). Dates that are not in this 56 year range are shifted - -- by multiples of 56 years to fit in this range + -- by multiples of 56 years to fit in this range. + -- The trick is that the number of days in any four year period in the Ada -- range of years (1901 - 2099) has a constant number of days. This is -- because we have the special case of 2000 which, contrary to the normal - -- exception for centuries, is a leap year after all. - -- 56 has been chosen, because it is not only a multiple of 4, but also - -- a multiple of 7. Thus two dates 56 years apart fall on the same day of - -- the week, and the Daylight Saving Time change dates are usually the same - -- for these two years. + -- exception for centuries, is a leap year after all. 56 has been chosen, + -- because it is not only a multiple of 4, but also a multiple of 7. Thus + -- two dates 56 years apart fall on the same day of the week, and the + -- Daylight Saving Time change dates are usually the same for these two + -- years. Unix_Year_Min : constant := 1970; Unix_Year_Max : constant := 2026; @@ -125,7 +126,6 @@ package body Ada.Calendar is pragma Unsuppress (Overflow_Check); begin return (Left + Time (Right)); - exception when Constraint_Error => raise Time_Error; @@ -135,7 +135,6 @@ package body Ada.Calendar is pragma Unsuppress (Overflow_Check); begin return (Time (Left) + Right); - exception when Constraint_Error => raise Time_Error; @@ -149,7 +148,6 @@ package body Ada.Calendar is pragma Unsuppress (Overflow_Check); begin return Left - Time (Right); - exception when Constraint_Error => raise Time_Error; @@ -159,7 +157,6 @@ package body Ada.Calendar is pragma Unsuppress (Overflow_Check); begin return Duration (Left) - Duration (Right); - exception when Constraint_Error => raise Time_Error; @@ -219,7 +216,6 @@ package body Ada.Calendar is DM : Month_Number; DD : Day_Number; DS : Day_Duration; - begin Split (Date, DY, DM, DD, DS); return DD; @@ -234,7 +230,6 @@ package body Ada.Calendar is DM : Month_Number; DD : Day_Number; DS : Day_Duration; - begin Split (Date, DY, DM, DD, DS); return DM; @@ -249,7 +244,6 @@ package body Ada.Calendar is DM : Month_Number; DD : Day_Number; DS : Day_Duration; - begin Split (Date, DY, DM, DD, DS); return DS; @@ -291,11 +285,11 @@ package body Ada.Calendar is D := Duration (Date); - -- First of all, filter out completely ludicrous values. Remember - -- that we use the full stored range of duration values, which may - -- be significantly larger than the allowed range of Ada times. Note - -- that these checks are wider than required to make absolutely sure - -- that there are no end effects from time zone differences. + -- First of all, filter out completely ludicrous values. Remember that + -- we use the full stored range of duration values, which may be + -- significantly larger than the allowed range of Ada times. Note that + -- these checks are wider than required to make absolutely sure that + -- there are no end effects from time zone differences. if D < LowD or else D > HighD then raise Time_Error; @@ -306,11 +300,11 @@ package body Ada.Calendar is -- required range of years (the guaranteed range available is only -- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1. - -- If we have a value outside this range, then we first adjust it - -- to be in the required range by adding multiples of 56 years. - -- For the range we are interested in, the number of days in any - -- consecutive 56 year period is constant. Then we do the split - -- on the adjusted value, and readjust the years value accordingly. + -- If we have a value outside this range, then we first adjust it to be + -- in the required range by adding multiples of 56 years. For the range + -- we are interested in, the number of days in any consecutive 56 year + -- period is constant. Then we do the split on the adjusted value, and + -- readjust the years value accordingly. Year_Val := 0; @@ -325,13 +319,13 @@ package body Ada.Calendar is end loop; -- Now we need to take the value D, which is now non-negative, and - -- break it down into seconds (to pass to the localtime_r function) - -- and fractions of seconds (for the adjustment below). + -- break it down into seconds (to pass to the localtime_r function) and + -- fractions of seconds (for the adjustment below). -- Surprisingly there is no easy way to do this in Ada, and certainly - -- no easy way to do it and generate efficient code. Therefore we - -- do it at a low level, knowing that it is really represented as - -- an integer with units of Small + -- no easy way to do it and generate efficient code. Therefore we do it + -- at a low level, knowing that it is really represented as an integer + -- with units of Small declare type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1; @@ -356,18 +350,18 @@ package body Ada.Calendar is Day := Tm_Val.tm_mday; -- The Seconds value is a little complex. The localtime function - -- returns the integral number of seconds, which is what we want, - -- but we want to retain the fractional part from the original - -- Time value, since this is typically stored more accurately. + -- returns the integral number of seconds, which is what we want, but + -- we want to retain the fractional part from the original Time value, + -- since this is typically stored more accurately. Seconds := Duration (Tm_Val.tm_hour * 3600 + Tm_Val.tm_min * 60 + Tm_Val.tm_sec) + Frac_Sec; - -- Note: the above expression is pretty horrible, one of these days - -- we should stop using time_of and do everything ourselves to avoid - -- these unnecessary divides and multiplies???. + -- Note: the above expression is pretty horrible, one of these days we + -- should stop using time_of and do everything ourselves to avoid these + -- unnecessary divides and multiplies???. -- The Year may still be out of range, since our entry test was -- deliberately crude. Trying to make this entry test accurate is @@ -404,8 +398,8 @@ package body Ada.Calendar is begin -- The following checks are redundant with respect to the constraint -- error checks that should normally be made on parameters, but we - -- decide to raise Constraint_Error in any case if bad values come - -- in (as a result of checks being off in the caller, or for other + -- decide to raise Constraint_Error in any case if bad values come in + -- (as a result of checks being off in the caller, or for other -- erroneous or bounded error cases). if not Year 'Valid @@ -433,10 +427,10 @@ package body Ada.Calendar is TM_Val.tm_mon := Month - 1; -- For the year, we have to adjust it to a year that Unix can handle. - -- We do this in 56 year steps, since the number of days in 56 years - -- is constant, so the timezone effect on the conversion from local - -- time to GMT is unaffected; also the DST change dates are usually - -- not modified. + -- We do this in 56 year steps, since the number of days in 56 years is + -- constant, so the timezone effect on the conversion from local time + -- to GMT is unaffected; also the DST change dates are usually not + -- modified. while Year_Val < Unix_Year_Min loop Year_Val := Year_Val + 56; @@ -450,8 +444,8 @@ package body Ada.Calendar is TM_Val.tm_year := Year_Val - 1900; - -- Since we do not have information on daylight savings, - -- rely on the default information. + -- Since we do not have information on daylight savings, rely on the + -- default information. TM_Val.tm_isdst := -1; Result_Secs := mktime (TM_Val'Unchecked_Access); @@ -459,14 +453,13 @@ package body Ada.Calendar is -- That gives us the basic value in seconds. Two adjustments are -- needed. First we must undo the year adjustment carried out above. -- Second we put back the fraction seconds value since in general the - -- Day_Duration value we received has additional precision which we - -- do not want to lose in the constructed result. + -- Day_Duration value we received has additional precision which we do + -- not want to lose in the constructed result. return Time (Duration (Result_Secs) + Duration_Adjust + (Seconds - Duration (Int_Secs))); - end Time_Of; ---------- @@ -478,7 +471,6 @@ package body Ada.Calendar is DM : Month_Number; DD : Day_Number; DS : Day_Duration; - begin Split (Date, DY, DM, DD, DS); return DY; diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 35801e2896e..0fc74d5231f 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2004, Ada Core Technologies -- +-- Copyright (C) 1995-2005, Ada Core Technologies -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,174 +32,171 @@ -- -- ------------------------------------------------------------------------------ --- The following notes are provided in case someone decides the --- implementation of this package is too complicated, or too slow. --- Please read this before making any "simplifications". +-- The following notes are provided in case someone decides the implementation +-- of this package is too complicated, or too slow. Please read this before +-- making any "simplifications". --- Correct implementation of this package is more difficult than one --- might expect. After considering (and coding) several alternatives, --- we settled on the present compromise. Things we do not like about --- this implementation include: +-- Correct implementation of this package is more difficult than one might +-- expect. After considering (and coding) several alternatives, 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 --- possibly trashing memory and crashing the runtime system. +-- - 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, --- except for types that happen to be the same size as System.Address, --- or shorter. +-- - It requires dynamic storage allocation for each new attribute value, +-- except for types that happen to be the same size as System.Address, or +-- shorter. -- - Instantiations at other than the library level rely on being able to -- do down-level calls to a procedure declared in the generic package body. -- This makes it potentially vulnerable to compiler changes. --- The main implementation issue here is that the connection from --- task to attribute is a potential source of dangling references. +-- The main implementation issue here is that the connection from task to +-- attribute is a potential source of dangling references. -- When a task goes away, we want to be able to recover all the storage -- associated with its attributes. The Ada mechanism for this is --- finalization, via controlled attribute types. For this reason, --- the ARM requires finalization of attribute values when the --- associated task terminates. +-- finalization, via controlled attribute types. For this reason, the ARM +-- requires finalization of attribute values when the associated task +-- terminates. --- This finalization must be triggered by the tasking runtime system, --- during termination of the task. Given the active set of instantiations --- of Ada.Task_Attributes is dynamic, the number and types of attributes +-- This finalization must be triggered by the tasking runtime system, during +-- termination of the task. Given the active set of instantiations of +-- Ada.Task_Attributes is dynamic, the number and types of attributes -- belonging to a task will not be known until the task actually terminates. -- Some of these types may be controlled and some may not. The RTS must find -- some way to determine which of these attributes need finalization, and -- invoke the appropriate finalization on them. --- One way this might be done is to create a special finalization chain --- for each task, similar to the finalization chain that is used for --- controlled objects within the task. This would differ from the usual --- finalization chain in that it would not have a LIFO structure, since --- attributes may be added to a task at any time during its lifetime. --- This might be the right way to go for the longer term, but at present --- this approach is not open, since GNAT does not provide such special --- finalization support. +-- One way this might be done is to create a special finalization chain for +-- each task, similar to the finalization chain that is used for controlled +-- objects within the task. This would differ from the usual finalization +-- chain in that it would not have a LIFO structure, since attributes may be +-- added to a task at any time during its lifetime. This might be the right +-- way to go for the longer term, but at present this approach is not open, +-- since GNAT does not provide such special finalization support. --- Lacking special compiler support, the RTS is limited to the --- normal ways an application invokes finalization, i.e. +-- Lacking special compiler support, the RTS is limited to the normal ways an +-- application invokes finalization, i.e. --- a) Explicit call to the procedure Finalize, if we know the type --- has this operation defined on it. This is not sufficient, since --- we have no way of determining whether a given generic formal --- Attribute type is controlled, and no visibility of the associated --- Finalize procedure, in the generic body. +-- a) Explicit call to the procedure Finalize, if we know the type has this +-- operation defined on it. This is not sufficient, since we have no way +-- of determining whether a given generic formal Attribute type is +-- controlled, and no visibility of the associated Finalize procedure, in +-- the generic body. --- b) Leaving the scope of a local object of a controlled type. --- This does not help, since the lifetime of an instantiation of --- Ada.Task_Attributes does not correspond to the lifetimes of the --- various tasks which may have that attribute. +-- b) Leaving the scope of a local object of a controlled type. This does not +-- help, since the lifetime of an instantiation of Ada.Task_Attributes +-- does not correspond to the lifetimes of the various tasks which may +-- have that attribute. --- c) Assignment of another value to the object. This would not help, --- since we then have to finalize the new value of the object. +-- c) Assignment of another value to the object. This would not help, since +-- we then have to finalize the new value of the object. --- d) Unchecked deallocation of an object of a controlled type. --- This seems to be the only mechanism available to the runtime --- system for finalization of task attributes. +-- d) Unchecked deallocation of an object of a controlled type. This seems to +-- be the only mechanism available to the runtime system for finalization +-- of task attributes. --- We considered two ways of using unchecked deallocation, both based --- on a linked list of that would hang from the task control block. +-- We considered two ways of using unchecked deallocation, both based on a +-- linked list of that would hang from the task control block. -- In the first approach the objects on the attribute list are all derived -- from one controlled type, say T, and are linked using an access type to --- T'Class. The runtime system has an Unchecked_Deallocation for T'Class --- with access type T'Class, and uses this to deallocate and finalize all --- the items in the list. The limitation of this approach is that each +-- T'Class. The runtime system has an Unchecked_Deallocation for T'Class with +-- access type T'Class, and uses this to deallocate and finalize all the +-- items in the list. The limitation of this approach is that each -- instantiation of the package Ada.Task_Attributes derives a new record --- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation --- is only allowed at the library level. - --- In the second approach the objects on the attribute list are of --- unrelated but structurally similar types. Unchecked conversion is --- used to circument Ada type checking. Each attribute-storage node --- contains not only the attribute value and a link for chaining, but --- also a pointer to a descriptor for the corresponding instantiation --- of Task_Attributes. The instantiation-descriptor contains a --- pointer to a procedure that can do the correct deallocation and --- finalization for that type of attribute. On task termination, the --- runtime system uses the pointer to call the appropriate deallocator. - --- While this gets around the limitation that instantations be at --- the library level, it relies on an implementation feature that --- may not always be safe, i.e. that it is safe to call the --- Deallocate procedure for an instantiation of Ada.Task_Attributes --- that no longer exists. In general, it seems this might result in --- dangling references. - --- Another problem with instantiations deeper than the library level --- is that there is risk of storage leakage, or dangling references --- to reused storage. That is, if an instantiation of Ada.Task_Attributes --- is made within a procedure, what happens to the storage allocated for --- attributes, when the procedure call returns? Apparently (RM 7.6.1 (4)) --- any such objects must be finalized, since they will no longer be --- accessible, and in general one would expect that the storage they occupy --- would be recovered for later reuse. (If not, we would have a case of --- storage leakage.) Assuming the storage is recovered and later reused, --- we have potentially dangerous dangling references. When the procedure --- containing the instantiation of Ada.Task_Attributes returns, there --- may still be unterminated tasks with associated attribute values for --- that instantiation. When such tasks eventually terminate, the RTS --- will attempt to call the Deallocate procedure on them. If the --- corresponding storage has already been deallocated, when the master --- of the access type was left, we have a potential disaster. This --- disaster is compounded since the pointer to Deallocate is probably --- through a "trampoline" which will also have been destroyed. - --- For this reason, we arrange to remove all dangling references --- before leaving the scope of an instantiation. This is ugly, since --- it requires traversing the list of all tasks, but it is no more ugly --- than a similar traversal that we must do at the point of instantiation --- in order to initialize the attributes of all tasks. At least we only --- need to do these traversals if the type is controlled. - --- We chose to defer allocation of storage for attributes until the --- Reference function is called or the attribute is first set to a value --- different from the default initial one. This allows a potential --- savings in allocation, for attributes that are not used by all tasks. +-- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is +-- only allowed at the library level. + +-- In the second approach the objects on the attribute list are of unrelated +-- but structurally similar types. Unchecked conversion is used to circument +-- Ada type checking. Each attribute-storage node contains not only the +-- attribute value and a link for chaining, but also a pointer to descriptor +-- for the corresponding instantiation of Task_Attributes. The instantiation +-- descriptor contains pointer to a procedure that can do the correct +-- deallocation and finalization for that type of attribute. On task +-- termination, the runtime system uses the pointer to call the appropriate +-- deallocator. + +-- While this gets around the limitation that instantations be at the library +-- level, it relies on an implementation feature that may not always be safe, +-- i.e. that it is safe to call the Deallocate procedure for an instantiation +-- of Ada.Task_Attributes that no longer exists. In general, it seems this +-- might result in dangling references. + +-- Another problem with instantiations deeper than the library level is that +-- there is risk of storage leakage, or dangling references to reused +-- storage. That is, if an instantiation of Ada.Task_Attributes is made +-- within a procedure, what happens to the storage allocated for attributes, +-- when the procedure call returns? Apparently (RM 7.6.1 (4)) any such +-- objects must be finalized, since they will no longer be accessible, and in +-- general one would expect that the storage they occupy would be recovered +-- for later reuse. (If not, we would have a case of storage leakage.) +-- Assuming the storage is recovered and later reused, we have potentially +-- dangerous dangling references. When the procedure containing the +-- instantiation of Ada.Task_Attributes returns, there may still be +-- unterminated tasks with associated attribute values for that instantiation. +-- When such tasks eventually terminate, the RTS will attempt to call the +-- Deallocate procedure on them. If the corresponding storage has already +-- been deallocated, when the master of the access type was left, we have a +-- potential disaster. This disaster is compounded since the pointer to +-- Deallocate is probably through a "trampoline" which will also have been +-- destroyed. + +-- For this reason, we arrange to remove all dangling references before +-- leaving the scope of an instantiation. This is ugly, since it requires +-- traversing the list of all tasks, but it is no more ugly than a similar +-- traversal that we must do at the point of instantiation in order to +-- initialize the attributes of all tasks. At least we only need to do these +-- traversals if the type is controlled. + +-- We chose to defer allocation of storage for attributes until the Reference +-- function is called or the attribute is first set to a value different from +-- the default initial one. This allows a potential savings in allocation, +-- for attributes that are not used by all tasks. -- For efficiency, we reserve space in the TCB for a fixed number of --- direct-access attributes. These are required to be of a size that --- fits in the space of an object of type System.Address. Because --- we must use unchecked bitwise copy operations on these values, they --- cannot be of a controlled type, but that is covered automatically --- since controlled objects are too large to fit in the spaces. +-- direct-access attributes. These are required to be of a size that fits in +-- the space of an object of type System.Address. Because we must use +-- unchecked bitwise copy operations on these values, they cannot be of a +-- controlled type, but that is covered automatically since controlled +-- objects are too large to fit in the spaces. -- We originally deferred the initialization of these direct-access --- attributes, just as we do for the indirect-access attributes, and --- used a per-task bit vector to keep track of which attributes were --- currently defined for that task. We found that the overhead of --- maintaining this bit-vector seriously slowed down access to the --- attributes, and made the fetch operation non-atomic, so that even --- to read an attribute value required locking the TCB. Therefore, --- we now initialize such attributes for all existing tasks at the time --- of the attribute instantiation, and initialize existing attributes --- for each new task at the time it is created. +-- attributes, just as we do for the indirect-access attributes, and used a +-- per-task bit vector to keep track of which attributes were currently +-- defined for that task. We found that the overhead of maintaining this +-- bit-vector seriously slowed down access to the attributes, and made the +-- fetch operation non-atomic, so that even to read an attribute value +-- required locking the TCB. Therefore, we now initialize such attributes for +-- all existing tasks at the time of the attribute instantiation, and +-- initialize existing attributes for each new task at the time it is +-- created. -- The latter initialization requires a list of all the instantiation --- descriptors. Updates to this list, as well as the bit-vector that --- is used to reserve slots for attributes in the TCB, require mutual --- exclusion. That is provided by the Lock/Unlock_RTS. - --- One special problem that added complexity to the design is that --- the per-task list of indirect attributes contains objects of --- different types. We use unchecked pointer conversion to link --- these nodes together and access them, but the records may not have --- identical internal structure. Initially, we thought it would be --- enough to allocate all the common components of the records at the --- front of each record, so that their positions would correspond. --- Unfortunately, GNAT adds "dope" information at the front of a record, --- if the record contains any controlled-type components. +-- descriptors. Updates to this list, as well as the bit-vector that is used +-- to reserve slots for attributes in the TCB, require mutual exclusion. That +-- is provided by the Lock/Unlock_RTS. + +-- One special problem that added complexity to the design is that the +-- per-task list of indirect attributes contains objects of different types. +-- We use unchecked pointer conversion to link these nodes together and +-- access them, but the records may not have identical internal structure. +-- Initially, we thought it would be enough to allocate all the common +-- components of the records at the front of each record, so that their +-- positions would correspond. Unfortunately, GNAT adds "dope" information at +-- the front of a record, if the record contains any controlled-type +-- components. -- --- This means that the offset of the fields we use to link the nodes is --- at different positions on nodes of different types. To get around this, --- each attribute storage record consists of a core node and wrapper. --- The core nodes are all of the same type, and it is these that are --- linked together and generally "seen" by the RTS. Each core node --- contains a pointer to its own wrapper, which is a record that contains --- the core node along with an attribute value, approximately --- as follows: +-- This means that the offset of the fields we use to link the nodes is at +-- different positions on nodes of different types. To get around this, each +-- attribute storage record consists of a core node and wrapper. The core +-- nodes are all of the same type, and it is these that are linked together +-- and generally "seen" by the RTS. Each core node contains a pointer to its +-- own wrapper, which is a record that contains the core node along with an +-- attribute value, approximately as follows: -- type Node; -- type Node_Access is access all Node; @@ -211,51 +208,50 @@ -- Wrapper : Access_Wrapper; -- end record; -- type Wrapper is record --- Noed : aliased Node; --- Value : aliased Attribute; -- the generic formal type +-- Dummy_Node : aliased Node; +-- Value : aliased Attribute; -- the generic formal type -- end record; --- Another interesting problem is with the initialization of --- the instantiation descriptors. Originally, we did this all via --- the Initialize procedure of the descriptor type and code in the --- package body. It turned out that the Initialize procedure needed --- quite a bit of information, including the size of the attribute --- type, the initial value of the attribute (if it fits in the TCB), --- and a pointer to the deallocator procedure. These needed to be --- "passed" in via access discriminants. GNAT was having trouble --- with access discriminants, so all this work was moved to the --- package body. +-- Another interesting problem is with the initialization of the +-- instantiation descriptors. Originally, we did this all via the Initialize +-- procedure of the descriptor type and code in the package body. It turned +-- out that the Initialize procedure needed quite a bit of information, +-- including the size of the attribute type, the initial value of the +-- attribute (if it fits in the TCB), and a pointer to the deallocator +-- procedure. These needed to be "passed" in via access discriminants. GNAT +-- was having trouble with access discriminants, so all this work was moved +-- to the package body. with Ada.Task_Identification; --- used for Task_Id +-- Used for Task_Id -- Null_Task_Id -- Current_Task with System.Error_Reporting; --- used for Shutdown; +-- Used for Shutdown; with System.Storage_Elements; --- used for Integer_Address +-- Used for Integer_Address with System.Task_Primitives.Operations; --- used for Write_Lock +-- Used for Write_Lock -- Unlock -- Lock/Unlock_RTS with System.Tasking; --- used for Access_Address +-- Used for Access_Address -- Task_Id -- Direct_Index_Vector -- Direct_Index with System.Tasking.Initialization; --- used for Defer_Abortion +-- Used for Defer_Abortion -- Undefer_Abortion -- Initialize_Attributes_Link -- Finalize_Attributes_Link with System.Tasking.Task_Attributes; --- used for Access_Node +-- Used for Access_Node -- Access_Dummy_Wrapper -- Deallocator -- Instance @@ -263,13 +259,13 @@ with System.Tasking.Task_Attributes; -- Access_Instance with Ada.Exceptions; --- used for Raise_Exception +-- Used for Raise_Exception with Unchecked_Conversion; with Unchecked_Deallocation; pragma Elaborate_All (System.Tasking.Task_Attributes); --- to ensure the initialization of object Local (below) will work +-- To ensure the initialization of object Local (below) will work package body Ada.Task_Attributes is @@ -295,11 +291,10 @@ package body Ada.Task_Attributes is pragma Warnings (Off); -- We turn warnings off for the following declarations of the - -- To_Attribute_Handle conversions, since these are used only - -- for small attributes where we know that there are no problems - -- with alignment, but the compiler will generate warnings for - -- the occurrences in the large attribute case, even though - -- they will not actually be used. + -- To_Attribute_Handle conversions, since these are used only for small + -- attributes where we know that there are no problems with alignment, but + -- the compiler will generate warnings for the occurrences in the large + -- attribute case, even though they will not actually be used. function To_Attribute_Handle is new Unchecked_Conversion (System.Address, Attribute_Handle); @@ -327,10 +322,10 @@ package body Ada.Task_Attributes is (Access_Dummy_Wrapper, Access_Wrapper); pragma Warnings (On); -- To fetch pointer to actual wrapper of attribute node. We turn off - -- warnings since this may generate an alignment warning. The warning - -- can be ignored since Dummy_Wrapper is only a non-generic standin - -- for the real wrapper type (we never actually allocate objects of - -- type Dummy_Wrapper). + -- warnings since this may generate an alignment warning. The warning can + -- be ignored since Dummy_Wrapper is only a non-generic standin for the + -- real wrapper type (we never actually allocate objects of type + -- Dummy_Wrapper). function To_Access_Dummy_Wrapper is new Unchecked_Conversion (Access_Wrapper, Access_Dummy_Wrapper); @@ -364,7 +359,7 @@ package body Ada.Task_Attributes is -- Initialized in package body type Wrapper is record - Noed : aliased Node; + Dummy_Node : aliased Node; Value : aliased Attribute := Initial_Value; -- The generic formal type, may be controlled @@ -450,7 +445,7 @@ package body Ada.Task_Attributes is ((null, Local'Unchecked_Access, null), Initial_Value); POP.Lock_RTS; - P := W.Noed'Unchecked_Access; + P := W.Dummy_Node'Unchecked_Access; P.Wrapper := To_Access_Dummy_Wrapper (W); P.Next := To_Access_Node (TT.Indirect_Attributes); TT.Indirect_Attributes := To_Access_Address (P); @@ -605,14 +600,14 @@ package body Ada.Task_Attributes is P := P.Next; end loop; - -- Unlock RTS here to follow the lock ordering rule that - -- prevent us from using new (i.e the Global_Lock) while - -- holding any other lock. + -- Unlock RTS here to follow the lock ordering rule that prevent us + -- from using new (i.e the Global_Lock) while holding any other + -- lock. POP.Unlock_RTS; W := new Wrapper'((null, Local'Unchecked_Access, null), Val); POP.Lock_RTS; - P := W.Noed'Unchecked_Access; + P := W.Dummy_Node'Unchecked_Access; P.Wrapper := To_Access_Dummy_Wrapper (W); P.Next := To_Access_Node (TT.Indirect_Attributes); TT.Indirect_Attributes := To_Access_Address (P); @@ -661,9 +656,9 @@ package body Ada.Task_Attributes is if Local.Index /= 0 then -- Get value of attribute. Warnings off, because for large - -- attributes, this code can generate alignment warnings. - -- But of course large attributes are never directly addressed - -- so in fact we will never execute the code in this case. + -- attributes, this code can generate alignment warnings. But of + -- course large attributes are never directly addressed so in fact + -- we will never execute the code in this case. pragma Warnings (Off); return To_Attribute_Handle @@ -734,13 +729,13 @@ begin POP.Lock_RTS; - -- Add this instantiation to the list of all instantiations. + -- Add this instantiation to the list of all instantiations Local.Next := System.Tasking.Task_Attributes.All_Attributes; System.Tasking.Task_Attributes.All_Attributes := Local'Unchecked_Access; - -- Try to find space for the attribute in the TCB. + -- Try to find space for the attribute in the TCB Local.Index := 0; Two_To_J := 1; @@ -754,9 +749,9 @@ begin In_Use := In_Use or Two_To_J; Local.Index := J; - -- This unchecked conversions can give a warning when the - -- the alignment is incorrect, but it will not be used in - -- such a case anyway, so the warning can be safely ignored. + -- This unchecked conversions can give a warning when the the + -- alignment is incorrect, but it will not be used in such a + -- case anyway, so the warning can be safely ignored. pragma Warnings (Off); To_Attribute_Handle (Local.Initial_Value'Access).all := @@ -773,13 +768,13 @@ begin -- Attribute goes directly in the TCB if Local.Index /= 0 then - -- Replace stub for initialization routine - -- that is called at task creation. + -- Replace stub for initialization routine that is called at task + -- creation. Initialization.Initialize_Attributes_Link := System.Tasking.Task_Attributes.Initialize_Attributes'Access; - -- Initialize the attribute, for all tasks. + -- Initialize the attribute, for all tasks declare C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; @@ -795,8 +790,8 @@ begin -- Attribute goes into a node onto a linked list else - -- Replace stub for finalization routine - -- that is called at task termination. + -- Replace stub for finalization routine that is called at task + -- termination. Initialization.Finalize_Attributes_Link := System.Tasking.Task_Attributes.Finalize_Attributes'Access; diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 17258902df2..3988800a4f2 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -20,7 +20,7 @@ -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- Extensive contributions were provided by AdaCore. -- -- -- ------------------------------------------------------------------------------ @@ -78,7 +78,7 @@ package body Comperr is -- the cause of the compiler abort and about the preferred method -- of reporting bugs. The default is a bug box appropriate for -- the FSF version of GNAT, but there are specializations for - -- the GNATPRO and Public releases by Ada Core Technologies. + -- the GNATPRO and Public releases by AdaCore. procedure End_Line; -- Add blanks up to column 76, and then a final vertical bar @@ -95,7 +95,6 @@ package body Comperr is Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public; Is_FSF_Version : constant Boolean := Get_Gnat_Build_Type = FSF; - Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP; -- Start of processing for Compiler_Abort @@ -268,22 +267,43 @@ package body Comperr is " http://gcc.gnu.org/bugs.html."); End_Line; + elsif Is_Public_Version then + Write_Str + ("| submit bug report by email " & + "to report@adacore.com."); + End_Line; + + Write_Str + ("| See gnatinfo.txt for full info on procedure " & + "for submitting bugs."); + End_Line; + else Write_Str - ("| Please submit bug report by email " & - "to report@gnat.com."); + ("| Please submit a bug report using GNAT Tracker:"); End_Line; Write_Str - ("| Use a subject line meaningful to you" & - " and us to track the bug."); + ("| http://www.adacore.com/gnattracker/ " & + "section 'send a report'."); + End_Line; + + Write_Str + ("| alternatively submit a bug report by email " & + "to report@adacore.com."); End_Line; end if; + + Write_Str + ("| Use a subject line meaningful to you" & + " and us to track the bug."); + End_Line; + if not (Is_Public_Version or Is_FSF_Version) then Write_Str - ("| (include your customer number #nnn " & - "in the subject line)."); + ("| Include your customer number #nnn " & + "in the subject line."); End_Line; end if; @@ -305,35 +325,9 @@ package body Comperr is ("| (concatenated together with no headers between files)."); End_Line; - if Is_Public_Version then + if not Is_FSF_Version then Write_Str - ("| (use plain ASCII or MIME attachment)."); - End_Line; - - Write_Str - ("| See gnatinfo.txt for full info on procedure " & - "for submitting bugs."); - End_Line; - - elsif Is_GAP_Version then - Write_Str - ("| (use plain ASCII or MIME attachment, or FTP " - & "to your GAP account.)."); - End_Line; - - Write_Str - ("| Please use your GAP account to report this."); - End_Line; - - elsif not Is_FSF_Version then - Write_Str - ("| (use plain ASCII or MIME attachment, or FTP " - & "to your customer directory)."); - End_Line; - - Write_Str - ("| See README.GNATPRO for full info on procedure " & - "for submitting bugs."); + ("| Use plain ASCII or MIME attachment."); End_Line; end if; end if; diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb index b1e83d70561..cea4ec8998c 100644 --- a/gcc/ada/s-bitops.adb +++ b/gcc/ada/s-bitops.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -107,8 +107,7 @@ package body System.Bit_Ops is (Left : Address; Llen : Natural; Right : Address; - Rlen : Natural) - return Boolean + Rlen : Natural) return Boolean is LeftB : constant Bits := To_Bits (Left); RightB : constant Bits := To_Bits (Right); diff --git a/gcc/ada/s-bitops.ads b/gcc/ada/s-bitops.ads index f22a5d4b7ce..dbecac3d0da 100644 --- a/gcc/ada/s-bitops.ads +++ b/gcc/ada/s-bitops.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,7 +40,8 @@ package System.Bit_Ops is -- Note: in all the following routines, the System.Address parameters -- represent the address of the first byte of an array used to represent -- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4}) - -- The length in bits is passed as a separate parameter. + -- The length in bits is passed as a separate parameter. Note that all + -- addresses must be of byte aligned arrays. procedure Bit_And (Left : System.Address; @@ -57,8 +58,7 @@ package System.Bit_Ops is (Left : System.Address; Llen : Natural; Right : System.Address; - Rlen : Natural) - return Boolean; + Rlen : Natural) return Boolean; -- Left and Right are the addresses of two bit packed arrays with Llen -- and Rlen being the respective length in bits. The routine compares the -- two bit strings for equality, being careful not to include the unused diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads index 42bdf02c73e..b09a471aafb 100644 --- a/gcc/ada/s-crtl.ads +++ b/gcc/ada/s-crtl.ads @@ -139,6 +139,12 @@ pragma Preelaborate (CRTL); function opendir (file_name : String) return DIRs; pragma Import (C, opendir, "opendir"); + function pclose (stream : System.Address) return int; + pragma Import (C, pclose, "pclose"); + + function popen (command, mode : System.Address) return System.Address; + pragma Import (C, popen, "popen"); + function read (fd : int; buffer : chars; nbytes : int) return int; pragma Import (C, read, "read"); diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index e2a8aaa0b5d..0ef7443a3a8 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -383,19 +383,22 @@ package body System.Finalization_Implementation is procedure Finalize_Global_List is begin -- There are three case here: + -- a. the application uses tasks, in which case Finalize_Global_Tasks - -- will defer abortion + -- will defer abort. + -- b. the application doesn't use tasks but uses other tasking -- constructs, such as ATCs and protected objects. In this case, -- the binder will call Finalize_Global_List instead of -- Finalize_Global_Tasks, letting abort undeferred, and leading -- to assertion failures in the GNULL + -- c. the application doesn't use any tasking construct in which case -- deferring abort isn't necessary. - -- + -- Until another solution is found to deal with case b, we need to -- call abort_defer here to pass the checks, but we do not need to - -- undefer abortion, since Finalize_Global_List is the last procedure + -- undefer abort, since Finalize_Global_List is the last procedure -- called before exiting the partition. SSL.Abort_Defer.all; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads index 60f410b01d7..a74659ada4c 100644 --- a/gcc/ada/s-intman-vms.ads +++ b/gcc/ada/s-intman-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,30 +31,31 @@ -- -- ------------------------------------------------------------------------------ --- This is the Alpha/VMS version of this package. --- --- This package encapsulates and centralizes information about --- all uses of interrupts (or signals), including the --- target-dependent mapping of interrupts (or signals) to exceptions. +-- This is the Alpha/VMS version of this package --- PLEASE DO NOT add any with-clauses to this package. --- This is designed to work for both tasking and non-tasking systems, --- without pulling in any of the tasking support. +-- This package encapsulates and centralizes information about all uses of +-- interrupts (or signals), including the target-dependent mapping of +-- interrupts (or signals) to exceptions. + +-- PLEASE DO NOT add any with-clauses to this package + +-- This is designed to work for both tasking and non-tasking systems, without +-- pulling in any of the tasking support. -- PLEASE DO NOT remove the Elaborate_Body pragma from this package. -- Elaboration of this package should happen early, as most other --- initializations depend on it. --- Forcing immediate elaboration of the body also helps to enforce --- the design assumption that this is a second-level --- package, just one level above System.OS_Interface, with no --- cross-dependences. - --- PLEASE DO NOT put any subprogram declarations with arguments of --- type Interrupt_ID into the visible part of this package. --- The type Interrupt_ID is used to derive the type in Ada.Interrupts, --- and adding more operations to that type would be illegal according --- to the Ada Reference Manual. (This is the reason why the signals sets --- below are implemented as visible arrays rather than functions.) + +-- Forcing immediate elaboration of the body also helps to enforce the design +-- assumption that this is a second-level package, just one level above +-- System.OS_Interface, with no cross-dependences. + +-- PLEASE DO NOT put any subprogram declarations with arguments of type +-- Interrupt_ID into the visible part of this package. + +-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according to the Ada +-- Reference Manual. (This is the reason why the signals sets below are +-- implemented as visible arrays rather than functions.) with System.OS_Interface; -- used for Signal @@ -70,49 +71,44 @@ package System.Interrupt_Management is type Interrupt_Set is array (Interrupt_ID) of Boolean; - -- The following objects serve as constants, but are initialized - -- in the body to aid portability. This permits us - -- to use more portable names for interrupts, - -- where distinct names may map to the same interrupt ID value. - -- For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. - -- If we have the convention that ID zero is not used for any "real" - -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally - -- supported signals, we can write + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write + -- Reserved (SIGRARE) := true; - -- and the initialization code will be portable. + + -- Then the initialization code will be portable Abort_Task_Interrupt : Interrupt_ID; - -- The interrupt that is used to implement task abortion, - -- if an interrupt is used for that purpose. - -- This is one of the reserved interrupts. + -- The interrupt that is used to implement task abort, if an interrupt is + -- used for that purpose. This is one of the reserved interrupts. Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is - -- one that must be kept unmasked at all times, - -- except (perhaps) for short critical sections. - -- This includes interrupts that are mapped to exceptions - -- (see System.Interrupt_Exceptions.Is_Exception), but may also - -- include interrupts (e.g. timer) that need to be kept unmasked - -- for other reasons. - -- Where interrupts are implemented as OS signals, and signal masking - -- is per-task, the interrupt should be unmasked in ALL TASKS. + -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept + -- unmasked at all times, except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions (see + -- System.Interrupt_Exceptions.Is_Exception), but may also include + -- interrupts (e.g. timer) that need to be kept unmasked for other + -- reasons. Where interrupts are implemented as OS signals, and signal + -- masking is per-task, the interrupt should be unmasked in ALL TASKS. Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that - -- cannot be permitted to be attached to a user handler. - -- The possible reasons are many. For example, - -- it may be mapped to an exception, used to implement task abortion, - -- or used to implement time delays. + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example it may be mapped to an exception used to implement task abort. Keep_Masked : Interrupt_Set := (others => False); -- Keep_Masked (I) is true iff the interrupt I must always be masked. - -- Where interrupts are implemented as OS signals, and signal masking - -- is per-task, the interrupt should be masked in ALL TASKS. - -- There might not be any interrupts in this class, depending on - -- the environment. For example, if interrupts are OS signals - -- and signal masking is per-task, use of the sigwait operation - -- requires the signal be masked in all tasks. + -- Where interrupts are implemented as OS signals, and signal masking is + -- per-task, the interrupt should be masked in ALL TASKS. There might not + -- be any interrupts in this class, depending on the environment. For + -- example, if interrupts are OS signals and signal masking is per-task, + -- use of the sigwait operation requires the signal be masked in all tasks. procedure Initialize_Interrupts; -- On systems where there is no signal inheritance between tasks (e.g @@ -121,7 +117,6 @@ package System.Interrupt_Management is -- only be called by initialize in this package body. private - use type System.OS_Interface.unsigned_long; type Interrupt_Mask is new System.OS_Interface.sigset_t; @@ -136,7 +131,7 @@ private Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; Interrupt_Mailbox : Interrupt_ID := 0; - Interrupt_Bufquo : System.OS_Interface.unsigned_long - := 1000 * (Interrupt_ID'Size / 8); + Interrupt_Bufquo : System.OS_Interface.unsigned_long := + 1000 * (Interrupt_ID'Size / 8); end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index b0a4c3c5bda..7e386f300f4 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the VxWorks version of this package. +-- This is the VxWorks version of this package -- This package encapsulates and centralizes information about all -- uses of interrupts (or signals), including the target-dependent @@ -76,48 +76,48 @@ package System.Interrupt_Management is type Signal_Set is array (Signal_ID) of Boolean; - -- The following objects serve as constants, but are initialized - -- in the body to aid portability. This permits us to use more - -- portable names for interrupts, where distinct names may map to - -- the same interrupt ID value. - -- - -- For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. If we - -- have the convention that ID zero is not used for any "real" - -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally - -- supported signals, we can write + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. + + -- For example, suppose SIGRARE is a signal that is not defined on all + -- systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write: + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. Abort_Task_Signal : Signal_ID; - -- The signal that is used to implement task abortion if - -- an interrupt is used for that purpose. This is one of the - -- reserved signals. + -- The signal that is used to implement task abort if an interrupt is used + -- for that purpose. This is one of the reserved signals. Keep_Unmasked : Signal_Set := (others => False); - -- Keep_Unmasked (I) is true iff the signal I is one that must - -- that must be kept unmasked at all times, except (perhaps) for - -- short critical sections. This includes signals that are - -- mapped to exceptions, but may also include interrupts - -- (e.g. timer) that need to be kept unmasked for other - -- reasons. Where signal masking is per-task, the signal should be + -- Keep_Unmasked (I) is true iff the signal I is one that must that must + -- be kept unmasked at all times, except (perhaps) for short critical + -- sections. This includes signals that are mapped to exceptions, but may + -- also include interrupts (e.g. timer) that need to be kept unmasked for + -- other reasons. Where signal masking is per-task, the signal should be -- unmasked in ALL TASKS. Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be - -- permitted to be attached to a user handler. The possible reasons - -- are many. For example, it may be mapped to an exception used to - -- implement task abortion, or used to implement time delays. + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. procedure Initialize_Interrupts; -- On systems where there is no signal inheritance between tasks (e.g -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should - -- only be called by initialize in this package body. + -- interrupts handling in each task. Otherwise this function should only + -- be called by initialize in this package body. private type Interrupt_Mask is new System.OS_Interface.sigset_t; - -- In some implementation Interrupt_Mask can be represented - -- as a linked list. + -- In some implementation Interrupt_Mask can be represented as a linked + -- list. end System.Interrupt_Management; diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads index 2353c9b29bf..c8d2a0e2d3c 100644 --- a/gcc/ada/s-intman.ads +++ b/gcc/ada/s-intman.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,26 +31,26 @@ -- -- ------------------------------------------------------------------------------ --- This package encapsulates and centralizes information about all --- uses of interrupts (or signals), including the target-dependent --- mapping of interrupts (or signals) to exceptions. +-- This package encapsulates and centralizes information about all uses of +-- interrupts (or signals), including the target-dependent mapping of +-- interrupts (or signals) to exceptions. --- Unlike the original design, System.Interrupt_Management can only --- be used for tasking systems. +-- Unlike the original design, System.Interrupt_Management can only be used +-- for tasking systems. -- PLEASE DO NOT remove the Elaborate_Body pragma from this package. -- Elaboration of this package should happen early, as most other --- initializations depend on it. Forcing immediate elaboration of --- the body also helps to enforce the design assumption that this --- is a second-level package, just one level above System.OS_Interface --- with no cross-dependencies. - --- PLEASE DO NOT put any subprogram declarations with arguments of --- type Interrupt_ID into the visible part of this package. The type --- Interrupt_ID is used to derive the type in Ada.Interrupts, and --- adding more operations to that type would be illegal according --- to the Ada Reference Manual. This is the reason why the signals --- sets are implemeneted using visible arrays rather than functions. +-- initializations depend on it. Forcing immediate elaboration of the body +-- also helps to enforce the design assumption that this is a second-level +-- package, just one level above System.OS_Interface with no +-- cross-dependencies. + +-- PLEASE DO NOT put any subprogram declarations with arguments of type +-- Interrupt_ID into the visible part of this package. The type Interrupt_ID +-- is used to derive the type in Ada.Interrupts, and adding more operations +-- to that type would be illegal according to the Ada Reference Manual. This +-- is the reason why the signals sets are implemeneted using visible arrays +-- rather than functions. with System.OS_Interface; -- used for sigset_t @@ -69,49 +69,49 @@ package System.Interrupt_Management is type Interrupt_Set is array (Interrupt_ID) of Boolean; - -- The following objects serve as constants, but are initialized - -- in the body to aid portability. This permits us to use more - -- portable names for interrupts, where distinct names may map to - -- the same interrupt ID value. - -- - -- For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. If we - -- have the convention that ID zero is not used for any "real" - -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally - -- supported signals, we can write - -- Reserved (SIGRARE) := true; + -- The following objects serve as constants, but are initialized in the + -- body to aid portability. This permits us to use more portable names for + -- interrupts, where distinct names may map to the same interrupt ID + -- value. + + -- For example, suppose SIGRARE is a signal that is not defined on all + -- systems, but is always reserved when it is defined. If we have the + -- convention that ID zero is not used for any "real" signals, and SIGRARE + -- = 0 when SIGRARE is not one of the locally supported signals, we can + -- write + + -- Reserved (SIGRARE) := True; + -- and the initialization code will be portable. Abort_Task_Interrupt : Interrupt_ID; - -- The interrupt that is used to implement task abortion if - -- an interrupt is used for that purpose. This is one of the - -- reserved interrupts. + -- The interrupt that is used to implement task abort if an interrupt is + -- used for that purpose. This is one of the reserved interrupts. Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is one that must - -- that must be kept unmasked at all times, except (perhaps) for - -- short critical sections. This includes interrupts that are - -- mapped to exceptions (see System.Interrupt_Exceptions.Is_Exception), - -- but may also include interrupts (e.g. timer) that need to be kept - -- unmasked for other reasons. Where interrupts are implemented as - -- OS signals, and signal masking is per-task, the interrupt should - -- be unmasked in ALL TASKS. + -- Keep_Unmasked (I) is true iff the interrupt I is one that must that + -- must be kept unmasked at all times, except (perhaps) for short critical + -- sections. This includes interrupts that are mapped to exceptions (see + -- System.Interrupt_Exceptions.Is_Exception), but may also include + -- interrupts (e.g. timer) that need to be kept unmasked for other + -- reasons. Where interrupts are implemented as OS signals, and signal + -- masking is per-task, the interrupt should be unmasked in ALL TASKS. Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be - -- permitted to be attached to a user handler. The possible reasons - -- are many. For example, it may be mapped to an exception used to - -- implement task abortion, or used to implement time delays. + -- Reserve (I) is true iff the interrupt I is one that cannot be permitted + -- to be attached to a user handler. The possible reasons are many. For + -- example, it may be mapped to an exception used to implement task abort, + -- or used to implement time delays. procedure Initialize_Interrupts; -- On systems where there is no signal inheritance between tasks (e.g -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should - -- only be called by initialize in this package body. + -- interrupts handling in each task. Otherwise this function should only + -- be called by initialize in this package body. private type Interrupt_Mask is new System.OS_Interface.sigset_t; - -- In some implementation Interrupt_Mask can be represented - -- as a linked list. + -- In some implementations Interrupt_Mask can be represented as a linked + -- list. end System.Interrupt_Management; diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb index 66637c7291b..6e995f452be 100644 --- a/gcc/ada/s-memory.adb +++ b/gcc/ada/s-memory.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,13 +35,13 @@ -- This implementation assumes that the underlying malloc/free/realloc -- implementation is thread safe, and thus, no additional lock is required. --- Note that we still need to defer abortion because on most systems, --- an asynchronous signal (as used for implementing asynchronous abortion --- of task) cannot safely be handled while malloc is executing. +-- Note that we still need to defer abort because on most systems, an +-- asynchronous signal (as used for implementing asynchronous abort of +-- task) cannot safely be handled while malloc is executing. --- If you are not using Ada constructs containing the "abort" keyword, --- then you can remove the calls to Abort_Defer.all and Abort_Undefer.all --- from this unit. +-- If you are not using Ada constructs containing the "abort" keyword, then +-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from +-- this unit. with Ada.Exceptions; with System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads index 256039d924b..1e4007479d8 100644 --- a/gcc/ada/s-soflin.ads +++ b/gcc/ada/s-soflin.ads @@ -52,7 +52,7 @@ package System.Soft_Links is pragma Import (Ada, Current_Target_Exception, "__gnat_current_target_exception"); - -- Import this subprogram from the private part of Ada.Exceptions. + -- Import this subprogram from the private part of Ada.Exceptions -- First we have the access subprogram types used to establish the links. -- The approach is to establish variables containing access subprogram @@ -112,20 +112,20 @@ package System.Soft_Links is -- Declarations for the no tasking versions of the required routines procedure Abort_Defer_NT; - -- Defer task abortion (non-tasking case, does nothing) + -- Defer task abort (non-tasking case, does nothing) procedure Abort_Undefer_NT; - -- Undefer task abortion (non-tasking case, does nothing) + -- Undefer task abort (non-tasking case, does nothing) procedure Abort_Handler_NT; - -- Handle task abortion (non-tasking case, does nothing). Currently, - -- only VMS uses this. + -- Handle task abort (non-tasking case, does nothing). Currently, only VMS + -- uses this. procedure Update_Exception_NT (X : EO := Current_Target_Exception); - -- Handle exception setting. This routine is provided for targets - -- which have built-in exception handling such as the Java Virtual - -- Machine. Currently, only JGNAT uses this. See 4jexcept.ads for - -- an explanation on how this routine is used. + -- Handle exception setting. This routine is provided for targets which + -- have built-in exception handling such as the Java Virtual Machine. + -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on + -- how this routine is used. function Check_Abort_Status_NT return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise @@ -143,14 +143,14 @@ package System.Soft_Links is Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; pragma Suppress (Access_Check, Abort_Defer); - -- Defer task abortion (task/non-task case as appropriate) + -- Defer task abort (task/non-task case as appropriate) Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; pragma Suppress (Access_Check, Abort_Undefer); - -- Undefer task abortion (task/non-task case as appropriate) + -- Undefer task abort (task/non-task case as appropriate) Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; - -- Handle task abortion (task/non-task case as appropriate) + -- Handle task abort (task/non-task case as appropriate) Update_Exception : Special_EO_Call := Update_Exception_NT'Access; -- Handle exception setting and tasking polling when appropriate @@ -196,7 +196,7 @@ package System.Soft_Links is -- explicitly or implicitly during the critical locked region. Adafinal : No_Param_Proc := Null_Adafinal'Access; - -- Performs the finalization of the Ada Runtime. + -- Performs the finalization of the Ada Runtime function Get_Jmpbuf_Address_NT return Address; procedure Set_Jmpbuf_Address_NT (Addr : Address); diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads index 21e24f616ae..ce21a5dfab8 100644 --- a/gcc/ada/s-taasde.ads +++ b/gcc/ada/s-taasde.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,8 +31,8 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the procedures to implements timeouts (delays) --- for asynchronous select statements. +-- This package contains the procedures to implements timeouts (delays) for +-- asynchronous select statements. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. @@ -100,8 +100,8 @@ package System.Tasking.Async_Delays is (T : in Duration; D : Delay_Block_Access) return Boolean; -- Enqueue the specified relative delay. Returns True if the delay has - -- been enqueued, False if it has already expired. - -- If the delay has been enqueued, abortion is deferred. + -- been enqueued, False if it has already expired. If the delay has been + -- enqueued, abort is deferred. procedure Cancel_Async_Delay (D : Delay_Block_Access); -- Cancel the specified asynchronous delay @@ -117,10 +117,10 @@ package System.Tasking.Async_Delays is private type Delay_Block is record - Self_Id : Task_Id; + Self_Id : Task_Id; -- ID of the calling task - Level : ATC_Level_Base; + Level : ATC_Level_Base; -- Normally Level is the ATC nesting level of the -- async. select statement to which this delay belongs, but -- after a call has been dequeued we set it to @@ -130,10 +130,10 @@ private Resume_Time : Duration; -- The absolute wake up time, represented as Duration - Timed_Out : Boolean := False; + Timed_Out : Boolean := False; -- Set to true if the delay has timed out - Succ, Pred : Delay_Block_Access; + Succ, Pred : Delay_Block_Access; -- A double linked list end record; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb index 9852c4e376c..ab6852dbcb6 100644 --- a/gcc/ada/s-taprob.adb +++ b/gcc/ada/s-taprob.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2004, Ada Core Technologies -- +-- Copyright (C) 1995-2005, Ada Core Technologies -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -90,15 +90,15 @@ package body System.Tasking.Protected_Objects is Ceiling_Violation : Boolean; begin - -- The lock is made without defering abortion. + -- The lock is made without defering abort - -- Therefore the abortion has to be deferred before calling this - -- routine. This means that the compiler has to generate a Defer_Abort - -- call before the call to Lock. + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. - -- The caller is responsible for undeferring abortion, and compiler + -- The caller is responsible for undeferring abort, and compiler -- generated calls must be protected with cleanup handlers to ensure - -- that abortion is undeferred in all cases. + -- that abort is undeferred in all cases. Write_Lock (Object.L'Access, Ceiling_Violation); diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb index c53a05e122c..d922adedcf8 100644 --- a/gcc/ada/s-taprop-os2.adb +++ b/gcc/ada/s-taprop-os2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -112,7 +112,7 @@ package body System.Task_Primitives.Operations is -- Local Data -- ----------------- - -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. + -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr -- This API reserves a small range of virtual addresses that is backed -- by different physical memory for each running thread. In this case we @@ -141,7 +141,7 @@ package body System.Task_Primitives.Operations is -- 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. + -- A variable to hold Task_Id for the environment task ----------------------- -- Local Subprograms -- @@ -223,7 +223,7 @@ package body System.Task_Primitives.Operations is Self_ID : Task_Id renames Thread_Local_Data_Ptr.Self_ID; begin - -- Check that the thread local data has been initialized. + -- Check that the thread local data has been initialized pragma Assert ((Thread_Local_Data_Ptr /= null @@ -458,7 +458,7 @@ package body System.Task_Primitives.Operations is Count : aliased ULONG; -- Used to store dummy result begin - -- Must reset Cond BEFORE L is unlocked. + -- Must reset Cond BEFORE L is unlocked Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); @@ -475,7 +475,7 @@ package body System.Task_Primitives.Operations is Sem_Must_Not_Fail (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT)); - -- Since L was previously accquired, lock operation should not fail. + -- Since L was previously accquired, lock operation should not fail if Single_Lock then Lock_RTS; @@ -516,7 +516,7 @@ package body System.Task_Primitives.Operations is Count : aliased ULONG; -- Used to store dummy result begin - -- Must reset Cond BEFORE Self_ID is unlocked. + -- Must reset Cond BEFORE Self_ID is unlocked Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, @@ -611,7 +611,7 @@ package body System.Task_Primitives.Operations is Write_Lock (Self_ID); end if; - -- Must reset Cond BEFORE Self_ID is unlocked. + -- Must reset Cond BEFORE Self_ID is unlocked Sem_Must_Not_Fail (DosResetEventSem (Self_ID.Common.LL.CV, @@ -767,7 +767,7 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is begin - -- Initialize thread local data. Must be done first. + -- Initialize thread local data. Must be done first Thread_Local_Data_Ptr.Self_ID := Self_ID; Thread_Local_Data_Ptr.Lock_Prio_Level := 0; @@ -927,7 +927,7 @@ package body System.Task_Primitives.Operations is T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper); - -- The OS implicitly gives the new task the priority of this task. + -- The OS implicitly gives the new task the priority of this task T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority; @@ -1007,7 +1007,7 @@ package body System.Task_Primitives.Operations is begin null; - -- Task abortion not implemented yet. + -- Task abort not implemented yet. -- Should perform other action ??? end Abort_Task; @@ -1103,9 +1103,9 @@ package body System.Task_Primitives.Operations is Environment_Task_Id := Environment_Task; Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs - -- Set ID of environment task. + -- Set ID of environment task Thread_Local_Data_Ptr.Self_ID := Environment_Task; Environment_Task.Common.LL.Thread := 1; -- By definition diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index a3340a6f615..4298e09e845 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -91,12 +91,12 @@ package body System.Task_Primitives.Operations is -- Local Data -- ---------------- - -- The followings are logically constants, but need to be initialized - -- at run time. + -- The followings are logically constants, but need to be initialized at + -- run time. Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. + -- This is a lock to allow only one thread of control in the RTS at 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 ATCB_Key : aliased System.Address := System.Null_Address; @@ -109,12 +109,12 @@ package body System.Task_Primitives.Operations is -- targets. Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task. + -- A variable to hold Task_Id for the environment task Unblocked_Signal_Mask : aliased sigset_t; -- The set of signals that should unblocked in all tasks - -- The followings are internal configuration constants needed. + -- The followings are internal configuration constants needed Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); @@ -126,12 +126,12 @@ package body System.Task_Primitives.Operations is pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. + -- Indicates whether FIFO_Within_Priorities is set Mutex_Protocol : Priority_Type; Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). + -- Used to identified fake tasks (i.e., non-Ada Threads) -------------------- -- Local Packages -- @@ -145,23 +145,23 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task function Self return Task_Id; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task end Specific; package body Specific is separate; - -- The body of this package is target specific. + -- The body of this package is target specific --------------------------------- -- Support for foreign threads -- --------------------------------- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread. + -- Allocate and Initialize a new ATCB for the current Thread function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is separate; @@ -171,7 +171,7 @@ package body System.Task_Primitives.Operations is ----------------------- procedure Abort_Handler (signo : Signal); - -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion. + -- Handler for the abort (SIGABRT) signal to handle asynchronous abort procedure Install_Signal_Handlers; -- Install the default signal handlers for the current task @@ -409,7 +409,8 @@ package body System.Task_Primitives.Operations is begin pragma Assert (Self_ID = Self); - -- Release the mutex before sleeping. + -- Release the mutex before sleeping + if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else @@ -418,15 +419,16 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. + -- Perform a blocking operation to take the CV semaphore. Note that a + -- blocking operation in VxWorks will reenable task scheduling. When we + -- are no longer blocked and control is returned, task scheduling will + -- again be disabled. Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); pragma Assert (Result = 0); - -- Take the mutex back. + -- Take the mutex back + if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else @@ -440,9 +442,8 @@ package body System.Task_Primitives.Operations is -- Timed_Sleep -- ----------------- - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. procedure Timed_Sleep (Self_ID : Task_Id; @@ -467,9 +468,9 @@ package body System.Task_Primitives.Operations is if Mode = Relative then Absolute := Orig + Time; - -- Systematically add one since the first tick will delay - -- *at most* 1 / Rate_Duration seconds, so we need to add one to - -- be on the safe side. + -- Systematically add one since the first tick will delay *at most* + -- 1 / Rate_Duration seconds, so we need to add one to be on the + -- safe side. Ticks := To_Clock_Ticks (Time); @@ -484,7 +485,8 @@ package body System.Task_Primitives.Operations is if Ticks > 0 then loop - -- Release the mutex before sleeping. + -- Release the mutex before sleeping + if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); else @@ -493,14 +495,15 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. + -- Perform a blocking operation to take the CV semaphore. Note + -- that a blocking operation in VxWorks will reenable task + -- scheduling. When we are no longer blocked and control is + -- returned, task scheduling will again be disabled. Result := semTake (Self_ID.Common.LL.CV, Ticks); if Result = 0 then + -- Somebody may have called Wakeup for us Wakeup := True; @@ -508,10 +511,11 @@ package body System.Task_Primitives.Operations is else if errno /= S_objLib_OBJ_TIMEOUT then Wakeup := True; + else - -- If Ticks = int'last, it was most probably truncated - -- so let's make another round after recomputing Ticks - -- from the the absolute time. + -- If Ticks = int'last, it was most probably truncated so + -- let's make another round after recomputing Ticks from + -- the the absolute time. if Ticks /= int'Last then Timedout := True; @@ -525,7 +529,8 @@ package body System.Task_Primitives.Operations is end if; end if; - -- Take the mutex back. + -- Take the mutex back + if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else @@ -540,7 +545,8 @@ package body System.Task_Primitives.Operations is else Timedout := True; - -- Should never hold a lock while yielding. + -- Should never hold a lock while yielding + if Single_Lock then Result := semGive (Single_RTS_Lock.Mutex); taskDelay (0); @@ -558,8 +564,8 @@ package body System.Task_Primitives.Operations is -- Timed_Delay -- ----------------- - -- This is for use in implementing delay statements, so - -- we assume the caller is holding no locks. + -- This is for use in implementing delay statements, so we assume the + -- caller is holding no locks. procedure Timed_Delay (Self_ID : Task_Id; @@ -582,9 +588,8 @@ package body System.Task_Primitives.Operations is if Ticks > 0 and then Ticks < int'Last then - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. + -- First tick will delay anytime between 0 and 1 / sysClkRateGet + -- seconds, so we need to add one to be on the safe side. Ticks := Ticks + 1; end if; @@ -595,7 +600,9 @@ package body System.Task_Primitives.Operations is end if; if Ticks > 0 then - -- Modifying State and Pending_Priority_Change, locking the TCB. + + -- Modifying State and Pending_Priority_Change, locking the TCB + if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); else @@ -630,6 +637,7 @@ package body System.Task_Primitives.Operations is Result := semTake (Self_ID.Common.LL.CV, Ticks); if Result /= 0 then + -- If Ticks = int'last, it was most probably truncated -- so let's make another round after recomputing Ticks -- from the the absolute time. @@ -749,6 +757,7 @@ package body System.Task_Primitives.Operations is if FIFO_Within_Priorities then -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its -- new active priority. @@ -794,7 +803,7 @@ package body System.Task_Primitives.Operations 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. + -- Properly initializes the FPU for PPC/MIPS systems begin Self_ID.Common.LL.Thread := taskIdSelf; @@ -802,7 +811,8 @@ package body System.Task_Primitives.Operations is Init_Float; - -- Install the signal handlers. + -- Install the signal handlers + -- This is called for each task since there is no signal inheritance -- between VxWorks tasks. @@ -892,28 +902,26 @@ package body System.Task_Primitives.Operations is Adjusted_Stack_Size := size_t (Stack_Size); end if; - -- Ask for 4 extra bytes of stack space so that the ATCB - -- pointer can be stored below the stack limit, plus extra - -- space for the frame of Task_Wrapper. This is so the user - -- gets the amount of stack requested exclusive of the needs - -- of the runtime. + -- Ask for four extra bytes of stack space so that the ATCB pointer can + -- be stored below the stack limit, plus extra space for the frame of + -- Task_Wrapper. This is so the user gets the amount of stack requested + -- exclusive of the needs -- - -- We also have to allocate n more bytes for the task name - -- storage and enough space for the Wind Task Control Block - -- which is around 0x778 bytes. VxWorks also seems to carve out - -- additional space, so use 2048 as a nice round number. - -- We might want to increment to the nearest page size in - -- case we ever support VxVMI. + -- We also have to allocate n more bytes for the task name storage and + -- enough space for the Wind Task Control Block which is around 0x778 + -- bytes. VxWorks also seems to carve out additional space, so use 2048 + -- as a nice round number. We might want to increment to the nearest + -- page size in case we ever support VxVMI. -- - -- XXX - we should come back and visit this so we can - -- set the task name to something appropriate. + -- XXX - we should come back and visit this so we can set the task name + -- to something appropriate. Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. + -- creator, and the Environment task has all its signals masked, we do + -- not need to manipulate caller's signal mask at this point. All tasks + -- in RTS will have All_Tasks_Mask initially. if T.Common.Task_Image_Len = 0 then T.Common.LL.Thread := taskSpawn @@ -926,6 +934,7 @@ package body System.Task_Primitives.Operations is else declare Name : aliased String (1 .. T.Common.Task_Image_Len + 1); + begin Name (1 .. Name'Last - 1) := T.Common.Task_Image (1 .. T.Common.Task_Image_Len); @@ -1004,7 +1013,7 @@ package body System.Task_Primitives.Operations is begin Result := kill (T.Common.LL.Thread, - Signal (Interrupt_Management.Abort_Task_Signal)); + Signal (Interrupt_Management.Abort_Task_Signal)); pragma Assert (Result = 0); end Abort_Task; @@ -1127,7 +1136,7 @@ package body System.Task_Primitives.Operations is Environment_Task_Id := Environment_Task; - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 8cea06be6cc..e3c80baf71b 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -82,23 +82,21 @@ package System.Task_Primitives.Operations is 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. - -- It must be called (once) by the task immediately after creation, - -- while abortion is still deferred. - -- The effects of other operations defined below are not defined - -- unless the caller has previously called Initialize_Task. + -- Initialize data structures specific to the calling task. Self must be + -- the ID of the calling task. It must be called (once) by the task + -- immediately after creation, while abort is still deferred. The effects + -- of other operations defined below are not defined unless the caller has + -- previously called Initialize_Task. procedure Exit_Task; pragma Inline (Exit_Task); - -- Destroy the thread of control. - -- Self must be the ID of the calling task. - -- The effects of further calls to operations defined below - -- on the task are undefined thereafter. + -- Destroy the thread of control. 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; pragma Inline (New_ATCB); - -- Allocate a new ATCB with the specified number of entries. + -- Allocate a new ATCB with the specified number of entries procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); pragma Inline (Initialize_TCB); @@ -106,19 +104,17 @@ package System.Task_Primitives.Operations is 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 - -- that were allocated by Create_Task (the one in this package). - -- This should only be called from Free_Task. - -- After it is called there should be no further + -- Finalizes Private_Data of ATCB, and then deallocates it. This is also + -- responsible for recovering any storage or other resources that were + -- allocated by Create_Task (the one in this package). This should only be + -- called from Free_Task. After it is called there should be no further -- reference to the ATCB that corresponds to T. 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 - -- abort is not deferred, or if it is blocked on an interruptible - -- system call. + -- Abort the task specified by T (the target task). This causes the target + -- task to asynchronously raise Abort_Signal if abort is not deferred, or + -- if it is blocked on an interruptible system call. -- -- precondition: -- the calling task is holding T's lock and has abort deferred @@ -130,7 +126,7 @@ package System.Task_Primitives.Operations is function Self return ST.Task_Id; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task type Lock_Level is (PO_Level, @@ -138,27 +134,27 @@ package System.Task_Primitives.Operations is RTS_Lock_Level, ATCB_Level); -- Type used to describe kind of lock for second form of Initialize_Lock - -- call specified below. - -- See locking rules in System.Tasking (spec) for more details. + -- call specified below. See locking rules in System.Tasking (spec) for + -- more details. procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock); procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level); pragma Inline (Initialize_Lock); -- Initialize a lock object. -- - -- For Lock, Prio is the ceiling priority associated with the lock. - -- For RTS_Lock, the ceiling is implicitly Priority'Last. + -- For Lock, Prio is the ceiling priority associated with the lock. For + -- RTS_Lock, the ceiling is implicitly Priority'Last. -- -- If the underlying system does not support priority ceiling -- locking, the Prio parameter is ignored. -- - -- The effect of either initialize operation is undefined unless L - -- is a lock object that has not been initialized, or which has been - -- finalized since it was last initialized. + -- The effect of either initialize operation is undefined unless is a lock + -- object that has not been initialized, or which has been finalized since + -- it was last initialized. -- - -- The effects of the other operations on lock objects - -- are undefined unless the lock object has been initialized - -- and has not since been finalized. + -- The effects of the other operations on lock objects are undefined + -- unless the lock object has been initialized and has not since been + -- finalized. -- -- Initialization of the per-task lock is implicit in Create_Task. -- @@ -230,89 +226,82 @@ package System.Task_Primitives.Operations is -- read or write permission. (That is, matching pairs of Lock and Unlock -- operations on each lock object must be properly nested.) - -- 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 RTS_Lock, Global_Lock should be set to True if L + -- is a global lock (Single_RTS_Lock, Global_Task_Lock). -- -- Note that Write_Lock for RTS_Lock does not have an out-parameter. - -- RTS_Locks are used in situations where we have not made provision - -- for recovery from ceiling violations. We do not expect them to - -- occur inside the runtime system, because all RTS locks have ceiling - -- Priority'Last. - - -- There is one way there can be a ceiling violation. - -- That is if the runtime system is called from a task that is - -- executing in the Interrupt_Priority range. - - -- It is not clear what to do about ceiling violations due - -- to RTS calls done at interrupt priority. In general, it - -- is not acceptable to give all RTS locks interrupt priority, - -- since that whould give terrible performance on systems where - -- this has the effect of masking hardware interrupts, though we - -- could get away with allowing Interrupt_Priority'last where we - -- are layered on an OS that does not allow us to mask interrupts. - -- Ideally, we would like to raise Program_Error back at the - -- original point of the RTS call, but this would require a lot of - -- detailed analysis and recoding, with almost certain performance - -- penalties. - - -- For POSIX systems, we considered just skipping setting a - -- priority ceiling on RTS locks. This would mean there is no - -- ceiling violation, but we would end up with priority inversions - -- inside the runtime system, resulting in failure to satisfy the - -- Ada priority rules, and possible missed validation tests. - -- This could be compensated-for by explicit priority-change calls - -- to raise the caller to Priority'Last whenever it first enters - -- the runtime system, but the expected overhead seems high, though - -- it might be lower than using locks with ceilings if the underlying - -- implementation of ceiling locks is an inefficient one. - - -- This issue should be reconsidered whenever we get around to - -- checking for calls to potentially blocking operations from - -- within protected operations. If we check for such calls and - -- catch them on entry to the OS, it may be that we can eliminate - -- the possibility of ceiling violations inside the RTS. For this - -- to work, we would have to forbid explicitly setting the priority - -- of a task to anything in the Interrupt_Priority range, at least. - -- We would also have to check that there are no RTS-lock operations - -- done inside any operations that are not treated as potentially - -- blocking. - - -- The latter approach seems to be the best, i.e. to check on entry - -- to RTS calls that may need to use locks that the priority is not - -- in the interrupt range. If there are RTS operations that NEED to - -- be called from interrupt handlers, those few RTS locks should then - -- be converted to PO-type locks, with ceiling Interrupt_Priority'Last. - - -- For now, we will just shut down the system if there is a - -- ceiling violation. + -- RTS_Locks are used in situations where we have not made provision for + -- recovery from ceiling violations. We do not expect them to occur inside + -- the runtime system, because all RTS locks have ceiling Priority'Last. + + -- There is one way there can be a ceiling violation. That is if the + -- runtime system is called from a task that is executing in the + -- Interrupt_Priority range. + + -- It is not clear what to do about ceiling violations due to RTS calls + -- done at interrupt priority. In general, it is not acceptable to give + -- all RTS locks interrupt priority, since that whould give terrible + -- performance on systems where this has the effect of masking hardware + -- interrupts, though we could get away with allowing + -- Interrupt_Priority'last where we are layered on an OS that does not + -- allow us to mask interrupts. Ideally, we would like to raise + -- Program_Error back at the original point of the RTS call, but this + -- would require a lot of detailed analysis and recoding, with almost + -- certain performance penalties. + + -- For POSIX systems, we considered just skipping setting priority ceiling + -- on RTS locks. This would mean there is no ceiling violation, but we + -- would end up with priority inversions inside the runtime system, + -- resulting in failure to satisfy the Ada priority rules, and possible + -- missed validation tests. This could be compensated-for by explicit + -- priority-change calls to raise the caller to Priority'Last whenever it + -- first enters the runtime system, but the expected overhead seems high, + -- though it might be lower than using locks with ceilings if the + -- underlying implementation of ceiling locks is an inefficient one. + + -- This issue should be reconsidered whenever we get around to checking + -- for calls to potentially blocking operations from within protected + -- operations. If we check for such calls and catch them on entry to the + -- OS, it may be that we can eliminate the possibility of ceiling + -- violations inside the RTS. For this to work, we would have to forbid + -- explicitly setting the priority of a task to anything in the + -- Interrupt_Priority range, at least. We would also have to check that + -- there are no RTS-lock operations done inside any operations that are + -- not treated as potentially blocking. + + -- The latter approach seems to be the best, i.e. to check on entry to RTS + -- calls that may need to use locks that the priority is not in the + -- interrupt range. If there are RTS operations that NEED to be called + -- from interrupt handlers, those few RTS locks should then be converted + -- to PO-type locks, with ceiling Interrupt_Priority'Last. + + -- For now, we will just shut down the system if there is ceiling violation procedure Yield (Do_Yield : Boolean := True); pragma Inline (Yield); - -- Yield the processor. Add the calling task to the tail of the - -- ready queue for its active_priority. - -- The Do_Yield argument is only used in some very rare cases very - -- a yield should have an effect on a specific target and not on regular - -- ones. + -- Yield the processor. Add the calling task to the tail of the ready + -- queue for its active_priority. The Do_Yield argument is only used in + -- some very rare cases very a yield should have an effect on a specific + -- target and not on regular ones. procedure Set_Priority (T : ST.Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False); pragma Inline (Set_Priority); - -- Set the priority of the task specified by T to T.Current_Priority. - -- The priority set is what would correspond to the Ada concept of - -- "base priority" in the terms of the lower layer system, but - -- the operation may be used by the upper layer to implement - -- changes in "active priority" that are not due to lock effects. - -- The effect should be consistent with the Ada Reference Manual. - -- In particular, when a task lowers its priority due to the loss of - -- inherited priority, it goes at the head of the queue for its new - -- priority (RM D.2.2 par 9). Loss_Of_Inheritance helps the underlying - -- implementation to do it right when the OS doesn't. + -- Set the priority of the task specified by T to T.Current_Priority. The + -- priority set is what would correspond to the Ada concept of "base + -- priority" in the terms of the lower layer system, but the operation may + -- be used by the upper layer to implement changes in "active priority" + -- that are not due to lock effects. The effect should be consistent with + -- the Ada Reference Manual. In particular, when a task lowers its + -- priority due to the loss of inherited priority, it goes at the head of + -- the queue for its new priority (RM D.2.2 par 9). 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; pragma Inline (Get_Priority); - -- Returns the priority last set by Set_Priority for this task. + -- Returns the priority last set by Set_Priority for this task function Monotonic_Clock return Duration; pragma Inline (Monotonic_Clock); @@ -343,17 +332,16 @@ package System.Task_Primitives.Operations is -- and has abort deferred -- -- postcondition: - -- The calling task is holding its own ATCB lock - -- and has abort deferred. + -- The calling task is holding its own ATCB lock and has abort deferred. -- The effect is to atomically unlock T's lock and wait, so that another -- task that is able to lock T's lock can be assured that the wait has -- actually commenced, and that a Wakeup operation will cause the waiting - -- task to become ready for execution once again. When Sleep returns, - -- the waiting task will again hold its own ATCB lock. The waiting task - -- may become ready for execution at any time (that is, spurious wakeups - -- are permitted), but it will definitely become ready for execution when - -- a Wakeup operation is performed for the same task. + -- task to become ready for execution once again. When Sleep returns, the + -- waiting task will again hold its own ATCB lock. The waiting task may + -- become ready for execution at any time (that is, spurious wakeups are + -- permitted), but it will definitely become ready for execution when a + -- Wakeup operation is performed for the same task. procedure Timed_Sleep (Self_ID : ST.Task_Id; @@ -399,21 +387,20 @@ package System.Task_Primitives.Operations is -- RTS Entrance/Exit -- ----------------------- - -- Following two routines are used for possible operations needed - -- to be setup/cleared upon entrance/exit of RTS while maintaining - -- a single thread of control in the RTS. Since we intend these - -- routines to be used for implementing the Single_Lock RTS, - -- Lock_RTS should follow the first Defer_Abortion operation - -- entering RTS. In the same fashion Unlock_RTS should preceed - -- the last Undefer_Abortion exiting RTS. + -- Following two routines are used for possible operations needed to be + -- setup/cleared upon entrance/exit of RTS while maintaining a single + -- thread of control in the RTS. Since we intend these routines to be used + -- for implementing the Single_Lock RTS, Lock_RTS should follow the first + -- Defer_Abortion operation entering RTS. In the same fashion Unlock_RTS + -- should preceed the last Undefer_Abortion exiting RTS. -- -- These routines also replace the functions Lock/Unlock_All_Tasks_List procedure Lock_RTS; - -- Take the global RTS lock. + -- Take the global RTS lock procedure Unlock_RTS; - -- Release the global RTS lock. + -- Release the global RTS lock -------------------- -- Stack Checking -- @@ -424,30 +411,29 @@ package System.Task_Primitives.Operations is -- an insufficient amount of stack space remains in the current task. -- The exact mechanism for a stack probe is target dependent. Typical - -- possibilities are to use a load from a non-existent page, a store - -- to a read-only page, or a comparison with some stack limit constant. - -- Where possible we prefer to use a trap on a bad page access, since - -- this has less overhead. The generation of stack probes is either - -- automatic if the ABI requires it (as on for example DEC Unix), or - -- is controlled by the gcc parameter -fstack-check. - - -- When we are using bad-page accesses, we need a bad page, called a - -- guard page, at the end of each task stack. On some systems, this - -- is provided automatically, but on other systems, we need to create - -- the guard page ourselves, and the procedure Stack_Guard is provided - -- for this purpose. + -- possibilities are to use a load from a non-existent page, a store to a + -- read-only page, or a comparison with some stack limit constant. Where + -- possible we prefer to use a trap on a bad page access, since this has + -- less overhead. The generation of stack probes is either automatic if + -- the ABI requires it (as on for example DEC Unix), or is controlled by + -- the gcc parameter -fstack-check. + + -- When we are using bad-page accesses, we need a bad page, called guard + -- page, at the end of each task stack. On some systems, this is provided + -- automatically, but on other systems, we need to create the guard page + -- ourselves, and the procedure Stack_Guard is provided for this purpose. 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: -- -- 1. When we create a task adjust its size so a guard page can - -- safely be set at the bottom of the stack + -- safely be set at the bottom of the stack. -- -- 2. When the thread is created (and its stack allocated by the -- underlying thread system), get the stack base (and size, depending - -- how the stack is growing), and create the guard page taking care of - -- page boundaries issues. + -- how the stack is growing), and create the guard page taking care + -- of page boundaries issues. -- -- 3. When the task is destroyed, remove the guard page. -- @@ -467,11 +453,11 @@ package System.Task_Primitives.Operations is 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. + -- Check that the current task is holding only Global_Task_Lock function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean; pragma Inline (Check_No_Locks); - -- Check that current task is holding no locks. + -- Check that current task is holding no locks function Suspend_Task (T : ST.Task_Id; diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index c2bee15dc0f..6a1da15615e 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,30 +41,30 @@ pragma Polling (Off); -- to poll it can cause infinite loops. with Ada.Exceptions; --- used for Exception_Occurrence_Access. +-- Used for Exception_Occurrence_Access with System.Tasking; pragma Elaborate_All (System.Tasking); --- ensure that the first step initializations have been performed +-- Ensure that the first step initializations have been performed with System.Task_Primitives; --- used for Lock +-- Used for Lock with System.Task_Primitives.Operations; --- used for Set_Priority +-- Used for Set_Priority -- Write_Lock -- Unlock -- Initialize_Lock with System.Soft_Links; --- used for the non-tasking routines (*_NT) that refer to global data. +-- Used for the non-tasking routines (*_NT) that refer to global data. -- They are needed here before the tasking run time has been elaborated. with System.Soft_Links.Tasking; -- Used for Init_Tasking_Soft_Links with System.Tasking.Debug; --- used for Trace +-- Used for Trace with System.Stack_Checking; @@ -88,7 +88,7 @@ package body System.Tasking.Initialization is function Current_Target_Exception return AE.Exception_Occurrence; pragma Import (Ada, Current_Target_Exception, "__gnat_current_target_exception"); - -- Import this subprogram from the private part of Ada.Exceptions. + -- Import this subprogram from the private part of Ada.Exceptions ---------------------------------------------------------------------- -- Tasking versions of some services needed by non-tasking programs -- @@ -150,7 +150,7 @@ package body System.Tasking.Initialization is -- Change_Base_Priority -- -------------------------- - -- Call only with abort deferred and holding Self_ID locked. + -- Call only with abort deferred and holding Self_ID locked procedure Change_Base_Priority (T : Task_Id) is begin @@ -269,7 +269,7 @@ package body System.Tasking.Initialization is -- while we had abort deferred below. loop - -- Temporarily defer abortion so that we can lock Self_ID. + -- Temporarily defer abort so that we can lock Self_ID Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; @@ -286,7 +286,7 @@ package body System.Tasking.Initialization is Unlock_RTS; end if; - -- Restore the original Deferral value. + -- Restore the original Deferral value Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; @@ -401,11 +401,11 @@ package body System.Tasking.Initialization is SSL.Tasking.Init_Tasking_Soft_Links; - -- Install tasking locks in the GCC runtime. + -- Install tasking locks in the GCC runtime Gnat_Install_Locks (Task_Lock'Access, Task_Unlock'Access); - -- Abortion is deferred in a new ATCB, so we need to undefer abortion + -- Abort is deferred in a new ATCB, so we need to undefer abort -- at this stage to make the environment task abortable. Undefer_Abort (Environment_Task); @@ -426,15 +426,16 @@ package body System.Tasking.Initialization is -- hurt to uncomment the above call, until the error is corrected for -- all targets. - -- See extended comments in package body System.Tasking.Abortion - -- for the overall design of the implementation of task abort. + -- See extended comments in package body System.Tasking.Abort for the + -- overall design of the implementation of task abort. + -- ??? there is no such package ??? - -- If the task is sleeping it will be in an abort-deferred region, - -- and will not have Abort_Signal raised by Abort_Task. - -- Such an "abort deferral" is just to protect the RTS internals, - -- and not necessarily required to enforce Ada semantics. - -- Abort_Task should wake the task up and let it decide if it wants - -- to complete the aborted construct immediately. + -- If the task is sleeping it will be in an abort-deferred region, and + -- will not have Abort_Signal raised by Abort_Task. Such an "abort + -- deferral" is just to protect the RTS internals, and not necessarily + -- required to enforce Ada semantics. Abort_Task should wake the task up + -- and let it decide if it wants to complete the aborted construct + -- immediately. -- Note that the effect of the lowl-level Abort_Task is not persistent. -- If the target task is not blocked, this wakeup will be missed. @@ -452,14 +453,13 @@ package body System.Tasking.Initialization is -- implement delays). That still left the possibility of missed -- wakeups. - -- We cannot safely call Vulnerable_Complete_Activation here, - -- since that requires locking Self_ID.Parent. The anti-deadlock - -- lock ordering rules would then require us to release the lock - -- on Self_ID first, which would create a timing window for other - -- tasks to lock Self_ID. This is significant for tasks that may be - -- aborted before their execution can enter the task body, and so - -- they do not get a chance to call Complete_Task. The actual work - -- for this case is done in Terminate_Task. + -- We cannot safely call Vulnerable_Complete_Activation here, since that + -- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules + -- would then require us to release the lock on Self_ID first, which would + -- create a timing window for other tasks to lock Self_ID. This is + -- significant for tasks that may be aborted before their execution can + -- enter the task body, and so they do not get a chance to call + -- Complete_Task. The actual work for this case is done in Terminate_Task. procedure Locked_Abort_To_Level (Self_ID : Task_Id; @@ -694,12 +694,12 @@ package body System.Tasking.Initialization is -- Precondition : Self does not hold any locks! - -- Undefer_Abort is called on any abortion completion point (aka. + -- Undefer_Abort is called on any abort completion point (aka. -- synchronization point). It performs the following actions if they -- are pending: (1) change the base priority, (2) abort the task. - -- The priority change has to occur before abortion. Otherwise, it would - -- take effect no earlier than the next abortion completion point. + -- The priority change has to occur before abort. Otherwise, it would + -- take effect no earlier than the next abort completion point. procedure Undefer_Abort (Self_ID : Task_Id) is begin @@ -761,8 +761,8 @@ package body System.Tasking.Initialization is -- Undefer_Abortion -- ---------------------- - -- Phase out RTS-internal use of Undefer_Abortion - -- to reduce overhead due to multiple calls to Self. + -- Phase out RTS-internal use of Undefer_Abortion to reduce overhead due + -- to multiple calls to Self. procedure Undefer_Abortion is Self_ID : Task_Id; @@ -806,7 +806,7 @@ package body System.Tasking.Initialization is -- Update_Exception -- ---------------------- - -- Call only when holding no locks. + -- Call only when holding no locks procedure Update_Exception (X : AE.Exception_Occurrence := Current_Target_Exception) diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads index 62bfc0c3463..8917dcc8aa5 100644 --- a/gcc/ada/s-tasini.ads +++ b/gcc/ada/s-tasini.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,8 +37,7 @@ package System.Tasking.Initialization is procedure Remove_From_All_Tasks_List (T : Task_Id); - -- Remove T from All_Tasks_List. - -- Call this function with RTS_Lock taken. + -- Remove T from All_Tasks_List. Call this function with RTS_Lock taken --------------------------------- -- Tasking-Specific Soft Links -- @@ -47,7 +46,8 @@ package System.Tasking.Initialization is -- These permit us to leave out certain portions of the tasking -- run-time system if they are not used. They are only used internally -- by the tasking run-time system. - -- So far, the only example is support for Ada.Task_Attributes. + + -- So far, the only example is support for Ada.Task_Attributes type Proc_T is access procedure (T : Task_Id); @@ -55,10 +55,10 @@ package System.Tasking.Initialization is 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 + -- should be called with abort deferred and T.L write-locked Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access; - -- should be called with abortion deferred, but holding no locks + -- should be called with abort deferred, but holding no locks ------------------------- -- Abort Defer/Undefer -- @@ -68,43 +68,41 @@ package System.Tasking.Initialization is -- in the calling task until a matching Undefer_Abort call is executed. -- Undefer_Abort DOES MORE than just undo the effects of one call to - -- Defer_Abort. It is the universal "polling point" for deferred + -- Defer_Abort. It is the universal "polling point" for deferred -- processing, including the following: -- 1) base priority changes -- 2) abort/ATC - -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), - -- but to avoid waste and undetected errors, it generally SHOULD NOT - -- be nested. The symptom of over-deferring abort is that an exception - -- may fail to be raised, or an abort may fail to take place. + -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), but + -- to avoid waste and undetected errors, it generally SHOULD NOT be + -- nested. The symptom of over-deferring abort is that an exception may + -- fail to be raised, or an abort may fail to take place. - -- Therefore, there are two sets of the inlinable defer/undefer - -- routines, which are the ones to be used inside GNARL. - -- One set allows nesting. The other does not. People who - -- maintain the GNARL should try to avoid using the nested versions, - -- or at least look very critically at the places where they are - -- used. + -- Therefore, there are two sets of the inlinable defer/undefer routines, + -- which are the ones to be used inside GNARL. One set allows nesting. The + -- other does not. People who maintain the GNARL should try to avoid using + -- the nested versions, or at least look very critically at the places + -- where they are used. - -- In general, any GNARL call that is potentially blocking, or - -- whose semantics require that it sometimes raise an exception, - -- or that is required to be an abort completion point, must be - -- made with abort Deferral_Level = 1. + -- In general, any GNARL call that is potentially blocking, or whose + -- semantics require that it sometimes raise an exception, or that is + -- required to be an abort completion point, must be made with abort + -- Deferral_Level = 1. - -- In general, non-blocking GNARL calls, which may be made from inside - -- a protected action, are likely to need to allow nested abort - -- deferral. + -- In general, non-blocking GNARL calls, which may be made from inside a + -- protected action, are likely to need to allow nested abort deferral. -- With some critical exceptions (which are supposed to be documented), -- internal calls to the tasking runtime system assume abort is already -- deferred, and do not modify the deferral level. - -- There is also a set of non-linable defer/undefer routines, - -- for direct call from the compiler. These are not in-lineable - -- because they may need to be called via pointers ("soft links"). - -- For the sake of efficiency, the version with Self_ID as parameter - -- should used wherever possible. These are all nestable. + -- There is also a set of non-linable defer/undefer routines, for direct + -- call from the compiler. These are not in-lineable because they may need + -- to be called via pointers ("soft links"). For the sake of efficiency, + -- the version with Self_ID as parameter should used wherever possible. + -- These are all nestable. -- Non-nestable inline versions @@ -128,16 +126,14 @@ package System.Tasking.Initialization is procedure Defer_Abortion; procedure Undefer_Abortion; - -- ????? - -- Try to phase out all uses of the above versions. + -- Try to phase out all uses of the above versions ??? procedure Do_Pending_Action (Self_ID : Task_Id); - -- Only call with no locks, and when Self_ID.Pending_Action = True - -- Perform necessary pending actions (e.g. abortion, priority change). - -- This procedure is usually called when needed as a result of - -- calling Undefer_Abort, although in the case of e.g. No_Abort - -- restriction, it can be necessary to force execution of pending - -- actions. + -- Only call with no locks, and when Self_ID.Pending_Action = True Perform + -- necessary pending actions (e.g. abort, priority change). This procedure + -- is usually called when needed as a result of calling Undefer_Abort, + -- although in the case of e.g. No_Abort restriction, it can be necessary + -- to force execution of pending actions. function Check_Abort_Status return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise @@ -148,9 +144,8 @@ package System.Tasking.Initialization is -------------------------- 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. + -- 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); -- Has to be called with Self_ID's ATCB write-locked. @@ -170,44 +165,41 @@ package System.Tasking.Initialization is -- within the GNARL. 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 - -- the old task may run concurrently with a new task that is allocated - -- the old tasks (now reused) ATCB. The critical thing here is to - -- not make any reference to the ATCB after the lock is released. - -- See also comments on Terminate_Task and Unlock. + -- 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 the old task may run + -- concurrently with a new task that is allocated the old tasks (now + -- reused) ATCB. The critical thing here is to not make any reference to + -- the ATCB after the lock is released. See also comments on + -- Terminate_Task and Unlock. procedure Wakeup_Entry_Caller (Self_ID : Task_Id; Entry_Call : Entry_Call_Link; New_State : Entry_Call_State); pragma Inline (Wakeup_Entry_Caller); - -- This is called at the end of service of an entry call, - -- to abort the caller if he is in an abortable part, and - -- to wake up the caller if he is on Entry_Caller_Sleep. - -- Call it holding the lock of Entry_Call.Self. + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if he + -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self. -- -- Timed_Call or Simple_Call: - -- The caller is waiting on Entry_Caller_Sleep, in - -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion, + -- or Wait_For_Completion_With_Timeout. -- -- Conditional_Call: -- The caller might be in Wait_For_Completion, - -- waiting for a rendezvous (possibly requeued without abort) - -- to complete. + -- waiting for a rendezvous (possibly requeued without abort) to + -- complete. -- -- Asynchronous_Call: - -- The caller may be executing in the abortable part o - -- an async. select, or on a time delay, - -- if Entry_Call.State >= Was_Abortable. + -- The caller may be executing in the abortable part an async. select, + -- or on a time delay, if Entry_Call.State >= Was_Abortable. procedure Locked_Abort_To_Level (Self_ID : Task_Id; T : Task_Id; L : ATC_Level); pragma Inline (Locked_Abort_To_Level); - -- Abort a task to a specified ATC level. - -- Call this only with T locked. + -- Abort a task to a specified ATC level. Call this only with T locked end System.Tasking.Initialization; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 1dd9e27d730..3bafc130065 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This package provides necessary type definitions for compiler interface. +-- This package provides necessary type definitions for compiler interface -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. @@ -62,13 +62,12 @@ package System.Tasking is -- The following rules must be followed at all times, to prevent -- deadlock and generally ensure correct operation of locking. - -- . Never lock a lock unless abort is deferred. + -- Never lock a lock unless abort is deferred - -- . Never undefer abort while holding a lock. + -- Never undefer abort while holding a lock - -- . Overlapping critical sections must be properly nested, - -- and locks must be released in LIFO order. - -- e.g., the following is not allowed: + -- Overlapping critical sections must be properly nested, and locks must + -- be released in LIFO order. e.g., the following is not allowed: -- Lock (X); -- ... @@ -80,7 +79,6 @@ package System.Tasking is -- Locks with lower (smaller) level number cannot be locked -- while holding a lock with a higher level number. (The level - -- number is the number at the left.) -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) @@ -94,13 +92,13 @@ package System.Tasking is -- clearly wrong since there can be calls to "new" inside protected -- operations. The new ordering prevents these failures. - -- Sometimes we need to hold two ATCB locks at the same time. To allow - -- us to order the locking, each ATCB is given a unique serial - -- number. If one needs to hold locks on several ATCBs at once, - -- the locks with lower serial numbers must be locked first. + -- Sometimes we need to hold two ATCB locks at the same time. To allow us + -- to order the locking, each ATCB is given a unique serial number. If one + -- needs to hold locks on several ATCBs at once, the locks with lower + -- serial numbers must be locked first. - -- We don't always need to check the serial numbers, since - -- the serial numbers are assigned sequentially, and so: + -- We don't always need to check the serial numbers, since the serial + -- numbers are assigned sequentially, and so: -- . The parent of a task always has a lower serial number. -- . The activator of a task always has a lower serial number. @@ -157,13 +155,13 @@ package System.Tasking is -- alternatives have been awakened and have terminated themselves. Activator_Sleep, - -- Task is waiting for created tasks to complete activation. + -- Task is waiting for created tasks to complete activation Acceptor_Sleep, - -- Task is waiting on an accept or selective wait statement. + -- Task is waiting on an accept or selective wait statement Entry_Caller_Sleep, - -- Task is waiting on an entry call. + -- Task is waiting on an entry call Async_Select_Sleep, -- Task is waiting to start the abortable part of an @@ -309,20 +307,20 @@ package System.Tasking is State : Entry_Call_State; pragma Atomic (State); -- Indicates part of the state of the call. - -- Protection: - -- If the call is not on a queue, it should - -- only be accessed by Self, and Self does not need any - -- lock to modify this field. - -- Once the call is on a queue, the value should be - -- something other than Done unless it is cancelled, and access is - -- controller by the "server" of the queue -- i.e., the lock - -- of Checked_To_Protection (Call_Target) - -- if the call record is on the queue of a PO, or the lock - -- of Called_Target if the call is on the queue of a task. - -- See comments on type declaration for more details. + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. + -- + -- Once the call is on a queue, the value should be something other + -- than Done unless it is cancelled, and access is controller by the + -- "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. Uninterpreted_Data : System.Address; - -- Data passed by the compiler. + -- Data passed by the compiler Exception_To_Raise : Ada.Exceptions.Exception_Id; -- The exception to raise once this call has been completed without @@ -351,7 +349,7 @@ package System.Tasking is -- Ada_Task_Control_Block (ATCB) definition -- ---------------------------------------------- - -- Notes on protection (synchronization) of TRTS data structures. + -- Notes on protection (synchronization) of TRTS data structures -- Any field of the TCB can be written by the activator of a task when the -- task is created, since no other task can access the new task's @@ -360,7 +358,7 @@ package System.Tasking is -- The protection for each field is described in a comment starting with -- "Protection:". - -- When a lock is used to protect an ATCB field, this lock is simply named. + -- When a lock is used to protect an ATCB field, this lock is simply named -- Some protection is described in terms of tasks related to the -- ATCB being protected. These are: @@ -390,7 +388,8 @@ package System.Tasking is -- Encodes some basic information about the state of a task, -- including whether it has been activated, whether it is sleeping, -- and whether it is terminated. - -- Protection: Self.L. + -- + -- Protection: Self.L Parent : Task_Id; -- The task on which this task depends. @@ -399,7 +398,8 @@ package System.Tasking is Base_Priority : System.Any_Priority; -- Base priority, not changed during entry calls, only changed -- via dynamic priorities package. - -- Protection: Only written by Self, accessed by anyone. + -- + -- Protection: Only written by Self, accessed by anyone Current_Priority : System.Any_Priority; -- Active priority, except that the effects of protected object @@ -428,96 +428,104 @@ package System.Tasking is Protected_Action_Nesting : Natural; pragma Atomic (Protected_Action_Nesting); - -- The dynamic level of protected action nesting for this task. - -- This field is needed for checking whether potentially - -- blocking operations are invoked from protected actions. - -- pragma Atomic is used because it can be read/written from - -- protected interrupt handlers. + -- The dynamic level of protected action nesting for this task. This + -- field is needed for checking whether potentially blocking operations + -- are invoked from protected actions. pragma Atomic is used because it + -- can be read/written from protected interrupt handlers. Task_Image : String (1 .. 32); -- Hold a string that provides a readable id for task, -- built from the variable of which it is a value or component. Task_Image_Len : Natural; - -- Actual length of Task_Image. + -- Actual length of Task_Image Call : Entry_Call_Link; -- The entry call that has been accepted by this task. - -- Protection: Self.L. Self will modify this field - -- when Self.Accepting is False, and will not need the mutex to do so. - -- Once a task sets Pending_ATC_Level = 0, no other task can access - -- this field. + -- + -- Protection: Self.L. Self will modify this field when Self.Accepting + -- is False, and will not need the mutex to do so. Once a task sets + -- Pending_ATC_Level = 0, no other task can access this field. LL : aliased Task_Primitives.Private_Data; - -- Control block used by the underlying low-level tasking - -- service (GNULLI). + -- Control block used by the underlying low-level tasking service + -- (GNULLI). + -- -- Protection: This is used only by the GNULLI implementation, which -- takes care of all of its synchronization. Task_Arg : System.Address; -- The argument to task procedure. Provide a handle for discriminant - -- information. - -- Protection: Part of the synchronization between Self and - -- Activator. Activator writes it, once, before Self starts - -- executing. Thereafter, Self only reads it. + -- information + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Thereafter, + -- Self only reads it. Task_Entry_Point : Task_Procedure_Access; -- Information needed to call the procedure containing the code for -- the body of this task. - -- Protection: Part of the synchronization between Self and - -- Activator. Activator writes it, once, before Self starts - -- executing. Self reads it, once, as part of its execution. + -- + -- Protection: Part of the synchronization between Self and Activator. + -- Activator writes it, once, before Self starts executing. Self reads + -- it, once, as part of its execution. Compiler_Data : System.Soft_Links.TSD; - -- Task-specific data needed by the compiler to store - -- per-task structures. - -- Protection: Only accessed by Self. + -- Task-specific data needed by the compiler to store per-task + -- structures. + -- + -- Protection: Only accessed by Self All_Tasks_Link : Task_Id; - -- Used to link this task to the list of all tasks in the system. - -- Protection: RTS_Lock. + -- Used to link this task to the list of all tasks in the system + -- + -- Protection: RTS_Lock Activation_Link : Task_Id; - -- Used to link this task to a list of tasks to be activated. - -- Protection: Only used by Activator. + -- Used to link this task to a list of tasks to be activated + -- + -- Protection: Only used by Activator 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. - -- Protection: Set by Activator before Self is activated, and - -- only read and modified by Self after that. + -- object or by executing a task allocator. The value is null iff Self + -- has completed activation. + -- + -- Protection: Set by Activator before Self is activated, and only read + -- and modified by Self after that. Wait_Count : Integer; - -- This count is used by a task that is waiting for other tasks. - -- At all other times, the value should be zero. - -- It is used differently in several different states. - -- Since a task cannot be in more than one of these states at the - -- same time, a single counter suffices. - -- Protection: Self.L. + -- This count is used by a task that is waiting for other tasks. At all + -- other times, the value should be zero. It is used differently in + -- several different states. Since a task cannot be in more than one of + -- these states at the same time, a single counter suffices. + -- + -- Protection: Self.L -- Activator_Sleep -- This is the number of tasks that this task is activating, i.e. the -- children that have started activation but have not completed it. - -- Protection: Self.L and Created.L. Both mutexes must be locked, - -- since Self.Activation_Count and Created.State must be synchronized. + -- + -- Protection: Self.L and Created.L. Both mutexes must be locked, since + -- Self.Activation_Count and Created.State must be synchronized. -- Master_Completion_Sleep (phase 1) - -- This is the number dependent tasks of a master being - -- completed by Self that are not activated, not terminated, and - -- not waiting on a terminate alternative. + -- This is the number dependent tasks of a master being completed by + -- Self that are not activated, not terminated, and not waiting on a + -- terminate alternative. -- Master_Completion_2_Sleep (phase 2) - -- This is the count of tasks dependent on a master being - -- completed by Self which are waiting on a terminate alternative. + -- This is the count of tasks dependent on a master being completed by + -- Self which are waiting on a terminate alternative. Elaborated : Access_Boolean; -- Pointer to a flag indicating that this task's body has been -- elaborated. The flag is created and managed by the -- compiler-generated code. + -- -- Protection: The field itself is only accessed by Activator. The flag -- that it points to is updated by Master and read by Activator; access -- is assumed to be atomic. @@ -539,6 +547,7 @@ package System.Tasking is -- restricted GNULL implementations to allocate an ATCB (see -- System.Task_Primitives.Operations.New_ATCB) that will take -- significantly less memory. + -- Note that the restricted GNARLI should only access fields that are -- present in the Restricted_Ada_Task_Control_Block structure. @@ -564,7 +573,7 @@ package System.Tasking is ----------------------- All_Tasks_List : Task_Id; - -- Global linked list of all tasks. + -- Global linked list of all tasks ------------------------------------------ -- Regular (non restricted) definitions -- @@ -577,13 +586,13 @@ package System.Tasking is subtype Master_Level is Integer; subtype Master_ID is Master_Level; - -- Normally, a task starts out with internal master nesting level - -- one larger than external master nesting level. It is incremented - -- to one by Enter_Master, which is called in the task body only if - -- the compiler thinks the task may have dependent tasks. It is set to 1 - -- for the environment task, the level 2 is reserved for server tasks of - -- the run-time system (the so called "independent tasks"), and the level - -- 3 is for the library level tasks. + -- Normally, a task starts out with internal master nesting level one + -- larger than external master nesting level. It is incremented to one by + -- Enter_Master, which is called in the task body only if the compiler + -- thinks the task may have dependent tasks. It is set to for the + -- environment task, the level 2 is reserved for server tasks of the + -- run-time system (the so called "independent tasks"), and the level 3 is + -- for the library level tasks. Environment_Task_Level : constant Master_Level := 1; Independent_Task_Level : constant Master_Level := 2; @@ -596,7 +605,7 @@ package System.Tasking is Unspecified_Priority : constant Integer := System.Priority'First - 1; Priority_Not_Boosted : constant Integer := System.Priority'First - 1; - -- Definition of Priority actually has to come from the RTS configuration. + -- Definition of Priority actually has to come from the RTS configuration subtype Rendezvous_Priority is Integer range Priority_Not_Boosted .. System.Any_Priority'Last; @@ -652,21 +661,19 @@ package System.Tasking is State : Entry_Call_State; pragma Atomic (State); - -- Indicates part of the state of the call. - -- Protection: - -- If the call is not on a queue, it should - -- only be accessed by Self, and Self does not need any - -- lock to modify this field. - -- Once the call is on a queue, the value should be - -- something other than Done unless it is cancelled, and access is - -- controller by the "server" of the queue -- i.e., the lock - -- of Checked_To_Protection (Call_Target) - -- if the call record is on the queue of a PO, or the lock - -- of Called_Target if the call is on the queue of a task. - -- See comments on type declaration for more details. + -- Indicates part of the state of the call + -- + -- Protection: If the call is not on a queue, it should only be + -- accessed by Self, and Self does not need any lock to modify this + -- field. Once the call is on a queue, the value should be something + -- other than Done unless it is cancelled, and access is controller by + -- the "server" of the queue -- i.e., the lock of Checked_To_Protection + -- (Call_Target) if the call record is on the queue of a PO, or the + -- lock of Called_Target if the call is on the queue of a task. See + -- comments on type declaration for more details. Uninterpreted_Data : System.Address; - -- Data passed by the compiler. + -- Data passed by the compiler Exception_To_Raise : Ada.Exceptions.Exception_Id; -- The exception to raise once this call has been completed without @@ -693,42 +700,39 @@ package System.Tasking is 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. - -- Conversely, unless State is Done and Onqueue is false, + -- Use for task entry calls. The value is null if the call record is + -- not in use. Conversely, unless State is Done and Onqueue is false, -- Called_Task points to an ATCB. - -- Protection: Called_Task.L. + -- + -- Protection: Called_Task.L Called_PO : System.Address; pragma Atomic (Called_PO); - -- Similar to Called_Task but for protected objects. + -- Similar to Called_Task but for protected objects + -- -- Note that the previous implementation tried to merge both -- Called_Task and Called_PO but this ended up in many unexpected -- complications (e.g having to add a magic number in the ATCB, which - -- caused gdb lots of confusion) with no real gain since the Lock_Server - -- implementation still need to loop around chasing for pointer changes - -- even with a single pointer. + -- caused gdb lots of confusion) with no real gain since the + -- Lock_Server implementation still need to loop around chasing for + -- pointer changes even with a single pointer. Acceptor_Prev_Call : Entry_Call_Link; - -- For task entry calls only. + -- For task entry calls only Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; - -- For task entry calls only. - -- The priority of the most recent prior call being serviced. - -- For protected entry calls, this function should be performed by - -- GNULLI ceiling locking. + -- For task entry calls only. The priority of the most recent prior + -- call being serviced. For protected entry calls, this function should + -- be performed by GNULLI ceiling locking. Cancellation_Attempted : Boolean := False; pragma Atomic (Cancellation_Attempted); -- Cancellation of the call has been attempted. - -- If it has succeeded, State = Cancelled. - -- ????? - -- Consider merging this into State? + -- Consider merging this into State??? Requeue_With_Abort : Boolean := False; -- Temporary to tell caller whether requeue is with abort. - -- ????? - -- Find a better way of doing this. + -- Find a better way of doing this ??? Needs_Requeue : Boolean := False; -- Temporary to tell acceptor of task entry call that @@ -756,10 +760,10 @@ package System.Tasking is type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; - -- Attributes with indices in this range are stored directly in - -- the task control block. Such attributes must be Address-sized. - -- Other attributes will be held in dynamically allocated records - -- chained off of the task control block. + -- Attributes with indices in this range are stored directly in the task + -- control block. Such attributes must be Address-sized. Other attributes + -- will be held in dynamically allocated records chained off of the task + -- control block. type Direct_Attribute_Element is mod Memory_Size; pragma Atomic (Direct_Attribute_Element); @@ -772,86 +776,95 @@ package System.Tasking is -- the usage of the direct attribute fields. type Task_Serial_Number is mod 2 ** 64; - -- Used to give each task a unique serial number. + -- Used to give each task a unique serial number type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is record Common : Common_ATCB; -- The common part between various tasking implementations Entry_Calls : Entry_Call_Array; - -- An array of entry calls. + -- An array of entry calls + -- -- Protection: The elements of this array are on entry call queues -- associated with protected objects or task entries, and are protected -- by the protected object lock or Acceptor.L, respectively. New_Base_Priority : System.Any_Priority; - -- New value for Base_Priority (for dynamic priorities package). - -- Protection: Self.L. + -- New value for Base_Priority (for dynamic priorities package) + -- + -- Protection: Self.L Global_Task_Lock_Nesting : Natural := 0; -- This is the current nesting level of calls to - -- System.Tasking.Stages.Lock_Task_T. - -- This allows a task to call Lock_Task_T multiple times without - -- deadlocking. A task only locks All_Task_Lock when its - -- All_Tasks_Nesting goes from 0 to 1, and only unlocked when it - -- goes from 1 to 0. - -- Protection: Only accessed by Self. + -- System.Tasking.Stages.Lock_Task_T. This allows a task to call + -- Lock_Task_T multiple times without deadlocking. A task only locks + -- All_Task_Lock when its All_Tasks_Nesting goes from 0 to 1, and only + -- unlocked when it goes from 1 to 0. + -- + -- Protection: Only accessed by Self Open_Accepts : Accept_List_Access; -- This points to the Open_Accepts array of accept alternatives passed - -- to the RTS by the compiler-generated code to Selective_Wait. - -- It is non-null iff this task is ready to accept an entry call. - -- Protection: Self.L. + -- to the RTS by the compiler-generated code to Selective_Wait. It is + -- non-null iff this task is ready to accept an entry call. + -- + -- Protection: Self.L Chosen_Index : Select_Index; -- The index in Open_Accepts of the entry call accepted by a selective -- wait executed by this task. - -- Protection: Written by both Self and Caller. Usually protected - -- by Self.L. However, once the selection is known to have been - -- written it can be accessed without protection. This happens - -- after Self has updated it itself using information from a suspended - -- Caller, or after Caller has updated it and awakened Self. + -- + -- Protection: Written by both Self and Caller. Usually protected by + -- Self.L. However, once the selection is known to have been written it + -- can be accessed without protection. This happens after Self has + -- updated it itself using information from a suspended Caller, or + -- after Caller has updated it and awakened Self. Master_of_Task : Master_Level; -- The task executing the master of this task, and the ID of this task's -- master (unique only among masters currently active within Parent). - -- Protection: Set by Activator before Self is activated, and - -- read after Self is activated. + -- + -- Protection: Set by Activator before Self is activated, and read + -- after Self is activated. Master_Within : Master_Level; -- The ID of the master currently executing within this task; that is, -- the most deeply nested currently active master. + -- -- Protection: Only written by Self, and only read by Self or by - -- dependents when Self is attempting to exit a master. Since Self - -- will not write this field until the master is complete, the + -- dependents when Self is attempting to exit a master. Since Self will + -- not write this field until the master is complete, the -- synchronization should be adequate to prevent races. Alive_Count : Integer := 0; -- Number of tasks directly dependent on this task (including itself) -- that are still "alive", i.e. not terminated. - -- Protection: Self.L. + -- + -- Protection: Self.L Awake_Count : Integer := 0; -- Number of tasks directly dependent on this task (including itself) -- still "awake", i.e., are not terminated and not waiting on a -- terminate alternative. + -- -- Invariant: Awake_Count <= Alive_Count - -- Protection: Self.L. - -- beginning of flags + -- Protection: Self.L + + -- Beginning of flags Aborting : Boolean := False; pragma Atomic (Aborting); -- Self is in the process of aborting. While set, prevents multiple - -- abortion signals from being sent by different aborter while abortion + -- abort signals from being sent by different aborter while abort -- is acted upon. This is essential since an aborter which calls -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level -- (than the current level), may be preempted and would send the - -- abortion signal when resuming execution. At this point, the abortee - -- may have completed abortion to the proper level such that the - -- signal (and resulting abortion exception) are not handled any more. + -- abort signal when resuming execution. At this point, the abortee + -- may have completed abort to the proper level such that the + -- signal (and resulting abort exception) are not handled any more. -- In other words, the flag prevents a race between multiple aborters - -- and the abortee. + -- -- Protection: protected by atomic access. ATC_Hack : Boolean := False; @@ -863,17 +876,17 @@ package System.Tasking is -- handler itself. Callable : Boolean := True; - -- It is OK to call entries of this task. + -- It is OK to call entries of this task Dependents_Aborted : Boolean := False; - -- This is set to True by whichever task takes responsibility - -- for aborting the dependents of this task. - -- Protection: Self.L. + -- This is set to True by whichever task takes responsibility for + -- aborting the dependents of this task. + -- + -- Protection: Self.L Interrupt_Entry : Boolean := False; - -- Indicates if one or more Interrupt Entries are attached to - -- the task. This flag is needed for cleaning up the Interrupt - -- Entry bindings. + -- Indicates if one or more Interrupt Entries are attached to the task. + -- This flag is needed for cleaning up the Interrupt Entry bindings. Pending_Action : Boolean := False; -- Unified flag indicating some action needs to be take when abort @@ -884,65 +897,68 @@ package System.Tasking is -- (Abortable field may have changed and the Wait_Until_Abortable -- has to recheck the abortable status of the call.) -- . Exception_To_Raise is non-null - -- Protection: Self.L. - -- This should never be reset back to False outside of the - -- procedure Do_Pending_Action, which is called by Undefer_Abort. - -- It should only be set to True by Set_Priority and Abort_To_Level. + -- + -- Protection: Self.L + -- + -- This should never be reset back to False outside of the procedure + -- Do_Pending_Action, which is called by Undefer_Abort. It should only + -- be set to True by Set_Priority and Abort_To_Level. Pending_Priority_Change : Boolean := False; -- Flag to indicate pending priority change (for dynamic priorities - -- package). The base priority is updated on the next abortion + -- package). The base priority is updated on the next abort -- completion point (aka. synchronization point). - -- Protection: Self.L. + -- + -- Protection: Self.L Terminate_Alternative : Boolean := False; - -- Task is accepting Select with Terminate Alternative. - -- Protection: Self.L. + -- Task is accepting Select with Terminate Alternative + -- + -- Protection: Self.L - -- end of flags + -- End of flags - -- beginning of counts + -- Beginning of counts ATC_Nesting_Level : ATC_Level := 1; -- The dynamic level of ATC nesting (currently executing nested -- asynchronous select statements) in this task. - -- Protection: Self_ID.L. - -- Only Self reads or updates this field. + + -- Protection: Self_ID.L. Only Self reads or updates this field. -- Decrementing it deallocates an Entry_Calls component, and care must - -- be taken that all references to that component are eliminated - -- before doing the decrement. This in turn will require locking - -- a protected object (for a protected entry call) or the Acceptor's - -- lock (for a task entry call). - -- No other task should attempt to read or modify this value. + -- be taken that all references to that component are eliminated before + -- doing the decrement. This in turn will require locking a protected + -- object (for a protected entry call) or the Acceptor's lock (for a + -- task entry call). No other task should attempt to read or modify + -- this value. Deferral_Level : Natural := 1; -- This is the number of times that Defer_Abortion has been called by - -- this task without a matching Undefer_Abortion call. Abortion is - -- only allowed when this zero. - -- It is initially 1, to protect the task at startup. - -- Protection: Only updated by Self; access assumed to be atomic. + -- this task without a matching Undefer_Abortion call. Abortion is only + -- allowed when this zero. It is initially 1, to protect the task at + -- startup. + + -- Protection: Only updated by Self; access assumed to be atomic Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; - -- The ATC level to which this task is currently being aborted. - -- If the value is zero, the entire task has "completed". - -- That may be via abort, exception propagation, or normal exit. - -- If the value is ATC_Level_Infinity, the task is not being - -- aborted to any level. - -- If the value is positive, the task has not completed. - -- This should ONLY be modified by - -- Abort_To_Level and Exit_One_ATC_Level. - -- Protection: Self.L. + -- The ATC level to which this task is currently being aborted. If the + -- value is zero, the entire task has "completed". That may be via + -- abort, exception propagation, or normal exit. If the value is + -- ATC_Level_Infinity, the task is not being aborted to any level. If + -- the value is positive, the task has not completed. This should ONLY + -- be modified by Abort_To_Level and Exit_One_ATC_Level. + -- + -- Protection: Self.L Serial_Number : Task_Serial_Number; - -- A growing number to provide some way to check locking - -- rules/ordering. + -- A growing number to provide some way to check locking rules/ordering Known_Tasks_Index : Integer := -1; - -- Index in the System.Tasking.Debug.Known_Tasks array. + -- Index in the System.Tasking.Debug.Known_Tasks array User_State : Long_Integer := 0; - -- User-writeable location, for use in debugging tasks; - -- also provides a simple task specific data. + -- User-writeable location, for use in debugging tasks; also provides a + -- simple task specific data. Direct_Attributes : Direct_Attribute_Array; -- For task attributes that have same size as Address @@ -951,11 +967,12 @@ package System.Tasking is -- Bit I is 1 iff Direct_Attributes (I) is defined Indirect_Attributes : Access_Address; - -- A pointer to chain of records for other attributes that - -- are not address-sized, including all tagged types. + -- A pointer to chain of records for other attributes that are not + -- address-sized, including all tagged types. Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); - -- An array of task entry queues. + -- An array of task entry queues + -- -- Protection: Self.L. Once a task has set Self.Stage to Completing, it -- has exclusive access to this field. end record; @@ -975,18 +992,18 @@ package System.Tasking is Stack_Size : System.Parameters.Size_Type; T : 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. - -- Need more documentation, mention T, and describe Success ??? + -- Initialize fields of a TCB and link into global TCB structures Call + -- this only with abort deferred and holding RTS_Lock. Need more + -- documentation, mention T, and describe Success ??? private Null_Task : constant Task_Id := null; GL_Detect_Blocking : Integer; pragma Import (C, GL_Detect_Blocking, "__gl_detect_blocking"); - -- Global variable exported by the binder generated file. A value - -- equal to 1 indicates that pragma Detect_Blocking is active, - -- while 0 is used for the pragma not being present. + -- Global variable exported by the binder generated file. A value equal to + -- 1 indicates that pragma Detect_Blocking is active, while 0 is used for + -- the pragma not being present. Detect_Blocking : constant Boolean := GL_Detect_Blocking = 1; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 9002eeeb031..6bdd8d27738 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -154,7 +154,7 @@ package body System.Tasking.Rendezvous is 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. + -- Call this only with abort deferred and holding lock of Acceptor procedure Call_Synchronous (Acceptor : Task_Id; @@ -255,7 +255,7 @@ package body System.Tasking.Rendezvous is Uninterpreted_Data := Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; else - -- Case of an aborted task. + -- Case of an aborted task Uninterpreted_Data := System.Null_Address; end if; @@ -701,7 +701,7 @@ package body System.Tasking.Rendezvous is (Self_Id, Entry_Call.Acceptor_Prev_Priority); else - -- The call does not need to be requeued. + -- The call does not need to be requeued Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; Entry_Call.Exception_To_Raise := Ex; @@ -712,7 +712,7 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Caller); - -- Done with Caller locked to make sure that Wakeup is not lost. + -- Done with Caller locked to make sure that Wakeup is not lost if Ex /= Ada.Exceptions.Null_Id then Transfer_Occurrence @@ -844,7 +844,7 @@ package body System.Tasking.Rendezvous is Queuing.Select_Task_Entry_Call (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); - -- Determine the kind and disposition of the select. + -- Determine the kind and disposition of the select Treatment := Default_Treatment (Select_Mode); Self_Id.Chosen_Index := No_Rendezvous; @@ -865,7 +865,7 @@ package body System.Tasking.Rendezvous is end if; end if; - -- Handle the select according to the disposition selected above. + -- Handle the select according to the disposition selected above case Treatment is when Accept_Alternative_Selected => @@ -882,7 +882,8 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Self_Id); when Accept_Alternative_Completed => - -- Accept body is null, so rendezvous is over immediately. + + -- Accept body is null, so rendezvous is over immediately if Parameters.Runtime_Traces then Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); @@ -896,7 +897,8 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Caller); when Accept_Alternative_Open => - -- Wait for caller. + + -- Wait for caller Self_Id.Open_Accepts := Open_Accepts; pragma Debug @@ -913,9 +915,9 @@ package body System.Tasking.Rendezvous is -- Self_Id.Common.Call should already be updated by the Caller if -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abortion. - -- Therefore, if the call is not empty we need to do the - -- rendezvous if the accept body is not Null_Body. + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. -- Aren't the first two conditions below redundant??? @@ -949,7 +951,7 @@ package body System.Tasking.Rendezvous is Self_Id.Open_Accepts := Open_Accepts; Self_Id.Common.State := Acceptor_Sleep; - -- Notify ancestors that this task is on a terminate alternative. + -- Notify ancestors that this task is on a terminate alternative STPO.Unlock (Self_Id); Utilities.Make_Passive (Self_Id, Task_Completed => False); @@ -1154,7 +1156,7 @@ package body System.Tasking.Rendezvous is STPO.Write_Lock (Acceptor); - -- If the acceptor is not callable, abort the call and return False. + -- If the acceptor is not callable, abort the call and return False if not Acceptor.Callable then STPO.Unlock (Acceptor); @@ -1176,35 +1178,35 @@ package body System.Tasking.Rendezvous is return False; end if; - -- Try to serve the call immediately. + -- Try to serve the call immediately if Acceptor.Open_Accepts /= null then for J in Acceptor.Open_Accepts'Range loop if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then - -- Commit acceptor to rendezvous with us. + -- Commit acceptor to rendezvous with us Acceptor.Chosen_Index := J; Null_Body := Acceptor.Open_Accepts (J).Null_Body; Acceptor.Open_Accepts := null; - -- Prevent abort while call is being served. + -- Prevent abort while call is being served if Entry_Call.State = Now_Abortable then Entry_Call.State := Was_Abortable; end if; if Acceptor.Terminate_Alternative then - -- Cancel terminate alternative. - -- See matching code in Selective_Wait and - -- Vulnerable_Complete_Master. + + -- Cancel terminate alternative. See matching code in + -- Selective_Wait and Vulnerable_Complete_Master. Acceptor.Terminate_Alternative := False; Acceptor.Awake_Count := Acceptor.Awake_Count + 1; if Acceptor.Awake_Count = 1 then - -- Notify parent that acceptor is awake. + -- Notify parent that acceptor is awake pragma Assert (Parent.Awake_Count > 0); @@ -1220,7 +1222,8 @@ package body System.Tasking.Rendezvous is end if; if Null_Body then - -- Rendezvous is over immediately. + + -- Rendezvous is over immediately STPO.Wakeup (Acceptor, Acceptor_Sleep); STPO.Unlock (Acceptor); @@ -1237,8 +1240,8 @@ package body System.Tasking.Rendezvous is else Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); - -- For terminate_alternative, acceptor may not be - -- asleep yet, so we skip the wakeup + -- For terminate_alternative, acceptor may not be asleep + -- yet, so we skip the wakeup if Acceptor.Common.State /= Runnable then STPO.Wakeup (Acceptor, Acceptor_Sleep); @@ -1255,7 +1258,7 @@ package body System.Tasking.Rendezvous is end if; end loop; - -- The acceptor is accepting, but not this entry. + -- The acceptor is accepting, but not this entry end if; -- If the acceptor was ready to accept this call, @@ -1360,11 +1363,11 @@ package body System.Tasking.Rendezvous is else -- This is an asynchronous call - -- Abortion must already be deferred by the compiler-generated - -- code. Without this, an abortion that occurs between the time - -- that this call is made and the time that the abortable part's - -- cleanup handler is set up might miss the cleanup handler and - -- leave the call pending. + -- Abort must already be deferred by the compiler-generated code. + -- Without this, an abort that occurs between the time that this + -- call is made and the time that the abortable part's cleanup + -- handler is set up might miss the cleanup handler and leave the + -- call pending. Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; pragma Debug @@ -1421,7 +1424,7 @@ package body System.Tasking.Rendezvous is Unlock_RTS; end if; - -- Note: following assignment needs to be atomic. + -- Note: following assignment needs to be atomic Rendezvous_Successful := Entry_Call.State = Done; end if; @@ -1506,7 +1509,7 @@ package body System.Tasking.Rendezvous is Queuing.Select_Task_Entry_Call (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); - -- Determine the kind and disposition of the select. + -- Determine the kind and disposition of the select Treatment := Default_Treatment (Select_Mode); Self_Id.Chosen_Index := No_Rendezvous; @@ -1528,7 +1531,7 @@ package body System.Tasking.Rendezvous is end if; end if; - -- Handle the select according to the disposition selected above. + -- Handle the select according to the disposition selected above case Treatment is when Accept_Alternative_Selected => @@ -1555,7 +1558,8 @@ package body System.Tasking.Rendezvous is STPO.Unlock (Caller); when Accept_Alternative_Open => - -- Wait for caller. + + -- Wait for caller Self_Id.Open_Accepts := Open_Accepts; @@ -1563,9 +1567,8 @@ package body System.Tasking.Rendezvous is -- Wakeup_Time is reached. -- Try to remove calls to Sleep in the loop below by letting the - -- caller a chance of getting ready immediately, using Unlock & - -- Yield. - -- See similar action in Wait_For_Completion & Wait_For_Call. + -- caller a chance of getting ready immediately, using Unlock + -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. if Single_Lock then Unlock_RTS; @@ -1622,9 +1625,9 @@ package body System.Tasking.Rendezvous is -- Self_Id.Common.Call should already be updated by the Caller if -- not aborted. It might also be ready to do rendezvous even if - -- this wakes up due to an abortion. - -- Therefore, if the call is not empty we need to do the - -- rendezvous if the accept body is not Null_Body. + -- this wakes up due to an abort. Therefore, if the call is not + -- empty we need to do the rendezvous if the accept body is not + -- Null_Body. if Self_Id.Chosen_Index /= No_Rendezvous and then Self_Id.Common.Call /= null @@ -1648,7 +1651,7 @@ package body System.Tasking.Rendezvous is -- for several reasons: -- 1) Delay is expired -- 2) Pending_Action needs to be checked - -- (Abortion, Priority change) + -- (Abort, Priority change) -- 3) Spurious wakeup Self_Id.Open_Accepts := null; @@ -1753,7 +1756,7 @@ package body System.Tasking.Rendezvous is Entry_Call.Called_PO := Null_Address; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; - -- Note: the caller will undefer abortion on return (see WARNING above) + -- Note: the caller will undefer abort on return (see WARNING above) if Single_Lock then Lock_RTS; @@ -1820,7 +1823,7 @@ package body System.Tasking.Rendezvous is Write_Lock (Self_Id); end if; - -- Check if this task has been aborted while the lock was released. + -- Check if this task has been aborted while the lock was released if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then Self_Id.Open_Accepts := null; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 0355e61e4c5..2a47c70cdf9 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -36,24 +36,24 @@ pragma Polling (Off); -- tasking operations. It causes infinite loops and other problems. with Ada.Exceptions; --- used for Raise_Exception +-- Used for Raise_Exception with System.Tasking.Debug; --- used for enabling tasking facilities with gdb +-- Used for enabling tasking facilities with gdb with System.Address_Image; --- used for the function itself. +-- Used for the function itself with System.Parameters; --- used for Size_Type +-- Used for Size_Type -- Single_Lock -- Runtime_Traces with System.Task_Info; --- used for Task_Info_Type +-- Used for Task_Info_Type with System.Task_Primitives.Operations; --- used for Finalize_Lock +-- Used for Finalize_Lock -- Enter_Task -- Write_Lock -- Unlock @@ -64,11 +64,11 @@ with System.Task_Primitives.Operations; -- New_ATCB with System.Soft_Links; --- These are procedure pointers to non-tasking routines that use --- task specific data. In the absence of tasking, these routines --- refer to global data. In the presense of tasking, they must be --- replaced with pointers to task-specific versions. --- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep +-- These are procedure pointers to non-tasking routines that use task +-- specific data. In the absence of tasking, these routines refer to global +-- data. In the presense of tasking, they must be replaced with pointers to +-- task-specific versions. Also used for Create_TSD, Destroy_TSD, +-- Get_Current_Excep with System.Tasking.Initialization; -- Used for Remove_From_All_Tasks_List @@ -79,7 +79,7 @@ with System.Tasking.Initialization; -- Initialize_Attributes_Link pragma Elaborate_All (System.Tasking.Initialization); --- This insures that tasking is initialized if any tasks are created. +-- This insures that tasking is initialized if any tasks are created with System.Tasking.Utilities; -- Used for Make_Passive @@ -98,22 +98,22 @@ with System.Finalization_Implementation; -- Used for System.Finalization_Implementation.Finalize_Global_List with System.Secondary_Stack; --- used for SS_Init +-- Used for SS_Init with System.Storage_Elements; --- used for Storage_Array +-- Used for Storage_Array with System.Restrictions; --- used for Abort_Allowed +-- Used for Abort_Allowed with System.Standard_Library; --- used for Exception_Trace +-- Used for Exception_Trace with System.Traces.Tasking; --- used for Send_Trace_Info +-- Used for Send_Trace_Info with Unchecked_Deallocation; --- To recover from failure of ATCB initialization. +-- To recover from failure of ATCB initialization package body System.Tasking.Stages is @@ -787,11 +787,11 @@ package body System.Tasking.Stages is Self_ID.Callable := False; - -- Exit level 2 master, for normal tasks in library-level packages. + -- Exit level 2 master, for normal tasks in library-level packages Complete_Master; - -- Force termination of "independent" library-level server tasks. + -- Force termination of "independent" library-level server tasks Lock_RTS; @@ -977,7 +977,7 @@ package body System.Tasking.Stages is -- clean ups associated with the exception handler that need to -- access task specific data. - -- Defer abortion so that this task can't be aborted while exiting + -- Defer abort so that this task can't be aborted while exiting when Standard'Abort_Signal => Initialization.Defer_Abort_Nestable (Self_ID); @@ -1209,7 +1209,7 @@ package body System.Tasking.Stages is -- The activator raises a Tasking_Error if any task it is activating -- is completed before the activation is done. However, if the reason - -- for the task completion is an abortion, we do not raise an exception. + -- for the task completion is an abort, we do not raise an exception. -- See RM 9.2(5). if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then @@ -1392,7 +1392,7 @@ package body System.Tasking.Stages is pragma Assert (Self_ID.Common.Wait_Count = 0); - -- Force any remaining dependents to terminate, by aborting them. + -- Force any remaining dependents to terminate by aborting them if not Single_Lock then Lock_RTS; @@ -1461,8 +1461,8 @@ package body System.Tasking.Stages is Unlock (Self_ID); end if; - -- We don't wake up for abortion here. We are already terminating - -- just as fast as we can, so there is no point. + -- We don't wake up for abort here. We are already terminating just as + -- fast as we can, so there is no point. -- Remove terminated tasks from the list of Self_ID's dependents, but -- don't free their ATCBs yet, because of lock order restrictions, @@ -1687,7 +1687,7 @@ package body System.Tasking.Stages is -- Package elaboration code begin - -- Establish the Adafinal softlink. + -- Establish the Adafinal softlink -- This is not done inside the central RTS initialization routine -- to avoid with-ing this package from System.Tasking.Initialization. diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads index ba9ab044c77..c8e02329a0b 100644 --- a/gcc/ada/s-tassta.ads +++ b/gcc/ada/s-tassta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -121,9 +121,9 @@ package System.Tasking.Stages is -- activate_tasks (_chain'unchecked_access); procedure Abort_Tasks (Tasks : Task_List); - -- Compiler interface only. Do not call from within the RTS. - -- Initiate abortion, however, the actual abortion is done by abortee by - -- means of Abort_Handler and Abort_Undefer + -- Compiler interface only. Do not call from within the RTS. Initiate + -- abort, however, the actual abort is done by abortee by means of + -- Abort_Handler and Abort_Undefer -- -- source code: -- Abort T1, T2; diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads index 8a4708a6c95..685bc08cd81 100644 --- a/gcc/ada/s-tasuti.ads +++ b/gcc/ada/s-tasuti.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -72,9 +72,9 @@ package System.Tasking.Utilities is -- the environment task (because every independent task depends on it), -- this counter is protected by the environment task's lock. - ------------------------------------ - -- Task Abortion related routines -- - ------------------------------------ + --------------------------------- + -- Task Abort Related Routines -- + --------------------------------- procedure Cancel_Queued_Entry_Calls (T : Task_Id); -- Cancel any entry calls queued on target task. @@ -93,13 +93,13 @@ package System.Tasking.Utilities is -- (3) always aborts whole task procedure Abort_Tasks (Tasks : Task_List); - -- Abort_Tasks is called to initiate abortion, however, the actual - -- abortion is done by abortee by means of Abort_Handler + -- Abort_Tasks is called to initiate abort, however, the actual + -- aborti is done by aborted task by means of Abort_Handler 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 - -- Terminate_Task, and RTS_Lock when Single_Lock is True. + -- 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 Terminate_Task, and RTS_Lock when + -- Single_Lock is True. end System.Tasking.Utilities; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads index d8716cd02e4..7031a625ce0 100644 --- a/gcc/ada/s-tataat.ads +++ b/gcc/ada/s-tataat.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2004, Ada Core Technologies -- +-- Copyright (C) 1995-2005, Ada Core Technologies -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,13 +32,13 @@ -- -- ------------------------------------------------------------------------------ --- This package provides support for the body of Ada.Task_Attributes. +-- This package provides support for the body of Ada.Task_Attributes with Ada.Finalization; --- used for Limited_Controlled +-- Used for Limited_Controlled with System.Storage_Elements; --- used for Integer_Address +-- Used for Integer_Address package System.Tasking.Task_Attributes is @@ -52,8 +52,8 @@ package System.Tasking.Task_Attributes is function To_Access_Node is new Unchecked_Conversion (Access_Address, Access_Node); - -- Used to fetch pointer to indirect attribute list. Declaration is - -- in spec to avoid any problems with aliasing assumptions. + -- Used to fetch pointer to indirect attribute list. Declaration is in + -- spec to avoid any problems with aliasing assumptions. type Dummy_Wrapper; type Access_Dummy_Wrapper is access all Dummy_Wrapper; @@ -67,7 +67,7 @@ package System.Tasking.Task_Attributes is -- of type Wrapper, no Dummy_Wrapper objects are ever created. type Deallocator is access procedure (P : in out Access_Node); - -- Called to deallocate an Wrapper. P is a pointer to a Node within. + -- Called to deallocate an Wrapper. P is a pointer to a Node within type Instance; @@ -78,11 +78,11 @@ package System.Tasking.Task_Attributes is Initial_Value : aliased System.Storage_Elements.Integer_Address; Index : Direct_Index; - -- The index of the TCB location used by this instantiation, - -- if it is stored in the TCB, otherwise zero. + -- The index of the TCB location used by this instantiation, if it is + -- stored in the TCB, otherwise zero. Next : Access_Instance; - -- Next instance in All_Attributes list. + -- Next instance in All_Attributes list end record; procedure Finalize (X : in out Instance); @@ -93,12 +93,11 @@ package System.Tasking.Task_Attributes is Next : Access_Node; end record; - -- The following type is a stand-in for the actual - -- wrapper type, which is different for each instantiation - -- of Ada.Task_Attributes. + -- The following type is a stand-in for the actual wrapper type, which is + -- different for each instantiation of Ada.Task_Attributes. type Dummy_Wrapper is record - Noed : aliased Node; + Dummy_Node : aliased Node; Value : aliased Attribute; -- The generic formal type, may be controlled @@ -110,23 +109,23 @@ package System.Tasking.Task_Attributes is -- Ensure that the designated object is always strictly enough aligned. In_Use : Direct_Index_Vector := 0; - -- is True for direct indices that are already used. + -- Set True for direct indices that are already used (True??? type???) All_Attributes : Access_Instance; - -- A linked list of all indirectly access attributes, - -- which includes all those that require finalization. + -- A linked list of all indirectly access attributes, which includes all + -- those that require finalization. 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 + -- 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, abort must be deferred + -- and the caller must hold no locks 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 - -- soft-link Finalize_Attributes_Link. On entry, abortion must be deferred + -- soft-link Finalize_Attributes_Link. On entry, abort must be deferred -- and T.L must be write-locked. end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb index c1d7d3ccae4..650f756ff78 100644 --- a/gcc/ada/s-tpoben.adb +++ b/gcc/ada/s-tpoben.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,39 +31,40 @@ -- -- ------------------------------------------------------------------------------ --- This package contains all the simple primitives related to --- Protected_Objects with entries (i.e init, lock, unlock). +-- This package contains all the simple primitives related to protected +-- objects with entries (i.e init, lock, unlock). -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the complex routines for protected -- objects with entries in System.Tasking.Protected_Objects.Operations. + -- The split between Entries and Operations is needed to break circular -- dependencies inside the run time. --- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Note: the compiler generates direct calls to this interface, via Rtsfind with Ada.Exceptions; --- used for Exception_Occurrence_Access +-- Used for Exception_Occurrence_Access -- Raise_Exception with System.Task_Primitives.Operations; --- used for Initialize_Lock +-- Used for Initialize_Lock -- Write_Lock -- Unlock -- Get_Priority -- Wakeup with System.Tasking.Initialization; --- used for Defer_Abort, +-- Used for Defer_Abort, -- Undefer_Abort, -- Change_Base_Priority pragma Elaborate_All (System.Tasking.Initialization); --- this insures that tasking is initialized if any protected objects are +-- This insures that tasking is initialized if any protected objects are -- created. with System.Parameters; --- used for Single_Lock +-- Used for Single_Lock package body System.Tasking.Protected_Objects.Entries is @@ -103,8 +104,9 @@ package body System.Tasking.Protected_Objects.Entries is end if; if Ceiling_Violation then - -- Dip our own priority down to ceiling of lock. - -- See similar code in Tasking.Entry_Calls.Lock_Server. + + -- Dip our own priority down to ceiling of lock. See similar code in + -- Tasking.Entry_Calls.Lock_Server. STPO.Write_Lock (Self_ID); Old_Base_Priority := Self_ID.Common.Base_Priority; @@ -130,7 +132,7 @@ package body System.Tasking.Protected_Objects.Entries is Object.Pending_Action := True; end if; - -- Send program_error to all tasks still queued on this object. + -- Send program_error to all tasks still queued on this object for E in Object.Entry_Queues'Range loop Entry_Call := Object.Entry_Queues (E).Head; @@ -229,10 +231,10 @@ package body System.Tasking.Protected_Objects.Entries is (Program_Error'Identity, "Protected Object is finalized"); end if; - -- If pragma Detect_Blocking is active then Program_Error must - -- be raised if this potentially blocking operation is called from - -- a protected action, and the protected object nesting level - -- must be increased. + -- If pragma Detect_Blocking is active then Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action, and the protected object nesting level must be + -- increased. if Detect_Blocking then declare @@ -242,8 +244,8 @@ package body System.Tasking.Protected_Objects.Entries is Ada.Exceptions.Raise_Exception (Program_Error'Identity, "potentially blocking operation"); else - -- We are entering in a protected action, so that we - -- increase the protected object nesting level. + -- We are entering in a protected action, so that we increase + -- the protected object nesting level. Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; @@ -251,15 +253,15 @@ package body System.Tasking.Protected_Objects.Entries is end; end if; - -- The lock is made without defering abortion. + -- The lock is made without defering abort - -- Therefore the abortion has to be deferred before calling this - -- routine. This means that the compiler has to generate a Defer_Abort - -- call before the call to Lock. + -- Therefore the abort has to be deferred before calling this routine. + -- This means that the compiler has to generate a Defer_Abort call + -- before the call to Lock. - -- The caller is responsible for undeferring abortion, and compiler + -- The caller is responsible for undeferring abort, and compiler -- generated calls must be protected with cleanup handlers to ensure - -- that abortion is undeferred in all cases. + -- that abort is undeferred in all cases. pragma Assert (STPO.Self.Deferral_Level > 0); Write_Lock (Object.L'Access, Ceiling_Violation); @@ -302,8 +304,8 @@ package body System.Tasking.Protected_Objects.Entries is Ada.Exceptions.Raise_Exception (Program_Error'Identity, "potentially blocking operation"); else - -- We are entering in a protected action, so that we - -- increase the protected object nesting level. + -- We are entering in a protected action, so that we increase + -- the protected object nesting level. Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads index c53e59e0fc5..09904f1d34d 100644 --- a/gcc/ada/s-tpobop.ads +++ b/gcc/ada/s-tpobop.ads @@ -2,12 +2,11 @@ -- -- -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- --- O P E R A T I O N S -- +-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,19 +31,20 @@ -- -- ------------------------------------------------------------------------------ --- This package contains all the extended primitives related to --- Protected_Objects with entries. +-- This package contains all the extended primitives related to protected +-- objects with entries. + -- The handling of protected objects with no entries is done in -- System.Tasking.Protected_Objects, the simple routines for protected --- objects with entries in System.Tasking.Protected_Objects.Entries. --- The split between Entries and Operations is needed to break circular +-- objects with entries in System.Tasking.Protected_Objects.Entries. The +-- split between Entries and Operations is needed to break circular -- dependencies inside the run time. -- Note: the compiler generates direct calls to this interface, via Rtsfind. -- Any changes to this interface may require corresponding compiler changes. with Ada.Exceptions; --- used for Exception_Id +-- Used for Exception_Id with System.Tasking.Protected_Objects.Entries; @@ -108,7 +108,7 @@ package System.Tasking.Protected_Objects.Operations is -- barriers, so this routine keeps checking barriers until all of -- them are closed. -- - -- This must be called with abortion deferred and with the corresponding + -- This must be called with abort deferred and with the corresponding -- object locked. -- -- If Unlock_Object is set True, then Object is unlocked on return, @@ -173,7 +173,7 @@ package System.Tasking.Protected_Objects.Operations is (Object : Entries.Protection_Entries'Class; E : Protected_Entry_Index) return Natural; - -- Return the number of entry calls to E on Object. + -- Return the number of entry calls to E on Object function Protected_Entry_Caller (Object : Entries.Protection_Entries'Class) return Task_Id; @@ -181,7 +181,7 @@ package System.Tasking.Protected_Objects.Operations is -- 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: + -- For internal use only procedure PO_Do_Or_Queue (Self_ID : Task_Id; @@ -189,7 +189,7 @@ package System.Tasking.Protected_Objects.Operations is Entry_Call : Entry_Call_Link; With_Abort : Boolean); -- This procedure either executes or queues an entry call, depending - -- on the status of the corresponding barrier. It assumes that abortion + -- on the status of the corresponding barrier. It assumes that abort -- is deferred and that the specified object is locked. private @@ -201,10 +201,9 @@ private pragma Volatile (Communication_Block); -- ????? - -- The Communication_Block seems to be a relic. - -- At the moment, the compiler seems to be generating - -- unnecessary conditional code based on this block. - -- See the code generated for async. select with task entry + -- The Communication_Block seems to be a relic. At the moment, the + -- compiler seems to be generating unnecessary conditional code based on + -- this block. See the code generated for async. select with task entry -- call for another way of solving this. end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index c80da272b76..ee6e8bb5151 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -1,1049 +1,1049 @@ -------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S N A M E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Namet; use Namet;
-with Table;
-
-package body Snames is
-
- -- Table used to record convention identifiers
-
- type Convention_Id_Entry is record
- Name : Name_Id;
- Convention : Convention_Id;
- end record;
-
- package Convention_Identifiers is new Table.Table (
- Table_Component_Type => Convention_Id_Entry,
- Table_Index_Type => Int,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 200,
- Table_Name => "Name_Convention_Identifiers");
-
- -- Table of names to be set by Initialize. Each name is terminated by a
- -- single #, and the end of the list is marked by a null entry, i.e. by
- -- two # marks in succession. Note that the table does not include the
- -- entries for a-z, since these are initialized by Namet itself.
-
- Preset_Names : constant String :=
- "_parent#" &
- "_tag#" &
- "off#" &
- "space#" &
- "time#" &
- "_abort_signal#" &
- "_alignment#" &
- "_assign#" &
- "_atcb#" &
- "_chain#" &
- "_clean#" &
- "_controller#" &
- "_entry_bodies#" &
- "_expunge#" &
- "_final_list#" &
- "_idepth#" &
- "_init#" &
- "_local_final_list#" &
- "_master#" &
- "_object#" &
- "_priority#" &
- "_process_atsd#" &
- "_secondary_stack#" &
- "_service#" &
- "_size#" &
- "_stack#" &
- "_tags#" &
- "_task#" &
- "_task_id#" &
- "_task_info#" &
- "_task_name#" &
- "_trace_sp#" &
- "initialize#" &
- "adjust#" &
- "finalize#" &
- "next#" &
- "prev#" &
- "_typecode#" &
- "_from_any#" &
- "_to_any#" &
- "allocate#" &
- "deallocate#" &
- "dereference#" &
- "decimal_io#" &
- "enumeration_io#" &
- "fixed_io#" &
- "float_io#" &
- "integer_io#" &
- "modular_io#" &
- "const#" &
- "<error>#" &
- "go#" &
- "put#" &
- "put_line#" &
- "to#" &
- "finalization#" &
- "finalization_root#" &
- "interfaces#" &
- "standard#" &
- "system#" &
- "text_io#" &
- "wide_text_io#" &
- "wide_wide_text_io#" &
- "no_dsa#" &
- "garlic_dsa#" &
- "polyorb_dsa#" &
- "addr#" &
- "async#" &
- "get_active_partition_id#" &
- "get_rci_package_receiver#" &
- "get_rci_package_ref#" &
- "origin#" &
- "params#" &
- "partition#" &
- "partition_interface#" &
- "ras#" &
- "call#" &
- "rci_name#" &
- "receiver#" &
- "result#" &
- "rpc#" &
- "subp_id#" &
- "operation#" &
- "argument#" &
- "arg_modes#" &
- "handler#" &
- "target#" &
- "req#" &
- "obj_typecode#" &
- "stub#" &
- "Oabs#" &
- "Oand#" &
- "Omod#" &
- "Onot#" &
- "Oor#" &
- "Orem#" &
- "Oxor#" &
- "Oeq#" &
- "One#" &
- "Olt#" &
- "Ole#" &
- "Ogt#" &
- "Oge#" &
- "Oadd#" &
- "Osubtract#" &
- "Oconcat#" &
- "Omultiply#" &
- "Odivide#" &
- "Oexpon#" &
- "ada_83#" &
- "ada_95#" &
- "ada_05#" &
- "c_pass_by_copy#" &
- "compile_time_warning#" &
- "component_alignment#" &
- "convention_identifier#" &
- "detect_blocking#" &
- "discard_names#" &
- "elaboration_checks#" &
- "eliminate#" &
- "explicit_overriding#" &
- "extend_system#" &
- "extensions_allowed#" &
- "external_name_casing#" &
- "float_representation#" &
- "initialize_scalars#" &
- "interrupt_state#" &
- "license#" &
- "locking_policy#" &
- "long_float#" &
- "no_run_time#" &
- "no_strict_aliasing#" &
- "normalize_scalars#" &
- "polling#" &
- "persistent_data#" &
- "persistent_object#" &
- "profile#" &
- "profile_warnings#" &
- "propagate_exceptions#" &
- "queuing_policy#" &
- "ravenscar#" &
- "restricted_run_time#" &
- "restrictions#" &
- "restriction_warnings#" &
- "reviewable#" &
- "source_file_name#" &
- "source_file_name_project#" &
- "style_checks#" &
- "suppress#" &
- "suppress_exception_locations#" &
- "task_dispatching_policy#" &
- "universal_data#" &
- "unsuppress#" &
- "use_vads_size#" &
- "validity_checks#" &
- "warnings#" &
- "abort_defer#" &
- "all_calls_remote#" &
- "annotate#" &
- "assert#" &
- "asynchronous#" &
- "atomic#" &
- "atomic_components#" &
- "attach_handler#" &
- "comment#" &
- "common_object#" &
- "complex_representation#" &
- "controlled#" &
- "convention#" &
- "cpp_class#" &
- "cpp_constructor#" &
- "cpp_virtual#" &
- "cpp_vtable#" &
- "debug#" &
- "elaborate#" &
- "elaborate_all#" &
- "elaborate_body#" &
- "export#" &
- "export_exception#" &
- "export_function#" &
- "export_object#" &
- "export_procedure#" &
- "export_value#" &
- "export_valued_procedure#" &
- "external#" &
- "finalize_storage_only#" &
- "ident#" &
- "import#" &
- "import_exception#" &
- "import_function#" &
- "import_object#" &
- "import_procedure#" &
- "import_valued_procedure#" &
- "inline#" &
- "inline_always#" &
- "inline_generic#" &
- "inspection_point#" &
- "interface_name#" &
- "interrupt_handler#" &
- "interrupt_priority#" &
- "java_constructor#" &
- "java_interface#" &
- "keep_names#" &
- "link_with#" &
- "linker_alias#" &
- "linker_options#" &
- "linker_section#" &
- "list#" &
- "machine_attribute#" &
- "main#" &
- "main_storage#" &
- "memory_size#" &
- "no_return#" &
- "obsolescent#" &
- "optimize#" &
- "optional_overriding#" &
- "pack#" &
- "page#" &
- "passive#" &
- "preelaborate#" &
- "priority#" &
- "psect_object#" &
- "pure#" &
- "pure_function#" &
- "remote_call_interface#" &
- "remote_types#" &
- "share_generic#" &
- "shared#" &
- "shared_passive#" &
- "source_reference#" &
- "stream_convert#" &
- "subtitle#" &
- "suppress_all#" &
- "suppress_debug_info#" &
- "suppress_initialization#" &
- "system_name#" &
- "task_info#" &
- "task_name#" &
- "task_storage#" &
- "thread_body#" &
- "time_slice#" &
- "title#" &
- "unchecked_union#" &
- "unimplemented_unit#" &
- "unreferenced#" &
- "unreserve_all_interrupts#" &
- "volatile#" &
- "volatile_components#" &
- "weak_external#" &
- "ada#" &
- "assembler#" &
- "cobol#" &
- "cpp#" &
- "fortran#" &
- "intrinsic#" &
- "java#" &
- "stdcall#" &
- "stubbed#" &
- "asm#" &
- "assembly#" &
- "default#" &
- "dll#" &
- "win32#" &
- "as_is#" &
- "body_file_name#" &
- "boolean_entry_barriers#" &
- "casing#" &
- "code#" &
- "component#" &
- "component_size_4#" &
- "copy#" &
- "d_float#" &
- "descriptor#" &
- "dot_replacement#" &
- "dynamic#" &
- "entity#" &
- "external_name#" &
- "first_optional_parameter#" &
- "form#" &
- "g_float#" &
- "gcc#" &
- "gnat#" &
- "gpl#" &
- "ieee_float#" &
- "internal#" &
- "link_name#" &
- "lowercase#" &
- "max_entry_queue_depth#" &
- "max_entry_queue_length#" &
- "max_size#" &
- "mechanism#" &
- "mixedcase#" &
- "modified_gpl#" &
- "name#" &
- "nca#" &
- "no#" &
- "no_dependence#" &
- "no_dynamic_attachment#" &
- "no_dynamic_interrupts#" &
- "no_requeue#" &
- "no_requeue_statements#" &
- "no_task_attributes#" &
- "no_task_attributes_package#" &
- "on#" &
- "parameter_types#" &
- "reference#" &
- "restricted#" &
- "result_mechanism#" &
- "result_type#" &
- "runtime#" &
- "sb#" &
- "secondary_stack_size#" &
- "section#" &
- "semaphore#" &
- "simple_barriers#" &
- "spec_file_name#" &
- "static#" &
- "stack_size#" &
- "subunit_file_name#" &
- "task_stack_size_default#" &
- "task_type#" &
- "time_slicing_enabled#" &
- "top_guard#" &
- "uba#" &
- "ubs#" &
- "ubsb#" &
- "unit_name#" &
- "unknown#" &
- "unrestricted#" &
- "uppercase#" &
- "user#" &
- "vax_float#" &
- "vms#" &
- "working_storage#" &
- "abort_signal#" &
- "access#" &
- "address#" &
- "address_size#" &
- "aft#" &
- "alignment#" &
- "asm_input#" &
- "asm_output#" &
- "ast_entry#" &
- "bit#" &
- "bit_order#" &
- "bit_position#" &
- "body_version#" &
- "callable#" &
- "caller#" &
- "code_address#" &
- "component_size#" &
- "compose#" &
- "constrained#" &
- "count#" &
- "default_bit_order#" &
- "definite#" &
- "delta#" &
- "denorm#" &
- "digits#" &
- "elaborated#" &
- "emax#" &
- "enum_rep#" &
- "epsilon#" &
- "exponent#" &
- "external_tag#" &
- "first#" &
- "first_bit#" &
- "fixed_value#" &
- "fore#" &
- "has_access_values#" &
- "has_discriminants#" &
- "identity#" &
- "img#" &
- "integer_value#" &
- "large#" &
- "last#" &
- "last_bit#" &
- "leading_part#" &
- "length#" &
- "machine_emax#" &
- "machine_emin#" &
- "machine_mantissa#" &
- "machine_overflows#" &
- "machine_radix#" &
- "machine_rounds#" &
- "machine_size#" &
- "mantissa#" &
- "max_size_in_storage_elements#" &
- "maximum_alignment#" &
- "mechanism_code#" &
- "mod#" &
- "model_emin#" &
- "model_epsilon#" &
- "model_mantissa#" &
- "model_small#" &
- "modulus#" &
- "null_parameter#" &
- "object_size#" &
- "partition_id#" &
- "passed_by_reference#" &
- "pool_address#" &
- "pos#" &
- "position#" &
- "range#" &
- "range_length#" &
- "round#" &
- "safe_emax#" &
- "safe_first#" &
- "safe_large#" &
- "safe_last#" &
- "safe_small#" &
- "scale#" &
- "scaling#" &
- "signed_zeros#" &
- "size#" &
- "small#" &
- "storage_size#" &
- "storage_unit#" &
- "stream_size#" &
- "tag#" &
- "target_name#" &
- "terminated#" &
- "to_address#" &
- "type_class#" &
- "uet_address#" &
- "unbiased_rounding#" &
- "unchecked_access#" &
- "unconstrained_array#" &
- "universal_literal_string#" &
- "unrestricted_access#" &
- "vads_size#" &
- "val#" &
- "valid#" &
- "value_size#" &
- "version#" &
- "wchar_t_size#" &
- "wide_wide_width#" &
- "wide_width#" &
- "width#" &
- "word_size#" &
- "adjacent#" &
- "ceiling#" &
- "copy_sign#" &
- "floor#" &
- "fraction#" &
- "image#" &
- "input#" &
- "machine#" &
- "max#" &
- "min#" &
- "model#" &
- "pred#" &
- "remainder#" &
- "rounding#" &
- "succ#" &
- "truncation#" &
- "value#" &
- "wide_image#" &
- "wide_wide_image#" &
- "wide_value#" &
- "wide_wide_value#" &
- "output#" &
- "read#" &
- "write#" &
- "elab_body#" &
- "elab_spec#" &
- "storage_pool#" &
- "base#" &
- "class#" &
- "ceiling_locking#" &
- "inheritance_locking#" &
- "fifo_queuing#" &
- "priority_queuing#" &
- "fifo_within_priorities#" &
- "access_check#" &
- "accessibility_check#" &
- "discriminant_check#" &
- "division_check#" &
- "elaboration_check#" &
- "index_check#" &
- "length_check#" &
- "overflow_check#" &
- "range_check#" &
- "storage_check#" &
- "tag_check#" &
- "all_checks#" &
- "abort#" &
- "abs#" &
- "accept#" &
- "and#" &
- "all#" &
- "array#" &
- "at#" &
- "begin#" &
- "body#" &
- "case#" &
- "constant#" &
- "declare#" &
- "delay#" &
- "do#" &
- "else#" &
- "elsif#" &
- "end#" &
- "entry#" &
- "exception#" &
- "exit#" &
- "for#" &
- "function#" &
- "generic#" &
- "goto#" &
- "if#" &
- "in#" &
- "is#" &
- "limited#" &
- "loop#" &
- "new#" &
- "not#" &
- "null#" &
- "of#" &
- "or#" &
- "others#" &
- "out#" &
- "package#" &
- "pragma#" &
- "private#" &
- "procedure#" &
- "raise#" &
- "record#" &
- "rem#" &
- "renames#" &
- "return#" &
- "reverse#" &
- "select#" &
- "separate#" &
- "subtype#" &
- "task#" &
- "terminate#" &
- "then#" &
- "type#" &
- "use#" &
- "when#" &
- "while#" &
- "with#" &
- "xor#" &
- "divide#" &
- "enclosing_entity#" &
- "exception_information#" &
- "exception_message#" &
- "exception_name#" &
- "file#" &
- "import_address#" &
- "import_largest_value#" &
- "import_value#" &
- "is_negative#" &
- "line#" &
- "rotate_left#" &
- "rotate_right#" &
- "shift_left#" &
- "shift_right#" &
- "shift_right_arithmetic#" &
- "source_location#" &
- "unchecked_conversion#" &
- "unchecked_deallocation#" &
- "to_pointer#" &
- "abstract#" &
- "aliased#" &
- "protected#" &
- "until#" &
- "requeue#" &
- "tagged#" &
- "raise_exception#" &
- "ada_roots#" &
- "binder#" &
- "binder_driver#" &
- "body_suffix#" &
- "builder#" &
- "compiler#" &
- "compiler_driver#" &
- "compiler_kind#" &
- "compute_dependency#" &
- "cross_reference#" &
- "default_linker#" &
- "default_switches#" &
- "dependency_option#" &
- "exec_dir#" &
- "executable#" &
- "executable_suffix#" &
- "extends#" &
- "externally_built#" &
- "finder#" &
- "global_configuration_pragmas#" &
- "gnatls#" &
- "gnatstub#" &
- "implementation#" &
- "implementation_exceptions#" &
- "implementation_suffix#" &
- "include_option#" &
- "language_processing#" &
- "languages#" &
- "library_dir#" &
- "library_auto_init#" &
- "library_gcc#" &
- "library_interface#" &
- "library_kind#" &
- "library_name#" &
- "library_options#" &
- "library_reference_symbol_file#" &
- "library_src_dir#" &
- "library_symbol_file#" &
- "library_symbol_policy#" &
- "library_version#" &
- "linker#" &
- "local_configuration_pragmas#" &
- "locally_removed_files#" &
- "metrics#" &
- "naming#" &
- "object_dir#" &
- "pretty_printer#" &
- "project#" &
- "separate_suffix#" &
- "source_dirs#" &
- "source_files#" &
- "source_list_file#" &
- "spec#" &
- "spec_suffix#" &
- "specification#" &
- "specification_exceptions#" &
- "specification_suffix#" &
- "switches#" &
- "unaligned_valid#" &
- "interface#" &
- "overriding#" &
- "synchronized#" &
- "#";
-
- ---------------------
- -- Generated Names --
- ---------------------
-
- -- This section lists the various cases of generated names which are
- -- built from existing names by adding unique leading and/or trailing
- -- upper case letters. In some cases these names are built recursively,
- -- in particular names built from types may be built from types which
- -- themselves have generated names. In this list, xxx represents an
- -- existing name to which identifying letters are prepended or appended,
- -- and a trailing n represents a serial number in an external name that
- -- has some semantic significance (e.g. the n'th index type of an array).
-
- -- xxxA access type for formal xxx in entry param record (Exp_Ch9)
- -- xxxB tag table for tagged type xxx (Exp_Ch3)
- -- xxxB task body procedure for task xxx (Exp_Ch9)
- -- xxxD dispatch table for tagged type xxx (Exp_Ch3)
- -- xxxD discriminal for discriminant xxx (Sem_Ch3)
- -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3)
- -- xxxE elaboration boolean flag for task xxx (Exp_Ch9)
- -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
- -- xxxE parameters for accept body for entry xxx (Exp_Ch9)
- -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
- -- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
- -- xxxM master Id value for access type xxx (Exp_Ch3)
- -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
- -- xxxP parameter record type for entry xxx (Exp_Ch9)
- -- xxxPA access to parameter record type for entry xxx (Exp_Ch9)
- -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3)
- -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3)
- -- xxxT tag table type for tagged type xxx (Exp_Ch3)
- -- xxxT literal table for enumeration type xxx (Sem_Ch3)
- -- xxxV type for task value record for task xxx (Exp_Ch9)
- -- xxxX entry index constant (Exp_Ch9)
- -- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
- -- xxxZ size variable for task xxx (Exp_Ch9)
-
- -- TSS names
-
- -- xxxDA deep adjust routine for type xxx (Exp_TSS)
- -- xxxDF deep finalize routine for type xxx (Exp_TSS)
- -- xxxDI deep initialize routine for type xxx (Exp_TSS)
- -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
- -- xxxIP initialization procedure for type xxx (Exp_TSS)
- -- xxxRA RAs type access routine for type xxx (Exp_TSS)
- -- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
- -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
- -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS)
- -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
- -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
- -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
- -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
-
- -- Implicit type names
-
- -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
-
- -- (Note: this list is not complete or accurate ???)
-
- ----------------------
- -- Get_Attribute_Id --
- ----------------------
-
- function Get_Attribute_Id (N : Name_Id) return Attribute_Id is
- begin
- return Attribute_Id'Val (N - First_Attribute_Name);
- end Get_Attribute_Id;
-
- ------------------
- -- Get_Check_Id --
- ------------------
-
- function Get_Check_Id (N : Name_Id) return Check_Id is
- begin
- return Check_Id'Val (N - First_Check_Name);
- end Get_Check_Id;
-
- -----------------------
- -- Get_Convention_Id --
- -----------------------
-
- function Get_Convention_Id (N : Name_Id) return Convention_Id is
- begin
- case N is
- when Name_Ada => return Convention_Ada;
- when Name_Assembler => return Convention_Assembler;
- when Name_C => return Convention_C;
- when Name_COBOL => return Convention_COBOL;
- when Name_CPP => return Convention_CPP;
- when Name_Fortran => return Convention_Fortran;
- when Name_Intrinsic => return Convention_Intrinsic;
- when Name_Java => return Convention_Java;
- when Name_Stdcall => return Convention_Stdcall;
- when Name_Stubbed => return Convention_Stubbed;
-
- -- If no direct match, then we must have a convention
- -- identifier pragma that has specified this name.
-
- when others =>
- for J in 1 .. Convention_Identifiers.Last loop
- if N = Convention_Identifiers.Table (J).Name then
- return Convention_Identifiers.Table (J).Convention;
- end if;
- end loop;
-
- raise Program_Error;
- end case;
- end Get_Convention_Id;
-
- ---------------------------
- -- Get_Locking_Policy_Id --
- ---------------------------
-
- function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is
- begin
- return Locking_Policy_Id'Val (N - First_Locking_Policy_Name);
- end Get_Locking_Policy_Id;
-
- -------------------
- -- Get_Pragma_Id --
- -------------------
-
- function Get_Pragma_Id (N : Name_Id) return Pragma_Id is
- begin
- if N = Name_AST_Entry then
- return Pragma_AST_Entry;
- elsif N = Name_Interface then
- return Pragma_Interface;
- elsif N = Name_Storage_Size then
- return Pragma_Storage_Size;
- elsif N = Name_Storage_Unit then
- return Pragma_Storage_Unit;
- elsif N not in First_Pragma_Name .. Last_Pragma_Name then
- return Unknown_Pragma;
- else
- return Pragma_Id'Val (N - First_Pragma_Name);
- end if;
- end Get_Pragma_Id;
-
- ---------------------------
- -- Get_Queuing_Policy_Id --
- ---------------------------
-
- function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is
- begin
- return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name);
- end Get_Queuing_Policy_Id;
-
- ------------------------------------
- -- Get_Task_Dispatching_Policy_Id --
- ------------------------------------
-
- function Get_Task_Dispatching_Policy_Id (N : Name_Id)
- return Task_Dispatching_Policy_Id is
- begin
- return Task_Dispatching_Policy_Id'Val
- (N - First_Task_Dispatching_Policy_Name);
- end Get_Task_Dispatching_Policy_Id;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- P_Index : Natural;
- Discard_Name : Name_Id;
-
- begin
- P_Index := Preset_Names'First;
-
- loop
- Name_Len := 0;
-
- while Preset_Names (P_Index) /= '#' loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Preset_Names (P_Index);
- P_Index := P_Index + 1;
- end loop;
-
- -- We do the Name_Find call to enter the name into the table, but
- -- we don't need to do anything with the result, since we already
- -- initialized all the preset names to have the right value (we
- -- are depending on the order of the names and Preset_Names).
-
- Discard_Name := Name_Find;
- P_Index := P_Index + 1;
- exit when Preset_Names (P_Index) = '#';
- end loop;
-
- -- Make sure that number of names in standard table is correct. If
- -- this check fails, run utility program XSNAMES to construct a new
- -- properly matching version of the body.
-
- pragma Assert (Discard_Name = Last_Predefined_Name);
-
- -- Initialize the convention identifiers table with the standard
- -- set of synonyms that we recognize for conventions.
-
- Convention_Identifiers.Init;
-
- Convention_Identifiers.Append ((Name_Asm, Convention_Assembler));
- Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler));
-
- Convention_Identifiers.Append ((Name_Default, Convention_C));
- Convention_Identifiers.Append ((Name_External, Convention_C));
-
- Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall));
- Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall));
- end Initialize;
-
- -----------------------
- -- Is_Attribute_Name --
- -----------------------
-
- function Is_Attribute_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Attribute_Name .. Last_Attribute_Name;
- end Is_Attribute_Name;
-
- -------------------
- -- Is_Check_Name --
- -------------------
-
- function Is_Check_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Check_Name .. Last_Check_Name;
- end Is_Check_Name;
-
- ------------------------
- -- Is_Convention_Name --
- ------------------------
-
- function Is_Convention_Name (N : Name_Id) return Boolean is
- begin
- -- Check if this is one of the standard conventions
-
- if N in First_Convention_Name .. Last_Convention_Name
- or else N = Name_C
- then
- return True;
-
- -- Otherwise check if it is in convention identifier table
-
- else
- for J in 1 .. Convention_Identifiers.Last loop
- if N = Convention_Identifiers.Table (J).Name then
- return True;
- end if;
- end loop;
-
- return False;
- end if;
- end Is_Convention_Name;
-
- ------------------------------
- -- Is_Entity_Attribute_Name --
- ------------------------------
-
- function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name;
- end Is_Entity_Attribute_Name;
-
- --------------------------------
- -- Is_Function_Attribute_Name --
- --------------------------------
-
- function Is_Function_Attribute_Name (N : Name_Id) return Boolean is
- begin
- return N in
- First_Renamable_Function_Attribute ..
- Last_Renamable_Function_Attribute;
- end Is_Function_Attribute_Name;
-
- ----------------------------
- -- Is_Locking_Policy_Name --
- ----------------------------
-
- function Is_Locking_Policy_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name;
- end Is_Locking_Policy_Name;
-
- -----------------------------
- -- Is_Operator_Symbol_Name --
- -----------------------------
-
- function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Operator_Name .. Last_Operator_Name;
- end Is_Operator_Symbol_Name;
-
- --------------------
- -- Is_Pragma_Name --
- --------------------
-
- function Is_Pragma_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Pragma_Name .. Last_Pragma_Name
- or else N = Name_AST_Entry
- or else N = Name_Interface
- or else N = Name_Storage_Size
- or else N = Name_Storage_Unit;
- end Is_Pragma_Name;
-
- ---------------------------------
- -- Is_Procedure_Attribute_Name --
- ---------------------------------
-
- function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Procedure_Attribute .. Last_Procedure_Attribute;
- end Is_Procedure_Attribute_Name;
-
- ----------------------------
- -- Is_Queuing_Policy_Name --
- ----------------------------
-
- function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name;
- end Is_Queuing_Policy_Name;
-
- -------------------------------------
- -- Is_Task_Dispatching_Policy_Name --
- -------------------------------------
-
- function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Task_Dispatching_Policy_Name ..
- Last_Task_Dispatching_Policy_Name;
- end Is_Task_Dispatching_Policy_Name;
-
- ----------------------------
- -- Is_Type_Attribute_Name --
- ----------------------------
-
- function Is_Type_Attribute_Name (N : Name_Id) return Boolean is
- begin
- return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name;
- end Is_Type_Attribute_Name;
-
- ----------------------------------
- -- Record_Convention_Identifier --
- ----------------------------------
-
- procedure Record_Convention_Identifier
- (Id : Name_Id;
- Convention : Convention_Id)
- is
- begin
- Convention_Identifiers.Append ((Id, Convention));
- end Record_Convention_Identifier;
-
-end Snames;
+------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S N A M E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Table; + +package body Snames is + + -- Table used to record convention identifiers + + type Convention_Id_Entry is record + Name : Name_Id; + Convention : Convention_Id; + end record; + + package Convention_Identifiers is new Table.Table ( + Table_Component_Type => Convention_Id_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 200, + Table_Name => "Name_Convention_Identifiers"); + + -- Table of names to be set by Initialize. Each name is terminated by a + -- single #, and the end of the list is marked by a null entry, i.e. by + -- two # marks in succession. Note that the table does not include the + -- entries for a-z, since these are initialized by Namet itself. + + Preset_Names : constant String := + "_parent#" & + "_tag#" & + "off#" & + "space#" & + "time#" & + "_abort_signal#" & + "_alignment#" & + "_assign#" & + "_atcb#" & + "_chain#" & + "_clean#" & + "_controller#" & + "_entry_bodies#" & + "_expunge#" & + "_final_list#" & + "_idepth#" & + "_init#" & + "_local_final_list#" & + "_master#" & + "_object#" & + "_priority#" & + "_process_atsd#" & + "_secondary_stack#" & + "_service#" & + "_size#" & + "_stack#" & + "_tags#" & + "_task#" & + "_task_id#" & + "_task_info#" & + "_task_name#" & + "_trace_sp#" & + "initialize#" & + "adjust#" & + "finalize#" & + "next#" & + "prev#" & + "_typecode#" & + "_from_any#" & + "_to_any#" & + "allocate#" & + "deallocate#" & + "dereference#" & + "decimal_io#" & + "enumeration_io#" & + "fixed_io#" & + "float_io#" & + "integer_io#" & + "modular_io#" & + "const#" & + "<error>#" & + "go#" & + "put#" & + "put_line#" & + "to#" & + "finalization#" & + "finalization_root#" & + "interfaces#" & + "standard#" & + "system#" & + "text_io#" & + "wide_text_io#" & + "wide_wide_text_io#" & + "no_dsa#" & + "garlic_dsa#" & + "polyorb_dsa#" & + "addr#" & + "async#" & + "get_active_partition_id#" & + "get_rci_package_receiver#" & + "get_rci_package_ref#" & + "origin#" & + "params#" & + "partition#" & + "partition_interface#" & + "ras#" & + "call#" & + "rci_name#" & + "receiver#" & + "result#" & + "rpc#" & + "subp_id#" & + "operation#" & + "argument#" & + "arg_modes#" & + "handler#" & + "target#" & + "req#" & + "obj_typecode#" & + "stub#" & + "Oabs#" & + "Oand#" & + "Omod#" & + "Onot#" & + "Oor#" & + "Orem#" & + "Oxor#" & + "Oeq#" & + "One#" & + "Olt#" & + "Ole#" & + "Ogt#" & + "Oge#" & + "Oadd#" & + "Osubtract#" & + "Oconcat#" & + "Omultiply#" & + "Odivide#" & + "Oexpon#" & + "ada_83#" & + "ada_95#" & + "ada_05#" & + "c_pass_by_copy#" & + "compile_time_warning#" & + "component_alignment#" & + "convention_identifier#" & + "detect_blocking#" & + "discard_names#" & + "elaboration_checks#" & + "eliminate#" & + "explicit_overriding#" & + "extend_system#" & + "extensions_allowed#" & + "external_name_casing#" & + "float_representation#" & + "initialize_scalars#" & + "interrupt_state#" & + "license#" & + "locking_policy#" & + "long_float#" & + "no_run_time#" & + "no_strict_aliasing#" & + "normalize_scalars#" & + "polling#" & + "persistent_data#" & + "persistent_object#" & + "profile#" & + "profile_warnings#" & + "propagate_exceptions#" & + "queuing_policy#" & + "ravenscar#" & + "restricted_run_time#" & + "restrictions#" & + "restriction_warnings#" & + "reviewable#" & + "source_file_name#" & + "source_file_name_project#" & + "style_checks#" & + "suppress#" & + "suppress_exception_locations#" & + "task_dispatching_policy#" & + "universal_data#" & + "unsuppress#" & + "use_vads_size#" & + "validity_checks#" & + "warnings#" & + "abort_defer#" & + "all_calls_remote#" & + "annotate#" & + "assert#" & + "asynchronous#" & + "atomic#" & + "atomic_components#" & + "attach_handler#" & + "comment#" & + "common_object#" & + "complex_representation#" & + "controlled#" & + "convention#" & + "cpp_class#" & + "cpp_constructor#" & + "cpp_virtual#" & + "cpp_vtable#" & + "debug#" & + "elaborate#" & + "elaborate_all#" & + "elaborate_body#" & + "export#" & + "export_exception#" & + "export_function#" & + "export_object#" & + "export_procedure#" & + "export_value#" & + "export_valued_procedure#" & + "external#" & + "finalize_storage_only#" & + "ident#" & + "import#" & + "import_exception#" & + "import_function#" & + "import_object#" & + "import_procedure#" & + "import_valued_procedure#" & + "inline#" & + "inline_always#" & + "inline_generic#" & + "inspection_point#" & + "interface_name#" & + "interrupt_handler#" & + "interrupt_priority#" & + "java_constructor#" & + "java_interface#" & + "keep_names#" & + "link_with#" & + "linker_alias#" & + "linker_options#" & + "linker_section#" & + "list#" & + "machine_attribute#" & + "main#" & + "main_storage#" & + "memory_size#" & + "no_return#" & + "obsolescent#" & + "optimize#" & + "optional_overriding#" & + "pack#" & + "page#" & + "passive#" & + "preelaborate#" & + "priority#" & + "psect_object#" & + "pure#" & + "pure_function#" & + "remote_call_interface#" & + "remote_types#" & + "share_generic#" & + "shared#" & + "shared_passive#" & + "source_reference#" & + "stream_convert#" & + "subtitle#" & + "suppress_all#" & + "suppress_debug_info#" & + "suppress_initialization#" & + "system_name#" & + "task_info#" & + "task_name#" & + "task_storage#" & + "thread_body#" & + "time_slice#" & + "title#" & + "unchecked_union#" & + "unimplemented_unit#" & + "unreferenced#" & + "unreserve_all_interrupts#" & + "volatile#" & + "volatile_components#" & + "weak_external#" & + "ada#" & + "assembler#" & + "cobol#" & + "cpp#" & + "fortran#" & + "intrinsic#" & + "java#" & + "stdcall#" & + "stubbed#" & + "asm#" & + "assembly#" & + "default#" & + "dll#" & + "win32#" & + "as_is#" & + "body_file_name#" & + "boolean_entry_barriers#" & + "casing#" & + "code#" & + "component#" & + "component_size_4#" & + "copy#" & + "d_float#" & + "descriptor#" & + "dot_replacement#" & + "dynamic#" & + "entity#" & + "external_name#" & + "first_optional_parameter#" & + "form#" & + "g_float#" & + "gcc#" & + "gnat#" & + "gpl#" & + "ieee_float#" & + "internal#" & + "link_name#" & + "lowercase#" & + "max_entry_queue_depth#" & + "max_entry_queue_length#" & + "max_size#" & + "mechanism#" & + "mixedcase#" & + "modified_gpl#" & + "name#" & + "nca#" & + "no#" & + "no_dependence#" & + "no_dynamic_attachment#" & + "no_dynamic_interrupts#" & + "no_requeue#" & + "no_requeue_statements#" & + "no_task_attributes#" & + "no_task_attributes_package#" & + "on#" & + "parameter_types#" & + "reference#" & + "restricted#" & + "result_mechanism#" & + "result_type#" & + "runtime#" & + "sb#" & + "secondary_stack_size#" & + "section#" & + "semaphore#" & + "simple_barriers#" & + "spec_file_name#" & + "static#" & + "stack_size#" & + "subunit_file_name#" & + "task_stack_size_default#" & + "task_type#" & + "time_slicing_enabled#" & + "top_guard#" & + "uba#" & + "ubs#" & + "ubsb#" & + "unit_name#" & + "unknown#" & + "unrestricted#" & + "uppercase#" & + "user#" & + "vax_float#" & + "vms#" & + "working_storage#" & + "abort_signal#" & + "access#" & + "address#" & + "address_size#" & + "aft#" & + "alignment#" & + "asm_input#" & + "asm_output#" & + "ast_entry#" & + "bit#" & + "bit_order#" & + "bit_position#" & + "body_version#" & + "callable#" & + "caller#" & + "code_address#" & + "component_size#" & + "compose#" & + "constrained#" & + "count#" & + "default_bit_order#" & + "definite#" & + "delta#" & + "denorm#" & + "digits#" & + "elaborated#" & + "emax#" & + "enum_rep#" & + "epsilon#" & + "exponent#" & + "external_tag#" & + "first#" & + "first_bit#" & + "fixed_value#" & + "fore#" & + "has_access_values#" & + "has_discriminants#" & + "identity#" & + "img#" & + "integer_value#" & + "large#" & + "last#" & + "last_bit#" & + "leading_part#" & + "length#" & + "machine_emax#" & + "machine_emin#" & + "machine_mantissa#" & + "machine_overflows#" & + "machine_radix#" & + "machine_rounds#" & + "machine_size#" & + "mantissa#" & + "max_size_in_storage_elements#" & + "maximum_alignment#" & + "mechanism_code#" & + "mod#" & + "model_emin#" & + "model_epsilon#" & + "model_mantissa#" & + "model_small#" & + "modulus#" & + "null_parameter#" & + "object_size#" & + "partition_id#" & + "passed_by_reference#" & + "pool_address#" & + "pos#" & + "position#" & + "range#" & + "range_length#" & + "round#" & + "safe_emax#" & + "safe_first#" & + "safe_large#" & + "safe_last#" & + "safe_small#" & + "scale#" & + "scaling#" & + "signed_zeros#" & + "size#" & + "small#" & + "storage_size#" & + "storage_unit#" & + "stream_size#" & + "tag#" & + "target_name#" & + "terminated#" & + "to_address#" & + "type_class#" & + "uet_address#" & + "unbiased_rounding#" & + "unchecked_access#" & + "unconstrained_array#" & + "universal_literal_string#" & + "unrestricted_access#" & + "vads_size#" & + "val#" & + "valid#" & + "value_size#" & + "version#" & + "wchar_t_size#" & + "wide_wide_width#" & + "wide_width#" & + "width#" & + "word_size#" & + "adjacent#" & + "ceiling#" & + "copy_sign#" & + "floor#" & + "fraction#" & + "image#" & + "input#" & + "machine#" & + "max#" & + "min#" & + "model#" & + "pred#" & + "remainder#" & + "rounding#" & + "succ#" & + "truncation#" & + "value#" & + "wide_image#" & + "wide_wide_image#" & + "wide_value#" & + "wide_wide_value#" & + "output#" & + "read#" & + "write#" & + "elab_body#" & + "elab_spec#" & + "storage_pool#" & + "base#" & + "class#" & + "ceiling_locking#" & + "inheritance_locking#" & + "fifo_queuing#" & + "priority_queuing#" & + "fifo_within_priorities#" & + "access_check#" & + "accessibility_check#" & + "discriminant_check#" & + "division_check#" & + "elaboration_check#" & + "index_check#" & + "length_check#" & + "overflow_check#" & + "range_check#" & + "storage_check#" & + "tag_check#" & + "all_checks#" & + "abort#" & + "abs#" & + "accept#" & + "and#" & + "all#" & + "array#" & + "at#" & + "begin#" & + "body#" & + "case#" & + "constant#" & + "declare#" & + "delay#" & + "do#" & + "else#" & + "elsif#" & + "end#" & + "entry#" & + "exception#" & + "exit#" & + "for#" & + "function#" & + "generic#" & + "goto#" & + "if#" & + "in#" & + "is#" & + "limited#" & + "loop#" & + "new#" & + "not#" & + "null#" & + "of#" & + "or#" & + "others#" & + "out#" & + "package#" & + "pragma#" & + "private#" & + "procedure#" & + "raise#" & + "record#" & + "rem#" & + "renames#" & + "return#" & + "reverse#" & + "select#" & + "separate#" & + "subtype#" & + "task#" & + "terminate#" & + "then#" & + "type#" & + "use#" & + "when#" & + "while#" & + "with#" & + "xor#" & + "divide#" & + "enclosing_entity#" & + "exception_information#" & + "exception_message#" & + "exception_name#" & + "file#" & + "import_address#" & + "import_largest_value#" & + "import_value#" & + "is_negative#" & + "line#" & + "rotate_left#" & + "rotate_right#" & + "shift_left#" & + "shift_right#" & + "shift_right_arithmetic#" & + "source_location#" & + "unchecked_conversion#" & + "unchecked_deallocation#" & + "to_pointer#" & + "abstract#" & + "aliased#" & + "protected#" & + "until#" & + "requeue#" & + "tagged#" & + "raise_exception#" & + "ada_roots#" & + "binder#" & + "binder_driver#" & + "body_suffix#" & + "builder#" & + "compiler#" & + "compiler_driver#" & + "compiler_kind#" & + "compute_dependency#" & + "cross_reference#" & + "default_linker#" & + "default_switches#" & + "dependency_option#" & + "exec_dir#" & + "executable#" & + "executable_suffix#" & + "extends#" & + "externally_built#" & + "finder#" & + "global_configuration_pragmas#" & + "gnatls#" & + "gnatstub#" & + "implementation#" & + "implementation_exceptions#" & + "implementation_suffix#" & + "include_option#" & + "language_processing#" & + "languages#" & + "library_dir#" & + "library_auto_init#" & + "library_gcc#" & + "library_interface#" & + "library_kind#" & + "library_name#" & + "library_options#" & + "library_reference_symbol_file#" & + "library_src_dir#" & + "library_symbol_file#" & + "library_symbol_policy#" & + "library_version#" & + "linker#" & + "local_configuration_pragmas#" & + "locally_removed_files#" & + "metrics#" & + "naming#" & + "object_dir#" & + "pretty_printer#" & + "project#" & + "separate_suffix#" & + "source_dirs#" & + "source_files#" & + "source_list_file#" & + "spec#" & + "spec_suffix#" & + "specification#" & + "specification_exceptions#" & + "specification_suffix#" & + "switches#" & + "unaligned_valid#" & + "interface#" & + "overriding#" & + "synchronized#" & + "#"; + + --------------------- + -- Generated Names -- + --------------------- + + -- This section lists the various cases of generated names which are + -- built from existing names by adding unique leading and/or trailing + -- upper case letters. In some cases these names are built recursively, + -- in particular names built from types may be built from types which + -- themselves have generated names. In this list, xxx represents an + -- existing name to which identifying letters are prepended or appended, + -- and a trailing n represents a serial number in an external name that + -- has some semantic significance (e.g. the n'th index type of an array). + + -- xxxA access type for formal xxx in entry param record (Exp_Ch9) + -- xxxB tag table for tagged type xxx (Exp_Ch3) + -- xxxB task body procedure for task xxx (Exp_Ch9) + -- xxxD dispatch table for tagged type xxx (Exp_Ch3) + -- xxxD discriminal for discriminant xxx (Sem_Ch3) + -- xxxDn n'th discr check function for rec type xxx (Exp_Ch3) + -- xxxE elaboration boolean flag for task xxx (Exp_Ch9) + -- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3) + -- xxxE parameters for accept body for entry xxx (Exp_Ch9) + -- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3) + -- xxxJ tag table type index for tagged type xxx (Exp_Ch3) + -- xxxM master Id value for access type xxx (Exp_Ch3) + -- xxxP tag table pointer type for tagged type xxx (Exp_Ch3) + -- xxxP parameter record type for entry xxx (Exp_Ch9) + -- xxxPA access to parameter record type for entry xxx (Exp_Ch9) + -- xxxPn pointer type for n'th primitive of tagged type xxx (Exp_Ch3) + -- xxxR dispatch table pointer for tagged type xxx (Exp_Ch3) + -- xxxT tag table type for tagged type xxx (Exp_Ch3) + -- xxxT literal table for enumeration type xxx (Sem_Ch3) + -- xxxV type for task value record for task xxx (Exp_Ch9) + -- xxxX entry index constant (Exp_Ch9) + -- xxxY dispatch table type for tagged type xxx (Exp_Ch3) + -- xxxZ size variable for task xxx (Exp_Ch9) + + -- TSS names + + -- xxxDA deep adjust routine for type xxx (Exp_TSS) + -- xxxDF deep finalize routine for type xxx (Exp_TSS) + -- xxxDI deep initialize routine for type xxx (Exp_TSS) + -- xxxEQ composite equality routine for record type xxx (Exp_TSS) + -- xxxIP initialization procedure for type xxx (Exp_TSS) + -- xxxRA RAs type access routine for type xxx (Exp_TSS) + -- xxxRD RAs type dereference routine for type xxx (Exp_TSS) + -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS) + -- xxxSA array/slice assignment for controlled comp. arrays (Exp_TSS) + -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS) + -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS) + -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS) + -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS) + + -- Implicit type names + + -- TxxxT type of literal table for enumeration type xxx (Sem_Ch3) + + -- (Note: this list is not complete or accurate ???) + + ---------------------- + -- Get_Attribute_Id -- + ---------------------- + + function Get_Attribute_Id (N : Name_Id) return Attribute_Id is + begin + return Attribute_Id'Val (N - First_Attribute_Name); + end Get_Attribute_Id; + + ------------------ + -- Get_Check_Id -- + ------------------ + + function Get_Check_Id (N : Name_Id) return Check_Id is + begin + return Check_Id'Val (N - First_Check_Name); + end Get_Check_Id; + + ----------------------- + -- Get_Convention_Id -- + ----------------------- + + function Get_Convention_Id (N : Name_Id) return Convention_Id is + begin + case N is + when Name_Ada => return Convention_Ada; + when Name_Assembler => return Convention_Assembler; + when Name_C => return Convention_C; + when Name_COBOL => return Convention_COBOL; + when Name_CPP => return Convention_CPP; + when Name_Fortran => return Convention_Fortran; + when Name_Intrinsic => return Convention_Intrinsic; + when Name_Java => return Convention_Java; + when Name_Stdcall => return Convention_Stdcall; + when Name_Stubbed => return Convention_Stubbed; + + -- If no direct match, then we must have a convention + -- identifier pragma that has specified this name. + + when others => + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return Convention_Identifiers.Table (J).Convention; + end if; + end loop; + + raise Program_Error; + end case; + end Get_Convention_Id; + + --------------------------- + -- Get_Locking_Policy_Id -- + --------------------------- + + function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is + begin + return Locking_Policy_Id'Val (N - First_Locking_Policy_Name); + end Get_Locking_Policy_Id; + + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Name_Id) return Pragma_Id is + begin + if N = Name_AST_Entry then + return Pragma_AST_Entry; + elsif N = Name_Interface then + return Pragma_Interface; + elsif N = Name_Storage_Size then + return Pragma_Storage_Size; + elsif N = Name_Storage_Unit then + return Pragma_Storage_Unit; + elsif N not in First_Pragma_Name .. Last_Pragma_Name then + return Unknown_Pragma; + else + return Pragma_Id'Val (N - First_Pragma_Name); + end if; + end Get_Pragma_Id; + + --------------------------- + -- Get_Queuing_Policy_Id -- + --------------------------- + + function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is + begin + return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name); + end Get_Queuing_Policy_Id; + + ------------------------------------ + -- Get_Task_Dispatching_Policy_Id -- + ------------------------------------ + + function Get_Task_Dispatching_Policy_Id (N : Name_Id) + return Task_Dispatching_Policy_Id is + begin + return Task_Dispatching_Policy_Id'Val + (N - First_Task_Dispatching_Policy_Name); + end Get_Task_Dispatching_Policy_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + P_Index : Natural; + Discard_Name : Name_Id; + + begin + P_Index := Preset_Names'First; + + loop + Name_Len := 0; + + while Preset_Names (P_Index) /= '#' loop + Name_Len := Name_Len + 1; + Name_Buffer (Name_Len) := Preset_Names (P_Index); + P_Index := P_Index + 1; + end loop; + + -- We do the Name_Find call to enter the name into the table, but + -- we don't need to do anything with the result, since we already + -- initialized all the preset names to have the right value (we + -- are depending on the order of the names and Preset_Names). + + Discard_Name := Name_Find; + P_Index := P_Index + 1; + exit when Preset_Names (P_Index) = '#'; + end loop; + + -- Make sure that number of names in standard table is correct. If + -- this check fails, run utility program XSNAMES to construct a new + -- properly matching version of the body. + + pragma Assert (Discard_Name = Last_Predefined_Name); + + -- Initialize the convention identifiers table with the standard + -- set of synonyms that we recognize for conventions. + + Convention_Identifiers.Init; + + Convention_Identifiers.Append ((Name_Asm, Convention_Assembler)); + Convention_Identifiers.Append ((Name_Assembly, Convention_Assembler)); + + Convention_Identifiers.Append ((Name_Default, Convention_C)); + Convention_Identifiers.Append ((Name_External, Convention_C)); + + Convention_Identifiers.Append ((Name_DLL, Convention_Stdcall)); + Convention_Identifiers.Append ((Name_Win32, Convention_Stdcall)); + end Initialize; + + ----------------------- + -- Is_Attribute_Name -- + ----------------------- + + function Is_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Attribute_Name .. Last_Attribute_Name; + end Is_Attribute_Name; + + ------------------- + -- Is_Check_Name -- + ------------------- + + function Is_Check_Name (N : Name_Id) return Boolean is + begin + return N in First_Check_Name .. Last_Check_Name; + end Is_Check_Name; + + ------------------------ + -- Is_Convention_Name -- + ------------------------ + + function Is_Convention_Name (N : Name_Id) return Boolean is + begin + -- Check if this is one of the standard conventions + + if N in First_Convention_Name .. Last_Convention_Name + or else N = Name_C + then + return True; + + -- Otherwise check if it is in convention identifier table + + else + for J in 1 .. Convention_Identifiers.Last loop + if N = Convention_Identifiers.Table (J).Name then + return True; + end if; + end loop; + + return False; + end if; + end Is_Convention_Name; + + ------------------------------ + -- Is_Entity_Attribute_Name -- + ------------------------------ + + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Entity_Attribute_Name .. Last_Entity_Attribute_Name; + end Is_Entity_Attribute_Name; + + -------------------------------- + -- Is_Function_Attribute_Name -- + -------------------------------- + + function Is_Function_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in + First_Renamable_Function_Attribute .. + Last_Renamable_Function_Attribute; + end Is_Function_Attribute_Name; + + ---------------------------- + -- Is_Locking_Policy_Name -- + ---------------------------- + + function Is_Locking_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Locking_Policy_Name .. Last_Locking_Policy_Name; + end Is_Locking_Policy_Name; + + ----------------------------- + -- Is_Operator_Symbol_Name -- + ----------------------------- + + function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is + begin + return N in First_Operator_Name .. Last_Operator_Name; + end Is_Operator_Symbol_Name; + + -------------------- + -- Is_Pragma_Name -- + -------------------- + + function Is_Pragma_Name (N : Name_Id) return Boolean is + begin + return N in First_Pragma_Name .. Last_Pragma_Name + or else N = Name_AST_Entry + or else N = Name_Interface + or else N = Name_Storage_Size + or else N = Name_Storage_Unit; + end Is_Pragma_Name; + + --------------------------------- + -- Is_Procedure_Attribute_Name -- + --------------------------------- + + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Procedure_Attribute .. Last_Procedure_Attribute; + end Is_Procedure_Attribute_Name; + + ---------------------------- + -- Is_Queuing_Policy_Name -- + ---------------------------- + + function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Queuing_Policy_Name .. Last_Queuing_Policy_Name; + end Is_Queuing_Policy_Name; + + ------------------------------------- + -- Is_Task_Dispatching_Policy_Name -- + ------------------------------------- + + function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is + begin + return N in First_Task_Dispatching_Policy_Name .. + Last_Task_Dispatching_Policy_Name; + end Is_Task_Dispatching_Policy_Name; + + ---------------------------- + -- Is_Type_Attribute_Name -- + ---------------------------- + + function Is_Type_Attribute_Name (N : Name_Id) return Boolean is + begin + return N in First_Type_Attribute_Name .. Last_Type_Attribute_Name; + end Is_Type_Attribute_Name; + + ---------------------------------- + -- Record_Convention_Identifier -- + ---------------------------------- + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id) + is + begin + Convention_Identifiers.Append ((Id, Convention)); + end Record_Convention_Identifier; + +end Snames; diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 85c2f467cf0..9b79ae448dc 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -1,1496 +1,1496 @@ -------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Types; use Types;
-
-package Snames is
-
--- This package contains definitions of standard names (i.e. entries in the
--- Names table) that are used throughout the GNAT compiler). It also contains
--- the definitions of some enumeration types whose definitions are tied to
--- the order of these preset names.
-
--- WARNING: There is a C file, a-snames.h which duplicates some of the
--- definitions in this file and must be kept properly synchronized.
-
- ------------------
- -- Preset Names --
- ------------------
-
- -- The following are preset entries in the names table, which are
- -- entered at the start of every compilation for easy access. Note
- -- that the order of initialization of these names in the body must
- -- be coordinated with the order of names in this table.
-
- -- Note: a name may not appear more than once in the following list.
- -- If additional pragmas or attributes are introduced which might
- -- otherwise cause a duplicate, then list it only once in this table,
- -- and adjust the definition of the functions for testing for pragma
- -- names and attribute names, and returning their ID values. Of course
- -- everything is simpler if no such duplications occur!
-
- -- First we have the one character names used to optimize the lookup
- -- process for one character identifiers (to avoid the hashing in this
- -- case) There are a full 256 of these, but only the entries for lower
- -- case and upper case letters have identifiers
-
- -- The lower case letter entries are used for one character identifiers
- -- appearing in the source, for example in pragma Interface (C).
-
- Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a');
- Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b');
- Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c');
- Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d');
- Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e');
- Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f');
- Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g');
- Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h');
- Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i');
- Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j');
- Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k');
- Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l');
- Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m');
- Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n');
- Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o');
- Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p');
- Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q');
- Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r');
- Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s');
- Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t');
- Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u');
- Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v');
- Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w');
- Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x');
- Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y');
- Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z');
-
- -- The upper case letter entries are used by expander code for local
- -- variables that do not require unique names (e.g. formal parameter
- -- names in constructed procedures)
-
- Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A');
- Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B');
- Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C');
- Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D');
- Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E');
- Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F');
- Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G');
- Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H');
- Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I');
- Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J');
- Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K');
- Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L');
- Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M');
- Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N');
- Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O');
- Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P');
- Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q');
- Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R');
- Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S');
- Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T');
- Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U');
- Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V');
- Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W');
- Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X');
- Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y');
- Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z');
-
- -- Note: the following table is read by the utility program XSNAMES and
- -- its format should not be changed without coordinating with this program.
-
- N : constant Name_Id := First_Name_Id + 256;
- -- Synonym used in standard name definitions
-
- -- Some names that are used by gigi, and whose definitions are reflected
- -- in the C header file a-snames.h. They are placed at the start so that
- -- the need to modify a-snames.h is minimized.
-
- Name_uParent : constant Name_Id := N + 000;
- Name_uTag : constant Name_Id := N + 001;
- Name_Off : constant Name_Id := N + 002;
- Name_Space : constant Name_Id := N + 003;
- Name_Time : constant Name_Id := N + 004;
-
- -- Some special names used by the expander. Note that the lower case u's
- -- at the start of these names get translated to extra underscores. These
- -- names are only referenced internally by expander generated code.
-
- Name_uAbort_Signal : constant Name_Id := N + 005;
- Name_uAlignment : constant Name_Id := N + 006;
- Name_uAssign : constant Name_Id := N + 007;
- Name_uATCB : constant Name_Id := N + 008;
- Name_uChain : constant Name_Id := N + 009;
- Name_uClean : constant Name_Id := N + 010;
- Name_uController : constant Name_Id := N + 011;
- Name_uEntry_Bodies : constant Name_Id := N + 012;
- Name_uExpunge : constant Name_Id := N + 013;
- Name_uFinal_List : constant Name_Id := N + 014;
- Name_uIdepth : constant Name_Id := N + 015;
- Name_uInit : constant Name_Id := N + 016;
- Name_uLocal_Final_List : constant Name_Id := N + 017;
- Name_uMaster : constant Name_Id := N + 018;
- Name_uObject : constant Name_Id := N + 019;
- Name_uPriority : constant Name_Id := N + 020;
- Name_uProcess_ATSD : constant Name_Id := N + 021;
- Name_uSecondary_Stack : constant Name_Id := N + 022;
- Name_uService : constant Name_Id := N + 023;
- Name_uSize : constant Name_Id := N + 024;
- Name_uStack : constant Name_Id := N + 025;
- Name_uTags : constant Name_Id := N + 026;
- Name_uTask : constant Name_Id := N + 027;
- Name_uTask_Id : constant Name_Id := N + 028;
- Name_uTask_Info : constant Name_Id := N + 029;
- Name_uTask_Name : constant Name_Id := N + 030;
- Name_uTrace_Sp : constant Name_Id := N + 031;
-
- -- Names of routines in Ada.Finalization, needed by expander
-
- Name_Initialize : constant Name_Id := N + 032;
- Name_Adjust : constant Name_Id := N + 033;
- Name_Finalize : constant Name_Id := N + 034;
-
- -- Names of fields declared in System.Finalization_Implementation,
- -- needed by the expander when generating code for finalization.
-
- Name_Next : constant Name_Id := N + 035;
- Name_Prev : constant Name_Id := N + 036;
-
- -- Names of TSS routines for implementation of DSA over PolyORB
-
- Name_uTypeCode : constant Name_Id := N + 037;
- Name_uFrom_Any : constant Name_Id := N + 038;
- Name_uTo_Any : constant Name_Id := N + 039;
-
- -- Names of allocation routines, also needed by expander
-
- Name_Allocate : constant Name_Id := N + 040;
- Name_Deallocate : constant Name_Id := N + 041;
- Name_Dereference : constant Name_Id := N + 042;
-
- -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
-
- First_Text_IO_Package : constant Name_Id := N + 043;
- Name_Decimal_IO : constant Name_Id := N + 043;
- Name_Enumeration_IO : constant Name_Id := N + 044;
- Name_Fixed_IO : constant Name_Id := N + 045;
- Name_Float_IO : constant Name_Id := N + 046;
- Name_Integer_IO : constant Name_Id := N + 047;
- Name_Modular_IO : constant Name_Id := N + 048;
- Last_Text_IO_Package : constant Name_Id := N + 048;
-
- subtype Text_IO_Package_Name is Name_Id
- range First_Text_IO_Package .. Last_Text_IO_Package;
-
- -- Some miscellaneous names used for error detection/recovery
-
- Name_Const : constant Name_Id := N + 049;
- Name_Error : constant Name_Id := N + 050;
- Name_Go : constant Name_Id := N + 051;
- Name_Put : constant Name_Id := N + 052;
- Name_Put_Line : constant Name_Id := N + 053;
- Name_To : constant Name_Id := N + 054;
-
- -- Names for packages that are treated specially by the compiler
-
- Name_Finalization : constant Name_Id := N + 055;
- Name_Finalization_Root : constant Name_Id := N + 056;
- Name_Interfaces : constant Name_Id := N + 057;
- Name_Standard : constant Name_Id := N + 058;
- Name_System : constant Name_Id := N + 059;
- Name_Text_IO : constant Name_Id := N + 060;
- Name_Wide_Text_IO : constant Name_Id := N + 061;
- Name_Wide_Wide_Text_IO : constant Name_Id := N + 062;
-
- -- Names of implementations of the distributed systems annex
-
- First_PCS_Name : constant Name_Id := N + 063;
- Name_No_DSA : constant Name_Id := N + 063;
- Name_GARLIC_DSA : constant Name_Id := N + 064;
- Name_PolyORB_DSA : constant Name_Id := N + 065;
- Last_PCS_Name : constant Name_Id := N + 065;
-
- subtype PCS_Names is Name_Id
- range First_PCS_Name .. Last_PCS_Name;
-
- -- Names of identifiers used in expanding distribution stubs
-
- Name_Addr : constant Name_Id := N + 066;
- Name_Async : constant Name_Id := N + 067;
- Name_Get_Active_Partition_ID : constant Name_Id := N + 068;
- Name_Get_RCI_Package_Receiver : constant Name_Id := N + 069;
- Name_Get_RCI_Package_Ref : constant Name_Id := N + 070;
- Name_Origin : constant Name_Id := N + 071;
- Name_Params : constant Name_Id := N + 072;
- Name_Partition : constant Name_Id := N + 073;
- Name_Partition_Interface : constant Name_Id := N + 074;
- Name_Ras : constant Name_Id := N + 075;
- Name_Call : constant Name_Id := N + 076;
- Name_RCI_Name : constant Name_Id := N + 077;
- Name_Receiver : constant Name_Id := N + 078;
- Name_Result : constant Name_Id := N + 079;
- Name_Rpc : constant Name_Id := N + 080;
- Name_Subp_Id : constant Name_Id := N + 081;
- Name_Operation : constant Name_Id := N + 082;
- Name_Argument : constant Name_Id := N + 083;
- Name_Arg_Modes : constant Name_Id := N + 084;
- Name_Handler : constant Name_Id := N + 085;
- Name_Target : constant Name_Id := N + 086;
- Name_Req : constant Name_Id := N + 087;
- Name_Obj_TypeCode : constant Name_Id := N + 088;
- Name_Stub : constant Name_Id := N + 089;
-
- -- Operator Symbol entries. The actual names have an upper case O at
- -- the start in place of the Op_ prefix (e.g. the actual name that
- -- corresponds to Name_Op_Abs is "Oabs".
-
- First_Operator_Name : constant Name_Id := N + 090;
- Name_Op_Abs : constant Name_Id := N + 090; -- "abs"
- Name_Op_And : constant Name_Id := N + 091; -- "and"
- Name_Op_Mod : constant Name_Id := N + 092; -- "mod"
- Name_Op_Not : constant Name_Id := N + 093; -- "not"
- Name_Op_Or : constant Name_Id := N + 094; -- "or"
- Name_Op_Rem : constant Name_Id := N + 095; -- "rem"
- Name_Op_Xor : constant Name_Id := N + 096; -- "xor"
- Name_Op_Eq : constant Name_Id := N + 097; -- "="
- Name_Op_Ne : constant Name_Id := N + 098; -- "/="
- Name_Op_Lt : constant Name_Id := N + 099; -- "<"
- Name_Op_Le : constant Name_Id := N + 100; -- "<="
- Name_Op_Gt : constant Name_Id := N + 101; -- ">"
- Name_Op_Ge : constant Name_Id := N + 102; -- ">="
- Name_Op_Add : constant Name_Id := N + 103; -- "+"
- Name_Op_Subtract : constant Name_Id := N + 104; -- "-"
- Name_Op_Concat : constant Name_Id := N + 105; -- "&"
- Name_Op_Multiply : constant Name_Id := N + 106; -- "*"
- Name_Op_Divide : constant Name_Id := N + 107; -- "/"
- Name_Op_Expon : constant Name_Id := N + 108; -- "**"
- Last_Operator_Name : constant Name_Id := N + 108;
-
- -- Names for all pragmas recognized by GNAT. The entries with the comment
- -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
- -- These pragmas are fully implemented in both Ada 83 and Ada 95 modes
- -- in GNAT.
-
- -- The entries marked GNAT are pragmas that are defined by GNAT
- -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions
- -- of these implementation dependent pragmas may be found in the
- -- appropriate section in unit Sem_Prag in file sem-prag.adb.
-
- -- The entries marked Ada05 are technically implementation dependent
- -- pragmas, but they correspond to standard proposals for Ada 2005.
-
- -- The entries marked VMS are VMS specific pragmas that are recognized
- -- only in OpenVMS versions of GNAT. They are ignored in other versions
- -- with an appropriate warning.
-
- -- The entries marked AAMP are AAMP specific pragmas that are recognized
- -- only in GNAT for the AAMP. They are ignored in other versions with
- -- appropriate warnings.
-
- First_Pragma_Name : constant Name_Id := N + 109;
-
- -- Configuration pragmas are grouped at start
-
- Name_Ada_83 : constant Name_Id := N + 109; -- GNAT
- Name_Ada_95 : constant Name_Id := N + 110; -- GNAT
- Name_Ada_05 : constant Name_Id := N + 111; -- GNAT
- Name_C_Pass_By_Copy : constant Name_Id := N + 112; -- GNAT
- Name_Compile_Time_Warning : constant Name_Id := N + 113; -- GNAT
- Name_Component_Alignment : constant Name_Id := N + 114; -- GNAT
- Name_Convention_Identifier : constant Name_Id := N + 115; -- GNAT
- Name_Detect_Blocking : constant Name_Id := N + 116; -- Ada05
- Name_Discard_Names : constant Name_Id := N + 117;
- Name_Elaboration_Checks : constant Name_Id := N + 118; -- GNAT
- Name_Eliminate : constant Name_Id := N + 119; -- GNAT
- Name_Explicit_Overriding : constant Name_Id := N + 120;
- Name_Extend_System : constant Name_Id := N + 121; -- GNAT
- Name_Extensions_Allowed : constant Name_Id := N + 122; -- GNAT
- Name_External_Name_Casing : constant Name_Id := N + 123; -- GNAT
- Name_Float_Representation : constant Name_Id := N + 124; -- GNAT
- Name_Initialize_Scalars : constant Name_Id := N + 125; -- GNAT
- Name_Interrupt_State : constant Name_Id := N + 126; -- GNAT
- Name_License : constant Name_Id := N + 127; -- GNAT
- Name_Locking_Policy : constant Name_Id := N + 128;
- Name_Long_Float : constant Name_Id := N + 129; -- VMS
- Name_No_Run_Time : constant Name_Id := N + 130; -- GNAT
- Name_No_Strict_Aliasing : constant Name_Id := N + 131; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 132;
- Name_Polling : constant Name_Id := N + 133; -- GNAT
- Name_Persistent_Data : constant Name_Id := N + 134; -- GNAT
- Name_Persistent_Object : constant Name_Id := N + 135; -- GNAT
- Name_Profile : constant Name_Id := N + 136; -- Ada05
- Name_Profile_Warnings : constant Name_Id := N + 137; -- GNAT
- Name_Propagate_Exceptions : constant Name_Id := N + 138; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 139;
- Name_Ravenscar : constant Name_Id := N + 140;
- Name_Restricted_Run_Time : constant Name_Id := N + 141;
- Name_Restrictions : constant Name_Id := N + 142;
- Name_Restriction_Warnings : constant Name_Id := N + 143; -- GNAT
- Name_Reviewable : constant Name_Id := N + 144;
- Name_Source_File_Name : constant Name_Id := N + 145; -- GNAT
- Name_Source_File_Name_Project : constant Name_Id := N + 146; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 147; -- GNAT
- Name_Suppress : constant Name_Id := N + 148;
- Name_Suppress_Exception_Locations : constant Name_Id := N + 149; -- GNAT
- Name_Task_Dispatching_Policy : constant Name_Id := N + 150;
- Name_Universal_Data : constant Name_Id := N + 151; -- AAMP
- Name_Unsuppress : constant Name_Id := N + 152; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 153; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 154; -- GNAT
- Name_Warnings : constant Name_Id := N + 155; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 155;
-
- -- Remaining pragma names
-
- Name_Abort_Defer : constant Name_Id := N + 156; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 157;
- Name_Annotate : constant Name_Id := N + 158; -- GNAT
-
- -- Note: AST_Entry is not in this list because its name matches the
- -- name of the corresponding attribute. However, it is included in the
- -- definition of the type Attribute_Id, and the functions Get_Pragma_Id
- -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
- -- AST_Entry is a VMS specific pragma.
-
- Name_Assert : constant Name_Id := N + 159; -- GNAT
- Name_Asynchronous : constant Name_Id := N + 160;
- Name_Atomic : constant Name_Id := N + 161;
- Name_Atomic_Components : constant Name_Id := N + 162;
- Name_Attach_Handler : constant Name_Id := N + 163;
- Name_Comment : constant Name_Id := N + 164; -- GNAT
- Name_Common_Object : constant Name_Id := N + 165; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 166; -- GNAT
- Name_Controlled : constant Name_Id := N + 167;
- Name_Convention : constant Name_Id := N + 168;
- Name_CPP_Class : constant Name_Id := N + 169; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 170; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 171; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 172; -- GNAT
- Name_Debug : constant Name_Id := N + 173; -- GNAT
- Name_Elaborate : constant Name_Id := N + 174; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 175;
- Name_Elaborate_Body : constant Name_Id := N + 176;
- Name_Export : constant Name_Id := N + 177;
- Name_Export_Exception : constant Name_Id := N + 178; -- VMS
- Name_Export_Function : constant Name_Id := N + 179; -- GNAT
- Name_Export_Object : constant Name_Id := N + 180; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 181; -- GNAT
- Name_Export_Value : constant Name_Id := N + 182; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 183; -- GNAT
- Name_External : constant Name_Id := N + 184; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 185; -- GNAT
- Name_Ident : constant Name_Id := N + 186; -- VMS
- Name_Import : constant Name_Id := N + 187;
- Name_Import_Exception : constant Name_Id := N + 188; -- VMS
- Name_Import_Function : constant Name_Id := N + 189; -- GNAT
- Name_Import_Object : constant Name_Id := N + 190; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 191; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 192; -- GNAT
- Name_Inline : constant Name_Id := N + 193;
- Name_Inline_Always : constant Name_Id := N + 194; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 195; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 196;
- Name_Interface_Name : constant Name_Id := N + 197; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 198;
- Name_Interrupt_Priority : constant Name_Id := N + 199;
- Name_Java_Constructor : constant Name_Id := N + 200; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 201; -- GNAT
- Name_Keep_Names : constant Name_Id := N + 202; -- GNAT
- Name_Link_With : constant Name_Id := N + 203; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 204; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 205;
- Name_Linker_Section : constant Name_Id := N + 206; -- GNAT
- Name_List : constant Name_Id := N + 207;
- Name_Machine_Attribute : constant Name_Id := N + 208; -- GNAT
- Name_Main : constant Name_Id := N + 209; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 210; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 211; -- Ada 83
- Name_No_Return : constant Name_Id := N + 212; -- GNAT
- Name_Obsolescent : constant Name_Id := N + 213; -- GNAT
- Name_Optimize : constant Name_Id := N + 214;
- Name_Optional_Overriding : constant Name_Id := N + 215;
- Name_Pack : constant Name_Id := N + 216;
- Name_Page : constant Name_Id := N + 217;
- Name_Passive : constant Name_Id := N + 218; -- GNAT
- Name_Preelaborate : constant Name_Id := N + 219;
- Name_Priority : constant Name_Id := N + 220;
- Name_Psect_Object : constant Name_Id := N + 221; -- VMS
- Name_Pure : constant Name_Id := N + 222;
- Name_Pure_Function : constant Name_Id := N + 223; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 224;
- Name_Remote_Types : constant Name_Id := N + 225;
- Name_Share_Generic : constant Name_Id := N + 226; -- GNAT
- Name_Shared : constant Name_Id := N + 227; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 228;
-
- -- Note: Storage_Size is not in this list because its name matches the
- -- name of the corresponding attribute. However, it is included in the
- -- definition of the type Attribute_Id, and the functions Get_Pragma_Id
- -- and Check_Pragma_Id correctly recognize and process Name_Storage_Size.
-
- -- Note: Storage_Unit is also omitted from the list because of a clash
- -- with an attribute name, and is treated similarly.
-
- Name_Source_Reference : constant Name_Id := N + 229; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 230; -- GNAT
- Name_Subtitle : constant Name_Id := N + 231; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 232; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 233; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 234; -- GNAT
- Name_System_Name : constant Name_Id := N + 235; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 236; -- GNAT
- Name_Task_Name : constant Name_Id := N + 237; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 238; -- VMS
- Name_Thread_Body : constant Name_Id := N + 239; -- GNAT
- Name_Time_Slice : constant Name_Id := N + 240; -- GNAT
- Name_Title : constant Name_Id := N + 241; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 242; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 243; -- GNAT
- Name_Unreferenced : constant Name_Id := N + 244; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 245; -- GNAT
- Name_Volatile : constant Name_Id := N + 246;
- Name_Volatile_Components : constant Name_Id := N + 247;
- Name_Weak_External : constant Name_Id := N + 248; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 248;
-
- -- Language convention names for pragma Convention/Export/Import/Interface
- -- Note that Name_C is not included in this list, since it was already
- -- declared earlier in the context of one-character identifier names
- -- (where the order is critical to the fast look up process).
-
- -- Note: there are no convention names corresponding to the conventions
- -- Entry and Protected, this is because these conventions cannot be
- -- specified by a pragma.
-
- First_Convention_Name : constant Name_Id := N + 249;
- Name_Ada : constant Name_Id := N + 249;
- Name_Assembler : constant Name_Id := N + 250;
- Name_COBOL : constant Name_Id := N + 251;
- Name_CPP : constant Name_Id := N + 252;
- Name_Fortran : constant Name_Id := N + 253;
- Name_Intrinsic : constant Name_Id := N + 254;
- Name_Java : constant Name_Id := N + 255;
- Name_Stdcall : constant Name_Id := N + 256;
- Name_Stubbed : constant Name_Id := N + 257;
- Last_Convention_Name : constant Name_Id := N + 257;
-
- -- The following names are preset as synonyms for Assembler
-
- Name_Asm : constant Name_Id := N + 258;
- Name_Assembly : constant Name_Id := N + 259;
-
- -- The following names are preset as synonyms for C
-
- Name_Default : constant Name_Id := N + 260;
- -- Name_Exernal (previously defined as pragma)
-
- -- The following names are present as synonyms for Stdcall
-
- Name_DLL : constant Name_Id := N + 261;
- Name_Win32 : constant Name_Id := N + 262;
-
- -- Other special names used in processing pragmas
-
- Name_As_Is : constant Name_Id := N + 263;
- Name_Body_File_Name : constant Name_Id := N + 264;
- Name_Boolean_Entry_Barriers : constant Name_Id := N + 265;
- Name_Casing : constant Name_Id := N + 266;
- Name_Code : constant Name_Id := N + 267;
- Name_Component : constant Name_Id := N + 268;
- Name_Component_Size_4 : constant Name_Id := N + 269;
- Name_Copy : constant Name_Id := N + 270;
- Name_D_Float : constant Name_Id := N + 271;
- Name_Descriptor : constant Name_Id := N + 272;
- Name_Dot_Replacement : constant Name_Id := N + 273;
- Name_Dynamic : constant Name_Id := N + 274;
- Name_Entity : constant Name_Id := N + 275;
- Name_External_Name : constant Name_Id := N + 276;
- Name_First_Optional_Parameter : constant Name_Id := N + 277;
- Name_Form : constant Name_Id := N + 278;
- Name_G_Float : constant Name_Id := N + 279;
- Name_Gcc : constant Name_Id := N + 280;
- Name_Gnat : constant Name_Id := N + 281;
- Name_GPL : constant Name_Id := N + 282;
- Name_IEEE_Float : constant Name_Id := N + 283;
- Name_Internal : constant Name_Id := N + 284;
- Name_Link_Name : constant Name_Id := N + 285;
- Name_Lowercase : constant Name_Id := N + 286;
- Name_Max_Entry_Queue_Depth : constant Name_Id := N + 287;
- Name_Max_Entry_Queue_Length : constant Name_Id := N + 288;
- Name_Max_Size : constant Name_Id := N + 289;
- Name_Mechanism : constant Name_Id := N + 290;
- Name_Mixedcase : constant Name_Id := N + 291;
- Name_Modified_GPL : constant Name_Id := N + 292;
- Name_Name : constant Name_Id := N + 293;
- Name_NCA : constant Name_Id := N + 294;
- Name_No : constant Name_Id := N + 295;
- Name_No_Dependence : constant Name_Id := N + 296;
- Name_No_Dynamic_Attachment : constant Name_Id := N + 297;
- Name_No_Dynamic_Interrupts : constant Name_Id := N + 298;
- Name_No_Requeue : constant Name_Id := N + 299;
- Name_No_Requeue_Statements : constant Name_Id := N + 300;
- Name_No_Task_Attributes : constant Name_Id := N + 301;
- Name_No_Task_Attributes_Package : constant Name_Id := N + 302;
- Name_On : constant Name_Id := N + 303;
- Name_Parameter_Types : constant Name_Id := N + 304;
- Name_Reference : constant Name_Id := N + 305;
- Name_Restricted : constant Name_Id := N + 306;
- Name_Result_Mechanism : constant Name_Id := N + 307;
- Name_Result_Type : constant Name_Id := N + 308;
- Name_Runtime : constant Name_Id := N + 309;
- Name_SB : constant Name_Id := N + 310;
- Name_Secondary_Stack_Size : constant Name_Id := N + 311;
- Name_Section : constant Name_Id := N + 312;
- Name_Semaphore : constant Name_Id := N + 313;
- Name_Simple_Barriers : constant Name_Id := N + 314;
- Name_Spec_File_Name : constant Name_Id := N + 315;
- Name_Static : constant Name_Id := N + 316;
- Name_Stack_Size : constant Name_Id := N + 317;
- Name_Subunit_File_Name : constant Name_Id := N + 318;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 319;
- Name_Task_Type : constant Name_Id := N + 320;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 321;
- Name_Top_Guard : constant Name_Id := N + 322;
- Name_UBA : constant Name_Id := N + 323;
- Name_UBS : constant Name_Id := N + 324;
- Name_UBSB : constant Name_Id := N + 325;
- Name_Unit_Name : constant Name_Id := N + 326;
- Name_Unknown : constant Name_Id := N + 327;
- Name_Unrestricted : constant Name_Id := N + 328;
- Name_Uppercase : constant Name_Id := N + 329;
- Name_User : constant Name_Id := N + 330;
- Name_VAX_Float : constant Name_Id := N + 331;
- Name_VMS : constant Name_Id := N + 332;
- Name_Working_Storage : constant Name_Id := N + 333;
-
- -- 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
- -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT.
-
- -- The entries marked GNAT are attributes that are defined by GNAT
- -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions
- -- of these implementation dependent attributes may be found in the
- -- appropriate section in package Sem_Attr in file sem-attr.ads.
-
- -- 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 + 334;
- Name_Abort_Signal : constant Name_Id := N + 334; -- GNAT
- Name_Access : constant Name_Id := N + 335;
- Name_Address : constant Name_Id := N + 336;
- Name_Address_Size : constant Name_Id := N + 337; -- GNAT
- Name_Aft : constant Name_Id := N + 338;
- Name_Alignment : constant Name_Id := N + 339;
- Name_Asm_Input : constant Name_Id := N + 340; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 341; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 342; -- VMS
- Name_Bit : constant Name_Id := N + 343; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 344;
- Name_Bit_Position : constant Name_Id := N + 345; -- GNAT
- Name_Body_Version : constant Name_Id := N + 346;
- Name_Callable : constant Name_Id := N + 347;
- Name_Caller : constant Name_Id := N + 348;
- Name_Code_Address : constant Name_Id := N + 349; -- GNAT
- Name_Component_Size : constant Name_Id := N + 350;
- Name_Compose : constant Name_Id := N + 351;
- Name_Constrained : constant Name_Id := N + 352;
- Name_Count : constant Name_Id := N + 353;
- Name_Default_Bit_Order : constant Name_Id := N + 354; -- GNAT
- Name_Definite : constant Name_Id := N + 355;
- Name_Delta : constant Name_Id := N + 356;
- Name_Denorm : constant Name_Id := N + 357;
- Name_Digits : constant Name_Id := N + 358;
- Name_Elaborated : constant Name_Id := N + 359; -- GNAT
- Name_Emax : constant Name_Id := N + 360; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 361; -- GNAT
- Name_Epsilon : constant Name_Id := N + 362; -- Ada 83
- Name_Exponent : constant Name_Id := N + 363;
- Name_External_Tag : constant Name_Id := N + 364;
- Name_First : constant Name_Id := N + 365;
- Name_First_Bit : constant Name_Id := N + 366;
- Name_Fixed_Value : constant Name_Id := N + 367; -- GNAT
- Name_Fore : constant Name_Id := N + 368;
- Name_Has_Access_Values : constant Name_Id := N + 369; -- GNAT
- Name_Has_Discriminants : constant Name_Id := N + 370; -- GNAT
- Name_Identity : constant Name_Id := N + 371;
- Name_Img : constant Name_Id := N + 372; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 373; -- GNAT
- Name_Large : constant Name_Id := N + 374; -- Ada 83
- Name_Last : constant Name_Id := N + 375;
- Name_Last_Bit : constant Name_Id := N + 376;
- Name_Leading_Part : constant Name_Id := N + 377;
- Name_Length : constant Name_Id := N + 378;
- Name_Machine_Emax : constant Name_Id := N + 379;
- Name_Machine_Emin : constant Name_Id := N + 380;
- Name_Machine_Mantissa : constant Name_Id := N + 381;
- Name_Machine_Overflows : constant Name_Id := N + 382;
- Name_Machine_Radix : constant Name_Id := N + 383;
- Name_Machine_Rounds : constant Name_Id := N + 384;
- Name_Machine_Size : constant Name_Id := N + 385; -- GNAT
- Name_Mantissa : constant Name_Id := N + 386; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 387;
- Name_Maximum_Alignment : constant Name_Id := N + 388; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 389; -- GNAT
- Name_Mod : constant Name_Id := N + 390;
- Name_Model_Emin : constant Name_Id := N + 391;
- Name_Model_Epsilon : constant Name_Id := N + 392;
- Name_Model_Mantissa : constant Name_Id := N + 393;
- Name_Model_Small : constant Name_Id := N + 394;
- Name_Modulus : constant Name_Id := N + 395;
- Name_Null_Parameter : constant Name_Id := N + 396; -- GNAT
- Name_Object_Size : constant Name_Id := N + 397; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 398;
- Name_Passed_By_Reference : constant Name_Id := N + 399; -- GNAT
- Name_Pool_Address : constant Name_Id := N + 400;
- Name_Pos : constant Name_Id := N + 401;
- Name_Position : constant Name_Id := N + 402;
- Name_Range : constant Name_Id := N + 403;
- Name_Range_Length : constant Name_Id := N + 404; -- GNAT
- Name_Round : constant Name_Id := N + 405;
- Name_Safe_Emax : constant Name_Id := N + 406; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 407;
- Name_Safe_Large : constant Name_Id := N + 408; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 409;
- Name_Safe_Small : constant Name_Id := N + 410; -- Ada 83
- Name_Scale : constant Name_Id := N + 411;
- Name_Scaling : constant Name_Id := N + 412;
- Name_Signed_Zeros : constant Name_Id := N + 413;
- Name_Size : constant Name_Id := N + 414;
- Name_Small : constant Name_Id := N + 415;
- Name_Storage_Size : constant Name_Id := N + 416;
- Name_Storage_Unit : constant Name_Id := N + 417; -- GNAT
- Name_Stream_Size : constant Name_Id := N + 418; -- Ada 05
- Name_Tag : constant Name_Id := N + 419;
- Name_Target_Name : constant Name_Id := N + 420; -- GNAT
- Name_Terminated : constant Name_Id := N + 421;
- Name_To_Address : constant Name_Id := N + 422; -- GNAT
- Name_Type_Class : constant Name_Id := N + 423; -- GNAT
- Name_UET_Address : constant Name_Id := N + 424; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 425;
- Name_Unchecked_Access : constant Name_Id := N + 426;
- Name_Unconstrained_Array : constant Name_Id := N + 427;
- Name_Universal_Literal_String : constant Name_Id := N + 428; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 429; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 430; -- GNAT
- Name_Val : constant Name_Id := N + 431;
- Name_Valid : constant Name_Id := N + 432;
- Name_Value_Size : constant Name_Id := N + 433; -- GNAT
- Name_Version : constant Name_Id := N + 434;
- Name_Wchar_T_Size : constant Name_Id := N + 435; -- GNAT
- Name_Wide_Wide_Width : constant Name_Id := N + 436; -- Ada 05
- Name_Wide_Width : constant Name_Id := N + 437;
- Name_Width : constant Name_Id := N + 438;
- Name_Word_Size : constant Name_Id := N + 439; -- GNAT
-
- -- Attributes that designate attributes returning renamable functions,
- -- i.e. functions that return other than a universal value and that
- -- have non-universal arguments.
-
- First_Renamable_Function_Attribute : constant Name_Id := N + 440;
- Name_Adjacent : constant Name_Id := N + 440;
- Name_Ceiling : constant Name_Id := N + 441;
- Name_Copy_Sign : constant Name_Id := N + 442;
- Name_Floor : constant Name_Id := N + 443;
- Name_Fraction : constant Name_Id := N + 444;
- Name_Image : constant Name_Id := N + 445;
- Name_Input : constant Name_Id := N + 446;
- Name_Machine : constant Name_Id := N + 447;
- Name_Max : constant Name_Id := N + 448;
- Name_Min : constant Name_Id := N + 449;
- Name_Model : constant Name_Id := N + 450;
- Name_Pred : constant Name_Id := N + 451;
- Name_Remainder : constant Name_Id := N + 452;
- Name_Rounding : constant Name_Id := N + 453;
- Name_Succ : constant Name_Id := N + 454;
- Name_Truncation : constant Name_Id := N + 455;
- Name_Value : constant Name_Id := N + 456;
- Name_Wide_Image : constant Name_Id := N + 457;
- Name_Wide_Wide_Image : constant Name_Id := N + 458;
- Name_Wide_Value : constant Name_Id := N + 459;
- Name_Wide_Wide_Value : constant Name_Id := N + 460;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 460;
-
- -- Attributes that designate procedures
-
- First_Procedure_Attribute : constant Name_Id := N + 461;
- Name_Output : constant Name_Id := N + 461;
- Name_Read : constant Name_Id := N + 462;
- Name_Write : constant Name_Id := N + 463;
- Last_Procedure_Attribute : constant Name_Id := N + 463;
-
- -- Remaining attributes are ones that return entities
-
- First_Entity_Attribute_Name : constant Name_Id := N + 464;
- Name_Elab_Body : constant Name_Id := N + 464; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 465; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 466;
-
- -- These attributes are the ones that return types
-
- First_Type_Attribute_Name : constant Name_Id := N + 467;
- Name_Base : constant Name_Id := N + 467;
- Name_Class : constant Name_Id := N + 468;
- Last_Type_Attribute_Name : constant Name_Id := N + 468;
- Last_Entity_Attribute_Name : constant Name_Id := N + 468;
- Last_Attribute_Name : constant Name_Id := N + 468;
-
- -- Names of recognized locking policy identifiers
-
- -- Note: policies are identified by the first character of the
- -- 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 + 469;
- Name_Ceiling_Locking : constant Name_Id := N + 469;
- Name_Inheritance_Locking : constant Name_Id := N + 470;
- Last_Locking_Policy_Name : constant Name_Id := N + 470;
-
- -- Names of recognized queuing policy identifiers.
-
- -- Note: policies are identified by the first character of the
- -- 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 + 471;
- Name_FIFO_Queuing : constant Name_Id := N + 471;
- Name_Priority_Queuing : constant Name_Id := N + 472;
- Last_Queuing_Policy_Name : constant Name_Id := N + 472;
-
- -- Names of recognized task dispatching policy identifiers
-
- -- Note: policies are identified by the first character of the
- -- 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 + 473;
- Name_FIFO_Within_Priorities : constant Name_Id := N + 473;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 473;
-
- -- Names of recognized checks for pragma Suppress
-
- First_Check_Name : constant Name_Id := N + 474;
- Name_Access_Check : constant Name_Id := N + 474;
- Name_Accessibility_Check : constant Name_Id := N + 475;
- Name_Discriminant_Check : constant Name_Id := N + 476;
- Name_Division_Check : constant Name_Id := N + 477;
- Name_Elaboration_Check : constant Name_Id := N + 478;
- Name_Index_Check : constant Name_Id := N + 479;
- Name_Length_Check : constant Name_Id := N + 480;
- Name_Overflow_Check : constant Name_Id := N + 481;
- Name_Range_Check : constant Name_Id := N + 482;
- Name_Storage_Check : constant Name_Id := N + 483;
- Name_Tag_Check : constant Name_Id := N + 484;
- Name_All_Checks : constant Name_Id := N + 485;
- Last_Check_Name : constant Name_Id := N + 485;
-
- -- Names corresponding to reserved keywords, excluding those already
- -- declared in the attribute list (Access, Delta, Digits, Mod, Range).
-
- Name_Abort : constant Name_Id := N + 486;
- Name_Abs : constant Name_Id := N + 487;
- Name_Accept : constant Name_Id := N + 488;
- Name_And : constant Name_Id := N + 489;
- Name_All : constant Name_Id := N + 490;
- Name_Array : constant Name_Id := N + 491;
- Name_At : constant Name_Id := N + 492;
- Name_Begin : constant Name_Id := N + 493;
- Name_Body : constant Name_Id := N + 494;
- Name_Case : constant Name_Id := N + 495;
- Name_Constant : constant Name_Id := N + 496;
- Name_Declare : constant Name_Id := N + 497;
- Name_Delay : constant Name_Id := N + 498;
- Name_Do : constant Name_Id := N + 499;
- Name_Else : constant Name_Id := N + 500;
- Name_Elsif : constant Name_Id := N + 501;
- Name_End : constant Name_Id := N + 502;
- Name_Entry : constant Name_Id := N + 503;
- Name_Exception : constant Name_Id := N + 504;
- Name_Exit : constant Name_Id := N + 505;
- Name_For : constant Name_Id := N + 506;
- Name_Function : constant Name_Id := N + 507;
- Name_Generic : constant Name_Id := N + 508;
- Name_Goto : constant Name_Id := N + 509;
- Name_If : constant Name_Id := N + 510;
- Name_In : constant Name_Id := N + 511;
- Name_Is : constant Name_Id := N + 512;
- Name_Limited : constant Name_Id := N + 513;
- Name_Loop : constant Name_Id := N + 514;
- Name_New : constant Name_Id := N + 515;
- Name_Not : constant Name_Id := N + 516;
- Name_Null : constant Name_Id := N + 517;
- Name_Of : constant Name_Id := N + 518;
- Name_Or : constant Name_Id := N + 519;
- Name_Others : constant Name_Id := N + 520;
- Name_Out : constant Name_Id := N + 521;
- Name_Package : constant Name_Id := N + 522;
- Name_Pragma : constant Name_Id := N + 523;
- Name_Private : constant Name_Id := N + 524;
- Name_Procedure : constant Name_Id := N + 525;
- Name_Raise : constant Name_Id := N + 526;
- Name_Record : constant Name_Id := N + 527;
- Name_Rem : constant Name_Id := N + 528;
- Name_Renames : constant Name_Id := N + 529;
- Name_Return : constant Name_Id := N + 530;
- Name_Reverse : constant Name_Id := N + 531;
- Name_Select : constant Name_Id := N + 532;
- Name_Separate : constant Name_Id := N + 533;
- Name_Subtype : constant Name_Id := N + 534;
- Name_Task : constant Name_Id := N + 535;
- Name_Terminate : constant Name_Id := N + 536;
- Name_Then : constant Name_Id := N + 537;
- Name_Type : constant Name_Id := N + 538;
- Name_Use : constant Name_Id := N + 539;
- Name_When : constant Name_Id := N + 540;
- Name_While : constant Name_Id := N + 541;
- Name_With : constant Name_Id := N + 542;
- Name_Xor : constant Name_Id := N + 543;
-
- -- 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 + 544;
- Name_Divide : constant Name_Id := N + 544;
- Name_Enclosing_Entity : constant Name_Id := N + 545;
- Name_Exception_Information : constant Name_Id := N + 546;
- Name_Exception_Message : constant Name_Id := N + 547;
- Name_Exception_Name : constant Name_Id := N + 548;
- Name_File : constant Name_Id := N + 549;
- Name_Import_Address : constant Name_Id := N + 550;
- Name_Import_Largest_Value : constant Name_Id := N + 551;
- Name_Import_Value : constant Name_Id := N + 552;
- Name_Is_Negative : constant Name_Id := N + 553;
- Name_Line : constant Name_Id := N + 554;
- Name_Rotate_Left : constant Name_Id := N + 555;
- Name_Rotate_Right : constant Name_Id := N + 556;
- Name_Shift_Left : constant Name_Id := N + 557;
- Name_Shift_Right : constant Name_Id := N + 558;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 559;
- Name_Source_Location : constant Name_Id := N + 560;
- Name_Unchecked_Conversion : constant Name_Id := N + 561;
- Name_Unchecked_Deallocation : constant Name_Id := N + 562;
- Name_To_Pointer : constant Name_Id := N + 563;
- Last_Intrinsic_Name : constant Name_Id := N + 563;
-
- -- Reserved words used only in Ada 95
-
- First_95_Reserved_Word : constant Name_Id := N + 564;
- Name_Abstract : constant Name_Id := N + 564;
- Name_Aliased : constant Name_Id := N + 565;
- Name_Protected : constant Name_Id := N + 566;
- Name_Until : constant Name_Id := N + 567;
- Name_Requeue : constant Name_Id := N + 568;
- Name_Tagged : constant Name_Id := N + 569;
- Last_95_Reserved_Word : constant Name_Id := N + 569;
-
- 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 + 570;
-
- -- Additional reserved words and identifiers used in GNAT Project Files
- -- Note that Name_External is already previously declared
-
- Name_Ada_Roots : constant Name_Id := N + 571;
- Name_Binder : constant Name_Id := N + 572;
- Name_Binder_Driver : constant Name_Id := N + 573;
- Name_Body_Suffix : constant Name_Id := N + 574;
- Name_Builder : constant Name_Id := N + 575;
- Name_Compiler : constant Name_Id := N + 576;
- Name_Compiler_Driver : constant Name_Id := N + 577;
- Name_Compiler_Kind : constant Name_Id := N + 578;
- Name_Compute_Dependency : constant Name_Id := N + 579;
- Name_Cross_Reference : constant Name_Id := N + 580;
- Name_Default_Linker : constant Name_Id := N + 581;
- Name_Default_Switches : constant Name_Id := N + 582;
- Name_Dependency_Option : constant Name_Id := N + 583;
- Name_Exec_Dir : constant Name_Id := N + 584;
- Name_Executable : constant Name_Id := N + 585;
- Name_Executable_Suffix : constant Name_Id := N + 586;
- Name_Extends : constant Name_Id := N + 587;
- Name_Externally_Built : constant Name_Id := N + 588;
- Name_Finder : constant Name_Id := N + 589;
- Name_Global_Configuration_Pragmas : constant Name_Id := N + 590;
- Name_Gnatls : constant Name_Id := N + 591;
- Name_Gnatstub : constant Name_Id := N + 592;
- Name_Implementation : constant Name_Id := N + 593;
- Name_Implementation_Exceptions : constant Name_Id := N + 594;
- Name_Implementation_Suffix : constant Name_Id := N + 595;
- Name_Include_Option : constant Name_Id := N + 596;
- Name_Language_Processing : constant Name_Id := N + 597;
- Name_Languages : constant Name_Id := N + 598;
- Name_Library_Dir : constant Name_Id := N + 599;
- Name_Library_Auto_Init : constant Name_Id := N + 600;
- Name_Library_GCC : constant Name_Id := N + 601;
- Name_Library_Interface : constant Name_Id := N + 602;
- Name_Library_Kind : constant Name_Id := N + 603;
- Name_Library_Name : constant Name_Id := N + 604;
- Name_Library_Options : constant Name_Id := N + 605;
- Name_Library_Reference_Symbol_File : constant Name_Id := N + 606;
- Name_Library_Src_Dir : constant Name_Id := N + 607;
- Name_Library_Symbol_File : constant Name_Id := N + 608;
- Name_Library_Symbol_Policy : constant Name_Id := N + 609;
- Name_Library_Version : constant Name_Id := N + 610;
- Name_Linker : constant Name_Id := N + 611;
- Name_Local_Configuration_Pragmas : constant Name_Id := N + 612;
- Name_Locally_Removed_Files : constant Name_Id := N + 613;
- Name_Metrics : constant Name_Id := N + 614;
- Name_Naming : constant Name_Id := N + 615;
- Name_Object_Dir : constant Name_Id := N + 616;
- Name_Pretty_Printer : constant Name_Id := N + 617;
- Name_Project : constant Name_Id := N + 618;
- Name_Separate_Suffix : constant Name_Id := N + 619;
- Name_Source_Dirs : constant Name_Id := N + 620;
- Name_Source_Files : constant Name_Id := N + 621;
- Name_Source_List_File : constant Name_Id := N + 622;
- Name_Spec : constant Name_Id := N + 623;
- Name_Spec_Suffix : constant Name_Id := N + 624;
- Name_Specification : constant Name_Id := N + 625;
- Name_Specification_Exceptions : constant Name_Id := N + 626;
- Name_Specification_Suffix : constant Name_Id := N + 627;
- Name_Switches : constant Name_Id := N + 628;
-
- -- Other miscellaneous names used in front end
-
- Name_Unaligned_Valid : constant Name_Id := N + 629;
-
- -- ----------------------------------------------------------------
- First_2005_Reserved_Word : constant Name_Id := N + 630;
- Name_Interface : constant Name_Id := N + 630;
- Name_Overriding : constant Name_Id := N + 631;
- Name_Synchronized : constant Name_Id := N + 632;
- Last_2005_Reserved_Word : constant Name_Id := N + 632;
-
- subtype Ada_2005_Reserved_Words is
- Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
-
- -- Mark last defined name for consistency check in Snames body
-
- Last_Predefined_Name : constant Name_Id := N + 632;
-
- subtype Any_Operator_Name is Name_Id range
- First_Operator_Name .. Last_Operator_Name;
-
- ------------------------------
- -- Attribute ID Definitions --
- ------------------------------
-
- type Attribute_Id is (
- Attribute_Abort_Signal,
- Attribute_Access,
- Attribute_Address,
- Attribute_Address_Size,
- Attribute_Aft,
- Attribute_Alignment,
- Attribute_Asm_Input,
- Attribute_Asm_Output,
- Attribute_AST_Entry,
- Attribute_Bit,
- Attribute_Bit_Order,
- Attribute_Bit_Position,
- Attribute_Body_Version,
- Attribute_Callable,
- Attribute_Caller,
- Attribute_Code_Address,
- Attribute_Component_Size,
- Attribute_Compose,
- Attribute_Constrained,
- Attribute_Count,
- Attribute_Default_Bit_Order,
- Attribute_Definite,
- Attribute_Delta,
- Attribute_Denorm,
- Attribute_Digits,
- Attribute_Elaborated,
- Attribute_Emax,
- Attribute_Enum_Rep,
- Attribute_Epsilon,
- Attribute_Exponent,
- Attribute_External_Tag,
- Attribute_First,
- Attribute_First_Bit,
- Attribute_Fixed_Value,
- Attribute_Fore,
- Attribute_Has_Access_Values,
- Attribute_Has_Discriminants,
- Attribute_Identity,
- Attribute_Img,
- Attribute_Integer_Value,
- Attribute_Large,
- Attribute_Last,
- Attribute_Last_Bit,
- Attribute_Leading_Part,
- Attribute_Length,
- Attribute_Machine_Emax,
- Attribute_Machine_Emin,
- Attribute_Machine_Mantissa,
- Attribute_Machine_Overflows,
- Attribute_Machine_Radix,
- Attribute_Machine_Rounds,
- Attribute_Machine_Size,
- Attribute_Mantissa,
- Attribute_Max_Size_In_Storage_Elements,
- Attribute_Maximum_Alignment,
- Attribute_Mechanism_Code,
- Attribute_Mod,
- Attribute_Model_Emin,
- Attribute_Model_Epsilon,
- Attribute_Model_Mantissa,
- Attribute_Model_Small,
- Attribute_Modulus,
- Attribute_Null_Parameter,
- Attribute_Object_Size,
- Attribute_Partition_ID,
- Attribute_Passed_By_Reference,
- Attribute_Pool_Address,
- Attribute_Pos,
- Attribute_Position,
- Attribute_Range,
- Attribute_Range_Length,
- Attribute_Round,
- Attribute_Safe_Emax,
- Attribute_Safe_First,
- Attribute_Safe_Large,
- Attribute_Safe_Last,
- Attribute_Safe_Small,
- Attribute_Scale,
- Attribute_Scaling,
- Attribute_Signed_Zeros,
- Attribute_Size,
- Attribute_Small,
- Attribute_Storage_Size,
- Attribute_Storage_Unit,
- Attribute_Stream_Size,
- Attribute_Tag,
- Attribute_Target_Name,
- Attribute_Terminated,
- Attribute_To_Address,
- Attribute_Type_Class,
- Attribute_UET_Address,
- Attribute_Unbiased_Rounding,
- Attribute_Unchecked_Access,
- Attribute_Unconstrained_Array,
- Attribute_Universal_Literal_String,
- Attribute_Unrestricted_Access,
- Attribute_VADS_Size,
- Attribute_Val,
- Attribute_Valid,
- Attribute_Value_Size,
- Attribute_Version,
- Attribute_Wchar_T_Size,
- Attribute_Wide_Wide_Width,
- Attribute_Wide_Width,
- Attribute_Width,
- Attribute_Word_Size,
-
- -- Attributes designating renamable functions
-
- Attribute_Adjacent,
- Attribute_Ceiling,
- Attribute_Copy_Sign,
- Attribute_Floor,
- Attribute_Fraction,
- Attribute_Image,
- Attribute_Input,
- Attribute_Machine,
- Attribute_Max,
- Attribute_Min,
- Attribute_Model,
- Attribute_Pred,
- Attribute_Remainder,
- Attribute_Rounding,
- Attribute_Succ,
- Attribute_Truncation,
- Attribute_Value,
- Attribute_Wide_Image,
- Attribute_Wide_Wide_Image,
- Attribute_Wide_Value,
- Attribute_Wide_Wide_Value,
-
- -- Attributes designating procedures
-
- Attribute_Output,
- Attribute_Read,
- Attribute_Write,
-
- -- Entity attributes (includes type attributes)
-
- Attribute_Elab_Body,
- Attribute_Elab_Spec,
- Attribute_Storage_Pool,
-
- -- Type attributes
-
- Attribute_Base,
- Attribute_Class);
-
- ------------------------------------
- -- Convention Name ID Definitions --
- ------------------------------------
-
- type Convention_Id is (
-
- -- The conventions that are defined by the RM come first
-
- Convention_Ada,
- Convention_Intrinsic,
- Convention_Entry,
- Convention_Protected,
-
- -- The remaining conventions are foreign language conventions
-
- Convention_Assembler, -- also Asm, Assembly
- Convention_C, -- also Default, External
- Convention_COBOL,
- Convention_CPP,
- Convention_Fortran,
- Convention_Java,
- Convention_Stdcall, -- also DLL, Win32
- Convention_Stubbed);
-
- -- Note: Convention C_Pass_By_Copy is allowed only for record
- -- types (where it is treated like C except that the appropriate
- -- flag is set in the record type). Recognizion of this convention
- -- is specially handled in Sem_Prag.
-
- for Convention_Id'Size use 8;
- -- Plenty of space for expansion
-
- subtype Foreign_Convention is
- Convention_Id range Convention_Assembler .. Convention_Stdcall;
-
- -----------------------------------
- -- Locking Policy ID Definitions --
- -----------------------------------
-
- type Locking_Policy_Id is (
- Locking_Policy_Inheritance_Locking,
- Locking_Policy_Ceiling_Locking);
-
- ---------------------------
- -- Pragma ID Definitions --
- ---------------------------
-
- type Pragma_Id is (
-
- -- Configuration pragmas
-
- Pragma_Ada_83,
- Pragma_Ada_95,
- Pragma_Ada_05,
- Pragma_C_Pass_By_Copy,
- Pragma_Compile_Time_Warning,
- Pragma_Component_Alignment,
- Pragma_Convention_Identifier,
- Pragma_Detect_Blocking,
- Pragma_Discard_Names,
- Pragma_Elaboration_Checks,
- Pragma_Eliminate,
- Pragma_Explicit_Overriding,
- Pragma_Extend_System,
- Pragma_Extensions_Allowed,
- Pragma_External_Name_Casing,
- Pragma_Float_Representation,
- Pragma_Initialize_Scalars,
- Pragma_Interrupt_State,
- Pragma_License,
- Pragma_Locking_Policy,
- Pragma_Long_Float,
- Pragma_No_Run_Time,
- Pragma_No_Strict_Aliasing,
- Pragma_Normalize_Scalars,
- Pragma_Polling,
- Pragma_Persistent_Data,
- Pragma_Persistent_Object,
- Pragma_Profile,
- Pragma_Profile_Warnings,
- Pragma_Propagate_Exceptions,
- Pragma_Queuing_Policy,
- Pragma_Ravenscar,
- Pragma_Restricted_Run_Time,
- Pragma_Restrictions,
- Pragma_Restriction_Warnings,
- Pragma_Reviewable,
- Pragma_Source_File_Name,
- Pragma_Source_File_Name_Project,
- Pragma_Style_Checks,
- Pragma_Suppress,
- Pragma_Suppress_Exception_Locations,
- Pragma_Task_Dispatching_Policy,
- Pragma_Universal_Data,
- Pragma_Unsuppress,
- Pragma_Use_VADS_Size,
- Pragma_Validity_Checks,
- Pragma_Warnings,
-
- -- Remaining (non-configuration) pragmas
-
- Pragma_Abort_Defer,
- Pragma_All_Calls_Remote,
- Pragma_Annotate,
- Pragma_Assert,
- Pragma_Asynchronous,
- Pragma_Atomic,
- Pragma_Atomic_Components,
- Pragma_Attach_Handler,
- Pragma_Comment,
- Pragma_Common_Object,
- Pragma_Complex_Representation,
- Pragma_Controlled,
- Pragma_Convention,
- Pragma_CPP_Class,
- Pragma_CPP_Constructor,
- Pragma_CPP_Virtual,
- Pragma_CPP_Vtable,
- Pragma_Debug,
- Pragma_Elaborate,
- Pragma_Elaborate_All,
- Pragma_Elaborate_Body,
- Pragma_Export,
- Pragma_Export_Exception,
- Pragma_Export_Function,
- Pragma_Export_Object,
- Pragma_Export_Procedure,
- Pragma_Export_Value,
- Pragma_Export_Valued_Procedure,
- Pragma_External,
- Pragma_Finalize_Storage_Only,
- Pragma_Ident,
- Pragma_Import,
- Pragma_Import_Exception,
- Pragma_Import_Function,
- Pragma_Import_Object,
- Pragma_Import_Procedure,
- Pragma_Import_Valued_Procedure,
- Pragma_Inline,
- Pragma_Inline_Always,
- Pragma_Inline_Generic,
- Pragma_Inspection_Point,
- Pragma_Interface_Name,
- Pragma_Interrupt_Handler,
- Pragma_Interrupt_Priority,
- Pragma_Java_Constructor,
- Pragma_Java_Interface,
- Pragma_Keep_Names,
- Pragma_Link_With,
- Pragma_Linker_Alias,
- Pragma_Linker_Options,
- Pragma_Linker_Section,
- Pragma_List,
- Pragma_Machine_Attribute,
- Pragma_Main,
- Pragma_Main_Storage,
- Pragma_Memory_Size,
- Pragma_No_Return,
- Pragma_Obsolescent,
- Pragma_Optimize,
- Pragma_Optional_Overriding,
- Pragma_Pack,
- Pragma_Page,
- Pragma_Passive,
- Pragma_Preelaborate,
- Pragma_Priority,
- Pragma_Psect_Object,
- Pragma_Pure,
- Pragma_Pure_Function,
- Pragma_Remote_Call_Interface,
- Pragma_Remote_Types,
- Pragma_Share_Generic,
- Pragma_Shared,
- Pragma_Shared_Passive,
- Pragma_Source_Reference,
- Pragma_Stream_Convert,
- Pragma_Subtitle,
- Pragma_Suppress_All,
- Pragma_Suppress_Debug_Info,
- Pragma_Suppress_Initialization,
- Pragma_System_Name,
- Pragma_Task_Info,
- Pragma_Task_Name,
- Pragma_Task_Storage,
- Pragma_Thread_Body,
- Pragma_Time_Slice,
- Pragma_Title,
- Pragma_Unchecked_Union,
- Pragma_Unimplemented_Unit,
- Pragma_Unreferenced,
- Pragma_Unreserve_All_Interrupts,
- Pragma_Volatile,
- Pragma_Volatile_Components,
- Pragma_Weak_External,
-
- -- The following pragmas are on their own, out of order, because of
- -- the special processing required to deal with the fact that their
- -- names match existing attribute names.
-
- Pragma_AST_Entry,
- Pragma_Interface,
- Pragma_Storage_Size,
- Pragma_Storage_Unit,
-
- -- The value to represent an unknown or unrecognized pragma
-
- Unknown_Pragma);
-
- -----------------------------------
- -- Queuing Policy ID definitions --
- -----------------------------------
-
- type Queuing_Policy_Id is (
- Queuing_Policy_FIFO_Queuing,
- Queuing_Policy_Priority_Queuing);
-
- --------------------------------------------
- -- Task Dispatching Policy ID definitions --
- --------------------------------------------
-
- type Task_Dispatching_Policy_Id is (
- Task_Dispatching_FIFO_Within_Priorities);
- -- Id values used to identify task dispatching policies
-
- -----------------
- -- Subprograms --
- -----------------
-
- procedure Initialize;
- -- Called to initialize the preset names in the names table.
-
- function Is_Attribute_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized attribute
-
- function Is_Entity_Attribute_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized entity attribute,
- -- i.e. an attribute reference that returns an entity.
-
- function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized attribute that
- -- designates a procedure (and can therefore appear as a statement).
-
- function Is_Function_Attribute_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized attribute
- -- that designates a renameable function, and can therefore appear in
- -- a renaming statement. Note that not all attributes designating
- -- functions are renamable, in particular, thos returning a universal
- -- value cannot be renamed.
-
- function Is_Type_Attribute_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized type attribute,
- -- i.e. an attribute reference that returns a type
-
- function Is_Check_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized suppress check
- -- as required by pragma Suppress.
-
- function Is_Convention_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of one of the recognized
- -- language conventions, as required by pragma Convention, Import,
- -- Export, Interface. Returns True if so. Also returns True for a
- -- name that has been specified by a Convention_Identifier pragma.
- -- If neither case holds, returns False.
-
- function Is_Locking_Policy_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized locking policy
-
- function Is_Operator_Symbol_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of an operator symbol
-
- function Is_Pragma_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized pragma. Note
- -- that pragmas AST_Entry, Storage_Size, and Storage_Unit are recognized
- -- as pragmas by this function even though their names are separate from
- -- the other pragma names.
-
- function Is_Queuing_Policy_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized queuing policy
-
- function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized task
- -- dispatching policy.
-
- function Get_Attribute_Id (N : Name_Id) return Attribute_Id;
- -- Returns Id of attribute corresponding to given name. It is an error to
- -- call this function with a name that is not the name of a attribute.
-
- function Get_Convention_Id (N : Name_Id) return Convention_Id;
- -- Returns Id of language convention corresponding to given name. It is an
- -- to call this function with a name that is not the name of a convention,
- -- or one previously given in a call to Record_Convention_Identifier.
-
- function Get_Check_Id (N : Name_Id) return Check_Id;
- -- Returns Id of suppress check corresponding to given name. It is an error
- -- to call this function with a name that is not the name of a check.
-
- function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id;
- -- Returns Id of locking policy corresponding to given name. It is an error
- -- to call this function with a name that is not the name of a check.
-
- function Get_Pragma_Id (N : Name_Id) return Pragma_Id;
- -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma
- -- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
- -- Note that the function also works correctly for names of pragmas that
- -- are not in the main list of pragma Names (AST_Entry, Storage_Size, and
- -- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
-
- function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
- -- Returns Id of queuing policy corresponding to given name. It is an error
- -- to call this function with a name that is not the name of a check.
-
- function Get_Task_Dispatching_Policy_Id
- (N : Name_Id)
- return Task_Dispatching_Policy_Id;
- -- Returns Id of task dispatching policy corresponding to given name.
- -- It is an error to call this function with a name that is not the
- -- name of a check.
-
- procedure Record_Convention_Identifier
- (Id : Name_Id;
- Convention : Convention_Id);
- -- A call to this procedure, resulting from an occurrence of a pragma
- -- Convention_Identifier, records that from now on an occurrence of
- -- Id will be recognized as a name for the specified convention.
-
-private
- pragma Inline (Is_Attribute_Name);
- pragma Inline (Is_Entity_Attribute_Name);
- pragma Inline (Is_Type_Attribute_Name);
- pragma Inline (Is_Check_Name);
- pragma Inline (Is_Locking_Policy_Name);
- pragma Inline (Is_Operator_Symbol_Name);
- pragma Inline (Is_Queuing_Policy_Name);
- pragma Inline (Is_Pragma_Name);
- pragma Inline (Is_Task_Dispatching_Policy_Name);
-
-end Snames;
+------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Types; use Types; + +package Snames is + +-- This package contains definitions of standard names (i.e. entries in the +-- Names table) that are used throughout the GNAT compiler). It also contains +-- the definitions of some enumeration types whose definitions are tied to +-- the order of these preset names. + +-- WARNING: There is a C file, a-snames.h which duplicates some of the +-- definitions in this file and must be kept properly synchronized. + + ------------------ + -- Preset Names -- + ------------------ + + -- The following are preset entries in the names table, which are + -- entered at the start of every compilation for easy access. Note + -- that the order of initialization of these names in the body must + -- be coordinated with the order of names in this table. + + -- Note: a name may not appear more than once in the following list. + -- If additional pragmas or attributes are introduced which might + -- otherwise cause a duplicate, then list it only once in this table, + -- and adjust the definition of the functions for testing for pragma + -- names and attribute names, and returning their ID values. Of course + -- everything is simpler if no such duplications occur! + + -- First we have the one character names used to optimize the lookup + -- process for one character identifiers (to avoid the hashing in this + -- case) There are a full 256 of these, but only the entries for lower + -- case and upper case letters have identifiers + + -- The lower case letter entries are used for one character identifiers + -- appearing in the source, for example in pragma Interface (C). + + Name_A : constant Name_Id := First_Name_Id + Character'Pos ('a'); + Name_B : constant Name_Id := First_Name_Id + Character'Pos ('b'); + Name_C : constant Name_Id := First_Name_Id + Character'Pos ('c'); + Name_D : constant Name_Id := First_Name_Id + Character'Pos ('d'); + Name_E : constant Name_Id := First_Name_Id + Character'Pos ('e'); + Name_F : constant Name_Id := First_Name_Id + Character'Pos ('f'); + Name_G : constant Name_Id := First_Name_Id + Character'Pos ('g'); + Name_H : constant Name_Id := First_Name_Id + Character'Pos ('h'); + Name_I : constant Name_Id := First_Name_Id + Character'Pos ('i'); + Name_J : constant Name_Id := First_Name_Id + Character'Pos ('j'); + Name_K : constant Name_Id := First_Name_Id + Character'Pos ('k'); + Name_L : constant Name_Id := First_Name_Id + Character'Pos ('l'); + Name_M : constant Name_Id := First_Name_Id + Character'Pos ('m'); + Name_N : constant Name_Id := First_Name_Id + Character'Pos ('n'); + Name_O : constant Name_Id := First_Name_Id + Character'Pos ('o'); + Name_P : constant Name_Id := First_Name_Id + Character'Pos ('p'); + Name_Q : constant Name_Id := First_Name_Id + Character'Pos ('q'); + Name_R : constant Name_Id := First_Name_Id + Character'Pos ('r'); + Name_S : constant Name_Id := First_Name_Id + Character'Pos ('s'); + Name_T : constant Name_Id := First_Name_Id + Character'Pos ('t'); + Name_U : constant Name_Id := First_Name_Id + Character'Pos ('u'); + Name_V : constant Name_Id := First_Name_Id + Character'Pos ('v'); + Name_W : constant Name_Id := First_Name_Id + Character'Pos ('w'); + Name_X : constant Name_Id := First_Name_Id + Character'Pos ('x'); + Name_Y : constant Name_Id := First_Name_Id + Character'Pos ('y'); + Name_Z : constant Name_Id := First_Name_Id + Character'Pos ('z'); + + -- The upper case letter entries are used by expander code for local + -- variables that do not require unique names (e.g. formal parameter + -- names in constructed procedures) + + Name_uA : constant Name_Id := First_Name_Id + Character'Pos ('A'); + Name_uB : constant Name_Id := First_Name_Id + Character'Pos ('B'); + Name_uC : constant Name_Id := First_Name_Id + Character'Pos ('C'); + Name_uD : constant Name_Id := First_Name_Id + Character'Pos ('D'); + Name_uE : constant Name_Id := First_Name_Id + Character'Pos ('E'); + Name_uF : constant Name_Id := First_Name_Id + Character'Pos ('F'); + Name_uG : constant Name_Id := First_Name_Id + Character'Pos ('G'); + Name_uH : constant Name_Id := First_Name_Id + Character'Pos ('H'); + Name_uI : constant Name_Id := First_Name_Id + Character'Pos ('I'); + Name_uJ : constant Name_Id := First_Name_Id + Character'Pos ('J'); + Name_uK : constant Name_Id := First_Name_Id + Character'Pos ('K'); + Name_uL : constant Name_Id := First_Name_Id + Character'Pos ('L'); + Name_uM : constant Name_Id := First_Name_Id + Character'Pos ('M'); + Name_uN : constant Name_Id := First_Name_Id + Character'Pos ('N'); + Name_uO : constant Name_Id := First_Name_Id + Character'Pos ('O'); + Name_uP : constant Name_Id := First_Name_Id + Character'Pos ('P'); + Name_uQ : constant Name_Id := First_Name_Id + Character'Pos ('Q'); + Name_uR : constant Name_Id := First_Name_Id + Character'Pos ('R'); + Name_uS : constant Name_Id := First_Name_Id + Character'Pos ('S'); + Name_uT : constant Name_Id := First_Name_Id + Character'Pos ('T'); + Name_uU : constant Name_Id := First_Name_Id + Character'Pos ('U'); + Name_uV : constant Name_Id := First_Name_Id + Character'Pos ('V'); + Name_uW : constant Name_Id := First_Name_Id + Character'Pos ('W'); + Name_uX : constant Name_Id := First_Name_Id + Character'Pos ('X'); + Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); + Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); + + -- Note: the following table is read by the utility program XSNAMES and + -- its format should not be changed without coordinating with this program. + + N : constant Name_Id := First_Name_Id + 256; + -- Synonym used in standard name definitions + + -- Some names that are used by gigi, and whose definitions are reflected + -- in the C header file a-snames.h. They are placed at the start so that + -- the need to modify a-snames.h is minimized. + + Name_uParent : constant Name_Id := N + 000; + Name_uTag : constant Name_Id := N + 001; + Name_Off : constant Name_Id := N + 002; + Name_Space : constant Name_Id := N + 003; + Name_Time : constant Name_Id := N + 004; + + -- Some special names used by the expander. Note that the lower case u's + -- at the start of these names get translated to extra underscores. These + -- names are only referenced internally by expander generated code. + + Name_uAbort_Signal : constant Name_Id := N + 005; + Name_uAlignment : constant Name_Id := N + 006; + Name_uAssign : constant Name_Id := N + 007; + Name_uATCB : constant Name_Id := N + 008; + Name_uChain : constant Name_Id := N + 009; + Name_uClean : constant Name_Id := N + 010; + Name_uController : constant Name_Id := N + 011; + Name_uEntry_Bodies : constant Name_Id := N + 012; + Name_uExpunge : constant Name_Id := N + 013; + Name_uFinal_List : constant Name_Id := N + 014; + Name_uIdepth : constant Name_Id := N + 015; + Name_uInit : constant Name_Id := N + 016; + Name_uLocal_Final_List : constant Name_Id := N + 017; + Name_uMaster : constant Name_Id := N + 018; + Name_uObject : constant Name_Id := N + 019; + Name_uPriority : constant Name_Id := N + 020; + Name_uProcess_ATSD : constant Name_Id := N + 021; + Name_uSecondary_Stack : constant Name_Id := N + 022; + Name_uService : constant Name_Id := N + 023; + Name_uSize : constant Name_Id := N + 024; + Name_uStack : constant Name_Id := N + 025; + Name_uTags : constant Name_Id := N + 026; + Name_uTask : constant Name_Id := N + 027; + Name_uTask_Id : constant Name_Id := N + 028; + Name_uTask_Info : constant Name_Id := N + 029; + Name_uTask_Name : constant Name_Id := N + 030; + Name_uTrace_Sp : constant Name_Id := N + 031; + + -- Names of routines in Ada.Finalization, needed by expander + + Name_Initialize : constant Name_Id := N + 032; + Name_Adjust : constant Name_Id := N + 033; + Name_Finalize : constant Name_Id := N + 034; + + -- Names of fields declared in System.Finalization_Implementation, + -- needed by the expander when generating code for finalization. + + Name_Next : constant Name_Id := N + 035; + Name_Prev : constant Name_Id := N + 036; + + -- Names of TSS routines for implementation of DSA over PolyORB + + Name_uTypeCode : constant Name_Id := N + 037; + Name_uFrom_Any : constant Name_Id := N + 038; + Name_uTo_Any : constant Name_Id := N + 039; + + -- Names of allocation routines, also needed by expander + + Name_Allocate : constant Name_Id := N + 040; + Name_Deallocate : constant Name_Id := N + 041; + Name_Dereference : constant Name_Id := N + 042; + + -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) + + First_Text_IO_Package : constant Name_Id := N + 043; + Name_Decimal_IO : constant Name_Id := N + 043; + Name_Enumeration_IO : constant Name_Id := N + 044; + Name_Fixed_IO : constant Name_Id := N + 045; + Name_Float_IO : constant Name_Id := N + 046; + Name_Integer_IO : constant Name_Id := N + 047; + Name_Modular_IO : constant Name_Id := N + 048; + Last_Text_IO_Package : constant Name_Id := N + 048; + + subtype Text_IO_Package_Name is Name_Id + range First_Text_IO_Package .. Last_Text_IO_Package; + + -- Some miscellaneous names used for error detection/recovery + + Name_Const : constant Name_Id := N + 049; + Name_Error : constant Name_Id := N + 050; + Name_Go : constant Name_Id := N + 051; + Name_Put : constant Name_Id := N + 052; + Name_Put_Line : constant Name_Id := N + 053; + Name_To : constant Name_Id := N + 054; + + -- Names for packages that are treated specially by the compiler + + Name_Finalization : constant Name_Id := N + 055; + Name_Finalization_Root : constant Name_Id := N + 056; + Name_Interfaces : constant Name_Id := N + 057; + Name_Standard : constant Name_Id := N + 058; + Name_System : constant Name_Id := N + 059; + Name_Text_IO : constant Name_Id := N + 060; + Name_Wide_Text_IO : constant Name_Id := N + 061; + Name_Wide_Wide_Text_IO : constant Name_Id := N + 062; + + -- Names of implementations of the distributed systems annex + + First_PCS_Name : constant Name_Id := N + 063; + Name_No_DSA : constant Name_Id := N + 063; + Name_GARLIC_DSA : constant Name_Id := N + 064; + Name_PolyORB_DSA : constant Name_Id := N + 065; + Last_PCS_Name : constant Name_Id := N + 065; + + subtype PCS_Names is Name_Id + range First_PCS_Name .. Last_PCS_Name; + + -- Names of identifiers used in expanding distribution stubs + + Name_Addr : constant Name_Id := N + 066; + Name_Async : constant Name_Id := N + 067; + Name_Get_Active_Partition_ID : constant Name_Id := N + 068; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 069; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 070; + Name_Origin : constant Name_Id := N + 071; + Name_Params : constant Name_Id := N + 072; + Name_Partition : constant Name_Id := N + 073; + Name_Partition_Interface : constant Name_Id := N + 074; + Name_Ras : constant Name_Id := N + 075; + Name_Call : constant Name_Id := N + 076; + Name_RCI_Name : constant Name_Id := N + 077; + Name_Receiver : constant Name_Id := N + 078; + Name_Result : constant Name_Id := N + 079; + Name_Rpc : constant Name_Id := N + 080; + Name_Subp_Id : constant Name_Id := N + 081; + Name_Operation : constant Name_Id := N + 082; + Name_Argument : constant Name_Id := N + 083; + Name_Arg_Modes : constant Name_Id := N + 084; + Name_Handler : constant Name_Id := N + 085; + Name_Target : constant Name_Id := N + 086; + Name_Req : constant Name_Id := N + 087; + Name_Obj_TypeCode : constant Name_Id := N + 088; + Name_Stub : constant Name_Id := N + 089; + + -- Operator Symbol entries. The actual names have an upper case O at + -- the start in place of the Op_ prefix (e.g. the actual name that + -- corresponds to Name_Op_Abs is "Oabs". + + First_Operator_Name : constant Name_Id := N + 090; + Name_Op_Abs : constant Name_Id := N + 090; -- "abs" + Name_Op_And : constant Name_Id := N + 091; -- "and" + Name_Op_Mod : constant Name_Id := N + 092; -- "mod" + Name_Op_Not : constant Name_Id := N + 093; -- "not" + Name_Op_Or : constant Name_Id := N + 094; -- "or" + Name_Op_Rem : constant Name_Id := N + 095; -- "rem" + Name_Op_Xor : constant Name_Id := N + 096; -- "xor" + Name_Op_Eq : constant Name_Id := N + 097; -- "=" + Name_Op_Ne : constant Name_Id := N + 098; -- "/=" + Name_Op_Lt : constant Name_Id := N + 099; -- "<" + Name_Op_Le : constant Name_Id := N + 100; -- "<=" + Name_Op_Gt : constant Name_Id := N + 101; -- ">" + Name_Op_Ge : constant Name_Id := N + 102; -- ">=" + Name_Op_Add : constant Name_Id := N + 103; -- "+" + Name_Op_Subtract : constant Name_Id := N + 104; -- "-" + Name_Op_Concat : constant Name_Id := N + 105; -- "&" + Name_Op_Multiply : constant Name_Id := N + 106; -- "*" + Name_Op_Divide : constant Name_Id := N + 107; -- "/" + Name_Op_Expon : constant Name_Id := N + 108; -- "**" + Last_Operator_Name : constant Name_Id := N + 108; + + -- Names for all pragmas recognized by GNAT. The entries with the comment + -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. + -- These pragmas are fully implemented in both Ada 83 and Ada 95 modes + -- in GNAT. + + -- The entries marked GNAT are pragmas that are defined by GNAT + -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions + -- of these implementation dependent pragmas may be found in the + -- appropriate section in unit Sem_Prag in file sem-prag.adb. + + -- The entries marked Ada05 are technically implementation dependent + -- pragmas, but they correspond to standard proposals for Ada 2005. + + -- The entries marked VMS are VMS specific pragmas that are recognized + -- only in OpenVMS versions of GNAT. They are ignored in other versions + -- with an appropriate warning. + + -- The entries marked AAMP are AAMP specific pragmas that are recognized + -- only in GNAT for the AAMP. They are ignored in other versions with + -- appropriate warnings. + + First_Pragma_Name : constant Name_Id := N + 109; + + -- Configuration pragmas are grouped at start + + Name_Ada_83 : constant Name_Id := N + 109; -- GNAT + Name_Ada_95 : constant Name_Id := N + 110; -- GNAT + Name_Ada_05 : constant Name_Id := N + 111; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + 112; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 113; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 114; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 115; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 116; -- Ada05 + Name_Discard_Names : constant Name_Id := N + 117; + Name_Elaboration_Checks : constant Name_Id := N + 118; -- GNAT + Name_Eliminate : constant Name_Id := N + 119; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 120; + Name_Extend_System : constant Name_Id := N + 121; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 122; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 123; -- GNAT + Name_Float_Representation : constant Name_Id := N + 124; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 125; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 126; -- GNAT + Name_License : constant Name_Id := N + 127; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 128; + Name_Long_Float : constant Name_Id := N + 129; -- VMS + Name_No_Run_Time : constant Name_Id := N + 130; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 131; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 132; + Name_Polling : constant Name_Id := N + 133; -- GNAT + Name_Persistent_Data : constant Name_Id := N + 134; -- GNAT + Name_Persistent_Object : constant Name_Id := N + 135; -- GNAT + Name_Profile : constant Name_Id := N + 136; -- Ada05 + Name_Profile_Warnings : constant Name_Id := N + 137; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 138; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 139; + Name_Ravenscar : constant Name_Id := N + 140; + Name_Restricted_Run_Time : constant Name_Id := N + 141; + Name_Restrictions : constant Name_Id := N + 142; + Name_Restriction_Warnings : constant Name_Id := N + 143; -- GNAT + Name_Reviewable : constant Name_Id := N + 144; + Name_Source_File_Name : constant Name_Id := N + 145; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 146; -- GNAT + Name_Style_Checks : constant Name_Id := N + 147; -- GNAT + Name_Suppress : constant Name_Id := N + 148; + Name_Suppress_Exception_Locations : constant Name_Id := N + 149; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 150; + Name_Universal_Data : constant Name_Id := N + 151; -- AAMP + Name_Unsuppress : constant Name_Id := N + 152; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 153; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 154; -- GNAT + Name_Warnings : constant Name_Id := N + 155; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 155; + + -- Remaining pragma names + + Name_Abort_Defer : constant Name_Id := N + 156; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 157; + Name_Annotate : constant Name_Id := N + 158; -- GNAT + + -- Note: AST_Entry is not in this list because its name matches the + -- name of the corresponding attribute. However, it is included in the + -- definition of the type Attribute_Id, and the functions Get_Pragma_Id + -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. + -- AST_Entry is a VMS specific pragma. + + Name_Assert : constant Name_Id := N + 159; -- GNAT + Name_Asynchronous : constant Name_Id := N + 160; + Name_Atomic : constant Name_Id := N + 161; + Name_Atomic_Components : constant Name_Id := N + 162; + Name_Attach_Handler : constant Name_Id := N + 163; + Name_Comment : constant Name_Id := N + 164; -- GNAT + Name_Common_Object : constant Name_Id := N + 165; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 166; -- GNAT + Name_Controlled : constant Name_Id := N + 167; + Name_Convention : constant Name_Id := N + 168; + Name_CPP_Class : constant Name_Id := N + 169; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 170; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 171; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 172; -- GNAT + Name_Debug : constant Name_Id := N + 173; -- GNAT + Name_Elaborate : constant Name_Id := N + 174; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 175; + Name_Elaborate_Body : constant Name_Id := N + 176; + Name_Export : constant Name_Id := N + 177; + Name_Export_Exception : constant Name_Id := N + 178; -- VMS + Name_Export_Function : constant Name_Id := N + 179; -- GNAT + Name_Export_Object : constant Name_Id := N + 180; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 181; -- GNAT + Name_Export_Value : constant Name_Id := N + 182; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 183; -- GNAT + Name_External : constant Name_Id := N + 184; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 185; -- GNAT + Name_Ident : constant Name_Id := N + 186; -- VMS + Name_Import : constant Name_Id := N + 187; + Name_Import_Exception : constant Name_Id := N + 188; -- VMS + Name_Import_Function : constant Name_Id := N + 189; -- GNAT + Name_Import_Object : constant Name_Id := N + 190; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 191; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 192; -- GNAT + Name_Inline : constant Name_Id := N + 193; + Name_Inline_Always : constant Name_Id := N + 194; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 195; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 196; + Name_Interface_Name : constant Name_Id := N + 197; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 198; + Name_Interrupt_Priority : constant Name_Id := N + 199; + Name_Java_Constructor : constant Name_Id := N + 200; -- GNAT + Name_Java_Interface : constant Name_Id := N + 201; -- GNAT + Name_Keep_Names : constant Name_Id := N + 202; -- GNAT + Name_Link_With : constant Name_Id := N + 203; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 204; -- GNAT + Name_Linker_Options : constant Name_Id := N + 205; + Name_Linker_Section : constant Name_Id := N + 206; -- GNAT + Name_List : constant Name_Id := N + 207; + Name_Machine_Attribute : constant Name_Id := N + 208; -- GNAT + Name_Main : constant Name_Id := N + 209; -- GNAT + Name_Main_Storage : constant Name_Id := N + 210; -- GNAT + Name_Memory_Size : constant Name_Id := N + 211; -- Ada 83 + Name_No_Return : constant Name_Id := N + 212; -- GNAT + Name_Obsolescent : constant Name_Id := N + 213; -- GNAT + Name_Optimize : constant Name_Id := N + 214; + Name_Optional_Overriding : constant Name_Id := N + 215; + Name_Pack : constant Name_Id := N + 216; + Name_Page : constant Name_Id := N + 217; + Name_Passive : constant Name_Id := N + 218; -- GNAT + Name_Preelaborate : constant Name_Id := N + 219; + Name_Priority : constant Name_Id := N + 220; + Name_Psect_Object : constant Name_Id := N + 221; -- VMS + Name_Pure : constant Name_Id := N + 222; + Name_Pure_Function : constant Name_Id := N + 223; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 224; + Name_Remote_Types : constant Name_Id := N + 225; + Name_Share_Generic : constant Name_Id := N + 226; -- GNAT + Name_Shared : constant Name_Id := N + 227; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 228; + + -- Note: Storage_Size is not in this list because its name matches the + -- name of the corresponding attribute. However, it is included in the + -- definition of the type Attribute_Id, and the functions Get_Pragma_Id + -- and Check_Pragma_Id correctly recognize and process Name_Storage_Size. + + -- Note: Storage_Unit is also omitted from the list because of a clash + -- with an attribute name, and is treated similarly. + + Name_Source_Reference : constant Name_Id := N + 229; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 230; -- GNAT + Name_Subtitle : constant Name_Id := N + 231; -- GNAT + Name_Suppress_All : constant Name_Id := N + 232; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 233; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 234; -- GNAT + Name_System_Name : constant Name_Id := N + 235; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 236; -- GNAT + Name_Task_Name : constant Name_Id := N + 237; -- GNAT + Name_Task_Storage : constant Name_Id := N + 238; -- VMS + Name_Thread_Body : constant Name_Id := N + 239; -- GNAT + Name_Time_Slice : constant Name_Id := N + 240; -- GNAT + Name_Title : constant Name_Id := N + 241; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 242; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 243; -- GNAT + Name_Unreferenced : constant Name_Id := N + 244; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 245; -- GNAT + Name_Volatile : constant Name_Id := N + 246; + Name_Volatile_Components : constant Name_Id := N + 247; + Name_Weak_External : constant Name_Id := N + 248; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 248; + + -- Language convention names for pragma Convention/Export/Import/Interface + -- Note that Name_C is not included in this list, since it was already + -- declared earlier in the context of one-character identifier names + -- (where the order is critical to the fast look up process). + + -- Note: there are no convention names corresponding to the conventions + -- Entry and Protected, this is because these conventions cannot be + -- specified by a pragma. + + First_Convention_Name : constant Name_Id := N + 249; + Name_Ada : constant Name_Id := N + 249; + Name_Assembler : constant Name_Id := N + 250; + Name_COBOL : constant Name_Id := N + 251; + Name_CPP : constant Name_Id := N + 252; + Name_Fortran : constant Name_Id := N + 253; + Name_Intrinsic : constant Name_Id := N + 254; + Name_Java : constant Name_Id := N + 255; + Name_Stdcall : constant Name_Id := N + 256; + Name_Stubbed : constant Name_Id := N + 257; + Last_Convention_Name : constant Name_Id := N + 257; + + -- The following names are preset as synonyms for Assembler + + Name_Asm : constant Name_Id := N + 258; + Name_Assembly : constant Name_Id := N + 259; + + -- The following names are preset as synonyms for C + + Name_Default : constant Name_Id := N + 260; + -- Name_Exernal (previously defined as pragma) + + -- The following names are present as synonyms for Stdcall + + Name_DLL : constant Name_Id := N + 261; + Name_Win32 : constant Name_Id := N + 262; + + -- Other special names used in processing pragmas + + Name_As_Is : constant Name_Id := N + 263; + Name_Body_File_Name : constant Name_Id := N + 264; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 265; + Name_Casing : constant Name_Id := N + 266; + Name_Code : constant Name_Id := N + 267; + Name_Component : constant Name_Id := N + 268; + Name_Component_Size_4 : constant Name_Id := N + 269; + Name_Copy : constant Name_Id := N + 270; + Name_D_Float : constant Name_Id := N + 271; + Name_Descriptor : constant Name_Id := N + 272; + Name_Dot_Replacement : constant Name_Id := N + 273; + Name_Dynamic : constant Name_Id := N + 274; + Name_Entity : constant Name_Id := N + 275; + Name_External_Name : constant Name_Id := N + 276; + Name_First_Optional_Parameter : constant Name_Id := N + 277; + Name_Form : constant Name_Id := N + 278; + Name_G_Float : constant Name_Id := N + 279; + Name_Gcc : constant Name_Id := N + 280; + Name_Gnat : constant Name_Id := N + 281; + Name_GPL : constant Name_Id := N + 282; + Name_IEEE_Float : constant Name_Id := N + 283; + Name_Internal : constant Name_Id := N + 284; + Name_Link_Name : constant Name_Id := N + 285; + Name_Lowercase : constant Name_Id := N + 286; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 287; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 288; + Name_Max_Size : constant Name_Id := N + 289; + Name_Mechanism : constant Name_Id := N + 290; + Name_Mixedcase : constant Name_Id := N + 291; + Name_Modified_GPL : constant Name_Id := N + 292; + Name_Name : constant Name_Id := N + 293; + Name_NCA : constant Name_Id := N + 294; + Name_No : constant Name_Id := N + 295; + Name_No_Dependence : constant Name_Id := N + 296; + Name_No_Dynamic_Attachment : constant Name_Id := N + 297; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 298; + Name_No_Requeue : constant Name_Id := N + 299; + Name_No_Requeue_Statements : constant Name_Id := N + 300; + Name_No_Task_Attributes : constant Name_Id := N + 301; + Name_No_Task_Attributes_Package : constant Name_Id := N + 302; + Name_On : constant Name_Id := N + 303; + Name_Parameter_Types : constant Name_Id := N + 304; + Name_Reference : constant Name_Id := N + 305; + Name_Restricted : constant Name_Id := N + 306; + Name_Result_Mechanism : constant Name_Id := N + 307; + Name_Result_Type : constant Name_Id := N + 308; + Name_Runtime : constant Name_Id := N + 309; + Name_SB : constant Name_Id := N + 310; + Name_Secondary_Stack_Size : constant Name_Id := N + 311; + Name_Section : constant Name_Id := N + 312; + Name_Semaphore : constant Name_Id := N + 313; + Name_Simple_Barriers : constant Name_Id := N + 314; + Name_Spec_File_Name : constant Name_Id := N + 315; + Name_Static : constant Name_Id := N + 316; + Name_Stack_Size : constant Name_Id := N + 317; + Name_Subunit_File_Name : constant Name_Id := N + 318; + Name_Task_Stack_Size_Default : constant Name_Id := N + 319; + Name_Task_Type : constant Name_Id := N + 320; + Name_Time_Slicing_Enabled : constant Name_Id := N + 321; + Name_Top_Guard : constant Name_Id := N + 322; + Name_UBA : constant Name_Id := N + 323; + Name_UBS : constant Name_Id := N + 324; + Name_UBSB : constant Name_Id := N + 325; + Name_Unit_Name : constant Name_Id := N + 326; + Name_Unknown : constant Name_Id := N + 327; + Name_Unrestricted : constant Name_Id := N + 328; + Name_Uppercase : constant Name_Id := N + 329; + Name_User : constant Name_Id := N + 330; + Name_VAX_Float : constant Name_Id := N + 331; + Name_VMS : constant Name_Id := N + 332; + Name_Working_Storage : constant Name_Id := N + 333; + + -- 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 + -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT. + + -- The entries marked GNAT are attributes that are defined by GNAT + -- and implemented in both Ada 83 and Ada 95 modes. Full descriptions + -- of these implementation dependent attributes may be found in the + -- appropriate section in package Sem_Attr in file sem-attr.ads. + + -- 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 + 334; + Name_Abort_Signal : constant Name_Id := N + 334; -- GNAT + Name_Access : constant Name_Id := N + 335; + Name_Address : constant Name_Id := N + 336; + Name_Address_Size : constant Name_Id := N + 337; -- GNAT + Name_Aft : constant Name_Id := N + 338; + Name_Alignment : constant Name_Id := N + 339; + Name_Asm_Input : constant Name_Id := N + 340; -- GNAT + Name_Asm_Output : constant Name_Id := N + 341; -- GNAT + Name_AST_Entry : constant Name_Id := N + 342; -- VMS + Name_Bit : constant Name_Id := N + 343; -- GNAT + Name_Bit_Order : constant Name_Id := N + 344; + Name_Bit_Position : constant Name_Id := N + 345; -- GNAT + Name_Body_Version : constant Name_Id := N + 346; + Name_Callable : constant Name_Id := N + 347; + Name_Caller : constant Name_Id := N + 348; + Name_Code_Address : constant Name_Id := N + 349; -- GNAT + Name_Component_Size : constant Name_Id := N + 350; + Name_Compose : constant Name_Id := N + 351; + Name_Constrained : constant Name_Id := N + 352; + Name_Count : constant Name_Id := N + 353; + Name_Default_Bit_Order : constant Name_Id := N + 354; -- GNAT + Name_Definite : constant Name_Id := N + 355; + Name_Delta : constant Name_Id := N + 356; + Name_Denorm : constant Name_Id := N + 357; + Name_Digits : constant Name_Id := N + 358; + Name_Elaborated : constant Name_Id := N + 359; -- GNAT + Name_Emax : constant Name_Id := N + 360; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 361; -- GNAT + Name_Epsilon : constant Name_Id := N + 362; -- Ada 83 + Name_Exponent : constant Name_Id := N + 363; + Name_External_Tag : constant Name_Id := N + 364; + Name_First : constant Name_Id := N + 365; + Name_First_Bit : constant Name_Id := N + 366; + Name_Fixed_Value : constant Name_Id := N + 367; -- GNAT + Name_Fore : constant Name_Id := N + 368; + Name_Has_Access_Values : constant Name_Id := N + 369; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 370; -- GNAT + Name_Identity : constant Name_Id := N + 371; + Name_Img : constant Name_Id := N + 372; -- GNAT + Name_Integer_Value : constant Name_Id := N + 373; -- GNAT + Name_Large : constant Name_Id := N + 374; -- Ada 83 + Name_Last : constant Name_Id := N + 375; + Name_Last_Bit : constant Name_Id := N + 376; + Name_Leading_Part : constant Name_Id := N + 377; + Name_Length : constant Name_Id := N + 378; + Name_Machine_Emax : constant Name_Id := N + 379; + Name_Machine_Emin : constant Name_Id := N + 380; + Name_Machine_Mantissa : constant Name_Id := N + 381; + Name_Machine_Overflows : constant Name_Id := N + 382; + Name_Machine_Radix : constant Name_Id := N + 383; + Name_Machine_Rounds : constant Name_Id := N + 384; + Name_Machine_Size : constant Name_Id := N + 385; -- GNAT + Name_Mantissa : constant Name_Id := N + 386; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 387; + Name_Maximum_Alignment : constant Name_Id := N + 388; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 389; -- GNAT + Name_Mod : constant Name_Id := N + 390; + Name_Model_Emin : constant Name_Id := N + 391; + Name_Model_Epsilon : constant Name_Id := N + 392; + Name_Model_Mantissa : constant Name_Id := N + 393; + Name_Model_Small : constant Name_Id := N + 394; + Name_Modulus : constant Name_Id := N + 395; + Name_Null_Parameter : constant Name_Id := N + 396; -- GNAT + Name_Object_Size : constant Name_Id := N + 397; -- GNAT + Name_Partition_ID : constant Name_Id := N + 398; + Name_Passed_By_Reference : constant Name_Id := N + 399; -- GNAT + Name_Pool_Address : constant Name_Id := N + 400; + Name_Pos : constant Name_Id := N + 401; + Name_Position : constant Name_Id := N + 402; + Name_Range : constant Name_Id := N + 403; + Name_Range_Length : constant Name_Id := N + 404; -- GNAT + Name_Round : constant Name_Id := N + 405; + Name_Safe_Emax : constant Name_Id := N + 406; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 407; + Name_Safe_Large : constant Name_Id := N + 408; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 409; + Name_Safe_Small : constant Name_Id := N + 410; -- Ada 83 + Name_Scale : constant Name_Id := N + 411; + Name_Scaling : constant Name_Id := N + 412; + Name_Signed_Zeros : constant Name_Id := N + 413; + Name_Size : constant Name_Id := N + 414; + Name_Small : constant Name_Id := N + 415; + Name_Storage_Size : constant Name_Id := N + 416; + Name_Storage_Unit : constant Name_Id := N + 417; -- GNAT + Name_Stream_Size : constant Name_Id := N + 418; -- Ada 05 + Name_Tag : constant Name_Id := N + 419; + Name_Target_Name : constant Name_Id := N + 420; -- GNAT + Name_Terminated : constant Name_Id := N + 421; + Name_To_Address : constant Name_Id := N + 422; -- GNAT + Name_Type_Class : constant Name_Id := N + 423; -- GNAT + Name_UET_Address : constant Name_Id := N + 424; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 425; + Name_Unchecked_Access : constant Name_Id := N + 426; + Name_Unconstrained_Array : constant Name_Id := N + 427; + Name_Universal_Literal_String : constant Name_Id := N + 428; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 429; -- GNAT + Name_VADS_Size : constant Name_Id := N + 430; -- GNAT + Name_Val : constant Name_Id := N + 431; + Name_Valid : constant Name_Id := N + 432; + Name_Value_Size : constant Name_Id := N + 433; -- GNAT + Name_Version : constant Name_Id := N + 434; + Name_Wchar_T_Size : constant Name_Id := N + 435; -- GNAT + Name_Wide_Wide_Width : constant Name_Id := N + 436; -- Ada 05 + Name_Wide_Width : constant Name_Id := N + 437; + Name_Width : constant Name_Id := N + 438; + Name_Word_Size : constant Name_Id := N + 439; -- GNAT + + -- Attributes that designate attributes returning renamable functions, + -- i.e. functions that return other than a universal value and that + -- have non-universal arguments. + + First_Renamable_Function_Attribute : constant Name_Id := N + 440; + Name_Adjacent : constant Name_Id := N + 440; + Name_Ceiling : constant Name_Id := N + 441; + Name_Copy_Sign : constant Name_Id := N + 442; + Name_Floor : constant Name_Id := N + 443; + Name_Fraction : constant Name_Id := N + 444; + Name_Image : constant Name_Id := N + 445; + Name_Input : constant Name_Id := N + 446; + Name_Machine : constant Name_Id := N + 447; + Name_Max : constant Name_Id := N + 448; + Name_Min : constant Name_Id := N + 449; + Name_Model : constant Name_Id := N + 450; + Name_Pred : constant Name_Id := N + 451; + Name_Remainder : constant Name_Id := N + 452; + Name_Rounding : constant Name_Id := N + 453; + Name_Succ : constant Name_Id := N + 454; + Name_Truncation : constant Name_Id := N + 455; + Name_Value : constant Name_Id := N + 456; + Name_Wide_Image : constant Name_Id := N + 457; + Name_Wide_Wide_Image : constant Name_Id := N + 458; + Name_Wide_Value : constant Name_Id := N + 459; + Name_Wide_Wide_Value : constant Name_Id := N + 460; + Last_Renamable_Function_Attribute : constant Name_Id := N + 460; + + -- Attributes that designate procedures + + First_Procedure_Attribute : constant Name_Id := N + 461; + Name_Output : constant Name_Id := N + 461; + Name_Read : constant Name_Id := N + 462; + Name_Write : constant Name_Id := N + 463; + Last_Procedure_Attribute : constant Name_Id := N + 463; + + -- Remaining attributes are ones that return entities + + First_Entity_Attribute_Name : constant Name_Id := N + 464; + Name_Elab_Body : constant Name_Id := N + 464; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 465; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 466; + + -- These attributes are the ones that return types + + First_Type_Attribute_Name : constant Name_Id := N + 467; + Name_Base : constant Name_Id := N + 467; + Name_Class : constant Name_Id := N + 468; + Last_Type_Attribute_Name : constant Name_Id := N + 468; + Last_Entity_Attribute_Name : constant Name_Id := N + 468; + Last_Attribute_Name : constant Name_Id := N + 468; + + -- Names of recognized locking policy identifiers + + -- Note: policies are identified by the first character of the + -- 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 + 469; + Name_Ceiling_Locking : constant Name_Id := N + 469; + Name_Inheritance_Locking : constant Name_Id := N + 470; + Last_Locking_Policy_Name : constant Name_Id := N + 470; + + -- Names of recognized queuing policy identifiers. + + -- Note: policies are identified by the first character of the + -- 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 + 471; + Name_FIFO_Queuing : constant Name_Id := N + 471; + Name_Priority_Queuing : constant Name_Id := N + 472; + Last_Queuing_Policy_Name : constant Name_Id := N + 472; + + -- Names of recognized task dispatching policy identifiers + + -- Note: policies are identified by the first character of the + -- 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 + 473; + Name_FIFO_Within_Priorities : constant Name_Id := N + 473; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 473; + + -- Names of recognized checks for pragma Suppress + + First_Check_Name : constant Name_Id := N + 474; + Name_Access_Check : constant Name_Id := N + 474; + Name_Accessibility_Check : constant Name_Id := N + 475; + Name_Discriminant_Check : constant Name_Id := N + 476; + Name_Division_Check : constant Name_Id := N + 477; + Name_Elaboration_Check : constant Name_Id := N + 478; + Name_Index_Check : constant Name_Id := N + 479; + Name_Length_Check : constant Name_Id := N + 480; + Name_Overflow_Check : constant Name_Id := N + 481; + Name_Range_Check : constant Name_Id := N + 482; + Name_Storage_Check : constant Name_Id := N + 483; + Name_Tag_Check : constant Name_Id := N + 484; + Name_All_Checks : constant Name_Id := N + 485; + Last_Check_Name : constant Name_Id := N + 485; + + -- Names corresponding to reserved keywords, excluding those already + -- declared in the attribute list (Access, Delta, Digits, Mod, Range). + + Name_Abort : constant Name_Id := N + 486; + Name_Abs : constant Name_Id := N + 487; + Name_Accept : constant Name_Id := N + 488; + Name_And : constant Name_Id := N + 489; + Name_All : constant Name_Id := N + 490; + Name_Array : constant Name_Id := N + 491; + Name_At : constant Name_Id := N + 492; + Name_Begin : constant Name_Id := N + 493; + Name_Body : constant Name_Id := N + 494; + Name_Case : constant Name_Id := N + 495; + Name_Constant : constant Name_Id := N + 496; + Name_Declare : constant Name_Id := N + 497; + Name_Delay : constant Name_Id := N + 498; + Name_Do : constant Name_Id := N + 499; + Name_Else : constant Name_Id := N + 500; + Name_Elsif : constant Name_Id := N + 501; + Name_End : constant Name_Id := N + 502; + Name_Entry : constant Name_Id := N + 503; + Name_Exception : constant Name_Id := N + 504; + Name_Exit : constant Name_Id := N + 505; + Name_For : constant Name_Id := N + 506; + Name_Function : constant Name_Id := N + 507; + Name_Generic : constant Name_Id := N + 508; + Name_Goto : constant Name_Id := N + 509; + Name_If : constant Name_Id := N + 510; + Name_In : constant Name_Id := N + 511; + Name_Is : constant Name_Id := N + 512; + Name_Limited : constant Name_Id := N + 513; + Name_Loop : constant Name_Id := N + 514; + Name_New : constant Name_Id := N + 515; + Name_Not : constant Name_Id := N + 516; + Name_Null : constant Name_Id := N + 517; + Name_Of : constant Name_Id := N + 518; + Name_Or : constant Name_Id := N + 519; + Name_Others : constant Name_Id := N + 520; + Name_Out : constant Name_Id := N + 521; + Name_Package : constant Name_Id := N + 522; + Name_Pragma : constant Name_Id := N + 523; + Name_Private : constant Name_Id := N + 524; + Name_Procedure : constant Name_Id := N + 525; + Name_Raise : constant Name_Id := N + 526; + Name_Record : constant Name_Id := N + 527; + Name_Rem : constant Name_Id := N + 528; + Name_Renames : constant Name_Id := N + 529; + Name_Return : constant Name_Id := N + 530; + Name_Reverse : constant Name_Id := N + 531; + Name_Select : constant Name_Id := N + 532; + Name_Separate : constant Name_Id := N + 533; + Name_Subtype : constant Name_Id := N + 534; + Name_Task : constant Name_Id := N + 535; + Name_Terminate : constant Name_Id := N + 536; + Name_Then : constant Name_Id := N + 537; + Name_Type : constant Name_Id := N + 538; + Name_Use : constant Name_Id := N + 539; + Name_When : constant Name_Id := N + 540; + Name_While : constant Name_Id := N + 541; + Name_With : constant Name_Id := N + 542; + Name_Xor : constant Name_Id := N + 543; + + -- 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 + 544; + Name_Divide : constant Name_Id := N + 544; + Name_Enclosing_Entity : constant Name_Id := N + 545; + Name_Exception_Information : constant Name_Id := N + 546; + Name_Exception_Message : constant Name_Id := N + 547; + Name_Exception_Name : constant Name_Id := N + 548; + Name_File : constant Name_Id := N + 549; + Name_Import_Address : constant Name_Id := N + 550; + Name_Import_Largest_Value : constant Name_Id := N + 551; + Name_Import_Value : constant Name_Id := N + 552; + Name_Is_Negative : constant Name_Id := N + 553; + Name_Line : constant Name_Id := N + 554; + Name_Rotate_Left : constant Name_Id := N + 555; + Name_Rotate_Right : constant Name_Id := N + 556; + Name_Shift_Left : constant Name_Id := N + 557; + Name_Shift_Right : constant Name_Id := N + 558; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 559; + Name_Source_Location : constant Name_Id := N + 560; + Name_Unchecked_Conversion : constant Name_Id := N + 561; + Name_Unchecked_Deallocation : constant Name_Id := N + 562; + Name_To_Pointer : constant Name_Id := N + 563; + Last_Intrinsic_Name : constant Name_Id := N + 563; + + -- Reserved words used only in Ada 95 + + First_95_Reserved_Word : constant Name_Id := N + 564; + Name_Abstract : constant Name_Id := N + 564; + Name_Aliased : constant Name_Id := N + 565; + Name_Protected : constant Name_Id := N + 566; + Name_Until : constant Name_Id := N + 567; + Name_Requeue : constant Name_Id := N + 568; + Name_Tagged : constant Name_Id := N + 569; + Last_95_Reserved_Word : constant Name_Id := N + 569; + + 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 + 570; + + -- Additional reserved words and identifiers used in GNAT Project Files + -- Note that Name_External is already previously declared + + Name_Ada_Roots : constant Name_Id := N + 571; + Name_Binder : constant Name_Id := N + 572; + Name_Binder_Driver : constant Name_Id := N + 573; + Name_Body_Suffix : constant Name_Id := N + 574; + Name_Builder : constant Name_Id := N + 575; + Name_Compiler : constant Name_Id := N + 576; + Name_Compiler_Driver : constant Name_Id := N + 577; + Name_Compiler_Kind : constant Name_Id := N + 578; + Name_Compute_Dependency : constant Name_Id := N + 579; + Name_Cross_Reference : constant Name_Id := N + 580; + Name_Default_Linker : constant Name_Id := N + 581; + Name_Default_Switches : constant Name_Id := N + 582; + Name_Dependency_Option : constant Name_Id := N + 583; + Name_Exec_Dir : constant Name_Id := N + 584; + Name_Executable : constant Name_Id := N + 585; + Name_Executable_Suffix : constant Name_Id := N + 586; + Name_Extends : constant Name_Id := N + 587; + Name_Externally_Built : constant Name_Id := N + 588; + Name_Finder : constant Name_Id := N + 589; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 590; + Name_Gnatls : constant Name_Id := N + 591; + Name_Gnatstub : constant Name_Id := N + 592; + Name_Implementation : constant Name_Id := N + 593; + Name_Implementation_Exceptions : constant Name_Id := N + 594; + Name_Implementation_Suffix : constant Name_Id := N + 595; + Name_Include_Option : constant Name_Id := N + 596; + Name_Language_Processing : constant Name_Id := N + 597; + Name_Languages : constant Name_Id := N + 598; + Name_Library_Dir : constant Name_Id := N + 599; + Name_Library_Auto_Init : constant Name_Id := N + 600; + Name_Library_GCC : constant Name_Id := N + 601; + Name_Library_Interface : constant Name_Id := N + 602; + Name_Library_Kind : constant Name_Id := N + 603; + Name_Library_Name : constant Name_Id := N + 604; + Name_Library_Options : constant Name_Id := N + 605; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 606; + Name_Library_Src_Dir : constant Name_Id := N + 607; + Name_Library_Symbol_File : constant Name_Id := N + 608; + Name_Library_Symbol_Policy : constant Name_Id := N + 609; + Name_Library_Version : constant Name_Id := N + 610; + Name_Linker : constant Name_Id := N + 611; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 612; + Name_Locally_Removed_Files : constant Name_Id := N + 613; + Name_Metrics : constant Name_Id := N + 614; + Name_Naming : constant Name_Id := N + 615; + Name_Object_Dir : constant Name_Id := N + 616; + Name_Pretty_Printer : constant Name_Id := N + 617; + Name_Project : constant Name_Id := N + 618; + Name_Separate_Suffix : constant Name_Id := N + 619; + Name_Source_Dirs : constant Name_Id := N + 620; + Name_Source_Files : constant Name_Id := N + 621; + Name_Source_List_File : constant Name_Id := N + 622; + Name_Spec : constant Name_Id := N + 623; + Name_Spec_Suffix : constant Name_Id := N + 624; + Name_Specification : constant Name_Id := N + 625; + Name_Specification_Exceptions : constant Name_Id := N + 626; + Name_Specification_Suffix : constant Name_Id := N + 627; + Name_Switches : constant Name_Id := N + 628; + + -- Other miscellaneous names used in front end + + Name_Unaligned_Valid : constant Name_Id := N + 629; + + -- ---------------------------------------------------------------- + First_2005_Reserved_Word : constant Name_Id := N + 630; + Name_Interface : constant Name_Id := N + 630; + Name_Overriding : constant Name_Id := N + 631; + Name_Synchronized : constant Name_Id := N + 632; + Last_2005_Reserved_Word : constant Name_Id := N + 632; + + subtype Ada_2005_Reserved_Words is + Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word; + + -- Mark last defined name for consistency check in Snames body + + Last_Predefined_Name : constant Name_Id := N + 632; + + subtype Any_Operator_Name is Name_Id range + First_Operator_Name .. Last_Operator_Name; + + ------------------------------ + -- Attribute ID Definitions -- + ------------------------------ + + type Attribute_Id is ( + Attribute_Abort_Signal, + Attribute_Access, + Attribute_Address, + Attribute_Address_Size, + Attribute_Aft, + Attribute_Alignment, + Attribute_Asm_Input, + Attribute_Asm_Output, + Attribute_AST_Entry, + Attribute_Bit, + Attribute_Bit_Order, + Attribute_Bit_Position, + Attribute_Body_Version, + Attribute_Callable, + Attribute_Caller, + Attribute_Code_Address, + Attribute_Component_Size, + Attribute_Compose, + Attribute_Constrained, + Attribute_Count, + Attribute_Default_Bit_Order, + Attribute_Definite, + Attribute_Delta, + Attribute_Denorm, + Attribute_Digits, + Attribute_Elaborated, + Attribute_Emax, + Attribute_Enum_Rep, + Attribute_Epsilon, + Attribute_Exponent, + Attribute_External_Tag, + Attribute_First, + Attribute_First_Bit, + Attribute_Fixed_Value, + Attribute_Fore, + Attribute_Has_Access_Values, + Attribute_Has_Discriminants, + Attribute_Identity, + Attribute_Img, + Attribute_Integer_Value, + Attribute_Large, + Attribute_Last, + Attribute_Last_Bit, + Attribute_Leading_Part, + Attribute_Length, + Attribute_Machine_Emax, + Attribute_Machine_Emin, + Attribute_Machine_Mantissa, + Attribute_Machine_Overflows, + Attribute_Machine_Radix, + Attribute_Machine_Rounds, + Attribute_Machine_Size, + Attribute_Mantissa, + Attribute_Max_Size_In_Storage_Elements, + Attribute_Maximum_Alignment, + Attribute_Mechanism_Code, + Attribute_Mod, + Attribute_Model_Emin, + Attribute_Model_Epsilon, + Attribute_Model_Mantissa, + Attribute_Model_Small, + Attribute_Modulus, + Attribute_Null_Parameter, + Attribute_Object_Size, + Attribute_Partition_ID, + Attribute_Passed_By_Reference, + Attribute_Pool_Address, + Attribute_Pos, + Attribute_Position, + Attribute_Range, + Attribute_Range_Length, + Attribute_Round, + Attribute_Safe_Emax, + Attribute_Safe_First, + Attribute_Safe_Large, + Attribute_Safe_Last, + Attribute_Safe_Small, + Attribute_Scale, + Attribute_Scaling, + Attribute_Signed_Zeros, + Attribute_Size, + Attribute_Small, + Attribute_Storage_Size, + Attribute_Storage_Unit, + Attribute_Stream_Size, + Attribute_Tag, + Attribute_Target_Name, + Attribute_Terminated, + Attribute_To_Address, + Attribute_Type_Class, + Attribute_UET_Address, + Attribute_Unbiased_Rounding, + Attribute_Unchecked_Access, + Attribute_Unconstrained_Array, + Attribute_Universal_Literal_String, + Attribute_Unrestricted_Access, + Attribute_VADS_Size, + Attribute_Val, + Attribute_Valid, + Attribute_Value_Size, + Attribute_Version, + Attribute_Wchar_T_Size, + Attribute_Wide_Wide_Width, + Attribute_Wide_Width, + Attribute_Width, + Attribute_Word_Size, + + -- Attributes designating renamable functions + + Attribute_Adjacent, + Attribute_Ceiling, + Attribute_Copy_Sign, + Attribute_Floor, + Attribute_Fraction, + Attribute_Image, + Attribute_Input, + Attribute_Machine, + Attribute_Max, + Attribute_Min, + Attribute_Model, + Attribute_Pred, + Attribute_Remainder, + Attribute_Rounding, + Attribute_Succ, + Attribute_Truncation, + Attribute_Value, + Attribute_Wide_Image, + Attribute_Wide_Wide_Image, + Attribute_Wide_Value, + Attribute_Wide_Wide_Value, + + -- Attributes designating procedures + + Attribute_Output, + Attribute_Read, + Attribute_Write, + + -- Entity attributes (includes type attributes) + + Attribute_Elab_Body, + Attribute_Elab_Spec, + Attribute_Storage_Pool, + + -- Type attributes + + Attribute_Base, + Attribute_Class); + + ------------------------------------ + -- Convention Name ID Definitions -- + ------------------------------------ + + type Convention_Id is ( + + -- The conventions that are defined by the RM come first + + Convention_Ada, + Convention_Intrinsic, + Convention_Entry, + Convention_Protected, + + -- The remaining conventions are foreign language conventions + + Convention_Assembler, -- also Asm, Assembly + Convention_C, -- also Default, External + Convention_COBOL, + Convention_CPP, + Convention_Fortran, + Convention_Java, + Convention_Stdcall, -- also DLL, Win32 + Convention_Stubbed); + + -- Note: Convention C_Pass_By_Copy is allowed only for record + -- types (where it is treated like C except that the appropriate + -- flag is set in the record type). Recognizion of this convention + -- is specially handled in Sem_Prag. + + for Convention_Id'Size use 8; + -- Plenty of space for expansion + + subtype Foreign_Convention is + Convention_Id range Convention_Assembler .. Convention_Stdcall; + + ----------------------------------- + -- Locking Policy ID Definitions -- + ----------------------------------- + + type Locking_Policy_Id is ( + Locking_Policy_Inheritance_Locking, + Locking_Policy_Ceiling_Locking); + + --------------------------- + -- Pragma ID Definitions -- + --------------------------- + + type Pragma_Id is ( + + -- Configuration pragmas + + Pragma_Ada_83, + Pragma_Ada_95, + Pragma_Ada_05, + Pragma_C_Pass_By_Copy, + Pragma_Compile_Time_Warning, + Pragma_Component_Alignment, + Pragma_Convention_Identifier, + Pragma_Detect_Blocking, + Pragma_Discard_Names, + Pragma_Elaboration_Checks, + Pragma_Eliminate, + Pragma_Explicit_Overriding, + Pragma_Extend_System, + Pragma_Extensions_Allowed, + Pragma_External_Name_Casing, + Pragma_Float_Representation, + Pragma_Initialize_Scalars, + Pragma_Interrupt_State, + Pragma_License, + Pragma_Locking_Policy, + Pragma_Long_Float, + Pragma_No_Run_Time, + Pragma_No_Strict_Aliasing, + Pragma_Normalize_Scalars, + Pragma_Polling, + Pragma_Persistent_Data, + Pragma_Persistent_Object, + Pragma_Profile, + Pragma_Profile_Warnings, + Pragma_Propagate_Exceptions, + Pragma_Queuing_Policy, + Pragma_Ravenscar, + Pragma_Restricted_Run_Time, + Pragma_Restrictions, + Pragma_Restriction_Warnings, + Pragma_Reviewable, + Pragma_Source_File_Name, + Pragma_Source_File_Name_Project, + Pragma_Style_Checks, + Pragma_Suppress, + Pragma_Suppress_Exception_Locations, + Pragma_Task_Dispatching_Policy, + Pragma_Universal_Data, + Pragma_Unsuppress, + Pragma_Use_VADS_Size, + Pragma_Validity_Checks, + Pragma_Warnings, + + -- Remaining (non-configuration) pragmas + + Pragma_Abort_Defer, + Pragma_All_Calls_Remote, + Pragma_Annotate, + Pragma_Assert, + Pragma_Asynchronous, + Pragma_Atomic, + Pragma_Atomic_Components, + Pragma_Attach_Handler, + Pragma_Comment, + Pragma_Common_Object, + Pragma_Complex_Representation, + Pragma_Controlled, + Pragma_Convention, + Pragma_CPP_Class, + Pragma_CPP_Constructor, + Pragma_CPP_Virtual, + Pragma_CPP_Vtable, + Pragma_Debug, + Pragma_Elaborate, + Pragma_Elaborate_All, + Pragma_Elaborate_Body, + Pragma_Export, + Pragma_Export_Exception, + Pragma_Export_Function, + Pragma_Export_Object, + Pragma_Export_Procedure, + Pragma_Export_Value, + Pragma_Export_Valued_Procedure, + Pragma_External, + Pragma_Finalize_Storage_Only, + Pragma_Ident, + Pragma_Import, + Pragma_Import_Exception, + Pragma_Import_Function, + Pragma_Import_Object, + Pragma_Import_Procedure, + Pragma_Import_Valued_Procedure, + Pragma_Inline, + Pragma_Inline_Always, + Pragma_Inline_Generic, + Pragma_Inspection_Point, + Pragma_Interface_Name, + Pragma_Interrupt_Handler, + Pragma_Interrupt_Priority, + Pragma_Java_Constructor, + Pragma_Java_Interface, + Pragma_Keep_Names, + Pragma_Link_With, + Pragma_Linker_Alias, + Pragma_Linker_Options, + Pragma_Linker_Section, + Pragma_List, + Pragma_Machine_Attribute, + Pragma_Main, + Pragma_Main_Storage, + Pragma_Memory_Size, + Pragma_No_Return, + Pragma_Obsolescent, + Pragma_Optimize, + Pragma_Optional_Overriding, + Pragma_Pack, + Pragma_Page, + Pragma_Passive, + Pragma_Preelaborate, + Pragma_Priority, + Pragma_Psect_Object, + Pragma_Pure, + Pragma_Pure_Function, + Pragma_Remote_Call_Interface, + Pragma_Remote_Types, + Pragma_Share_Generic, + Pragma_Shared, + Pragma_Shared_Passive, + Pragma_Source_Reference, + Pragma_Stream_Convert, + Pragma_Subtitle, + Pragma_Suppress_All, + Pragma_Suppress_Debug_Info, + Pragma_Suppress_Initialization, + Pragma_System_Name, + Pragma_Task_Info, + Pragma_Task_Name, + Pragma_Task_Storage, + Pragma_Thread_Body, + Pragma_Time_Slice, + Pragma_Title, + Pragma_Unchecked_Union, + Pragma_Unimplemented_Unit, + Pragma_Unreferenced, + Pragma_Unreserve_All_Interrupts, + Pragma_Volatile, + Pragma_Volatile_Components, + Pragma_Weak_External, + + -- The following pragmas are on their own, out of order, because of + -- the special processing required to deal with the fact that their + -- names match existing attribute names. + + Pragma_AST_Entry, + Pragma_Interface, + Pragma_Storage_Size, + Pragma_Storage_Unit, + + -- The value to represent an unknown or unrecognized pragma + + Unknown_Pragma); + + ----------------------------------- + -- Queuing Policy ID definitions -- + ----------------------------------- + + type Queuing_Policy_Id is ( + Queuing_Policy_FIFO_Queuing, + Queuing_Policy_Priority_Queuing); + + -------------------------------------------- + -- Task Dispatching Policy ID definitions -- + -------------------------------------------- + + type Task_Dispatching_Policy_Id is ( + Task_Dispatching_FIFO_Within_Priorities); + -- Id values used to identify task dispatching policies + + ----------------- + -- Subprograms -- + ----------------- + + procedure Initialize; + -- Called to initialize the preset names in the names table. + + function Is_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute + + function Is_Entity_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized entity attribute, + -- i.e. an attribute reference that returns an entity. + + function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute that + -- designates a procedure (and can therefore appear as a statement). + + function Is_Function_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized attribute + -- that designates a renameable function, and can therefore appear in + -- a renaming statement. Note that not all attributes designating + -- functions are renamable, in particular, thos returning a universal + -- value cannot be renamed. + + function Is_Type_Attribute_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized type attribute, + -- i.e. an attribute reference that returns a type + + function Is_Check_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized suppress check + -- as required by pragma Suppress. + + function Is_Convention_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of one of the recognized + -- language conventions, as required by pragma Convention, Import, + -- Export, Interface. Returns True if so. Also returns True for a + -- name that has been specified by a Convention_Identifier pragma. + -- If neither case holds, returns False. + + function Is_Locking_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized locking policy + + function Is_Operator_Symbol_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of an operator symbol + + function Is_Pragma_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized pragma. Note + -- that pragmas AST_Entry, Storage_Size, and Storage_Unit are recognized + -- as pragmas by this function even though their names are separate from + -- the other pragma names. + + function Is_Queuing_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized queuing policy + + function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean; + -- Test to see if the name N is the name of a recognized task + -- dispatching policy. + + function Get_Attribute_Id (N : Name_Id) return Attribute_Id; + -- Returns Id of attribute corresponding to given name. It is an error to + -- call this function with a name that is not the name of a attribute. + + function Get_Convention_Id (N : Name_Id) return Convention_Id; + -- Returns Id of language convention corresponding to given name. It is an + -- to call this function with a name that is not the name of a convention, + -- or one previously given in a call to Record_Convention_Identifier. + + function Get_Check_Id (N : Name_Id) return Check_Id; + -- Returns Id of suppress check corresponding to given name. It is an error + -- to call this function with a name that is not the name of a check. + + function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id; + -- Returns Id of locking policy corresponding to given name. It is an error + -- to call this function with a name that is not the name of a check. + + function Get_Pragma_Id (N : Name_Id) return Pragma_Id; + -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma + -- if N is not a name of a known (Ada defined or GNAT-specific) pragma. + -- Note that the function also works correctly for names of pragmas that + -- are not in the main list of pragma Names (AST_Entry, Storage_Size, and + -- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size). + + function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id; + -- Returns Id of queuing policy corresponding to given name. It is an error + -- to call this function with a name that is not the name of a check. + + function Get_Task_Dispatching_Policy_Id + (N : Name_Id) + return Task_Dispatching_Policy_Id; + -- Returns Id of task dispatching policy corresponding to given name. + -- It is an error to call this function with a name that is not the + -- name of a check. + + procedure Record_Convention_Identifier + (Id : Name_Id; + Convention : Convention_Id); + -- A call to this procedure, resulting from an occurrence of a pragma + -- Convention_Identifier, records that from now on an occurrence of + -- Id will be recognized as a name for the specified convention. + +private + pragma Inline (Is_Attribute_Name); + pragma Inline (Is_Entity_Attribute_Name); + pragma Inline (Is_Type_Attribute_Name); + pragma Inline (Is_Check_Name); + pragma Inline (Is_Locking_Policy_Name); + pragma Inline (Is_Operator_Symbol_Name); + pragma Inline (Is_Queuing_Policy_Name); + pragma Inline (Is_Pragma_Name); + pragma Inline (Is_Task_Dispatching_Policy_Name); + +end Snames; diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index e96d22a0601..740ad785aa2 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -72,16 +72,16 @@ package Tbuild is function Make_DT_Component (Loc : Source_Ptr; Typ : Entity_Id; - I : Positive) return Node_Id; - -- Gives a reference to the Ith component of the Dispatch Table of + N : Positive) return Node_Id; + -- Gives a reference to the Nth component of the Dispatch Table of -- a given Tagged Type. -- - -- I = 1 --> Inheritance_Depth - -- I = 2 --> Tags (array of ancestors) - -- I = 3, 4 --> predefined primitive + -- N = 1 --> Inheritance_Depth + -- N = 2 --> Tags (array of ancestors) + -- N = 3, 4 --> predefined primitive -- function _Size (X : Typ) return Long_Long_Integer; -- function _Equality (X : Typ; Y : Typ'Class) return Boolean; - -- I >= 5 --> User-Defined Primitive Operations + -- N >= 5 --> User-Defined Primitive Operations function Make_DT_Access (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id; diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index 008ac6e3ab2..787d01e284a 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -679,9 +679,9 @@ build_binary_op (enum tree_code op_code, tree result_type, || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0))) == ARRAY_TYPE)) && (0 == (best_type - == find_common_type (right_type, - TREE_TYPE (TREE_OPERAND - (right_operand, 0)))) + = find_common_type (right_type, + TREE_TYPE (TREE_OPERAND + (right_operand, 0)))) || right_type != best_type)) { right_operand = TREE_OPERAND (right_operand, 0); |