From 499f3d24605eba5c1be61b4cb04e01008554361a Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 15 Mar 2005 16:19:40 +0000 Subject: [PATCH] 2005-03-08 Robert Dewar * s-bitops.adb, s-bitops.ads, s-taprop-os2.adb, s-intman-vms.ads, s-intman-vxworks.ads, s-taprop-vxworks.adb, a-caldel.ads, a-calend.adb, a-tasatt.adb, tbuild.ads, s-finimp.adb, s-imgwch.adb, s-intman.ads, s-intman.ads, s-memory.adb, s-soflin.ads, s-taasde.ads, s-taprob.adb, s-taprop.ads, s-taprop.ads, s-tasini.adb, s-tasini.ads, s-tasini.ads, s-tasini.ads, s-taskin.ads, s-tasren.adb, s-tassta.adb, s-tassta.ads, s-tassta.ads, s-tasuti.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, s-tataat.ads, s-tpoben.adb, s-tpoben.adb, s-tpobop.ads: Update comments. Minor reformatting. 2005-03-08 Eric Botcazou * utils2.c (build_binary_op): Fix typo. 2005-03-08 Doug Rupp * s-crtl.ads (popen,pclose): New imports. 2005-03-08 Cyrille Comar * comperr.adb (Compiler_Abort): remove references to obsolete procedures in the bug boxes for various GNAT builds. 2005-03-08 Vincent Celier * snames.ads, snames.adb: Save as Unix text file, not as DOS text file git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@96512 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/a-caldel.ads | 19 +- gcc/ada/a-calend.adb | 86 +- gcc/ada/a-tasatt.adb | 363 +++-- gcc/ada/comperr.adb | 70 +- gcc/ada/s-bitops.adb | 5 +- gcc/ada/s-bitops.ads | 8 +- gcc/ada/s-crtl.ads | 6 + gcc/ada/s-finimp.adb | 9 +- gcc/ada/s-intman-vms.ads | 109 +- gcc/ada/s-intman-vxworks.ads | 58 +- gcc/ada/s-intman.ads | 94 +- gcc/ada/s-memory.adb | 14 +- gcc/ada/s-soflin.ads | 26 +- gcc/ada/s-taasde.ads | 18 +- gcc/ada/s-taprob.adb | 14 +- gcc/ada/s-taprop-os2.adb | 26 +- gcc/ada/s-taprop-vxworks.adb | 133 +- gcc/ada/s-taprop.ads | 252 ++-- gcc/ada/s-tasini.adb | 70 +- gcc/ada/s-tasini.ads | 112 +- gcc/ada/s-taskin.ads | 419 +++--- gcc/ada/s-tasren.adb | 89 +- gcc/ada/s-tassta.adb | 52 +- gcc/ada/s-tassta.ads | 8 +- gcc/ada/s-tasuti.ads | 20 +- gcc/ada/s-tataat.ads | 43 +- gcc/ada/s-tpoben.adb | 54 +- gcc/ada/s-tpobop.ads | 31 +- gcc/ada/snames.adb | 2098 ++++++++++++++--------------- gcc/ada/snames.ads | 2992 +++++++++++++++++++++--------------------- gcc/ada/tbuild.ads | 14 +- gcc/ada/utils2.c | 6 +- 32 files changed, 3654 insertions(+), 3664 deletions(-) diff --git a/gcc/ada/a-caldel.ads b/gcc/ada/a-caldel.ads index c2ea1a8..f69634b 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 e5788a4..f5dd501 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 35801e2..0fc74d5 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 1725890..3988800a 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 b1e83d7..cea4ec8 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 f22a5d4..dbecac3 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 42bdf02..b09a471 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 e2a8aaa..0ef7443 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 60f410b..a74659a 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 b0a4c3c..7e386f3 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 2353c9b..c8d2a0e 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 66637c7..6e995f4 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 256039d..1e40074 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 21e24f6..ce21a5d 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 9852c4e..ab6852d 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 c53a05e..d922ade 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 a3340a6..4298e09 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 8cea06b..e3c80ba 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 c2bee15..6a1da15 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 62bfc0c..8917dcc 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 1dd9e27..3bafc13 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 9002eee..6bdd8d2 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 0355e61..2a47c70 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 ba9ab04..c8e0232 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 8a4708a..685bc08 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 d8716cd..7031a62 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 c1d7d3c..650f756 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 c53e59e..09904f1 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 c80da27..ee6e8bb 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#" & - "#" & - "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#" & + "#" & + "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 85c2f46..9b79ae4 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 e96d22a..740ad78 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 008ac6e..787d01e 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); -- 2.7.4