Skip to content

R
riscv-gcc-1
Commit b11e8d6f by Robert Dewar Committed by Arnaud Charlet
Options

s-intman-irix.adb, [...]: Minor reformatting 

2007-08-14  Robert Dewar  <dewar@adacore.com>

	* s-intman-irix.adb, s-osinte-irix.adb, s-osinte-irix.ads,
	s-proinf-irix-athread.ads, s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads,
	s-parame-hpux.ads, s-intman-dummy.adb, s-tasinf-solaris.adb,
	s-tasinf-solaris.ads, s-asthan-vms-alpha.adb, s-inmaop-vms.adb,
	s-intman-vms.adb, s-intman-vms.ads, s-osprim-mingw.adb,
	s-parame-vms-restrict.ads, s-parame-ae653.ads, s-intman-vxworks.ads,
	s-intman-vxworks.ads, s-intman-vxworks.adb, s-parame-vxworks.ads,
	s-tfsetr-vxworks.adb, s-interr.adb, s-interr.ads, a-tasatt.adb,
	exp_ch13.adb, s-htable.ads, s-imgboo.ads, s-imglli.ads, s-imgllu.ads,
	s-imguns.ads, g-eacodu.adb, par-ch12.adb, s-stache.ads, s-stausa.adb,
	s-poosiz.adb, s-parame.ads, s-mastop.ads, s-osinte-darwin.ads,
	a-chtgke.adb, s-asthan-vms-alpha.adb, s-parame-vms-alpha.ads,
	s-parame-vms-ia64.ads, s-parame-vxworks.adb, s-except.ads,
	g-altcon.adb: Minor reformatting

	ada-tree.h: Delete empty line.

	ali.ads: Minor reformatting
	Clarification of comments.
	Minor spelling correction

	* exp_dbug.adb: Add Warnings Off to suppress new warning

	* a-witeio.adb (Write): Add Warnings (Off) for unneeded IN OUT mode
	formal

	* a-strunb.adb (Set_Unbounded_String): Avoid memory leak by freeing old
	value

	* a-textio.adb (Write): Remove an unnecessary IN OUT mode from

	* a-textio.ads: Reorder the standard input/output/error declarations
	for consistency.

	* g-dirope.adb, g-dirope.ads: Change Dir to mode IN for Open call

	* par-ch2.adb: Recognize RM specially in errout
	Change 'R'M to RM in all error messages

	* scng.adb: Recognize RM specially in errout

	* sem.ads, sem.adb, exp_strm.adb, exp_ch5.ads, expander.adb: Rename
	N_Return node to be N_Simple_Return, to reflect Ada 2005 terminology.

	* s-direio.adb: Add missing routine header box.

	* sem_attr.ads: Add ??? comments

	* sem_eval.adb: Recognize RM specially in errout
	Change 'R'M to RM in all error messages

	* sem_maps.adb, sem_maps.ads: Remove some unnecessary IN OUT modes

	* s-tasinf.ads: Fix minor comment typo.

	* a-cihama.adb: Minor comment addition

	* a-ztexio.adb (Write): Add Warnings (Off) for unneeded IN OUT mode
	formal

	* s-tasinf-tru64.ads: Fix minor comment typo.

	* itypes.ads: Comment update.

	* ali-util.adb: Remove Generic_Separately_Compiled guard, not needed
	anymore.

	* argv.c: Added protection against null gnat_argv and gnat_envp.

	* bcheck.adb (Check_Consistency): Use correct markup character ({) in
	warning message when Tolerate_Consistency_Errors is True.

	* cstand.adb (Create_Standard): Do not call Init_Size_Alignment for
	Any_Id, as this subprogram is only applicable to *type* entities (it
	sets RM_Size). Instead initialize just Esize and Alignment.

From-SVN: r127440
parent 9410151a
Showing with 741 additions and 536 deletions
gcc/ada/a-chtgke.adb
......@@ -7,7 +7,7 @@
-- --
-- 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- --
......@@ -268,7 +268,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
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
......
gcc/ada/a-cihama.adb
......@@ -7,7 +7,7 @@
-- --
-- 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- --
......
gcc/ada/a-strunb.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -847,10 +847,12 @@ package body Ada.Strings.Unbounded is
(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;
-----------
......
gcc/ada/a-tasatt.adb
......@@ -126,23 +126,22 @@
-- 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
......@@ -156,38 +155,36 @@
-- 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
......@@ -211,15 +208,14 @@
-- 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;
......@@ -284,11 +280,11 @@ package body Ada.Task_Attributes is
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);
......@@ -342,8 +338,8 @@ package body Ada.Task_Attributes is
------------------------
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 --
......@@ -359,9 +355,9 @@ package body Ada.Task_Attributes is
-- 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;
......@@ -598,8 +594,7 @@ package body Ada.Task_Attributes is
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);
......@@ -652,7 +647,7 @@ package body Ada.Task_Attributes is
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.
......@@ -708,9 +703,9 @@ package body Ada.Task_Attributes is
-- 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);
......@@ -789,8 +784,7 @@ begin
-- Attribute goes into a node onto a linked list
else
-- Replace stub for finalization routine that is called at task
-- termination.
-- Replace stub for finalization routine called at task termination
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;
......
gcc/ada/a-textio.adb
......@@ -1810,6 +1810,9 @@ package body Ada.Text_IO is
(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
......@@ -1822,6 +1825,10 @@ package body Ada.Text_IO is
Siz : constant size_t := Item'Length;
-------------------------------
-- Has_Translated_Characters --
-------------------------------
function Has_Translated_Characters return Boolean is
begin
for K in Item'Range loop
......@@ -1833,7 +1840,10 @@ package body Ada.Text_IO is
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
......@@ -1853,7 +1863,6 @@ package body Ada.Text_IO is
-- with text mode if needed.
if Needs_Binary_Write then
if fflush (File.Stream) = -1 then
raise Device_Error;
end if;
......@@ -1869,7 +1878,6 @@ package body Ada.Text_IO is
-- we reset to text mode.
if Needs_Binary_Write then
if fflush (File.Stream) = -1 then
raise Device_Error;
end if;
......@@ -1887,6 +1895,7 @@ package body Ada.Text_IO is
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 --
......
gcc/ada/a-textio.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
......@@ -391,13 +391,13 @@ private
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;
......
gcc/ada/a-witeio.adb
......@@ -1806,6 +1806,9 @@ package body Ada.Wide_Text_IO is
(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
......
gcc/ada/a-ztexio.adb
......@@ -1807,6 +1807,9 @@ package body Ada.Wide_Wide_Text_IO is
(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
......
gcc/ada/ada-tree.h
......@@ -37,7 +37,6 @@ enum gnat_tree_code {
union lang_tree_node
GTY((desc ("0"),
chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)")))
{
union tree_node GTY((tag ("0"))) t;
};
......
gcc/ada/ali-util.adb
......@@ -26,7 +26,6 @@
with Debug; use Debug;
with Binderr; use Binderr;
with Lib; use Lib;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
......@@ -248,21 +247,17 @@ package body ALI.Util is
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;
end if;
-- Enter in ALIs table
......@@ -307,8 +302,6 @@ package body ALI.Util is
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.
......
gcc/ada/ali.ads
......@@ -261,16 +261,16 @@ package ALI is
-- 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
......@@ -278,20 +278,20 @@ package ALI is
-- 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)
......@@ -327,13 +327,13 @@ package ALI is
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
......
gcc/ada/argv.c
......@@ -6,7 +6,7 @@
* *
* 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- *
......@@ -79,12 +79,16 @@ __gnat_arg_count (void)
int
__gnat_len_arg (int arg_num)
{
if (gnat_argv != NULL)
return strlen (gnat_argv[arg_num]);
else
return 0;
}
void
__gnat_fill_arg (char *a, int i)
{
if (gnat_argv != NULL)
strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
}
......@@ -101,11 +105,15 @@ __gnat_env_count (void)
int
__gnat_len_env (int env_num)
{
if (gnat_envp != NULL)
return strlen (gnat_envp[env_num]);
else
return 0;
}
void
__gnat_fill_env (char *a, int i)
{
if (gnat_envp != NULL)
strncpy (a, gnat_envp[i], strlen (gnat_envp[i]));
}
gcc/ada/bcheck.adb
......@@ -202,7 +202,7 @@ package body Bcheck is
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)");
......
gcc/ada/cstand.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -948,7 +948,8 @@ package body CStand is
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;
......
gcc/ada/exp_ch13.adb
......@@ -86,6 +86,7 @@ package body Exp_Ch13 is
-- 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
-- of the type initialization procedure, it replaces an implicit
-- call to the init proc, and must be respected. Note that for
......
gcc/ada/exp_ch5.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,5 +37,5 @@ package Exp_Ch5 is
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;
gcc/ada/exp_dbug.adb
......@@ -673,7 +673,7 @@ package body Exp_Dbug is
-- 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)
......@@ -1331,6 +1331,9 @@ package body Exp_Dbug is
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
......
gcc/ada/exp_strm.adb
......@@ -219,7 +219,7 @@ package body Exp_Strm is
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 :=
......@@ -1158,7 +1158,7 @@ package body Exp_Strm is
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);
......
gcc/ada/expander.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -379,8 +379,8 @@ package body Expander is
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);
......
gcc/ada/g-altcon.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -78,7 +78,7 @@ package body GNAT.Altivec.Conversions is
-- 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);
......@@ -86,7 +86,7 @@ package body GNAT.Altivec.Conversions is
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);
......@@ -94,7 +94,7 @@ package body GNAT.Altivec.Conversions is
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);
......
gcc/ada/g-dirope.adb
......@@ -647,7 +647,7 @@ package body GNAT.Directory_Operations is
----------
procedure Read
(Dir : in out Dir_Type;
(Dir : Dir_Type;
Str : out String;
Last : out Natural)
is
......
gcc/ada/g-dirope.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -230,7 +230,7 @@ package GNAT.Directory_Operations is
-- 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
......
gcc/ada/g-eacodu.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is the default (Unix) version.
-- This is the default (Unix) version
separate (GNAT.Exception_Actions)
procedure Core_Dump (Occurrence : Exception_Occurrence) is
......
gcc/ada/itypes.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -74,6 +74,12 @@ package Itypes is
-- 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 --
......
gcc/ada/par-ch12.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -332,7 +332,7 @@ package body Ch12 is
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
......@@ -375,7 +375,7 @@ package body Ch12 is
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;
......
gcc/ada/par-ch2.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -177,7 +177,7 @@ package body Ch2 is
-- 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 --
......@@ -185,7 +185,7 @@ package body Ch2 is
-- 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.
-------------------------
......@@ -479,7 +479,7 @@ package body Ch2 is
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;
......
gcc/ada/s-asthan-vms-alpha.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha version.
-- This is the OpenVMS/Alpha version
with System; use System;
......@@ -205,7 +205,7 @@ package body System.AST_Handling is
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,
......@@ -241,7 +241,7 @@ package body System.AST_Handling is
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;
......@@ -583,7 +583,7 @@ package body System.AST_Handling is
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;
......
gcc/ada/s-direio.adb
......@@ -319,6 +319,10 @@ package body System.Direct_IO is
procedure Do_Write;
-- Do the actual write
--------------
-- Do_Write --
--------------
procedure Do_Write is
begin
FIO.Write_Buf (AP (File), Item, Size);
......
gcc/ada/s-except.ads
......@@ -42,7 +42,7 @@ package System.Exceptions is
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
......
gcc/ada/s-htable.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -54,7 +54,7 @@ package System.HTable is
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
......@@ -120,7 +120,7 @@ package System.HTable is
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
......@@ -137,7 +137,7 @@ package System.HTable is
-- 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;
......
gcc/ada/s-imgboo.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,6 +37,6 @@ package System.Img_Bool is
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;
gcc/ada/s-imglli.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -39,7 +39,7 @@ package System.Img_LLI is
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;
......
gcc/ada/s-imgllu.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -43,7 +43,7 @@ package System.Img_LLU is
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;
......
gcc/ada/s-imguns.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -43,7 +43,7 @@ package System.Img_Uns is
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;
......
gcc/ada/s-inmaop-vms.adb
......@@ -283,6 +283,8 @@ package body System.Interrupt_Management.Operations is
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;
......
gcc/ada/s-interr.adb
......@@ -257,7 +257,7 @@ package body System.Interrupts is
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 --
......@@ -920,7 +920,7 @@ package body System.Interrupts is
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;
......@@ -1267,18 +1267,18 @@ package body System.Interrupts is
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
......@@ -1287,7 +1287,7 @@ package body System.Interrupts is
-- 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);
......@@ -1361,7 +1361,7 @@ package body System.Interrupts is
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);
......@@ -1397,7 +1397,7 @@ package body System.Interrupts is
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);
......@@ -1417,7 +1417,7 @@ package body System.Interrupts is
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;
......@@ -1470,7 +1470,7 @@ package body System.Interrupts is
-- 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);
......
gcc/ada/s-interr.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -134,7 +134,7 @@ package System.Interrupts is
-- 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 --
......@@ -157,7 +157,7 @@ package System.Interrupts is
-- 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 ???
......
gcc/ada/s-intman-dummy.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is a NO tasking version of this package.
-- This is a NO tasking version of this package
package body System.Interrupt_Management is
......
gcc/ada/s-intman-irix.adb
......@@ -6,8 +6,7 @@
-- --
-- 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- --
......@@ -32,13 +31,11 @@
-- --
------------------------------------------------------------------------------
-- 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
......
gcc/ada/s-intman-vms.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/Alpha version of this package.
-- This is a OpenVMS/Alpha version of this package
package body System.Interrupt_Management is
......
gcc/ada/s-intman-vms.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -67,11 +67,9 @@ package System.Interrupt_Management is
-- 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
......
gcc/ada/s-intman-vxworks.adb
......@@ -31,13 +31,11 @@
-- --
------------------------------------------------------------------------------
-- 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
......@@ -62,9 +60,8 @@ 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';
......
gcc/ada/s-intman-vxworks.ads
......@@ -78,9 +78,7 @@ package System.Interrupt_Management is
-- 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;
......
gcc/ada/s-mastop.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -88,8 +88,17 @@ package System.Machine_State_Operations is
-- 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
......
gcc/ada/s-osinte-darwin.ads
......@@ -7,7 +7,7 @@
-- 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- --
......@@ -32,14 +32,13 @@
-- --
------------------------------------------------------------------------------
-- 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
......@@ -174,7 +173,7 @@ package System.OS_Interface is
----------
Time_Slice_Supported : constant Boolean := True;
-- Indicates wether time slicing is supported.
-- Indicates wether time slicing is supported
type timespec is private;
......@@ -210,7 +209,7 @@ package System.OS_Interface is
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 --
......
gcc/ada/s-osinte-hpux-dce.adb
......@@ -7,7 +7,7 @@
-- 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- --
......@@ -126,7 +126,7 @@ package body System.OS_Interface is
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);
......
gcc/ada/s-osinte-hpux-dce.ads
......@@ -291,9 +291,8 @@ package System.OS_Interface is
(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");
--------------------------
......@@ -302,7 +301,7 @@ package System.OS_Interface is
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;
......
gcc/ada/s-osinte-irix.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,14 +31,14 @@
-- --
------------------------------------------------------------------------------
-- 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;
......
gcc/ada/s-osinte-irix.ads
......@@ -119,7 +119,7 @@ package System.OS_Interface is
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
......
gcc/ada/s-osprim-mingw.adb
......@@ -99,7 +99,7 @@ package body System.OS_Primitives is
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;
......@@ -160,8 +160,8 @@ package body System.OS_Primitives is
-- 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;
......@@ -180,7 +180,7 @@ package body System.OS_Primitives is
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
......
gcc/ada/s-parame-ae653.ads
......@@ -193,7 +193,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame-hpux.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -191,7 +191,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame-vms-alpha.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -191,7 +191,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame-vms-ia64.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -191,7 +191,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame-vms-restrict.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -191,7 +191,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame-vxworks.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-- Version used on all VxWorks targets.
-- Version used on all VxWorks targets
package body System.Parameters is
......
gcc/ada/s-parame-vxworks.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -193,7 +193,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-parame.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -191,7 +191,7 @@ package System.Parameters is
-----------------------
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 --
......
gcc/ada/s-poosiz.adb
......@@ -40,12 +40,11 @@ package body System.Pool_Size is
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;
......@@ -58,9 +57,9 @@ package body System.Pool_Size is
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.
......
gcc/ada/s-proinf-irix-athread.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,20 +31,19 @@
-- --
------------------------------------------------------------------------------
-- 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.
......@@ -56,9 +55,9 @@ package System.Program_Info is
-- 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
......
gcc/ada/s-stache.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -73,7 +73,7 @@ private
(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
......
gcc/ada/s-stausa.adb
......@@ -353,6 +353,7 @@ package body System.Stack_Usage is
Task_Name_Blanks :
constant String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
(others => ' ');
begin
Set_Output (Standard_Error);
......@@ -362,6 +363,7 @@ package body System.Stack_Usage is
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.
......
gcc/ada/s-tasinf-solaris.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -34,14 +34,13 @@
-- 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
......@@ -54,10 +53,9 @@ package body System.Task_Info is
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
......@@ -70,4 +68,22 @@ package body System.Task_Info is
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;
gcc/ada/s-tasinf-solaris.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -41,7 +41,7 @@
-- 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;
......@@ -84,7 +84,7 @@ package System.Task_Info is
-- 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.
......
gcc/ada/s-tasinf-tru64.ads
......@@ -7,7 +7,7 @@
-- 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- --
......@@ -42,7 +42,7 @@
-- 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;
......@@ -64,7 +64,7 @@ package System.Task_Info is
-- 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.
......
gcc/ada/s-tasinf.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -61,7 +61,7 @@ package System.Task_Info is
-- 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.
......
gcc/ada/s-tfsetr-vxworks.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -31,11 +31,11 @@
-- --
------------------------------------------------------------------------------
-- 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.
......
gcc/ada/scng.adb
......@@ -571,7 +571,7 @@ package body Scng is
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;
......@@ -1178,7 +1178,10 @@ package body Scng is
-- 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
......@@ -1187,7 +1190,11 @@ package body Scng 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
......@@ -1237,7 +1244,11 @@ package body Scng is
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) = '-'
......@@ -1251,7 +1262,11 @@ package body Scng is
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;
......@@ -1261,7 +1276,11 @@ package body Scng is
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
......@@ -1291,7 +1310,11 @@ package body Scng is
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
......@@ -1303,7 +1326,11 @@ package body Scng is
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
......@@ -1324,7 +1351,11 @@ package body Scng is
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
......@@ -1369,7 +1400,11 @@ package body Scng is
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
......@@ -1401,7 +1436,10 @@ package body Scng is
-- 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,
......@@ -1447,7 +1485,10 @@ package body Scng is
-- 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
......@@ -1538,7 +1579,7 @@ package body Scng is
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;
......@@ -1581,7 +1622,11 @@ package body Scng is
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
......@@ -1686,7 +1731,11 @@ package body Scng is
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
......@@ -1717,7 +1766,11 @@ package body Scng is
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
......@@ -1736,7 +1789,11 @@ package body Scng is
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;
......@@ -1749,7 +1806,7 @@ package body Scng is
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;
......@@ -2321,10 +2378,14 @@ package body Scng is
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.
-- 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"
......@@ -2332,8 +2393,7 @@ package body Scng is
-- Ada 2005 (AI-340): Do not apply the style check in case of
-- MOD attribute.
if Style_Check
and then Source (Token_Ptr) <= 'Z'
if Source (Token_Ptr) <= 'Z'
and then (Prev_Token /= Tok_Apostrophe
or else
(Token /= Tok_Access and then
......@@ -2349,6 +2409,14 @@ package body Scng is
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
-- if we leave Token_Name set, the parser gets confused because
-- it thinks it is dealing with an identifier instead of the
......@@ -2470,7 +2538,10 @@ package body Scng is
-- 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
......
gcc/ada/sem.adb
......@@ -53,6 +53,8 @@ with Sinfo; use Sinfo;
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)
......@@ -448,8 +450,8 @@ package body Sem is
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);
......@@ -724,65 +726,73 @@ package body Sem is
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));
if Found then
return;
end if;
end if;
end;
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
-- 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;
-------------------------
......@@ -812,29 +822,26 @@ package body Sem is
-----------------------
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)
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 R.Suppress;
return Ptr.Suppress;
end if;
end;
Ptr := Ptr.Prev;
end loop;
end if;
return False;
end if;
end Explicit_Suppress;
-----------------------------
......@@ -880,9 +887,26 @@ package body Sem is
----------------
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;
......@@ -1136,53 +1160,52 @@ package body Sem is
-------------------------
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)
-- 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 R.Suppress;
return Ptr.Suppress;
end if;
end;
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);
begin
if R.Entity = E
and then (R.Check = All_Checks or else R.Check = C)
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 R.Suppress;
return Ptr.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.
if C in Predefined_Check_Id then
return Scope_Suppress (C);
else
return Scope_Suppress (All_Checks);
end if;
end Is_Check_Suppressed;
----------
......@@ -1191,14 +1214,54 @@ package body Sem is
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 --
---------------
......
gcc/ada/sem.ads
......@@ -211,26 +211,27 @@ package Sem is
-----------------------------
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
......@@ -259,6 +260,121 @@ package Sem is
-- 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 --
......@@ -324,8 +440,8 @@ package Sem is
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)
......@@ -383,92 +499,6 @@ package Sem is
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 --
-----------------
......
gcc/ada/sem_eval.adb
......@@ -1501,7 +1501,7 @@ package body Sem_Eval is
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;
......@@ -2732,7 +2732,7 @@ package body Sem_Eval is
-- 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;
......@@ -4450,7 +4450,7 @@ package body Sem_Eval is
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;
......@@ -4469,7 +4469,7 @@ package body Sem_Eval is
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;
......@@ -4486,19 +4486,19 @@ package body Sem_Eval is
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));
......@@ -4522,7 +4522,7 @@ package body Sem_Eval is
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
......@@ -4535,14 +4535,14 @@ package body Sem_Eval is
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;
......@@ -4556,7 +4556,7 @@ package body Sem_Eval is
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;
......@@ -4564,43 +4564,43 @@ package body Sem_Eval is
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));
......@@ -4614,11 +4614,11 @@ package body Sem_Eval is
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));
......@@ -4628,12 +4628,12 @@ package body Sem_Eval is
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;
......
gcc/ada/sem_maps.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -55,7 +55,7 @@ package body Sem_Maps is
---------------------
procedure Add_Association
(M : in out Map;
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
......@@ -318,7 +318,7 @@ package body Sem_Maps is
------------------------
procedure Update_Association
(M : in out Map;
(M : Map;
O_Id : Entity_Id;
N_Id : Entity_Id;
Kind : Scope_Kind := S_Local)
......
gcc/ada/sem_maps.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -64,14 +64,14 @@ package Sem_Maps is
-- 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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment