-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, 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- --
return;
end if;
- -- The node is a bucket different from the bucket implied by Key.
+ -- The node is a bucket different from the bucket implied by Key
if HT.Busy > 0 then
raise Program_Error with
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, 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- --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
(Target : out Unbounded_String;
Source : String)
is
+ Old : String_Access := Target.Reference;
begin
Target.Last := Source'Length;
Target.Reference := new String (1 .. Source'Length);
Target.Reference.all := Source;
+ Free (Old);
end Set_Unbounded_String;
-----------
-- 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.
+-- 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
-- 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.
-
--- 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.
+-- 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.
+
+-- We originally deferred 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.
-- 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.
+-- 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
-- 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 System.Error_Reporting;
-- Used for Shutdown;
type Access_Wrapper is access all Wrapper;
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.
+ -- We turn warnings off for the following 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 Ada.Unchecked_Conversion
(System.Address, Attribute_Handle);
------------------------
procedure Deallocate (P : in out Access_Node);
- -- Passed to the RTS via unchecked conversion of a pointer to
- -- permit finalization and deallocation of attribute storage nodes
+ -- Passed to the RTS via unchecked conversion of a pointer to permit
+ -- finalization and deallocation of attribute storage nodes.
--------------------------
-- Instantiation Record --
-- The generic formal type, may be controlled
end record;
- -- A number of unchecked conversions involving Wrapper_Access sources
- -- are performed in this unit. We have to ensure that the designated
- -- object is always strictly enough aligned.
+ -- A number of unchecked conversions involving Wrapper_Access sources are
+ -- performed in this unit. We have to ensure that the designated object is
+ -- always strictly enough aligned.
for Wrapper'Alignment use Standard'Maximum_Alignment;
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.
+ -- 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);
if Local.Index /= 0 then
- -- Get value of attribute. Warnings off, because for large
+ -- Get value of attribute. We turn 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.
-- Start of elaboration code for package Ada.Task_Attributes
begin
- -- This unchecked conversion can give warnings when alignments
- -- are incorrect, but they will not be used in such cases anyway,
- -- so the warnings can be safely ignored.
+ -- This unchecked conversion can give warnings when alignments are
+ -- incorrect, but they will not be used in such cases anyway, so the
+ -- warnings can be safely ignored.
pragma Warnings (Off);
Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
-- 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 called at task termination
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;
(File : in out Text_AFCB;
Item : Stream_Element_Array)
is
+ pragma Warnings (Off, File);
+ -- Because in this implementation we don't need IN OUT, we only read
+
function Has_Translated_Characters return Boolean;
-- return True if Item array contains a character which will be
-- translated under the text file mode. There is only one such
Siz : constant size_t := Item'Length;
+ -------------------------------
+ -- Has_Translated_Characters --
+ -------------------------------
+
function Has_Translated_Characters return Boolean is
begin
for K in Item'Range loop
end Has_Translated_Characters;
Needs_Binary_Write : constant Boolean :=
- text_translation_required and then Has_Translated_Characters;
+ text_translation_required
+ and then Has_Translated_Characters;
+
+ -- Start of processing for Write
begin
if File.Mode = FCB.In_File then
-- with text mode if needed.
if Needs_Binary_Write then
-
if fflush (File.Stream) = -1 then
raise Device_Error;
end if;
-- we reset to text mode.
if Needs_Binary_Write then
-
if fflush (File.Stream) = -1 then
raise Device_Error;
end if;
Err_Name : aliased String := "*stderr" & ASCII.Nul;
In_Name : aliased String := "*stdin" & ASCII.Nul;
Out_Name : aliased String := "*stdout" & ASCII.Nul;
+
begin
-------------------------------
-- Initialize Standard Files --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
Null_Str : aliased constant String := "";
-- Used as name and form of standard files
- Standard_Err_AFCB : aliased Text_AFCB;
Standard_In_AFCB : aliased Text_AFCB;
Standard_Out_AFCB : aliased Text_AFCB;
+ Standard_Err_AFCB : aliased Text_AFCB;
- Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
Standard_In : aliased File_Type := Standard_In_AFCB'Access;
Standard_Out : aliased File_Type := Standard_Out_AFCB'Access;
+ Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
-- Standard files
Current_In : aliased File_Type := Standard_In;
(File : in out Wide_Text_AFCB;
Item : Stream_Element_Array)
is
+ pragma Warnings (Off, File);
+ -- Because in this implementation we don't need IN OUT, we only read
+
Siz : constant size_t := Item'Length;
begin
(File : in out Wide_Wide_Text_AFCB;
Item : Stream_Element_Array)
is
+ pragma Warnings (Off, File);
+ -- Because in this implementation we don't need IN OUT, we only read
+
Siz : constant size_t := Item'Length;
begin
union lang_tree_node
GTY((desc ("0"),
chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)")))
-
{
union tree_node GTY((tag ("0"))) t;
};
with Debug; use Debug;
with Binderr; use Binderr;
-with Lib; use Lib;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
then
Text := Read_Library_Info (Afile);
- -- Return with an error if source cannot be found and if this
- -- is not a library generic (now we can, but does not have to
- -- compile library generics)
+ -- Return with an error if source cannot be found. We used to
+ -- skip this check when we did not compile library generics
+ -- separately, but we now always do, so there is no special
+ -- case here anymore.
if Text = null then
- if Generic_Separately_Compiled (Withs.Table (W).Sfile) then
- Error_Msg_File_1 := Afile;
- Error_Msg_File_2 := Withs.Table (W).Sfile;
- Error_Msg ("{ not found, { must be compiled");
- Set_Name_Table_Info (Afile, Int (No_Unit_Id));
- return;
-
- else
- goto Skip_Library_Generics;
- end if;
+ Error_Msg_File_1 := Afile;
+ Error_Msg_File_2 := Withs.Table (W).Sfile;
+ Error_Msg ("{ not found, { must be compiled");
+ Set_Name_Table_Info (Afile, Int (No_Unit_Id));
+ return;
end if;
-- Enter in ALIs table
Read_ALI (Idread);
end if;
- <<Skip_Library_Generics>> null;
-
-- If the ALI file has already been processed and is an interface,
-- set the flag in the entry of the Withs table.
-- have an elaboration routine (since it has no elaboration code).
Pure : Boolean;
- -- Indicates presence of PU parameter for a pure package
+ -- Indicates presence of PU parameter for a package having pragma Pure
Dynamic_Elab : Boolean;
- -- Set to True if the unit was compiled with dynamic elaboration
- -- checks (i.e. either -gnatE or pragma Elaboration_Checks (RM)
- -- was used to compile the unit).
+ -- Set to True if the unit was compiled with dynamic elaboration checks
+ -- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to
+ -- compile the unit).
Elaborate_Body : Boolean;
- -- Indicates presence of EB parameter for a package which has a
- -- pragma Preelaborate_Body.
+ -- Indicates presence of EB parameter for a package which has a pragma
+ -- Elaborate_Body, and also for generic package instantiations.
Set_Elab_Entity : Boolean;
-- Indicates presence of EE parameter for a unit which has an
-- elaboration of the entity.
Has_RACW : Boolean;
- -- Indicates presence of RA parameter for a package that declares
- -- at least one Remote Access to Class_Wide (RACW) object.
+ -- Indicates presence of RA parameter for a package that declares at
+ -- least one Remote Access to Class_Wide (RACW) object.
Remote_Types : Boolean;
-- Indicates presence of RT parameter for a package which has a
-- pragma Remote_Types.
Shared_Passive : Boolean;
- -- Indicates presence of SP parameter for a package which has a
- -- pragma Shared_Passive.
+ -- Indicates presence of SP parameter for a package which has a pragma
+ -- Shared_Passive.
RCI : Boolean;
- -- Indicates presence of RC parameter for a package which has a
- -- pragma Remote_Call_Interface.
+ -- Indicates presence of RC parameter for a package which has a pragma
+ -- Remote_Call_Interface.
Predefined : Boolean;
-- Indicates if unit is language predefined (or a child of such a unit)
Icasing : Casing_Type;
-- Indicates casing of identifiers in source file for this unit. This
- -- is used for informational output, and also for constructing the
- -- main unit if it is being built in Ada.
+ -- is used for informational output, and also for constructing the main
+ -- unit if it is being built in Ada.
Kcasing : Casing_Type;
- -- Indicates casing of keyowords in source file for this unit. This
- -- is used for informational output, and also for constructing the
- -- main unit if it is being built in Ada.
+ -- Indicates casing of keywords in source file for this unit. This is
+ -- used for informational output, and also for constructing the main
+ -- unit if it is being built in Ada.
Elab_Position : aliased Natural;
-- Initialized to zero. Set non-zero when a unit is chosen and
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2003 Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2007, 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- *
int
__gnat_len_arg (int arg_num)
{
- return strlen (gnat_argv[arg_num]);
+ if (gnat_argv != NULL)
+ return strlen (gnat_argv[arg_num]);
+ else
+ return 0;
}
void
__gnat_fill_arg (char *a, int i)
{
- strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
+ if (gnat_argv != NULL)
+ strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
}
int
int
__gnat_len_env (int env_num)
{
- return strlen (gnat_envp[env_num]);
+ if (gnat_envp != NULL)
+ return strlen (gnat_envp[env_num]);
+ else
+ return 0;
}
void
__gnat_fill_env (char *a, int i)
{
- strncpy (a, gnat_envp[i], strlen (gnat_envp[i]));
+ if (gnat_envp != NULL)
+ strncpy (a, gnat_envp[i], strlen (gnat_envp[i]));
}
elsif Tolerate_Consistency_Errors then
Error_Msg
- ("?% should be recompiled (% has been modified)");
+ ("?{ should be recompiled ({ has been modified)");
else
Error_Msg ("{ must be recompiled ({ has been modified)");
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
Set_Ekind (Any_Id, E_Variable);
Set_Scope (Any_Id, Standard_Standard);
Set_Etype (Any_Id, Any_Type);
- Init_Size_Align (Any_Id);
+ Init_Esize (Any_Id);
+ Init_Alignment (Any_Id);
Make_Name (Any_Id, "any id");
Any_Access := New_Standard_Entity;
-- original node is in the source. An exception though is the case
-- of an access variable which is default initialized to null, and
-- such initialization is retained.
- -- Furthermore, if the initialization is the equivalent aggregate
+
+ -- Furthermore, if the initialization is the equivalent aggregate
-- of the type initialization procedure, it replaces an implicit
-- call to the init proc, and must be respected. Note that for
-- packed types we do not build equivalent aggregates.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
procedure Expand_N_Goto_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id);
procedure Expand_N_Loop_Statement (N : Node_Id);
- procedure Expand_N_Return_Statement (N : Node_Id);
+ procedure Expand_N_Simple_Return_Statement (N : Node_Id);
end Exp_Ch5;
-- If the front end has already computed a fully qualified name,
-- then it is also the case that no further qualification is
- -- required
+ -- required.
if Present (Scope (Scope (Entity)))
and then not Has_Fully_Qualified_Name (Entity)
procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
SL : Natural;
+ pragma Warnings (Off, BNPE_Suffix_Found);
+ -- Since this procedure only ever sets the flag
+
begin
-- Search for and strip BNPE suffix
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))),
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V)));
Fnam :=
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))),
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V)));
Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
when N_Requeue_Statement =>
Expand_N_Requeue_Statement (N);
- when N_Return_Statement =>
- Expand_N_Return_Statement (N);
+ when N_Simple_Return_Statement =>
+ Expand_N_Simple_Return_Statement (N);
when N_Selected_Component =>
Expand_N_Selected_Component (N);
-- --
-- B o d y --
-- --
--- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2005-2007, 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- --
-- relying on internal knowledge about the bits layout in the different
-- types (all 128 value bits blocks).
- -- View<->Vector straight bitwise conversions on BE targets.
+ -- View<->Vector straight bitwise conversions on BE targets
function UNC_To_Vector is
new Ada.Unchecked_Conversion (View_Type, Vector_Type);
function UNC_To_View is
new Ada.Unchecked_Conversion (Vector_Type, View_Type);
- -- Varray->Vector/View for returning mirrored results on LE targets.
+ -- Varray->Vector/View for returning mirrored results on LE targets
function UNC_To_Vector is
new Ada.Unchecked_Conversion (Varray_Type, Vector_Type);
function UNC_To_View is
new Ada.Unchecked_Conversion (Varray_Type, View_Type);
- -- Vector/View->Varray for to-be-permuted source on LE targets.
+ -- Vector/View->Varray for to-be-permuted source on LE targets
function UNC_To_Varray is
new Ada.Unchecked_Conversion (Vector_Type, Varray_Type);
----------
procedure Read
- (Dir : in out Dir_Type;
+ (Dir : Dir_Type;
Str : out String;
Last : out Natural)
is
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2005, AdaCore --
+-- Copyright (C) 1998-2007, AdaCore --
-- --
-- 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- --
-- Returns True if Dir is open, or False otherwise
procedure Read
- (Dir : in out Dir_Type;
+ (Dir : Dir_Type;
Str : out String;
Last : out Natural);
-- Reads the next entry from the directory and sets Str to the name
-- --
-- B o d y --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2007, 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- --
-- --
------------------------------------------------------------------------------
--- This is the default (Unix) version.
+-- This is the default (Unix) version
separate (GNAT.Exception_Actions)
procedure Core_Dump (Occurrence : Exception_Occurrence) is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- call to New_Copy_Tree is to create a complete duplicate of a tree,
-- as though it had appeared separately in the source), the Itype in
-- question is duplicated as part of the New_Copy_Tree processing.
+ -- As a consequence of this copying mechanism, the association between
+ -- itypes and associated nodes must be one-to-one: several itypes must
+ -- not share an associated node. For example, the semantic decoration
+ -- of an array aggregate generates several itypes: for each index subtype
+ -- and for the array subtype. The associated node of each index subtype
+ -- is the corresponding range expression.
-----------------
-- Subprograms --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
begin
Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr);
- -- Ada2005: an association can be given by: others => <>.
+ -- Ada2005: an association can be given by: others => <>
if Token = Tok_Others then
if Ada_Version < Ada_05 then
end if;
end if;
- -- In Ada 2005 the actual can be a box.
+ -- In Ada 2005 the actual can be a box
if Token = Tok_Box then
Scan;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER '
- -- Handled by the scanner and returned as Tok_Character_Literal
+ -- Handled by the scanner and returned as Tok_Char_Literal
-------------------------
-- 2.6 String Literal --
-- STRING LITERAL ::= "{STRING_ELEMENT}"
- -- Handled by the scanner and returned as Tok_Character_Literal
+ -- Handled by the scanner and returned as Tok_String_Literal
-- or if the string looks like an operator as Tok_Operator_Symbol.
-------------------------
if Identifier_Seen then
Error_Msg_SC
- ("|pragma argument identifier required here ('R'M' 2.8(4))");
+ ("|pragma argument identifier required here (RM 2.8(4))");
end if;
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2006 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2007, 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- --
-- --
------------------------------------------------------------------------------
--- This is the OpenVMS/Alpha version.
+-- This is the OpenVMS/Alpha version
with System; use System;
end record;
AST_Vector_Init : AST_Vector_Ptr;
- -- Initial value, treated as constant, Vector will be null.
+ -- Initial value, treated as constant, Vector will be null
package AST_Attribute is new Ada.Task_Attributes
(Attribute => AST_Vector_Ptr,
AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
pragma Volatile_Components (AST_Service_Queue);
- -- The circular buffer used to store active AST requests.
+ -- The circular buffer used to store active AST requests
AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
if Is_Waiting (J) then
Is_Waiting (J) := False;
- -- Sleeps are handled by ASTs on VMS, so don't call Wakeup.
+ -- Sleeps are handled by ASTs on VMS, so don't call Wakeup
STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit;
procedure Do_Write;
-- Do the actual write
+ --------------
+ -- Do_Write --
+ --------------
+
procedure Do_Write is
begin
FIO.Write_Buf (AP (File), Item, Size);
pragma Warnings (Off);
pragma Preelaborate_05;
pragma Warnings (On);
- -- To let Ada.Exceptions "with" us and let us "with" Standard_Library.
+ -- To let Ada.Exceptions "with" us and let us "with" Standard_Library
package SSL renames System.Standard_Library;
-- To let some of the hooks below have formal parameters typed in
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2005 AdaCore --
+-- Copyright (C) 1995-2007, AdaCore --
-- --
-- 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- --
generic
type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ -- An integer type indicating the number and range of hash headers
type Element is private;
-- The type of element to be stored
generic
type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ -- An integer type indicating the number and range of hash headers
type Element (<>) is limited private;
-- The type of element to be stored. This is historically part of the
-- type, but could be some other form of type such as an integer type).
Null_Ptr : Elmt_Ptr;
- -- The null value of the Elmt_Ptr type.
+ -- The null value of the Elmt_Ptr type
with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
with function Next (E : Elmt_Ptr) return Elmt_Ptr;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
pragma Pure;
function Image_Boolean (V : Boolean) return String;
- -- Computes Boolean'Image (V) and returns the result.
+ -- Computes Boolean'Image (V) and returns the result
end System.Img_Bool;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
pragma Preelaborate;
function Image_Long_Long_Integer (V : Long_Long_Integer) return String;
- -- Computes Long_Long_Integer'Image (V) and returns the result.
+ -- Computes Long_Long_Integer'Image (V) and returns the result
procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned)
return String;
- -- Computes Long_Long_Unsigned'Image (V) and returns the result.
+ -- Computes Long_Long_Unsigned'Image (V) and returns the result
procedure Set_Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Image_Unsigned
(V : System.Unsigned_Types.Unsigned)
return String;
- -- Computes Unsigned'Image (V) and returns the result.
+ -- Computes Unsigned'Image (V) and returns the result
procedure Set_Image_Unsigned
(V : System.Unsigned_Types.Unsigned;
P1 => To_unsigned_long (Interrupt'Address),
P2 => Interrupt_ID'Size / 8);
+ -- The following could use a comment ???
+
pragma Assert ((Status and 1) = 1);
end Interrupt_Self_Process;
Registered_Handler_Tail : R_Link := null;
Access_Hold : Server_Task_Access;
- -- variable used to allocate Server_Task using "new".
+ -- Variable used to allocate Server_Task using "new"
-----------------------
-- Local Subprograms --
if New_Handler = null then
- -- The null handler means we are detaching the handler.
+ -- The null handler means we are detaching the handler
User_Handler (Interrupt).Static := False;
System.Tasking.Utilities.Make_Independent;
- -- Install default action in system level.
+ -- Install default action in system level
IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
- -- Note: All tasks in RTS will have all the Reserve Interrupts
- -- being masked (except the Interrupt_Manager) and Keep_Unmasked
- -- unmasked when created.
+ -- Note: All tasks in RTS will have all the Reserve Interrupts being
+ -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
+ -- created.
- -- Abort_Task_Interrupt is one of the Interrupt unmasked
- -- in all tasks. We mask the Interrupt in this particular task
- -- so that "sigwait" is possible to catch an explicitely sent
- -- Abort_Task_Interrupt from the Interrupt_Manager.
+ -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
+ -- We mask the Interrupt in this particular task so that "sigwait" is
+ -- possible to catch an explicitely sent Abort_Task_Interrupt from the
+ -- Interrupt_Manager.
-- There are two Interrupt interrupts that this task catch through
-- "sigwait." One is the Interrupt this task is designated to catch
-- Interrupt_Manager to inform status changes (e.g: become Blocked,
-- Handler or Entry is to be detached).
- -- Prepare a mask to used for sigwait.
+ -- Prepare a mask to used for sigwait
IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
- -- Inform the Interrupt_Manager of wakeup from above sigwait.
+ -- Inform the Interrupt_Manager of wakeup from above sigwait
POP.Abort_Task (Interrupt_Manager_ID);
if User_Handler (Interrupt).H /= null then
Tmp_Handler := User_Handler (Interrupt).H;
- -- RTS calls should not be made with self being locked.
+ -- RTS calls should not be made with self being locked
POP.Unlock (Self_ID);
Tmp_ID := User_Entry (Interrupt).T;
Tmp_Entry_Index := User_Entry (Interrupt).E;
- -- RTS calls should not be made with self being locked.
+ -- RTS calls should not be made with self being locked
if Single_Lock then
POP.Unlock_RTS;
-- Elaboration code for package System.Interrupts
begin
- -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
+ -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- already bound to another entry, Program_Error will be raised.
procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id);
- -- This procedure detaches all the Interrupt Entries bound to a task.
+ -- This procedure detaches all the Interrupt Entries bound to a task
------------------------------
-- POSIX.5 Signals Services --
-- Comment needed ???
procedure Ignore_Interrupt (Interrupt : Interrupt_ID);
- -- Set the sigacion for the interrupt to SIG_IGN.
+ -- Set the sigacion for the interrupt to SIG_IGN
procedure Unignore_Interrupt (Interrupt : Interrupt_ID);
-- Comment needed ???
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is a NO tasking version of this package.
+-- This is a NO tasking version of this package
package body System.Interrupt_Management is
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-1994, Florida State University --
---- Copyright (C) 1995-2006, AdaCore --
+-- Copyright (C) 1995-2007, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is a SGI Pthread version of this package.
+-- This is a SGI Pthread version of this package
--- Make a careful study of all signals available under the OS,
--- to see which need to be reserved, kept always unmasked,
--- or kept always unmasked.
--- Be on the lookout for special signals that
--- may be used by the thread library.
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
package body System.Interrupt_Management is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is a OpenVMS/Alpha version of this package.
+-- This is a OpenVMS/Alpha version of this package
package body System.Interrupt_Management is
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2007, 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- --
-- 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
-
+ -- write:
-- Reserved (SIGRARE) := true;
-
- -- Then 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 abort, if an interrupt is
-- --
------------------------------------------------------------------------------
--- This is the VxWorks version of this package.
+-- This is the VxWorks version of this package
--- Make a careful study of all signals available under the OS,
--- to see which need to be reserved, kept always unmasked,
--- or kept always unmasked.
--- Be on the lookout for special signals that
--- may be used by the thread library.
+-- Make a careful study of all signals available under the OS, to see which
+-- need to be reserved, kept always unmasked, or kept always unmasked. Be on
+-- the lookout for special signals that may be used by the thread library.
package body System.Interrupt_Management is
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
+ -- Get interrupt state. Defined in init.c The input argument is the
+ -- interrupt number, and the result is one of the following:
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 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 : Signal_ID;
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2007, 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- --
-- Some architectures (notably VMS) use a descriptor to describe
-- a subprogram address. This function computes the actual starting
-- address of the code from Loc.
- -- Do not add pragma Inline, see 9116-002.
+ --
-- ??? This function will go away when 'Code_Address is fixed on VMS.
+ --
+ -- Do not add pragma Inline to this function: there is a curious
+ -- interaction between rtsfind and front-end inlining. The exception
+ -- declaration in s-auxdec calls rtsfind, which forces several other system
+ -- packages to be compiled. Some of those have a pragma Inline, and we
+ -- compile the corresponding bodies so that inlining can take place. One
+ -- of these packages is s-mastop, which depends on s-auxdec, which is still
+ -- being compiled: we have not seen all the declarations in it yet, so we
+ -- get confused semantic errors.
procedure Set_Machine_State (M : Machine_State);
-- This routine sets M from the current machine state. It is called
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is Darwin pthreads version of this package.
+-- This is Darwin pthreads version of this package
--- This package includes all direct interfaces to OS services
--- that are needed by children of System.
+-- This package includes all direct interfaces to OS services that are needed
+-- by children of System.
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Elaborate_Body.
--- It is designed to be a bottom-level (leaf) package.
+-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
+-- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
with Interfaces.C;
package System.OS_Interface is
type Signal_Set is array (Natural range <>) of Signal;
- Unmasked : constant Signal_Set :=
+ Unmasked : constant Signal_Set :=
(SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
- Reserved : constant Signal_Set :=
+ Reserved : constant Signal_Set :=
(SIGKILL, SIGSTOP);
type sigset_t is private;
----------
Time_Slice_Supported : constant Boolean := True;
- -- Indicates wether time slicing is supported.
+ -- Indicates wether time slicing is supported
type timespec is private;
function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int;
- -- Maps System.Any_Priority to a POSIX priority.
+ -- Maps System.Any_Priority to a POSIX priority
-------------
-- Process --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2005, AdaCore --
+-- Copyright (C) 1995-2007, AdaCore --
-- --
-- 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- --
return 0;
end sigwait;
- -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it.
+ -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it
function pthread_kill (thread : pthread_t; sig : Signal) return int is
pragma Unreferenced (thread, sig);
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, 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- --
(how : int;
set : access sigset_t;
oset : access sigset_t) return int;
- -- DCE THREADS does not have pthread_sigmask. Instead, it uses
- -- sigprocmask to do the signal handling when the thread library is
- -- sucked in.
+ -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
+ -- to do the signal handling when the thread library is sucked in.
pragma Import (C, pthread_sigmask, "sigprocmask");
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
- -- DCE_THREADS has a nonstandard pthread_mutexattr_init.
+ -- DCE_THREADS has a nonstandard pthread_mutexattr_init
function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t) return int;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This is the IRIX version of this package.
+-- This is the IRIX version of this package
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+-- This package encapsulates all direct interfaces to OS services that are
+-- needed by children of System.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, 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- --
SIGCKPT : constant := 33; -- Checkpoint warning
SIGRESTART : constant := 34; -- Restart warning
SIGUME : constant := 35; -- Uncorrectable memory error
- -- Signals defined for Posix 1003.1c.
+ -- Signals defined for Posix 1003.1c
SIGPTINTR : constant := 47;
SIGPTRESCHED : constant := 48;
-- Posix 1003.1b signals
Base_Ticks : aliased LARGE_INTEGER;
BTA : constant LIA := Base_Ticks'Access;
- -- Holds the Tick count for the base time.
+ -- Holds the Tick count for the base time
Base_Monotonic_Ticks : aliased LARGE_INTEGER;
BMTA : constant LIA := Base_Monotonic_Ticks'Access;
-- If we have a shift of more than Max_Shift seconds we resynchonize the
-- Clock. This is probably due to a manual Clock adjustment, an DST
- -- adjustment or an NTP synchronisation. And we want to adjust the
- -- time for this system (non-monotonic) clock.
+ -- adjustment or an NTP synchronisation. And we want to adjust the time
+ -- for this system (non-monotonic) clock.
if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
Get_Base_Time;
procedure Get_Base_Time is
- -- The resolution for GetSystemTime is 1 millisecond.
+ -- The resolution for GetSystemTime is 1 millisecond
-- The time to get both base times should take less than 1 millisecond.
-- Therefore, the elapsed time reported by GetSystemTime between both
-----------------------
Max_Task_Image_Length : constant := 32;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, 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- --
-- --
------------------------------------------------------------------------------
--- Version used on all VxWorks targets.
+-- Version used on all VxWorks targets
package body System.Parameters is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 32;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-----------------------
Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image.
+ -- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
- -- Even though these storage pools are typically only used
- -- by a single task, if multiple tasks are declared at the
- -- same or a more nested scope as the storage pool, there
- -- still may be concurrent access. The current implementation
- -- of Stack_Bounded_Pool always uses a global lock for protecting
- -- access. This should eventually be replaced by an atomic
+ -- Even though these storage pools are typically only used by a single
+ -- task, if multiple tasks are declared at the same or a more nested scope
+ -- as the storage pool, there still may be concurrent access. The current
+ -- implementation of Stack_Bounded_Pool always uses a global lock for
+ -- protecting access. This should eventually be replaced by an atomic
-- linked list implementation for efficiency reasons.
package SSL renames System.Soft_Links;
package Variable_Size_Management is
- -- Embedded pool that manages allocation of variable-size data.
+ -- Embedded pool that manages allocation of variable-size data
- -- This pool is used as soon as the Elmt_sizS of the pool object is 0.
+ -- This pool is used as soon as the Elmt_sizS of the pool object is 0
-- Allocation is done on the first chunk long enough for the request.
-- Deallocation just puts the freed chunk at the beginning of the list.
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2007, 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- --
-- --
------------------------------------------------------------------------------
--- This package contains the definitions and routines used as parameters
--- to the run-time system at program startup for the SGI implementation.
+-- This package contains the definitions and routines used as parameters to
+-- the run-time system at program startup for the SGI implementation.
package System.Program_Info is
pragma Preelaborate;
function Initial_Sproc_Count return Integer;
- -- The number of sproc created at program startup for scheduling
- -- threads.
+ -- The number of sproc created at program startup for scheduling threads
function Max_Sproc_Count return Integer;
- -- The maximum number of sprocs that can be created by the program
- -- for servicing threads. This limit includes both the pre-created
- -- sprocs and those explicitly created under program control.
+ -- The maximum number of sprocs that can be created by the program for
+ -- servicing threads. This limit includes both the pre-created sprocs and
+ -- those explicitly created under program control.
function Sproc_Stack_Size return Integer;
-- The size, in bytes, of the sproc's initial stack.
-- Task_Info pragma. See s-tasinf.ads for more information.
function Default_Task_Stack return Integer;
- -- The default stack size for each created thread. This default value
- -- can be overriden on a per-task basis by the language-defined
- -- Storage_Size pragma.
+ -- The default stack size for each created thread. This default value can
+ -- be overriden on a per-task basis by the language-defined Storage_Size
+ -- pragma.
function Stack_Guard_Pages return Integer;
-- The number of non-writable, guard pages to append to the bottom of
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2007, 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- --
(Limit => System.Null_Address,
Base => System.Null_Address,
Size => 0);
- -- Use explicit assignment to avoid elaboration code (call to init proc).
+ -- Use explicit assignment to avoid elaboration code (call to init proc)
Null_Stack : constant Stack_Access := Null_Stack_Info'Access;
-- Stack_Access value that will return a Stack_Base and Stack_Limit
Task_Name_Blanks :
constant String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
- (others => ' ');
+ (others => ' ');
+
begin
Set_Output (Standard_Error);
end if;
if Result_Array'Length > 0 then
+
-- Computes the size of the largest strings that will get displayed,
-- in order to do correct column alignment.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- This package body contains the routines associated with the implementation
-- of the Task_Info pragma.
--- This is the Solaris (native) version of this module.
+-- This is the Solaris (native) version of this module
package body System.Task_Info is
- function Unbound_Thread_Attributes return Thread_Attributes is
- begin
- return (False, False);
- end Unbound_Thread_Attributes;
+ -----------------------------
+ -- Bound_Thread_Attributes --
+ -----------------------------
function Bound_Thread_Attributes return Thread_Attributes is
begin
return (True, True, CPU);
end Bound_Thread_Attributes;
- function New_Unbound_Thread_Attributes return Task_Info_Type is
- begin
- return new Thread_Attributes'(False, False);
- end New_Unbound_Thread_Attributes;
+ ---------------------------------
+ -- New_Bound_Thread_Attributes --
+ ---------------------------------
function New_Bound_Thread_Attributes return Task_Info_Type is
begin
return new Thread_Attributes'(True, True, CPU);
end New_Bound_Thread_Attributes;
+ -----------------------------------
+ -- New_Unbound_Thread_Attributes --
+ -----------------------------------
+
+ function New_Unbound_Thread_Attributes return Task_Info_Type is
+ begin
+ return new Thread_Attributes'(False, False);
+ end New_Unbound_Thread_Attributes;
+
+ -------------------------------
+ -- Unbound_Thread_Attributes --
+ -------------------------------
+
+ function Unbound_Thread_Attributes return Thread_Attributes is
+ begin
+ return (False, False);
+ end Unbound_Thread_Attributes;
+
end System.Task_Info;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable.
--- This is the Solaris (native) version of this module.
+-- This is the Solaris (native) version of this module
with System.OS_Interface;
-- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
-- is present, then it supplies an alternative value. If the argument of
-- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value.
-- S p e c --
-- (Compiler Interface) --
-- --
--- Copyright (C) 1998-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2007, 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- --
-- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable.
--- This is a DEC Unix 4.0d version of this package.
+-- This is a DEC Unix 4.0d version of this package
package System.Task_Info is
pragma Preelaborate;
-- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
-- is present, then it supplies an alternative value. If the argument of
-- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma
- -- appears, then the value Task_Info_Unspecified is passed. If a pragma
+ -- appears, then the value Unspecified_Task_Info is passed. If a pragma
-- is present, then it supplies an alternative value. If the argument of
-- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value.
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
--- This version is for VxWorks targets.
+-- This version is for VxWorks targets
--- Trace information is sent to WindView using the wvEvent function.
+-- Trace information is sent to WindView using the wvEvent function
--- Note that wvEvent is from the VxWorks API.
+-- Note that wvEvent is from the VxWorks API
-- When adding a new event, just give an Id to then event, and then modify
-- the WindView events database.
if Warn_On_Obsolescent_Feature then
Error_Msg_S
- ("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
+ ("use of "":"" is an obsolescent feature (RM J.2(3))?");
Error_Msg_S
("\use ""'#"" instead?");
end if;
-- Horizontal tab, just skip past it
when HT =>
- if Style_Check then Style.Check_HT; end if;
+ if Style_Check then
+ Style.Check_HT;
+ end if;
+
Scan_Ptr := Scan_Ptr + 1;
-- End of file character, treated as an end of file only if it is
when EOF =>
if Scan_Ptr = Source_Last (Current_Source_File) then
Check_End_Of_Line;
- if Style_Check then Style.Check_EOF; end if;
+
+ if Style_Check then
+ Style.Check_EOF;
+ end if;
+
Token := Tok_EOF;
return;
else
if Double_Char_Token ('=') then
Token := Tok_Colon_Equal;
- if Style_Check then Style.Check_Colon_Equal; end if;
+
+ if Style_Check then
+ Style.Check_Colon_Equal;
+ end if;
+
return;
elsif Source (Scan_Ptr + 1) = '-'
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Colon;
- if Style_Check then Style.Check_Colon; end if;
+
+ if Style_Check then
+ Style.Check_Colon;
+ end if;
+
return;
end if;
Accumulate_Checksum ('(');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
- if Style_Check then Style.Check_Left_Paren; end if;
+
+ if Style_Check then
+ Style.Check_Left_Paren;
+ end if;
+
return;
-- Left bracket
Accumulate_Checksum (',');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Comma;
- if Style_Check then Style.Check_Comma; end if;
+
+ if Style_Check then
+ Style.Check_Comma;
+ end if;
+
return;
-- Dot, which is either an isolated period, or part of a double dot
if Double_Char_Token ('.') then
Token := Tok_Dot_Dot;
- if Style_Check then Style.Check_Dot_Dot; end if;
+
+ if Style_Check then
+ Style.Check_Dot_Dot;
+ end if;
+
return;
elsif Source (Scan_Ptr + 1) in '0' .. '9' then
if Double_Char_Token ('>') then
Token := Tok_Arrow;
- if Style_Check then Style.Check_Arrow; end if;
+
+ if Style_Check then
+ Style.Check_Arrow;
+ end if;
+
return;
elsif Source (Scan_Ptr + 1) = '=' then
elsif Double_Char_Token ('>') then
Token := Tok_Box;
- if Style_Check then Style.Check_Box; end if;
+
+ if Style_Check then
+ Style.Check_Box;
+ end if;
+
return;
elsif Double_Char_Token ('<') then
-- Comment
else -- Source (Scan_Ptr + 1) = '-' then
- if Style_Check then Style.Check_Comment; end if;
+ if Style_Check then
+ Style.Check_Comment;
+ end if;
+
Scan_Ptr := Scan_Ptr + 2;
-- If we are in preprocessor mode with Replace_In_Comments set,
-- Keep going if horizontal tab
if Source (Scan_Ptr) = HT then
- if Style_Check then Style.Check_HT; end if;
+ if Style_Check then
+ Style.Check_HT;
+ end if;
+
Scan_Ptr := Scan_Ptr + 1;
-- Terminate scan of comment if line terminator
if Warn_On_Obsolescent_Feature then
Error_Msg_S
- ("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
+ ("use of ""'%"" is an obsolescent feature (RM J.2(4))?");
Error_Msg_S
("\use """""" instead?");
end if;
or else Prev_Token in Token_Class_Literal
then
Token := Tok_Apostrophe;
- if Style_Check then Style.Check_Apostrophe; end if;
+
+ if Style_Check then
+ Style.Check_Apostrophe;
+ end if;
+
return;
-- Otherwise the apostrophe starts a character literal
Accumulate_Checksum (')');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
- if Style_Check then Style.Check_Right_Paren; end if;
+
+ if Style_Check then
+ Style.Check_Right_Paren;
+ end if;
+
return;
-- Right bracket or right brace, treated as right paren
Accumulate_Checksum (';');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Semicolon;
- if Style_Check then Style.Check_Semicolon; end if;
+
+ if Style_Check then
+ Style.Check_Semicolon;
+ end if;
+
return;
-- Vertical bar
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar;
- if Style_Check then Style.Check_Vertical_Bar; end if;
+
+ if Style_Check then
+ Style.Check_Vertical_Bar;
+ end if;
+
return;
end if;
end Vertical_Bar_Case;
if Warn_On_Obsolescent_Feature then
Error_Msg_S
- ("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?");
+ ("use of ""'!"" is an obsolescent feature (RM J.2(2))?");
Error_Msg_S
("\use ""'|"" instead?");
end if;
if Is_Keyword_Name (Token_Name) then
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
- -- Deal with possible style check for non-lower case keyword, but
- -- we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords for
- -- this purpose if they appear as attribute designators. Actually
- -- we only check the first character for speed.
-
- -- Ada 2005 (AI-284): Do not apply the style check in case of
- -- "pragma Interface"
-
- -- Ada 2005 (AI-340): Do not apply the style check in case of
- -- MOD attribute.
-
- if Style_Check
- and then Source (Token_Ptr) <= 'Z'
- and then (Prev_Token /= Tok_Apostrophe
- or else
- (Token /= Tok_Access and then
- Token /= Tok_Delta and then
- Token /= Tok_Digits and then
- Token /= Tok_Mod and then
- Token /= Tok_Range))
- and then (Token /= Tok_Interface
- or else
- (Token = Tok_Interface
- and then Prev_Token /= Tok_Pragma))
- then
- Style.Non_Lower_Case_Keyword;
+ -- Keyword style checks
+
+ if Style_Check then
+
+ -- Deal with possible style check for non-lower case keyword,
+ -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
+ -- for this purpose if they appear as attribute designators.
+ -- Actually we only check the first character for speed.
+
+ -- Ada 2005 (AI-284): Do not apply the style check in case of
+ -- "pragma Interface"
+
+ -- Ada 2005 (AI-340): Do not apply the style check in case of
+ -- MOD attribute.
+
+ if Source (Token_Ptr) <= 'Z'
+ and then (Prev_Token /= Tok_Apostrophe
+ or else
+ (Token /= Tok_Access and then
+ Token /= Tok_Delta and then
+ Token /= Tok_Digits and then
+ Token /= Tok_Mod and then
+ Token /= Tok_Range))
+ and then (Token /= Tok_Interface
+ or else
+ (Token = Tok_Interface
+ and then Prev_Token /= Tok_Pragma))
+ then
+ Style.Non_Lower_Case_Keyword;
+ end if;
+
+ if (Token = Tok_Then and then Prev_Token /= Tok_And)
+ or else
+ (Token = Tok_Else and then Prev_Token /= Tok_Or)
+ then
+ Style.Check_Separate_Stmt_Lines;
+ end if;
end if;
-- We must reset Token_Name since this is not an identifier and
-- Outer loop keeps going only if a horizontal tab follows
if Source (Scan_Ptr) = HT then
- if Style_Check then Style.Check_HT; end if;
+ if Style_Check then
+ Style.Check_HT;
+ end if;
+
Scan_Ptr := Scan_Ptr + 1;
Start_Column := (Start_Column / 8) * 8 + 8;
else
with Stand; use Stand;
with Uintp; use Uintp;
+with Unchecked_Deallocation;
+
pragma Warnings (Off, Sem_Util);
-- Suppress warnings of unused with for Sem_Util (used only in asserts)
when N_Requeue_Statement =>
Analyze_Requeue (N);
- when N_Return_Statement =>
- Analyze_Return_Statement (N);
+ when N_Simple_Return_Statement =>
+ Analyze_Simple_Return_Statement (N);
when N_Selected_Component =>
Find_Selected_Component (N);
From : Entity_Id;
To : Entity_Id)
is
+ Found : Boolean;
+
+ procedure Search_Stack
+ (Top : Suppress_Stack_Entry_Ptr;
+ Found : out Boolean);
+ -- Search given suppress stack for matching entry for entity. If found
+ -- then set Checks_May_Be_Suppressed on To, and push an appropriate
+ -- entry for To onto the local suppress stack.
+
+ ------------------
+ -- Search_Stack --
+ ------------------
+
+ procedure Search_Stack
+ (Top : Suppress_Stack_Entry_Ptr;
+ Found : out Boolean)
+ is
+ Ptr : Suppress_Stack_Entry_Ptr;
+
+ begin
+ Ptr := Top;
+ while Ptr /= null loop
+ if Ptr.Entity = From
+ and then (Ptr.Check = All_Checks or else Ptr.Check = C)
+ then
+ if Ptr.Suppress then
+ Set_Checks_May_Be_Suppressed (To, True);
+ Push_Local_Suppress_Stack_Entry
+ (Entity => To,
+ Check => C,
+ Suppress => True);
+ Found := True;
+ return;
+ end if;
+ end if;
+
+ Ptr := Ptr.Prev;
+ end loop;
+
+ Found := False;
+ return;
+ end Search_Stack;
+
+ -- Start of processing for Copy_Suppress_Status
+
begin
if not Checks_May_Be_Suppressed (From) then
return;
end if;
- -- First search the local entity suppress table, we search this in
+ -- First search the local entity suppress stack, we search this in
-- reverse order so that we get the innermost entry that applies to
-- this case if there are nested entries. Note that for the purpose
-- of this procedure we are ONLY looking for entries corresponding
-- to a two-argument Suppress, where the second argument matches From.
- for J in
- reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
- loop
- declare
- R : Entity_Check_Suppress_Record
- renames Local_Entity_Suppress.Table (J);
+ Search_Stack (Global_Suppress_Stack_Top, Found);
- begin
- if R.Entity = From
- and then (R.Check = All_Checks or else R.Check = C)
- then
- if R.Suppress then
- Set_Checks_May_Be_Suppressed (To, True);
- Local_Entity_Suppress.Append
- ((Entity => To,
- Check => C,
- Suppress => True));
- return;
- end if;
- end if;
- end;
- end loop;
+ if Found then
+ return;
+ end if;
-- Now search the global entity suppress table for a matching entry
-- We also search this in reverse order so that if there are multiple
-- pragmas for the same entity, the last one applies.
- for J in
- reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
- loop
- declare
- R : Entity_Check_Suppress_Record
- renames Global_Entity_Suppress.Table (J);
-
- begin
- if R.Entity = From
- and then (R.Check = All_Checks or else R.Check = C)
- then
- if R.Suppress then
- Set_Checks_May_Be_Suppressed (To, True);
- Local_Entity_Suppress.Append
- ((Entity => To,
- Check => C,
- Suppress => True));
- end if;
- end if;
- end;
- end loop;
+ Search_Stack (Local_Suppress_Stack_Top, Found);
end Copy_Suppress_Status;
-------------------------
-----------------------
function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
+ Ptr : Suppress_Stack_Entry_Ptr;
+
begin
if not Checks_May_Be_Suppressed (E) then
return False;
else
- for J in
- reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
- loop
- declare
- R : Entity_Check_Suppress_Record
- renames Global_Entity_Suppress.Table (J);
-
- begin
- if R.Entity = E
- and then (R.Check = All_Checks or else R.Check = C)
- then
- return R.Suppress;
- end if;
- end;
- end loop;
+ Ptr := Global_Suppress_Stack_Top;
+ while Ptr /= null loop
+ if Ptr.Entity = E
+ and then (Ptr.Check = All_Checks or else Ptr.Check = C)
+ then
+ return Ptr.Suppress;
+ end if;
- return False;
+ Ptr := Ptr.Prev;
+ end loop;
end if;
+
+ return False;
end Explicit_Suppress;
-----------------------------
----------------
procedure Initialize is
+ Next : Suppress_Stack_Entry_Ptr;
+
+ procedure Free is new Unchecked_Deallocation
+ (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
+
begin
- Local_Entity_Suppress.Init;
- Global_Entity_Suppress.Init;
+ -- Free any global suppress stack entries from a previous invocation
+ -- of the compiler (in the normal case this loop does nothing).
+
+ while Suppress_Stack_Entries /= null loop
+ Next := Global_Suppress_Stack_Top.Next;
+ Free (Suppress_Stack_Entries);
+ Suppress_Stack_Entries := Next;
+ end loop;
+
+ Local_Suppress_Stack_Top := null;
+ Global_Suppress_Stack_Top := null;
+
+ -- Clear scope stack, and reset global variables
+
Scope_Stack.Init;
Unloaded_Subunits := False;
end Initialize;
-------------------------
function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
- begin
- -- First search the local entity suppress table, we search this in
- -- reverse order so that we get the innermost entry that applies to
- -- this case if there are nested entries.
- for J in
- reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
- loop
- declare
- R : Entity_Check_Suppress_Record
- renames Local_Entity_Suppress.Table (J);
+ Ptr : Suppress_Stack_Entry_Ptr;
- begin
- if (R.Entity = Empty or else R.Entity = E)
- and then (R.Check = All_Checks or else R.Check = C)
- then
- return R.Suppress;
- end if;
- end;
+ begin
+ -- First search the local entity suppress stack, we search this from the
+ -- top of the stack down, so that we get the innermost entry that
+ -- applies to this case if there are nested entries.
+
+ Ptr := Local_Suppress_Stack_Top;
+ while Ptr /= null loop
+ if (Ptr.Entity = Empty or else Ptr.Entity = E)
+ and then (Ptr.Check = All_Checks or else Ptr.Check = C)
+ then
+ return Ptr.Suppress;
+ end if;
+
+ Ptr := Ptr.Prev;
end loop;
-- Now search the global entity suppress table for a matching entry
- -- We also search this in reverse order so that if there are multiple
+ -- We also search this from the top down so that if there are multiple
-- pragmas for the same entity, the last one applies (not clear what
-- or whether the RM specifies this handling, but it seems reasonable).
- for J in
- reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
- loop
- declare
- R : Entity_Check_Suppress_Record
- renames Global_Entity_Suppress.Table (J);
+ Ptr := Global_Suppress_Stack_Top;
+ while Ptr /= null loop
+ if (Ptr.Entity = Empty or else Ptr.Entity = E)
+ and then (Ptr.Check = All_Checks or else Ptr.Check = C)
+ then
+ return Ptr.Suppress;
+ end if;
- begin
- if R.Entity = E
- and then (R.Check = All_Checks or else R.Check = C)
- then
- return R.Suppress;
- end if;
- end;
+ Ptr := Ptr.Prev;
end loop;
-- If we did not find a matching entry, then use the normal scope
-- suppress value after all (actually this will be the global setting
- -- since it clearly was not overridden at any point)
+ -- since it clearly was not overridden at any point). For a predefined
+ -- check, we test the specific flag. For a user defined check, we check
+ -- the All_Checks flag.
- return Scope_Suppress (C);
+ if C in Predefined_Check_Id then
+ return Scope_Suppress (C);
+ else
+ return Scope_Suppress (All_Checks);
+ end if;
end Is_Check_Suppressed;
----------
procedure Lock is
begin
- Local_Entity_Suppress.Locked := True;
- Global_Entity_Suppress.Locked := True;
Scope_Stack.Locked := True;
- Local_Entity_Suppress.Release;
- Global_Entity_Suppress.Release;
Scope_Stack.Release;
end Lock;
+ --------------------------------------
+ -- Push_Global_Suppress_Stack_Entry --
+ --------------------------------------
+
+ procedure Push_Global_Suppress_Stack_Entry
+ (Entity : Entity_Id;
+ Check : Check_Id;
+ Suppress : Boolean)
+ is
+ begin
+ Global_Suppress_Stack_Top :=
+ new Suppress_Stack_Entry'
+ (Entity => Entity,
+ Check => Check,
+ Suppress => Suppress,
+ Prev => Global_Suppress_Stack_Top,
+ Next => Suppress_Stack_Entries);
+ Suppress_Stack_Entries := Global_Suppress_Stack_Top;
+ return;
+
+ end Push_Global_Suppress_Stack_Entry;
+
+ -------------------------------------
+ -- Push_Local_Suppress_Stack_Entry --
+ -------------------------------------
+
+ procedure Push_Local_Suppress_Stack_Entry
+ (Entity : Entity_Id;
+ Check : Check_Id;
+ Suppress : Boolean)
+ is
+ begin
+ Local_Suppress_Stack_Top :=
+ new Suppress_Stack_Entry'
+ (Entity => Entity,
+ Check => Check,
+ Suppress => Suppress,
+ Prev => Local_Suppress_Stack_Top,
+ Next => Suppress_Stack_Entries);
+ Suppress_Stack_Entries := Local_Suppress_Stack_Top;
+
+ return;
+ end Push_Local_Suppress_Stack_Entry;
+
---------------
-- Semantics --
---------------
-----------------------------
Full_Analysis : Boolean := True;
- -- Switch to indicate whether we are doing a full analysis or a
- -- pre-analysis. In normal analysis mode (Analysis-Expansion for
- -- instructions or declarations) or (Analysis-Resolution-Expansion for
- -- expressions) this flag is set. Note that if we are not generating
- -- code the expansion phase merely sets the Analyzed flag to True in
- -- this case. If we are in Pre-Analysis mode (see above) this flag is
- -- set to False then the expansion phase is skipped.
- -- When this flag is False the flag Expander_Active is also False
- -- (the Expander_Activer flag defined in the spec of package Expander
- -- tells you whether expansion is currently enabled).
- -- You should really regard this as a read only flag.
+ -- Switch to indicate if we are doing a full analysis or a pre-analysis.
+ -- In normal analysis mode (Analysis-Expansion for instructions or
+ -- declarations) or (Analysis-Resolution-Expansion for expressions) this
+ -- flag is set. Note that if we are not generating code the expansion phase
+ -- merely sets the Analyzed flag to True in this case. If we are in
+ -- Pre-Analysis mode (see above) this flag is set to False then the
+ -- expansion phase is skipped.
+ --
+ -- When this flag is False the flag Expander_Active is also False (the
+ -- Expander_Activer flag defined in the spec of package Expander tells you
+ -- whether expansion is currently enabled). You should really regard this
+ -- as a read only flag.
In_Default_Expression : Boolean := False;
-- Switch to indicate that we are in a default expression, as described
-- above. Note that this must be recursively saved on a Semantics call
- -- since it is possible for the analysis of an expression to result in
- -- a recursive call (e.g. to get the entity for System.Address as part
- -- of the processing of an Address attribute reference).
- -- When this switch is True then Full_Analysis above must be False.
- -- You should really regard this as a read only flag.
+ -- since it is possible for the analysis of an expression to result in a
+ -- recursive call (e.g. to get the entity for System.Address as part of the
+ -- processing of an Address attribute reference). When this switch is True
+ -- then Full_Analysis above must be False. You should really regard this as
+ -- a read only flag.
In_Deleted_Code : Boolean := False;
-- If the condition in an if-statement is statically known, the branch
-- about unused variables, since these warnings are unreliable in this
-- case. We could perhaps do a more accurate job and retain some of the
-- warnings, but it is quite a tricky job. See test 4323-002.
+ -- Should not reference TN's in the source comments ???
+
+ -----------------------------------
+ -- Handling of Check Suppression --
+ -----------------------------------
+
+ -- There are two kinds of suppress checks: scope based suppress checks,
+ -- and entity based suppress checks.
+
+ -- Scope based suppress checks for the predefined checks (from initial
+ -- command line arguments, or from Suppress pragmas not including an entity
+ -- entity name) are recorded in the Sem.Supress variable, and all that is
+ -- necessary is to save the state of this variable on scope entry, and
+ -- restore it on scope exit. This mechanism allows for fast checking of
+ -- the scope suppress state without needing complex data structures.
+
+ -- Entity based checks, from Suppress/Unsuppress pragmas giving an
+ -- Entity_Id and scope based checks for non-predefined checks (introduced
+ -- using pragma Check_Name), are handled as follows. If a suppress or
+ -- unsuppress pragma is encountered for a given entity, then the flag
+ -- Checks_May_Be_Suppressed is set in the entity and an entry is made in
+ -- either the Local_Entity_Suppress stack (case of pragma that appears in
+ -- other than a package spec), or in the Global_Entity_Suppress stack (case
+ -- of pragma that appears in a package spec, which is by the rule of RM
+ -- 11.5(7) applicable throughout the life of the entity). Similarly, a
+ -- Suppress/Unsuppress pragma for a non-predefined check which does not
+ -- specify an entity is also stored in one of these stacks.
+
+ -- If the Checks_May_Be_Suppressed flag is set in an entity then the
+ -- procedure is to search first the local and then the global suppress
+ -- stacks (we search these in reverse order, top element first). The only
+ -- other point is that we have to make sure that we have proper nested
+ -- interaction between such specific pragmas and locally applied general
+ -- pragmas applying to all entities. This is achieved by including in the
+ -- Local_Entity_Suppress table dummy entries with an empty Entity field
+ -- that are applicable to all entities. A similar search is needed for any
+ -- non-predefined check even if no specific entity is involved.
+
+ Scope_Suppress : Suppress_Array := Suppress_Options;
+ -- This array contains the current scope based settings of the suppress
+ -- switches. It is initialized from the options as shown, and then modified
+ -- by pragma Suppress. On entry to each scope, the current setting is saved
+ -- the scope stack, and then restored on exit from the scope. This record
+ -- may be rapidly checked to determine the current status of a check if
+ -- no specific entity is involved or if the specific entity involved is
+ -- one for which no specific Suppress/Unsuppress pragma has been set (as
+ -- indicated by the Checks_May_Be_Suppressed flag being set).
+
+ -- This scheme is a little complex, but serves the purpose of enabling
+ -- a very rapid check in the common case where no entity specific pragma
+ -- applies, and gives the right result when such pragmas are used even
+ -- in complex cases of nested Suppress and Unsuppress pragmas.
+
+ -- The Local_Entity_Suppress and Global_Entity_Suppress stacks are handled
+ -- using dynamic allocation and linked lists. We do not often use this
+ -- approach in the compiler (preferring to use extensible tables instead).
+ -- The reason we do it here is that scope stack entries save a pointer to
+ -- the current local stack top, which is also saved and restored on scope
+ -- exit. Furthermore for processing of generics we save pointers to the
+ -- top of the stack, so that the local stack is actually a tree of stacks
+ -- rather than a single stack, a structure that is easy to represent using
+ -- linked lists, but impossible to represent using a single table. Note
+ -- that because of the generic issue, we never release entries in these
+ -- stacks, but that's no big deal, since we are unlikely to have a huge
+ -- number of Suppress/Unsuppress entries in a single compilation.
+
+ type Suppress_Stack_Entry;
+ type Suppress_Stack_Entry_Ptr is access all Suppress_Stack_Entry;
+
+ type Suppress_Stack_Entry is record
+ Entity : Entity_Id;
+ -- Entity to which the check applies, or Empty for a check that has
+ -- no entity name (and thus applies to all entities).
+
+ Check : Check_Id;
+ -- Check which is set (can be All_Checks for the All_Checks case)
+
+ Suppress : Boolean;
+ -- Set True for Suppress, and False for Unsuppress
+
+ Prev : Suppress_Stack_Entry_Ptr;
+ -- Pointer to previous entry on stack
+
+ Next : Suppress_Stack_Entry_Ptr;
+ -- All allocated Suppress_Stack_Entry records are chained together in
+ -- a linked list whose head is Suppress_Stack_Entries, and the Next
+ -- field is used as a forward pointer (null ends the list). This is
+ -- used to free all entries in Sem.Init (which will be important if
+ -- we ever setup the compiler to be reused).
+ end record;
+
+ Suppress_Stack_Entries : Suppress_Stack_Entry_Ptr := null;
+ -- Pointer to linked list of records (see comments for Next above)
+
+ Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
+ -- Pointer to top element of local suppress stack. This is the entry that
+ -- is saved and restored in the scope stack, and also saved for generic
+ -- body expansion.
+
+ Global_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
+ -- Pointer to top element of global suppress stack
+
+ procedure Push_Local_Suppress_Stack_Entry
+ (Entity : Entity_Id;
+ Check : Check_Id;
+ Suppress : Boolean);
+ -- Push a new entry on to the top of the local suppress stack, updating
+ -- the value in Local_Suppress_Stack_Top;
+
+ procedure Push_Global_Suppress_Stack_Entry
+ (Entity : Entity_Id;
+ Check : Check_Id;
+ Suppress : Boolean);
+ -- Push a new entry on to the top of the global suppress stack, updating
+ -- the value in Global_Suppress_Stack_Top;
-----------------
-- Scope Stack --
Save_Scope_Suppress : Suppress_Array;
-- Save contents of Scope_Suppress on entry
- Save_Local_Entity_Suppress : Int;
- -- Save contents of Local_Entity_Suppress.Last on entry
+ Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
+ -- Save contents of Local_Suppress_Stack on entry to restore on exit
Is_Transient : Boolean;
-- Marks Transient Scopes (See Exp_Ch7 body for details)
Table_Increment => Alloc.Scope_Stack_Increment,
Table_Name => "Sem.Scope_Stack");
- -----------------------------------
- -- Handling of Check Suppression --
- -----------------------------------
-
- -- There are two kinds of suppress checks: scope based suppress checks,
- -- and entity based suppress checks.
-
- -- Scope based suppress checks (from initial command line arguments,
- -- or from Suppress pragmas not including an entity name) are recorded
- -- in the Sem.Supress variable, and all that is necessary is to save the
- -- state of this variable on scope entry, and restore it on scope exit.
-
- -- Entity based suppress checks, from Suppress pragmas giving an Entity_Id,
- -- are handled as follows. If a suppress or unsuppress pragma is
- -- encountered for a given entity, then the flag Checks_May_Be_Suppressed
- -- is set in the entity and an entry is made in either the
- -- Local_Entity_Suppress table (case of pragma that appears in other than
- -- a package spec), or in the Global_Entity_Suppress table (case of pragma
- -- that appears in a package spec, which is by the rule of RM 11.5(7)
- -- applicable throughout the life of the entity).
-
- -- If the Checks_May_Be_Suppressed flag is set in an entity then the
- -- procedure is to search first the local and then the global suppress
- -- tables (the local one being searched in reverse order, i.e. last in
- -- searched first). The only other point is that we have to make sure
- -- that we have proper nested interaction between such specific pragmas
- -- and locally applied general pragmas applying to all entities. This
- -- is achieved by including in the Local_Entity_Suppress table dummy
- -- entries with an empty Entity field that are applicable to all entities.
-
- Scope_Suppress : Suppress_Array := Suppress_Options;
- -- This array contains the current scope based settings of the suppress
- -- switches. It is initialized from the options as shown, and then modified
- -- by pragma Suppress. On entry to each scope, the current setting is saved
- -- the scope stack, and then restored on exit from the scope. This record
- -- may be rapidly checked to determine the current status of a check if
- -- no specific entity is involved or if the specific entity involved is
- -- one for which no specific Suppress/Unsuppress pragma has been set (as
- -- indicated by the Checks_May_Be_Suppressed flag being set).
-
- -- This scheme is a little complex, but serves the purpose of enabling
- -- a very rapid check in the common case where no entity specific pragma
- -- applies, and gives the right result when such pragmas are used even
- -- in complex cases of nested Suppress and Unsuppress pragmas.
-
- type Entity_Check_Suppress_Record is record
- Entity : Entity_Id;
- -- Entity to which the check applies, or Empty for a local check
- -- that has no entity name (and thus applies to all entities).
-
- Check : Check_Id;
- -- Check which is set (note this cannot be All_Checks, if the All_Checks
- -- case, a sequence of eentries appears for the individual checks.
-
- Suppress : Boolean;
- -- Set True for Suppress, and False for Unsuppress
- end record;
-
- -- The Local_Entity_Suppress table is a stack, to which new entries are
- -- added for Suppress and Unsuppress pragmas appearing in other than
- -- package specs. Such pragmas are effective only to the end of the scope
- -- in which they appear. This is achieved by marking the stack on entry
- -- to a scope and then cutting back the stack to that marked point on
- -- scope exit.
-
- package Local_Entity_Suppress is new Table.Table (
- Table_Component_Type => Entity_Check_Suppress_Record,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Entity_Suppress_Initial,
- Table_Increment => Alloc.Entity_Suppress_Increment,
- Table_Name => "Local_Entity_Suppress");
-
- -- The Global_Entity_Suppress table is used for entities which have
- -- a Suppress or Unsuppress pragma naming a specific entity in a
- -- package spec. Such pragmas always refer to entities in the package
- -- spec and are effective throughout the lifetime of the named entity.
-
- package Global_Entity_Suppress is new Table.Table (
- Table_Component_Type => Entity_Check_Suppress_Record,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Entity_Suppress_Initial,
- Table_Increment => Alloc.Entity_Suppress_Increment,
- Table_Name => "Global_Entity_Suppress");
-
-----------------
-- Subprograms --
-----------------
Set_Etype (N, Etype (Right));
end if;
- Fold_Str (N, End_String, True);
+ Fold_Str (N, End_String, Static => True);
end if;
end;
end Eval_Concatenation;
-- Fold conversion, case of string type. The result is not static
if Is_String_Type (Target_Type) then
- Fold_Str (N, Strval (Get_String_Val (Operand)), False);
+ Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
return;
if Raises_Constraint_Error (Expr) then
Error_Msg_N
("expression raises exception, cannot be static " &
- "('R'M 4.9(34))!", N);
+ "(RM 4.9(34))!", N);
return;
end if;
then
Error_Msg_N
("static expression must have scalar or string type " &
- "('R'M 4.9(2))!", N);
+ "(RM 4.9(2))!", N);
return;
end if;
end if;
elsif Ekind (E) = E_Constant then
if not Is_Static_Expression (Constant_Value (E)) then
Error_Msg_NE
- ("& is not a static constant ('R'M 4.9(5))!", N, E);
+ ("& is not a static constant (RM 4.9(5))!", N, E);
end if;
else
Error_Msg_NE
("& is not static constant or named number " &
- "('R'M 4.9(5))!", N, E);
+ "(RM 4.9(5))!", N, E);
end if;
when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
- ("shift functions are never static ('R'M 4.9(6,18))!", N);
+ ("shift functions are never static (RM 4.9(6,18))!", N);
else
Why_Not_Static (Left_Opnd (N));
if Attribute_Name (N) = Name_Size then
Error_Msg_N
("size attribute is only static for scalar type " &
- "('R'M 4.9(7,8))", N);
+ "(RM 4.9(7,8))", N);
-- Flag array cases
then
Error_Msg_N
("static array attribute must be Length, First, or Last " &
- "('R'M 4.9(8))!", N);
+ "(RM 4.9(8))!", N);
-- Since we know the expression is not-static (we already
-- tested for this, must mean array is not static).
else
Error_Msg_N
- ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N));
+ ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
end if;
return;
then
Error_Msg_N
("attribute of generic type is never static " &
- "('R'M 4.9(7,8))!", N);
+ "(RM 4.9(7,8))!", N);
elsif Is_Static_Subtype (E) then
null;
elsif Is_Scalar_Type (E) then
Error_Msg_N
("prefix type for attribute is not static scalar subtype " &
- "('R'M 4.9(7))!", N);
+ "(RM 4.9(7))!", N);
else
Error_Msg_N
("static attribute must apply to array/scalar type " &
- "('R'M 4.9(7,8))!", N);
+ "(RM 4.9(7,8))!", N);
end if;
when N_String_Literal =>
Error_Msg_N
- ("subtype of string literal is non-static ('R'M 4.9(4))!", N);
+ ("subtype of string literal is non-static (RM 4.9(4))!", N);
when N_Explicit_Dereference =>
Error_Msg_N
- ("explicit dereference is never static ('R'M 4.9)!", N);
+ ("explicit dereference is never static (RM 4.9)!", N);
when N_Function_Call =>
Why_Not_Static_List (Parameter_Associations (N));
- Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N);
+ Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
when N_Parameter_Association =>
Why_Not_Static (Explicit_Actual_Parameter (N));
when N_Indexed_Component =>
Error_Msg_N
- ("indexed component is never static ('R'M 4.9)!", N);
+ ("indexed component is never static (RM 4.9)!", N);
when N_Procedure_Call_Statement =>
Error_Msg_N
- ("procedure call is never static ('R'M 4.9)!", N);
+ ("procedure call is never static (RM 4.9)!", N);
when N_Qualified_Expression =>
Why_Not_Static (Expression (N));
when N_Aggregate | N_Extension_Aggregate =>
Error_Msg_N
- ("an aggregate is never static ('R'M 4.9)!", N);
+ ("an aggregate is never static (RM 4.9)!", N);
when N_Range =>
Why_Not_Static (Low_Bound (N));
when N_Selected_Component =>
Error_Msg_N
- ("selected component is never static ('R'M 4.9)!", N);
+ ("selected component is never static (RM 4.9)!", N);
when N_Slice =>
Error_Msg_N
- ("slice is never static ('R'M 4.9)!", N);
+ ("slice is never static (RM 4.9)!", N);
when N_Type_Conversion =>
Why_Not_Static (Expression (N));
then
Error_Msg_N
("static conversion requires static scalar subtype result " &
- "('R'M 4.9(9))!", N);
+ "(RM 4.9(9))!", N);
end if;
when N_Unchecked_Type_Conversion =>
Error_Msg_N
- ("unchecked type conversion is never static ('R'M 4.9)!", N);
+ ("unchecked type conversion is never static (RM 4.9)!", N);
when others =>
null;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2007, 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- --
---------------------
procedure Add_Association
- (M : in out Map;
+ (M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
------------------------
procedure Update_Association
- (M : in out Map;
+ (M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2007, 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- --
-- Retrieve image of E under M, Empty if undefined
procedure Add_Association
- (M : in out Map;
+ (M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local);
-- Update M in place. On entry M (O_Id) must not be defined
procedure Update_Association
- (M : in out Map;
+ (M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local);
projects / platform / upstream / linaro-gcc.git / commitdiff