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 786 additions and 581 deletions
gcc/ada/a-chtgke.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -268,7 +268,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is
return; return;
end if; 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 if HT.Busy > 0 then
raise Program_Error with raise Program_Error with
......
gcc/ada/a-cihama.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
......
gcc/ada/a-strunb.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -847,10 +847,12 @@ package body Ada.Strings.Unbounded is ...@@ -847,10 +847,12 @@ package body Ada.Strings.Unbounded is
(Target : out Unbounded_String; (Target : out Unbounded_String;
Source : String) Source : String)
is is
Old : String_Access := Target.Reference;
begin begin
Target.Last := Source'Length; Target.Last := Source'Length;
Target.Reference := new String (1 .. Source'Length); Target.Reference := new String (1 .. Source'Length);
Target.Reference.all := Source; Target.Reference.all := Source;
Free (Old);
end Set_Unbounded_String; end Set_Unbounded_String;
----------- -----------
......
gcc/ada/a-tasatt.adb
...@@ -126,23 +126,22 @@ ...@@ -126,23 +126,22 @@
-- might result in dangling references. -- might result in dangling references.
-- Another problem with instantiations deeper than the library level is that -- Another problem with instantiations deeper than the library level is that
-- there is risk of storage leakage, or dangling references to reused -- there is risk of storage leakage, or dangling references to reused storage.
-- storage. That is, if an instantiation of Ada.Task_Attributes is made -- That is, if an instantiation of Ada.Task_Attributes is made within a
-- within a procedure, what happens to the storage allocated for attributes, -- procedure, what happens to the storage allocated for attributes, when the
-- when the procedure call returns? Apparently (RM 7.6.1 (4)) any such -- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be
-- objects must be finalized, since they will no longer be accessible, and in -- finalized, since they will no longer be accessible, and in general one
-- general one would expect that the storage they occupy would be recovered -- would expect that the storage they occupy would be recovered for later
-- for later reuse. (If not, we would have a case of storage leakage.) -- reuse. (If not, we would have a case of storage leakage.) Assuming the
-- Assuming the storage is recovered and later reused, we have potentially -- storage is recovered and later reused, we have potentially dangerous
-- dangerous dangling references. When the procedure containing the -- dangling references. When the procedure containing the instantiation of
-- instantiation of Ada.Task_Attributes returns, there may still be -- Ada.Task_Attributes returns, there may still be unterminated tasks with
-- unterminated tasks with associated attribute values for that instantiation. -- associated attribute values for that instantiation. When such tasks
-- When such tasks eventually terminate, the RTS will attempt to call the -- eventually terminate, the RTS will attempt to call the Deallocate procedure
-- Deallocate procedure on them. If the corresponding storage has already -- on them. If the corresponding storage has already been deallocated, when
-- been deallocated, when the master of the access type was left, we have a -- the master of the access type was left, we have a potential disaster. This
-- potential disaster. This disaster is compounded since the pointer to -- disaster is compounded since the pointer to Deallocate is probably through
-- Deallocate is probably through a "trampoline" which will also have been -- a "trampoline" which will also have been destroyed.
-- destroyed.
-- For this reason, we arrange to remove all dangling references before -- For this reason, we arrange to remove all dangling references before
-- leaving the scope of an instantiation. This is ugly, since it requires -- leaving the scope of an instantiation. This is ugly, since it requires
...@@ -156,38 +155,36 @@ ...@@ -156,38 +155,36 @@
-- the default initial one. This allows a potential savings in allocation, -- the default initial one. This allows a potential savings in allocation,
-- for attributes that are not used by all tasks. -- for attributes that are not used by all tasks.
-- For efficiency, we reserve space in the TCB for a fixed number of -- For efficiency, we reserve space in the TCB for a fixed number of direct-
-- direct-access attributes. These are required to be of a size that fits in -- access attributes. These are required to be of a size that fits in the
-- the space of an object of type System.Address. Because we must use -- space of an object of type System.Address. Because we must use unchecked
-- unchecked bitwise copy operations on these values, they cannot be of a -- bitwise copy operations on these values, they cannot be of a controlled
-- controlled type, but that is covered automatically since controlled -- type, but that is covered automatically since controlled objects are too
-- objects are too large to fit in the spaces. -- large to fit in the spaces.
-- We originally deferred the initialization of these direct-access -- We originally deferred initialization of these direct-access attributes,
-- attributes, just as we do for the indirect-access attributes, and used a -- just as we do for the indirect-access attributes, and used a per-task bit
-- per-task bit vector to keep track of which attributes were currently -- vector to keep track of which attributes were currently defined for that
-- defined for that task. We found that the overhead of maintaining this -- task. We found that the overhead of maintaining this bit-vector seriously
-- bit-vector seriously slowed down access to the attributes, and made the -- slowed down access to the attributes, and made the fetch operation non-
-- fetch operation non-atomic, so that even to read an attribute value -- atomic, so that even to read an attribute value required locking the TCB.
-- required locking the TCB. Therefore, we now initialize such attributes for -- Therefore, we now initialize such attributes for all existing tasks at the
-- all existing tasks at the time of the attribute instantiation, and -- time of the attribute instantiation, and initialize existing attributes for
-- initialize existing attributes for each new task at the time it is -- each new task at the time it is created.
-- created.
-- The latter initialization requires a list of all the instantiation -- The latter initialization requires a list of all the instantiation
-- descriptors. Updates to this list, as well as the bit-vector that is used -- 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 -- to reserve slots for attributes in the TCB, require mutual exclusion. That
-- is provided by the Lock/Unlock_RTS. -- is provided by the Lock/Unlock_RTS.
-- One special problem that added complexity to the design is that the -- One special problem that added complexity to the design is that the per-
-- per-task list of indirect attributes contains objects of different types. -- task list of indirect attributes contains objects of different types. We
-- We use unchecked pointer conversion to link these nodes together and -- use unchecked pointer conversion to link these nodes together and access
-- access them, but the records may not have identical internal structure. -- them, but the records may not have identical internal structure. Initially,
-- Initially, we thought it would be enough to allocate all the common -- we thought it would be enough to allocate all the common components of
-- components of the records at the front of each record, so that their -- the records at the front of each record, so that their positions would
-- positions would correspond. Unfortunately, GNAT adds "dope" information at -- correspond. Unfortunately, GNAT adds "dope" information at the front
-- the front of a record, if the record contains any controlled-type -- of a record, if the record contains any controlled-type components.
-- components.
-- --
-- This means that the offset of the fields we use to link the nodes is at -- 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 -- different positions on nodes of different types. To get around this, each
...@@ -211,15 +208,14 @@ ...@@ -211,15 +208,14 @@
-- Value : aliased Attribute; -- the generic formal type -- Value : aliased Attribute; -- the generic formal type
-- end record; -- end record;
-- Another interesting problem is with the initialization of the -- Another interesting problem is with the initialization of the instantiation
-- instantiation descriptors. Originally, we did this all via the Initialize -- descriptors. Originally, we did this all via the Initialize procedure of
-- procedure of the descriptor type and code in the package body. It turned -- the descriptor type and code in the package body. It turned out that the
-- out that the Initialize procedure needed quite a bit of information, -- Initialize procedure needed quite a bit of information, including the size
-- including the size of the attribute type, the initial value of the -- of the attribute type, the initial value of the attribute (if it fits in
-- attribute (if it fits in the TCB), and a pointer to the deallocator -- the TCB), and a pointer to the deallocator procedure. These needed to be
-- procedure. These needed to be "passed" in via access discriminants. GNAT -- "passed" in via access discriminants. GNAT was having trouble with access
-- was having trouble with access discriminants, so all this work was moved -- discriminants, so all this work was moved to the package body.
-- to the package body.
with System.Error_Reporting; with System.Error_Reporting;
-- Used for Shutdown; -- Used for Shutdown;
...@@ -284,11 +280,11 @@ package body Ada.Task_Attributes is ...@@ -284,11 +280,11 @@ package body Ada.Task_Attributes is
type Access_Wrapper is access all Wrapper; type Access_Wrapper is access all Wrapper;
pragma Warnings (Off); pragma Warnings (Off);
-- We turn warnings off for the following declarations of the -- We turn warnings off for the following To_Attribute_Handle conversions,
-- To_Attribute_Handle conversions, since these are used only for small -- since these are used only for small attributes where we know that there
-- attributes where we know that there are no problems with alignment, but -- are no problems with alignment, but the compiler will generate warnings
-- the compiler will generate warnings for the occurrences in the large -- for the occurrences in the large attribute case, even though they will
-- attribute case, even though they will not actually be used. -- not actually be used.
function To_Attribute_Handle is new Ada.Unchecked_Conversion function To_Attribute_Handle is new Ada.Unchecked_Conversion
(System.Address, Attribute_Handle); (System.Address, Attribute_Handle);
...@@ -342,8 +338,8 @@ package body Ada.Task_Attributes is ...@@ -342,8 +338,8 @@ package body Ada.Task_Attributes is
------------------------ ------------------------
procedure Deallocate (P : in out Access_Node); procedure Deallocate (P : in out Access_Node);
-- Passed to the RTS via unchecked conversion of a pointer to -- Passed to the RTS via unchecked conversion of a pointer to permit
-- permit finalization and deallocation of attribute storage nodes -- finalization and deallocation of attribute storage nodes.
-------------------------- --------------------------
-- Instantiation Record -- -- Instantiation Record --
...@@ -359,9 +355,9 @@ package body Ada.Task_Attributes is ...@@ -359,9 +355,9 @@ package body Ada.Task_Attributes is
-- The generic formal type, may be controlled -- The generic formal type, may be controlled
end record; end record;
-- A number of unchecked conversions involving Wrapper_Access sources -- A number of unchecked conversions involving Wrapper_Access sources are
-- are performed in this unit. We have to ensure that the designated -- performed in this unit. We have to ensure that the designated object is
-- object is always strictly enough aligned. -- always strictly enough aligned.
for Wrapper'Alignment use Standard'Maximum_Alignment; for Wrapper'Alignment use Standard'Maximum_Alignment;
...@@ -598,8 +594,7 @@ package body Ada.Task_Attributes is ...@@ -598,8 +594,7 @@ package body Ada.Task_Attributes is
end loop; end loop;
-- Unlock RTS here to follow the lock ordering rule that prevent us -- Unlock RTS here to follow the lock ordering rule that prevent us
-- from using new (i.e the Global_Lock) while holding any other -- from using new (i.e the Global_Lock) while holding any other lock.
-- lock.
POP.Unlock_RTS; POP.Unlock_RTS;
W := new Wrapper'((null, Local'Unchecked_Access, null), Val); W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
...@@ -652,7 +647,7 @@ package body Ada.Task_Attributes is ...@@ -652,7 +647,7 @@ package body Ada.Task_Attributes is
if Local.Index /= 0 then 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 -- attributes, this code can generate alignment warnings. But of
-- course large attributes are never directly addressed so in fact -- course large attributes are never directly addressed so in fact
-- we will never execute the code in this case. -- we will never execute the code in this case.
...@@ -708,9 +703,9 @@ package body Ada.Task_Attributes is ...@@ -708,9 +703,9 @@ package body Ada.Task_Attributes is
-- Start of elaboration code for package Ada.Task_Attributes -- Start of elaboration code for package Ada.Task_Attributes
begin begin
-- This unchecked conversion can give warnings when alignments -- This unchecked conversion can give warnings when alignments are
-- are incorrect, but they will not be used in such cases anyway, -- incorrect, but they will not be used in such cases anyway, so the
-- so the warnings can be safely ignored. -- warnings can be safely ignored.
pragma Warnings (Off); pragma Warnings (Off);
Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access); Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
...@@ -789,8 +784,7 @@ begin ...@@ -789,8 +784,7 @@ begin
-- Attribute goes into a node onto a linked list -- Attribute goes into a node onto a linked list
else else
-- Replace stub for finalization routine that is called at task -- Replace stub for finalization routine called at task termination
-- termination.
Initialization.Finalize_Attributes_Link := Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access; System.Tasking.Task_Attributes.Finalize_Attributes'Access;
......
gcc/ada/a-textio.adb
...@@ -1810,6 +1810,9 @@ package body Ada.Text_IO is ...@@ -1810,6 +1810,9 @@ package body Ada.Text_IO is
(File : in out Text_AFCB; (File : in out Text_AFCB;
Item : Stream_Element_Array) Item : Stream_Element_Array)
is is
pragma Warnings (Off, File);
-- Because in this implementation we don't need IN OUT, we only read
function Has_Translated_Characters return Boolean; function Has_Translated_Characters return Boolean;
-- return True if Item array contains a character which will be -- return True if Item array contains a character which will be
-- translated under the text file mode. There is only one such -- translated under the text file mode. There is only one such
...@@ -1822,6 +1825,10 @@ package body Ada.Text_IO is ...@@ -1822,6 +1825,10 @@ package body Ada.Text_IO is
Siz : constant size_t := Item'Length; Siz : constant size_t := Item'Length;
-------------------------------
-- Has_Translated_Characters --
-------------------------------
function Has_Translated_Characters return Boolean is function Has_Translated_Characters return Boolean is
begin begin
for K in Item'Range loop for K in Item'Range loop
...@@ -1833,7 +1840,10 @@ package body Ada.Text_IO is ...@@ -1833,7 +1840,10 @@ package body Ada.Text_IO is
end Has_Translated_Characters; end Has_Translated_Characters;
Needs_Binary_Write : constant Boolean := 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 begin
if File.Mode = FCB.In_File then if File.Mode = FCB.In_File then
...@@ -1853,7 +1863,6 @@ package body Ada.Text_IO is ...@@ -1853,7 +1863,6 @@ package body Ada.Text_IO is
-- with text mode if needed. -- with text mode if needed.
if Needs_Binary_Write then if Needs_Binary_Write then
if fflush (File.Stream) = -1 then if fflush (File.Stream) = -1 then
raise Device_Error; raise Device_Error;
end if; end if;
...@@ -1869,7 +1878,6 @@ package body Ada.Text_IO is ...@@ -1869,7 +1878,6 @@ package body Ada.Text_IO is
-- we reset to text mode. -- we reset to text mode.
if Needs_Binary_Write then if Needs_Binary_Write then
if fflush (File.Stream) = -1 then if fflush (File.Stream) = -1 then
raise Device_Error; raise Device_Error;
end if; end if;
...@@ -1887,6 +1895,7 @@ package body Ada.Text_IO is ...@@ -1887,6 +1895,7 @@ package body Ada.Text_IO is
Err_Name : aliased String := "*stderr" & ASCII.Nul; Err_Name : aliased String := "*stderr" & ASCII.Nul;
In_Name : aliased String := "*stdin" & ASCII.Nul; In_Name : aliased String := "*stdin" & ASCII.Nul;
Out_Name : aliased String := "*stdout" & ASCII.Nul; Out_Name : aliased String := "*stdout" & ASCII.Nul;
begin begin
------------------------------- -------------------------------
-- Initialize Standard Files -- -- Initialize Standard Files --
......
gcc/ada/a-textio.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -391,13 +391,13 @@ private ...@@ -391,13 +391,13 @@ private
Null_Str : aliased constant String := ""; Null_Str : aliased constant String := "";
-- Used as name and form of standard files -- Used as name and form of standard files
Standard_Err_AFCB : aliased Text_AFCB;
Standard_In_AFCB : aliased Text_AFCB; Standard_In_AFCB : aliased Text_AFCB;
Standard_Out_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_In : aliased File_Type := Standard_In_AFCB'Access;
Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; Standard_Out : aliased File_Type := Standard_Out_AFCB'Access;
Standard_Err : aliased File_Type := Standard_Err_AFCB'Access;
-- Standard files -- Standard files
Current_In : aliased File_Type := Standard_In; Current_In : aliased File_Type := Standard_In;
......
gcc/ada/a-witeio.adb
...@@ -1806,6 +1806,9 @@ package body Ada.Wide_Text_IO is ...@@ -1806,6 +1806,9 @@ package body Ada.Wide_Text_IO is
(File : in out Wide_Text_AFCB; (File : in out Wide_Text_AFCB;
Item : Stream_Element_Array) Item : Stream_Element_Array)
is is
pragma Warnings (Off, File);
-- Because in this implementation we don't need IN OUT, we only read
Siz : constant size_t := Item'Length; Siz : constant size_t := Item'Length;
begin begin
......
gcc/ada/a-ztexio.adb
...@@ -1807,6 +1807,9 @@ package body Ada.Wide_Wide_Text_IO is ...@@ -1807,6 +1807,9 @@ package body Ada.Wide_Wide_Text_IO is
(File : in out Wide_Wide_Text_AFCB; (File : in out Wide_Wide_Text_AFCB;
Item : Stream_Element_Array) Item : Stream_Element_Array)
is is
pragma Warnings (Off, File);
-- Because in this implementation we don't need IN OUT, we only read
Siz : constant size_t := Item'Length; Siz : constant size_t := Item'Length;
begin begin
......
gcc/ada/ada-tree.h
...@@ -37,7 +37,6 @@ enum gnat_tree_code { ...@@ -37,7 +37,6 @@ enum gnat_tree_code {
union lang_tree_node union lang_tree_node
GTY((desc ("0"), GTY((desc ("0"),
chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)"))) chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)")))
{ {
union tree_node GTY((tag ("0"))) t; union tree_node GTY((tag ("0"))) t;
}; };
......
gcc/ada/ali-util.adb
...@@ -26,7 +26,6 @@ ...@@ -26,7 +26,6 @@
with Debug; use Debug; with Debug; use Debug;
with Binderr; use Binderr; with Binderr; use Binderr;
with Lib; use Lib;
with Opt; use Opt; with Opt; use Opt;
with Output; use Output; with Output; use Output;
with Osint; use Osint; with Osint; use Osint;
...@@ -248,21 +247,17 @@ package body ALI.Util is ...@@ -248,21 +247,17 @@ package body ALI.Util is
then then
Text := Read_Library_Info (Afile); Text := Read_Library_Info (Afile);
-- Return with an error if source cannot be found and if this -- Return with an error if source cannot be found. We used to
-- is not a library generic (now we can, but does not have to -- skip this check when we did not compile library generics
-- compile library generics) -- separately, but we now always do, so there is no special
-- case here anymore.
if Text = null then if Text = null then
if Generic_Separately_Compiled (Withs.Table (W).Sfile) then Error_Msg_File_1 := Afile;
Error_Msg_File_1 := Afile; Error_Msg_File_2 := Withs.Table (W).Sfile;
Error_Msg_File_2 := Withs.Table (W).Sfile; Error_Msg ("{ not found, { must be compiled");
Error_Msg ("{ not found, { must be compiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id));
Set_Name_Table_Info (Afile, Int (No_Unit_Id)); return;
return;
else
goto Skip_Library_Generics;
end if;
end if; end if;
-- Enter in ALIs table -- Enter in ALIs table
...@@ -307,8 +302,6 @@ package body ALI.Util is ...@@ -307,8 +302,6 @@ package body ALI.Util is
Read_ALI (Idread); Read_ALI (Idread);
end if; end if;
<<Skip_Library_Generics>> null;
-- If the ALI file has already been processed and is an interface, -- If the ALI file has already been processed and is an interface,
-- set the flag in the entry of the Withs table. -- set the flag in the entry of the Withs table.
......
gcc/ada/ali.ads
...@@ -261,16 +261,16 @@ package ALI is ...@@ -261,16 +261,16 @@ package ALI is
-- have an elaboration routine (since it has no elaboration code). -- have an elaboration routine (since it has no elaboration code).
Pure : Boolean; 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; Dynamic_Elab : Boolean;
-- Set to True if the unit was compiled with dynamic elaboration -- Set to True if the unit was compiled with dynamic elaboration checks
-- checks (i.e. either -gnatE or pragma Elaboration_Checks (RM) -- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to
-- was used to compile the unit). -- compile the unit).
Elaborate_Body : Boolean; Elaborate_Body : Boolean;
-- Indicates presence of EB parameter for a package which has a -- Indicates presence of EB parameter for a package which has a pragma
-- pragma Preelaborate_Body. -- Elaborate_Body, and also for generic package instantiations.
Set_Elab_Entity : Boolean; Set_Elab_Entity : Boolean;
-- Indicates presence of EE parameter for a unit which has an -- Indicates presence of EE parameter for a unit which has an
...@@ -278,20 +278,20 @@ package ALI is ...@@ -278,20 +278,20 @@ package ALI is
-- elaboration of the entity. -- elaboration of the entity.
Has_RACW : Boolean; Has_RACW : Boolean;
-- Indicates presence of RA parameter for a package that declares -- Indicates presence of RA parameter for a package that declares at
-- at least one Remote Access to Class_Wide (RACW) object. -- least one Remote Access to Class_Wide (RACW) object.
Remote_Types : Boolean; Remote_Types : Boolean;
-- Indicates presence of RT parameter for a package which has a -- Indicates presence of RT parameter for a package which has a
-- pragma Remote_Types. -- pragma Remote_Types.
Shared_Passive : Boolean; Shared_Passive : Boolean;
-- Indicates presence of SP parameter for a package which has a -- Indicates presence of SP parameter for a package which has a pragma
-- pragma Shared_Passive. -- Shared_Passive.
RCI : Boolean; RCI : Boolean;
-- Indicates presence of RC parameter for a package which has a -- Indicates presence of RC parameter for a package which has a pragma
-- pragma Remote_Call_Interface. -- Remote_Call_Interface.
Predefined : Boolean; Predefined : Boolean;
-- Indicates if unit is language predefined (or a child of such a unit) -- Indicates if unit is language predefined (or a child of such a unit)
...@@ -327,13 +327,13 @@ package ALI is ...@@ -327,13 +327,13 @@ package ALI is
Icasing : Casing_Type; Icasing : Casing_Type;
-- Indicates casing of identifiers in source file for this unit. This -- Indicates casing of identifiers in source file for this unit. This
-- is used for informational output, and also for constructing the -- is used for informational output, and also for constructing the main
-- main unit if it is being built in Ada. -- unit if it is being built in Ada.
Kcasing : Casing_Type; Kcasing : Casing_Type;
-- Indicates casing of keyowords in source file for this unit. This -- Indicates casing of keywords in source file for this unit. This is
-- is used for informational output, and also for constructing the -- used for informational output, and also for constructing the main
-- main unit if it is being built in Ada. -- unit if it is being built in Ada.
Elab_Position : aliased Natural; Elab_Position : aliased Natural;
-- Initialized to zero. Set non-zero when a unit is chosen and -- Initialized to zero. Set non-zero when a unit is chosen and
......
gcc/ada/argv.c
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -79,13 +79,17 @@ __gnat_arg_count (void) ...@@ -79,13 +79,17 @@ __gnat_arg_count (void)
int int
__gnat_len_arg (int arg_num) __gnat_len_arg (int arg_num)
{ {
return strlen (gnat_argv[arg_num]); if (gnat_argv != NULL)
return strlen (gnat_argv[arg_num]);
else
return 0;
} }
void void
__gnat_fill_arg (char *a, int i) __gnat_fill_arg (char *a, int i)
{ {
strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); if (gnat_argv != NULL)
strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
} }
int int
...@@ -101,11 +105,15 @@ __gnat_env_count (void) ...@@ -101,11 +105,15 @@ __gnat_env_count (void)
int int
__gnat_len_env (int env_num) __gnat_len_env (int env_num)
{ {
return strlen (gnat_envp[env_num]); if (gnat_envp != NULL)
return strlen (gnat_envp[env_num]);
else
return 0;
} }
void void
__gnat_fill_env (char *a, int i) __gnat_fill_env (char *a, int i)
{ {
strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); if (gnat_envp != NULL)
strncpy (a, gnat_envp[i], strlen (gnat_envp[i]));
} }
gcc/ada/bcheck.adb
...@@ -202,7 +202,7 @@ package body Bcheck is ...@@ -202,7 +202,7 @@ package body Bcheck is
elsif Tolerate_Consistency_Errors then elsif Tolerate_Consistency_Errors then
Error_Msg Error_Msg
("?% should be recompiled (% has been modified)"); ("?{ should be recompiled ({ has been modified)");
else else
Error_Msg ("{ must be recompiled ({ has been modified)"); Error_Msg ("{ must be recompiled ({ has been modified)");
......
gcc/ada/cstand.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -948,7 +948,8 @@ package body CStand is ...@@ -948,7 +948,8 @@ package body CStand is
Set_Ekind (Any_Id, E_Variable); Set_Ekind (Any_Id, E_Variable);
Set_Scope (Any_Id, Standard_Standard); Set_Scope (Any_Id, Standard_Standard);
Set_Etype (Any_Id, Any_Type); 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"); Make_Name (Any_Id, "any id");
Any_Access := New_Standard_Entity; Any_Access := New_Standard_Entity;
......
gcc/ada/exp_ch13.adb
...@@ -86,7 +86,8 @@ package body Exp_Ch13 is ...@@ -86,7 +86,8 @@ package body Exp_Ch13 is
-- original node is in the source. An exception though is the case -- original node is in the source. An exception though is the case
-- of an access variable which is default initialized to null, and -- of an access variable which is default initialized to null, and
-- such initialization is retained. -- such initialization is retained.
-- Furthermore, if the initialization is the equivalent aggregate
-- Furthermore, if the initialization is the equivalent aggregate
-- of the type initialization procedure, it replaces an implicit -- of the type initialization procedure, it replaces an implicit
-- call to the init proc, and must be respected. Note that for -- call to the init proc, and must be respected. Note that for
-- packed types we do not build equivalent aggregates. -- packed types we do not build equivalent aggregates.
......
gcc/ada/exp_ch5.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -37,5 +37,5 @@ package Exp_Ch5 is ...@@ -37,5 +37,5 @@ package Exp_Ch5 is
procedure Expand_N_Goto_Statement (N : Node_Id); procedure Expand_N_Goto_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id);
procedure Expand_N_Loop_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; end Exp_Ch5;
gcc/ada/exp_dbug.adb
...@@ -673,7 +673,7 @@ package body Exp_Dbug is ...@@ -673,7 +673,7 @@ package body Exp_Dbug is
-- If the front end has already computed a fully qualified name, -- If the front end has already computed a fully qualified name,
-- then it is also the case that no further qualification is -- then it is also the case that no further qualification is
-- required -- required.
if Present (Scope (Scope (Entity))) if Present (Scope (Scope (Entity)))
and then not Has_Fully_Qualified_Name (Entity) and then not Has_Fully_Qualified_Name (Entity)
...@@ -1331,6 +1331,9 @@ package body Exp_Dbug is ...@@ -1331,6 +1331,9 @@ package body Exp_Dbug is
procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is
SL : Natural; SL : Natural;
pragma Warnings (Off, BNPE_Suffix_Found);
-- Since this procedure only ever sets the flag
begin begin
-- Search for and strip BNPE suffix -- Search for and strip BNPE suffix
......
gcc/ada/exp_strm.adb
...@@ -219,7 +219,7 @@ package body Exp_Strm is ...@@ -219,7 +219,7 @@ package body Exp_Strm is
Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))), Make_Identifier (Loc, Name_V))),
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V))); Expression => Make_Identifier (Loc, Name_V)));
Fnam := Fnam :=
...@@ -1158,7 +1158,7 @@ package body Exp_Strm is ...@@ -1158,7 +1158,7 @@ package body Exp_Strm is
Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))), Make_Identifier (Loc, Name_V))),
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V))); Expression => Make_Identifier (Loc, Name_V)));
Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input); Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
......
gcc/ada/expander.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -379,8 +379,8 @@ package body Expander is ...@@ -379,8 +379,8 @@ package body Expander is
when N_Requeue_Statement => when N_Requeue_Statement =>
Expand_N_Requeue_Statement (N); Expand_N_Requeue_Statement (N);
when N_Return_Statement => when N_Simple_Return_Statement =>
Expand_N_Return_Statement (N); Expand_N_Simple_Return_Statement (N);
when N_Selected_Component => when N_Selected_Component =>
Expand_N_Selected_Component (N); Expand_N_Selected_Component (N);
......
gcc/ada/g-altcon.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -78,7 +78,7 @@ package body GNAT.Altivec.Conversions is ...@@ -78,7 +78,7 @@ package body GNAT.Altivec.Conversions is
-- relying on internal knowledge about the bits layout in the different -- relying on internal knowledge about the bits layout in the different
-- types (all 128 value bits blocks). -- 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 function UNC_To_Vector is
new Ada.Unchecked_Conversion (View_Type, Vector_Type); new Ada.Unchecked_Conversion (View_Type, Vector_Type);
...@@ -86,7 +86,7 @@ package body GNAT.Altivec.Conversions is ...@@ -86,7 +86,7 @@ package body GNAT.Altivec.Conversions is
function UNC_To_View is function UNC_To_View is
new Ada.Unchecked_Conversion (Vector_Type, View_Type); 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 function UNC_To_Vector is
new Ada.Unchecked_Conversion (Varray_Type, Vector_Type); new Ada.Unchecked_Conversion (Varray_Type, Vector_Type);
...@@ -94,7 +94,7 @@ package body GNAT.Altivec.Conversions is ...@@ -94,7 +94,7 @@ package body GNAT.Altivec.Conversions is
function UNC_To_View is function UNC_To_View is
new Ada.Unchecked_Conversion (Varray_Type, View_Type); 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 function UNC_To_Varray is
new Ada.Unchecked_Conversion (Vector_Type, Varray_Type); new Ada.Unchecked_Conversion (Vector_Type, Varray_Type);
......
gcc/ada/g-dirope.adb
...@@ -647,7 +647,7 @@ package body GNAT.Directory_Operations is ...@@ -647,7 +647,7 @@ package body GNAT.Directory_Operations is
---------- ----------
procedure Read procedure Read
(Dir : in out Dir_Type; (Dir : Dir_Type;
Str : out String; Str : out String;
Last : out Natural) Last : out Natural)
is is
......
gcc/ada/g-dirope.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -230,7 +230,7 @@ package GNAT.Directory_Operations is ...@@ -230,7 +230,7 @@ package GNAT.Directory_Operations is
-- Returns True if Dir is open, or False otherwise -- Returns True if Dir is open, or False otherwise
procedure Read procedure Read
(Dir : in out Dir_Type; (Dir : Dir_Type;
Str : out String; Str : out String;
Last : out Natural); Last : out Natural);
-- Reads the next entry from the directory and sets Str to the name -- Reads the next entry from the directory and sets Str to the name
......
gcc/ada/g-eacodu.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is the default (Unix) version. -- This is the default (Unix) version
separate (GNAT.Exception_Actions) separate (GNAT.Exception_Actions)
procedure Core_Dump (Occurrence : Exception_Occurrence) is procedure Core_Dump (Occurrence : Exception_Occurrence) is
......
gcc/ada/itypes.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -74,6 +74,12 @@ package Itypes is ...@@ -74,6 +74,12 @@ package Itypes is
-- call to New_Copy_Tree is to create a complete duplicate of a tree, -- 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 -- as though it had appeared separately in the source), the Itype in
-- question is duplicated as part of the New_Copy_Tree processing. -- 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 -- -- Subprograms --
......
gcc/ada/par-ch12.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -332,7 +332,7 @@ package body Ch12 is ...@@ -332,7 +332,7 @@ package body Ch12 is
begin begin
Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); 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 Token = Tok_Others then
if Ada_Version < Ada_05 then if Ada_Version < Ada_05 then
...@@ -375,7 +375,7 @@ package body Ch12 is ...@@ -375,7 +375,7 @@ package body Ch12 is
end if; end if;
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 if Token = Tok_Box then
Scan; Scan;
......
gcc/ada/par-ch2.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -177,7 +177,7 @@ package body Ch2 is ...@@ -177,7 +177,7 @@ package body Ch2 is
-- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' -- 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 -- -- 2.6 String Literal --
...@@ -185,7 +185,7 @@ package body Ch2 is ...@@ -185,7 +185,7 @@ package body Ch2 is
-- STRING LITERAL ::= "{STRING_ELEMENT}" -- 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. -- or if the string looks like an operator as Tok_Operator_Symbol.
------------------------- -------------------------
...@@ -479,7 +479,7 @@ package body Ch2 is ...@@ -479,7 +479,7 @@ package body Ch2 is
if Identifier_Seen then if Identifier_Seen then
Error_Msg_SC 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; end if;
end if; end if;
......
gcc/ada/s-asthan-vms-alpha.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha version. -- This is the OpenVMS/Alpha version
with System; use System; with System; use System;
...@@ -205,7 +205,7 @@ package body System.AST_Handling is ...@@ -205,7 +205,7 @@ package body System.AST_Handling is
end record; end record;
AST_Vector_Init : AST_Vector_Ptr; 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 package AST_Attribute is new Ada.Task_Attributes
(Attribute => AST_Vector_Ptr, (Attribute => AST_Vector_Ptr,
...@@ -241,7 +241,7 @@ package body System.AST_Handling is ...@@ -241,7 +241,7 @@ package body System.AST_Handling is
AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
pragma Volatile_Components (AST_Service_Queue); 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_Put : AST_Service_Queue_Index := 0;
AST_Service_Queue_Get : AST_Service_Queue_Index := 0; AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
...@@ -583,7 +583,7 @@ package body System.AST_Handling is ...@@ -583,7 +583,7 @@ package body System.AST_Handling is
if Is_Waiting (J) then if Is_Waiting (J) then
Is_Waiting (J) := False; 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))); STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit; exit;
......
gcc/ada/s-direio.adb
...@@ -319,6 +319,10 @@ package body System.Direct_IO is ...@@ -319,6 +319,10 @@ package body System.Direct_IO is
procedure Do_Write; procedure Do_Write;
-- Do the actual write -- Do the actual write
--------------
-- Do_Write --
--------------
procedure Do_Write is procedure Do_Write is
begin begin
FIO.Write_Buf (AP (File), Item, Size); FIO.Write_Buf (AP (File), Item, Size);
......
gcc/ada/s-except.ads
...@@ -42,7 +42,7 @@ package System.Exceptions is ...@@ -42,7 +42,7 @@ package System.Exceptions is
pragma Warnings (Off); pragma Warnings (Off);
pragma Preelaborate_05; pragma Preelaborate_05;
pragma Warnings (On); 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; package SSL renames System.Standard_Library;
-- To let some of the hooks below have formal parameters typed in -- To let some of the hooks below have formal parameters typed in
......
gcc/ada/s-htable.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -54,7 +54,7 @@ package System.HTable is ...@@ -54,7 +54,7 @@ package System.HTable is
generic generic
type Header_Num is range <>; 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; type Element is private;
-- The type of element to be stored -- The type of element to be stored
...@@ -120,7 +120,7 @@ package System.HTable is ...@@ -120,7 +120,7 @@ package System.HTable is
generic generic
type Header_Num is range <>; 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; type Element (<>) is limited private;
-- The type of element to be stored. This is historically part of the -- The type of element to be stored. This is historically part of the
...@@ -137,7 +137,7 @@ package System.HTable is ...@@ -137,7 +137,7 @@ package System.HTable is
-- type, but could be some other form of type such as an integer type). -- type, but could be some other form of type such as an integer type).
Null_Ptr : Elmt_Ptr; 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 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
with function Next (E : Elmt_Ptr) return Elmt_Ptr; with function Next (E : Elmt_Ptr) return Elmt_Ptr;
......
gcc/ada/s-imgboo.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -37,6 +37,6 @@ package System.Img_Bool is ...@@ -37,6 +37,6 @@ package System.Img_Bool is
pragma Pure; pragma Pure;
function Image_Boolean (V : Boolean) return String; 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; end System.Img_Bool;
gcc/ada/s-imglli.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -39,7 +39,7 @@ package System.Img_LLI is ...@@ -39,7 +39,7 @@ package System.Img_LLI is
pragma Preelaborate; pragma Preelaborate;
function Image_Long_Long_Integer (V : Long_Long_Integer) return String; 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 procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer; (V : Long_Long_Integer;
......
gcc/ada/s-imgllu.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,7 +43,7 @@ package System.Img_LLU is ...@@ -43,7 +43,7 @@ package System.Img_LLU is
function Image_Long_Long_Unsigned function Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned) (V : System.Unsigned_Types.Long_Long_Unsigned)
return String; 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 procedure Set_Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned; (V : System.Unsigned_Types.Long_Long_Unsigned;
......
gcc/ada/s-imguns.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,7 +43,7 @@ package System.Img_Uns is ...@@ -43,7 +43,7 @@ package System.Img_Uns is
function Image_Unsigned function Image_Unsigned
(V : System.Unsigned_Types.Unsigned) (V : System.Unsigned_Types.Unsigned)
return String; return String;
-- Computes Unsigned'Image (V) and returns the result. -- Computes Unsigned'Image (V) and returns the result
procedure Set_Image_Unsigned procedure Set_Image_Unsigned
(V : System.Unsigned_Types.Unsigned; (V : System.Unsigned_Types.Unsigned;
......
gcc/ada/s-inmaop-vms.adb
...@@ -283,6 +283,8 @@ package body System.Interrupt_Management.Operations is ...@@ -283,6 +283,8 @@ package body System.Interrupt_Management.Operations is
P1 => To_unsigned_long (Interrupt'Address), P1 => To_unsigned_long (Interrupt'Address),
P2 => Interrupt_ID'Size / 8); P2 => Interrupt_ID'Size / 8);
-- The following could use a comment ???
pragma Assert ((Status and 1) = 1); pragma Assert ((Status and 1) = 1);
end Interrupt_Self_Process; end Interrupt_Self_Process;
......
gcc/ada/s-interr.adb
...@@ -257,7 +257,7 @@ package body System.Interrupts is ...@@ -257,7 +257,7 @@ package body System.Interrupts is
Registered_Handler_Tail : R_Link := null; Registered_Handler_Tail : R_Link := null;
Access_Hold : Server_Task_Access; Access_Hold : Server_Task_Access;
-- variable used to allocate Server_Task using "new". -- Variable used to allocate Server_Task using "new"
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
...@@ -920,7 +920,7 @@ package body System.Interrupts is ...@@ -920,7 +920,7 @@ package body System.Interrupts is
if New_Handler = null then 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; User_Handler (Interrupt).Static := False;
...@@ -1267,18 +1267,18 @@ package body System.Interrupts is ...@@ -1267,18 +1267,18 @@ package body System.Interrupts is
System.Tasking.Utilities.Make_Independent; 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)); IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
-- Note: All tasks in RTS will have all the Reserve Interrupts -- Note: All tasks in RTS will have all the Reserve Interrupts being
-- being masked (except the Interrupt_Manager) and Keep_Unmasked -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when
-- unmasked when created. -- created.
-- Abort_Task_Interrupt is one of the Interrupt unmasked -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks.
-- in all tasks. We mask the Interrupt in this particular task -- We mask the Interrupt in this particular task so that "sigwait" is
-- so that "sigwait" is possible to catch an explicitely sent -- possible to catch an explicitely sent Abort_Task_Interrupt from the
-- Abort_Task_Interrupt from the Interrupt_Manager. -- Interrupt_Manager.
-- There are two Interrupt interrupts that this task catch through -- There are two Interrupt interrupts that this task catch through
-- "sigwait." One is the Interrupt this task is designated to catch -- "sigwait." One is the Interrupt this task is designated to catch
...@@ -1287,7 +1287,7 @@ package body System.Interrupts is ...@@ -1287,7 +1287,7 @@ package body System.Interrupts is
-- Interrupt_Manager to inform status changes (e.g: become Blocked, -- Interrupt_Manager to inform status changes (e.g: become Blocked,
-- Handler or Entry is to be detached). -- 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); IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
...@@ -1361,7 +1361,7 @@ package body System.Interrupts is ...@@ -1361,7 +1361,7 @@ package body System.Interrupts is
if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then 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); POP.Abort_Task (Interrupt_Manager_ID);
...@@ -1397,7 +1397,7 @@ package body System.Interrupts is ...@@ -1397,7 +1397,7 @@ package body System.Interrupts is
if User_Handler (Interrupt).H /= null then if User_Handler (Interrupt).H /= null then
Tmp_Handler := User_Handler (Interrupt).H; 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); POP.Unlock (Self_ID);
...@@ -1417,7 +1417,7 @@ package body System.Interrupts is ...@@ -1417,7 +1417,7 @@ package body System.Interrupts is
Tmp_ID := User_Entry (Interrupt).T; Tmp_ID := User_Entry (Interrupt).T;
Tmp_Entry_Index := User_Entry (Interrupt).E; 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 if Single_Lock then
POP.Unlock_RTS; POP.Unlock_RTS;
...@@ -1470,7 +1470,7 @@ package body System.Interrupts is ...@@ -1470,7 +1470,7 @@ package body System.Interrupts is
-- Elaboration code for package System.Interrupts -- Elaboration code for package System.Interrupts
begin 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); Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
......
gcc/ada/s-interr.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -134,7 +134,7 @@ package System.Interrupts is ...@@ -134,7 +134,7 @@ package System.Interrupts is
-- already bound to another entry, Program_Error will be raised. -- already bound to another entry, Program_Error will be raised.
procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id); procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id);
-- This procedure detaches all the Interrupt Entries bound to a task. -- This procedure detaches all the Interrupt Entries bound to a task
------------------------------ ------------------------------
-- POSIX.5 Signals Services -- -- POSIX.5 Signals Services --
...@@ -157,7 +157,7 @@ package System.Interrupts is ...@@ -157,7 +157,7 @@ package System.Interrupts is
-- Comment needed ??? -- Comment needed ???
procedure Ignore_Interrupt (Interrupt : Interrupt_ID); 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); procedure Unignore_Interrupt (Interrupt : Interrupt_ID);
-- Comment needed ??? -- Comment needed ???
......
gcc/ada/s-intman-dummy.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -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 package body System.Interrupt_Management is
......
gcc/ada/s-intman-irix.adb
...@@ -6,8 +6,7 @@ ...@@ -6,8 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1995-2007, AdaCore --
--- Copyright (C) 1995-2006, AdaCore --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,13 +31,11 @@ ...@@ -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, -- Make a careful study of all signals available under the OS, to see which
-- to see which need to be reserved, kept always unmasked, -- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- or kept always unmasked. -- the lookout for special signals that may be used by the thread library.
-- Be on the lookout for special signals that
-- may be used by the thread library.
package body System.Interrupt_Management is package body System.Interrupt_Management is
......
gcc/ada/s-intman-vms.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -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 package body System.Interrupt_Management is
......
gcc/ada/s-intman-vms.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -67,11 +67,9 @@ package System.Interrupt_Management is ...@@ -67,11 +67,9 @@ package System.Interrupt_Management is
-- all systems, but is always reserved when it is defined. If we have the -- 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 -- 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 -- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write -- write:
-- Reserved (SIGRARE) := true; -- Reserved (SIGRARE) := true;
-- Then the initialization code will be portable.
-- Then the initialization code will be portable
Abort_Task_Interrupt : Interrupt_ID; Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abort, if an interrupt is -- The interrupt that is used to implement task abort, if an interrupt is
......
gcc/ada/s-intman-vxworks.adb
...@@ -31,13 +31,11 @@ ...@@ -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, -- Make a careful study of all signals available under the OS, to see which
-- to see which need to be reserved, kept always unmasked, -- need to be reserved, kept always unmasked, or kept always unmasked. Be on
-- or kept always unmasked. -- the lookout for special signals that may be used by the thread library.
-- Be on the lookout for special signals that
-- may be used by the thread library.
package body System.Interrupt_Management is package body System.Interrupt_Management is
...@@ -62,9 +60,8 @@ package body System.Interrupt_Management is ...@@ -62,9 +60,8 @@ package body System.Interrupt_Management is
function State (Int : Interrupt_ID) return Character; function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state"); pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in init.c -- Get interrupt state. Defined in init.c The input argument is the
-- The input argument is the interrupt number, -- interrupt number, and the result is one of the following:
-- and the result is one of the following:
Runtime : constant Character := 'r'; Runtime : constant Character := 'r';
Default : constant Character := 's'; Default : constant Character := 's';
......
gcc/ada/s-intman-vxworks.ads
...@@ -78,9 +78,7 @@ package System.Interrupt_Management is ...@@ -78,9 +78,7 @@ package System.Interrupt_Management is
-- convention that ID zero is not used for any "real" signals, and SIGRARE -- 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 -- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write: -- write:
-- Reserved (SIGRARE) := true; -- Reserved (SIGRARE) := true;
-- and the initialization code will be portable. -- and the initialization code will be portable.
Abort_Task_Interrupt : Signal_ID; Abort_Task_Interrupt : Signal_ID;
......
gcc/ada/s-mastop.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -88,8 +88,17 @@ package System.Machine_State_Operations is ...@@ -88,8 +88,17 @@ package System.Machine_State_Operations is
-- Some architectures (notably VMS) use a descriptor to describe -- Some architectures (notably VMS) use a descriptor to describe
-- a subprogram address. This function computes the actual starting -- a subprogram address. This function computes the actual starting
-- address of the code from Loc. -- 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. -- ??? 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); procedure Set_Machine_State (M : Machine_State);
-- This routine sets M from the current machine state. It is called -- This routine sets M from the current machine state. It is called
......
gcc/ada/s-osinte-darwin.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,14 +32,13 @@ ...@@ -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 -- This package includes all direct interfaces to OS services that are needed
-- that are needed by children of System. -- by children of System.
-- PLEASE DO NOT add any with-clauses to this package -- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- or remove the pragma Elaborate_Body. -- Elaborate_Body. It is designed to be a bottom-level (leaf) package.
-- It is designed to be a bottom-level (leaf) package.
with Interfaces.C; with Interfaces.C;
package System.OS_Interface is package System.OS_Interface is
...@@ -115,10 +114,10 @@ package System.OS_Interface is ...@@ -115,10 +114,10 @@ package System.OS_Interface is
type Signal_Set is array (Natural range <>) of Signal; type Signal_Set is array (Natural range <>) of Signal;
Unmasked : constant Signal_Set := Unmasked : constant Signal_Set :=
(SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP); (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP);
Reserved : constant Signal_Set := Reserved : constant Signal_Set :=
(SIGKILL, SIGSTOP); (SIGKILL, SIGSTOP);
type sigset_t is private; type sigset_t is private;
...@@ -174,7 +173,7 @@ package System.OS_Interface is ...@@ -174,7 +173,7 @@ package System.OS_Interface is
---------- ----------
Time_Slice_Supported : constant Boolean := True; Time_Slice_Supported : constant Boolean := True;
-- Indicates wether time slicing is supported. -- Indicates wether time slicing is supported
type timespec is private; type timespec is private;
...@@ -210,7 +209,7 @@ package System.OS_Interface is ...@@ -210,7 +209,7 @@ package System.OS_Interface is
function To_Target_Priority function To_Target_Priority
(Prio : System.Any_Priority) return Interfaces.C.int; (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 -- -- Process --
......
gcc/ada/s-osinte-hpux-dce.adb
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -126,7 +126,7 @@ package body System.OS_Interface is ...@@ -126,7 +126,7 @@ package body System.OS_Interface is
return 0; return 0;
end sigwait; 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 function pthread_kill (thread : pthread_t; sig : Signal) return int is
pragma Unreferenced (thread, sig); pragma Unreferenced (thread, sig);
......
gcc/ada/s-osinte-hpux-dce.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -291,9 +291,8 @@ package System.OS_Interface is ...@@ -291,9 +291,8 @@ package System.OS_Interface is
(how : int; (how : int;
set : access sigset_t; set : access sigset_t;
oset : access sigset_t) return int; oset : access sigset_t) return int;
-- DCE THREADS does not have pthread_sigmask. Instead, it uses -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask
-- sigprocmask to do the signal handling when the thread library is -- to do the signal handling when the thread library is sucked in.
-- sucked in.
pragma Import (C, pthread_sigmask, "sigprocmask"); pragma Import (C, pthread_sigmask, "sigprocmask");
-------------------------- --------------------------
...@@ -302,7 +301,7 @@ package System.OS_Interface is ...@@ -302,7 +301,7 @@ package System.OS_Interface is
function pthread_mutexattr_init function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int; (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 function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t) return int; (attr : access pthread_mutexattr_t) return int;
......
gcc/ada/s-osinte-irix.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,14 +31,14 @@ ...@@ -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 -- This package encapsulates all direct interfaces to OS services that are
-- that are needed by children of System. -- needed by children of System.
pragma Polling (Off); pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during -- Turn off polling, we do not want ATC polling to take place during tasking
-- tasking operations. It causes infinite loops and other problems. -- operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C; with Interfaces.C; use Interfaces.C;
......
gcc/ada/s-osinte-irix.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -119,7 +119,7 @@ package System.OS_Interface is ...@@ -119,7 +119,7 @@ package System.OS_Interface is
SIGCKPT : constant := 33; -- Checkpoint warning SIGCKPT : constant := 33; -- Checkpoint warning
SIGRESTART : constant := 34; -- Restart warning SIGRESTART : constant := 34; -- Restart warning
SIGUME : constant := 35; -- Uncorrectable memory error SIGUME : constant := 35; -- Uncorrectable memory error
-- Signals defined for Posix 1003.1c. -- Signals defined for Posix 1003.1c
SIGPTINTR : constant := 47; SIGPTINTR : constant := 47;
SIGPTRESCHED : constant := 48; SIGPTRESCHED : constant := 48;
-- Posix 1003.1b signals -- Posix 1003.1b signals
......
gcc/ada/s-osprim-mingw.adb
...@@ -99,7 +99,7 @@ package body System.OS_Primitives is ...@@ -99,7 +99,7 @@ package body System.OS_Primitives is
Base_Ticks : aliased LARGE_INTEGER; Base_Ticks : aliased LARGE_INTEGER;
BTA : constant LIA := Base_Ticks'Access; 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; Base_Monotonic_Ticks : aliased LARGE_INTEGER;
BMTA : constant LIA := Base_Monotonic_Ticks'Access; BMTA : constant LIA := Base_Monotonic_Ticks'Access;
...@@ -160,8 +160,8 @@ package body System.OS_Primitives is ...@@ -160,8 +160,8 @@ package body System.OS_Primitives is
-- If we have a shift of more than Max_Shift seconds we resynchonize the -- 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 -- Clock. This is probably due to a manual Clock adjustment, an DST
-- adjustment or an NTP synchronisation. And we want to adjust the -- adjustment or an NTP synchronisation. And we want to adjust the time
-- time for this system (non-monotonic) clock. -- for this system (non-monotonic) clock.
if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
Get_Base_Time; Get_Base_Time;
...@@ -180,7 +180,7 @@ package body System.OS_Primitives is ...@@ -180,7 +180,7 @@ package body System.OS_Primitives is
procedure Get_Base_Time 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. -- The time to get both base times should take less than 1 millisecond.
-- Therefore, the elapsed time reported by GetSystemTime between both -- Therefore, the elapsed time reported by GetSystemTime between both
......
gcc/ada/s-parame-ae653.ads
...@@ -193,7 +193,7 @@ package System.Parameters is ...@@ -193,7 +193,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 32; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame-hpux.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,7 @@ package System.Parameters is ...@@ -191,7 +191,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 256; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame-vms-alpha.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,7 @@ package System.Parameters is ...@@ -191,7 +191,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 256; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame-vms-ia64.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,7 @@ package System.Parameters is ...@@ -191,7 +191,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 256; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame-vms-restrict.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,7 @@ package System.Parameters is ...@@ -191,7 +191,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 256; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame-vxworks.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Version used on all VxWorks targets. -- Version used on all VxWorks targets
package body System.Parameters is package body System.Parameters is
......
gcc/ada/s-parame-vxworks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -193,7 +193,7 @@ package System.Parameters is ...@@ -193,7 +193,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 32; 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 -- -- Exception Message Length --
......
gcc/ada/s-parame.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,7 +191,7 @@ package System.Parameters is ...@@ -191,7 +191,7 @@ package System.Parameters is
----------------------- -----------------------
Max_Task_Image_Length : constant := 256; 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 -- -- Exception Message Length --
......
gcc/ada/s-poosiz.adb
...@@ -40,12 +40,11 @@ package body System.Pool_Size is ...@@ -40,12 +40,11 @@ package body System.Pool_Size is
package SSE renames System.Storage_Elements; package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset; use type SSE.Storage_Offset;
-- Even though these storage pools are typically only used -- Even though these storage pools are typically only used by a single
-- by a single task, if multiple tasks are declared at the -- task, if multiple tasks are declared at the same or a more nested scope
-- same or a more nested scope as the storage pool, there -- as the storage pool, there still may be concurrent access. The current
-- still may be concurrent access. The current implementation -- implementation of Stack_Bounded_Pool always uses a global lock for
-- of Stack_Bounded_Pool always uses a global lock for protecting -- protecting access. This should eventually be replaced by an atomic
-- access. This should eventually be replaced by an atomic
-- linked list implementation for efficiency reasons. -- linked list implementation for efficiency reasons.
package SSL renames System.Soft_Links; package SSL renames System.Soft_Links;
...@@ -58,9 +57,9 @@ package body System.Pool_Size is ...@@ -58,9 +57,9 @@ package body System.Pool_Size is
package Variable_Size_Management 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. -- Allocation is done on the first chunk long enough for the request.
-- Deallocation just puts the freed chunk at the beginning of the list. -- Deallocation just puts the freed chunk at the beginning of the list.
......
gcc/ada/s-proinf-irix-athread.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,20 +31,19 @@ ...@@ -31,20 +31,19 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains the definitions and routines used as parameters -- This package contains the definitions and routines used as parameters to
-- to the run-time system at program startup for the SGI implementation. -- the run-time system at program startup for the SGI implementation.
package System.Program_Info is package System.Program_Info is
pragma Preelaborate; pragma Preelaborate;
function Initial_Sproc_Count return Integer; function Initial_Sproc_Count return Integer;
-- The number of sproc created at program startup for scheduling -- The number of sproc created at program startup for scheduling threads
-- threads.
function Max_Sproc_Count return Integer; function Max_Sproc_Count return Integer;
-- The maximum number of sprocs that can be created by the program -- The maximum number of sprocs that can be created by the program for
-- for servicing threads. This limit includes both the pre-created -- servicing threads. This limit includes both the pre-created sprocs and
-- sprocs and those explicitly created under program control. -- those explicitly created under program control.
function Sproc_Stack_Size return Integer; function Sproc_Stack_Size return Integer;
-- The size, in bytes, of the sproc's initial stack. -- The size, in bytes, of the sproc's initial stack.
...@@ -56,9 +55,9 @@ package System.Program_Info is ...@@ -56,9 +55,9 @@ package System.Program_Info is
-- Task_Info pragma. See s-tasinf.ads for more information. -- Task_Info pragma. See s-tasinf.ads for more information.
function Default_Task_Stack return Integer; function Default_Task_Stack return Integer;
-- The default stack size for each created thread. This default value -- The default stack size for each created thread. This default value can
-- can be overriden on a per-task basis by the language-defined -- be overriden on a per-task basis by the language-defined Storage_Size
-- Storage_Size pragma. -- pragma.
function Stack_Guard_Pages return Integer; function Stack_Guard_Pages return Integer;
-- The number of non-writable, guard pages to append to the bottom of -- The number of non-writable, guard pages to append to the bottom of
......
gcc/ada/s-stache.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -73,7 +73,7 @@ private ...@@ -73,7 +73,7 @@ private
(Limit => System.Null_Address, (Limit => System.Null_Address,
Base => System.Null_Address, Base => System.Null_Address,
Size => 0); 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; Null_Stack : constant Stack_Access := Null_Stack_Info'Access;
-- Stack_Access value that will return a Stack_Base and Stack_Limit -- Stack_Access value that will return a Stack_Base and Stack_Limit
......
gcc/ada/s-stausa.adb
...@@ -352,7 +352,8 @@ package body System.Stack_Usage is ...@@ -352,7 +352,8 @@ package body System.Stack_Usage is
Task_Name_Blanks : Task_Name_Blanks :
constant String (1 .. Task_Name_Length - Task_Name_Str'Length) := constant String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
(others => ' '); (others => ' ');
begin begin
Set_Output (Standard_Error); Set_Output (Standard_Error);
...@@ -362,6 +363,7 @@ package body System.Stack_Usage is ...@@ -362,6 +363,7 @@ package body System.Stack_Usage is
end if; end if;
if Result_Array'Length > 0 then if Result_Array'Length > 0 then
-- Computes the size of the largest strings that will get displayed, -- Computes the size of the largest strings that will get displayed,
-- in order to do correct column alignment. -- in order to do correct column alignment.
......
gcc/ada/s-tasinf-solaris.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -34,14 +34,13 @@ ...@@ -34,14 +34,13 @@
-- This package body contains the routines associated with the implementation -- This package body contains the routines associated with the implementation
-- of the Task_Info pragma. -- 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 package body System.Task_Info is
function Unbound_Thread_Attributes return Thread_Attributes is -----------------------------
begin -- Bound_Thread_Attributes --
return (False, False); -----------------------------
end Unbound_Thread_Attributes;
function Bound_Thread_Attributes return Thread_Attributes is function Bound_Thread_Attributes return Thread_Attributes is
begin begin
...@@ -54,10 +53,9 @@ package body System.Task_Info is ...@@ -54,10 +53,9 @@ package body System.Task_Info is
return (True, True, CPU); return (True, True, CPU);
end Bound_Thread_Attributes; end Bound_Thread_Attributes;
function New_Unbound_Thread_Attributes return Task_Info_Type is ---------------------------------
begin -- New_Bound_Thread_Attributes --
return new Thread_Attributes'(False, False); ---------------------------------
end New_Unbound_Thread_Attributes;
function New_Bound_Thread_Attributes return Task_Info_Type is function New_Bound_Thread_Attributes return Task_Info_Type is
begin begin
...@@ -70,4 +68,22 @@ package body System.Task_Info is ...@@ -70,4 +68,22 @@ package body System.Task_Info is
return new Thread_Attributes'(True, True, CPU); return new Thread_Attributes'(True, True, CPU);
end New_Bound_Thread_Attributes; 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; end System.Task_Info;
gcc/ada/s-tasinf-solaris.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,7 +41,7 @@ ...@@ -41,7 +41,7 @@
-- This unit may be used directly from an application program by providing -- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable. -- 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; with System.OS_Interface;
...@@ -84,7 +84,7 @@ package System.Task_Info is ...@@ -84,7 +84,7 @@ package System.Task_Info is
-- The Task_Info pragma appears within a task definition (compare the -- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma -- 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 -- 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 -- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value. -- a task by task basis by supplying the appropriate discriminant value.
......
gcc/ada/s-tasinf-tru64.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- (Compiler Interface) -- -- (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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -42,7 +42,7 @@ ...@@ -42,7 +42,7 @@
-- This unit may be used directly from an application program by providing -- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable. -- 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 package System.Task_Info is
pragma Preelaborate; pragma Preelaborate;
...@@ -64,7 +64,7 @@ package System.Task_Info is ...@@ -64,7 +64,7 @@ package System.Task_Info is
-- The Task_Info pragma appears within a task definition (compare the -- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma -- 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 -- 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 -- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value. -- a task by task basis by supplying the appropriate discriminant value.
......
gcc/ada/s-tasinf.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -61,7 +61,7 @@ package System.Task_Info is ...@@ -61,7 +61,7 @@ package System.Task_Info is
-- The Task_Info pragma appears within a task definition (compare the -- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma -- 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 -- 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 -- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value. -- a task by task basis by supplying the appropriate discriminant value.
......
gcc/ada/s-tfsetr-vxworks.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -31,11 +31,11 @@ ...@@ -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 -- When adding a new event, just give an Id to then event, and then modify
-- the WindView events database. -- the WindView events database.
......
gcc/ada/scng.adb
...@@ -571,7 +571,7 @@ package body Scng is ...@@ -571,7 +571,7 @@ package body Scng is
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
Error_Msg_S 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 Error_Msg_S
("\use ""'#"" instead?"); ("\use ""'#"" instead?");
end if; end if;
...@@ -1178,7 +1178,10 @@ package body Scng is ...@@ -1178,7 +1178,10 @@ package body Scng is
-- Horizontal tab, just skip past it -- Horizontal tab, just skip past it
when HT => 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; Scan_Ptr := Scan_Ptr + 1;
-- End of file character, treated as an end of file only if it is -- End of file character, treated as an end of file only if it is
...@@ -1187,7 +1190,11 @@ package body Scng is ...@@ -1187,7 +1190,11 @@ package body Scng is
when EOF => when EOF =>
if Scan_Ptr = Source_Last (Current_Source_File) then if Scan_Ptr = Source_Last (Current_Source_File) then
Check_End_Of_Line; 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; Token := Tok_EOF;
return; return;
else else
...@@ -1237,7 +1244,11 @@ package body Scng is ...@@ -1237,7 +1244,11 @@ package body Scng is
if Double_Char_Token ('=') then if Double_Char_Token ('=') then
Token := Tok_Colon_Equal; 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; return;
elsif Source (Scan_Ptr + 1) = '-' elsif Source (Scan_Ptr + 1) = '-'
...@@ -1251,7 +1262,11 @@ package body Scng is ...@@ -1251,7 +1262,11 @@ package body Scng is
else else
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Colon; Token := Tok_Colon;
if Style_Check then Style.Check_Colon; end if;
if Style_Check then
Style.Check_Colon;
end if;
return; return;
end if; end if;
...@@ -1261,7 +1276,11 @@ package body Scng is ...@@ -1261,7 +1276,11 @@ package body Scng is
Accumulate_Checksum ('('); Accumulate_Checksum ('(');
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren; 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; return;
-- Left bracket -- Left bracket
...@@ -1291,7 +1310,11 @@ package body Scng is ...@@ -1291,7 +1310,11 @@ package body Scng is
Accumulate_Checksum (','); Accumulate_Checksum (',');
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Comma; Token := Tok_Comma;
if Style_Check then Style.Check_Comma; end if;
if Style_Check then
Style.Check_Comma;
end if;
return; return;
-- Dot, which is either an isolated period, or part of a double dot -- Dot, which is either an isolated period, or part of a double dot
...@@ -1303,7 +1326,11 @@ package body Scng is ...@@ -1303,7 +1326,11 @@ package body Scng is
if Double_Char_Token ('.') then if Double_Char_Token ('.') then
Token := Tok_Dot_Dot; 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; return;
elsif Source (Scan_Ptr + 1) in '0' .. '9' then elsif Source (Scan_Ptr + 1) in '0' .. '9' then
...@@ -1324,7 +1351,11 @@ package body Scng is ...@@ -1324,7 +1351,11 @@ package body Scng is
if Double_Char_Token ('>') then if Double_Char_Token ('>') then
Token := Tok_Arrow; Token := Tok_Arrow;
if Style_Check then Style.Check_Arrow; end if;
if Style_Check then
Style.Check_Arrow;
end if;
return; return;
elsif Source (Scan_Ptr + 1) = '=' then elsif Source (Scan_Ptr + 1) = '=' then
...@@ -1369,7 +1400,11 @@ package body Scng is ...@@ -1369,7 +1400,11 @@ package body Scng is
elsif Double_Char_Token ('>') then elsif Double_Char_Token ('>') then
Token := Tok_Box; Token := Tok_Box;
if Style_Check then Style.Check_Box; end if;
if Style_Check then
Style.Check_Box;
end if;
return; return;
elsif Double_Char_Token ('<') then elsif Double_Char_Token ('<') then
...@@ -1401,7 +1436,10 @@ package body Scng is ...@@ -1401,7 +1436,10 @@ package body Scng is
-- Comment -- Comment
else -- Source (Scan_Ptr + 1) = '-' then 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; Scan_Ptr := Scan_Ptr + 2;
-- If we are in preprocessor mode with Replace_In_Comments set, -- If we are in preprocessor mode with Replace_In_Comments set,
...@@ -1447,7 +1485,10 @@ package body Scng is ...@@ -1447,7 +1485,10 @@ package body Scng is
-- Keep going if horizontal tab -- Keep going if horizontal tab
if Source (Scan_Ptr) = HT then 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; Scan_Ptr := Scan_Ptr + 1;
-- Terminate scan of comment if line terminator -- Terminate scan of comment if line terminator
...@@ -1538,7 +1579,7 @@ package body Scng is ...@@ -1538,7 +1579,7 @@ package body Scng is
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
Error_Msg_S 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 Error_Msg_S
("\use """""" instead?"); ("\use """""" instead?");
end if; end if;
...@@ -1581,7 +1622,11 @@ package body Scng is ...@@ -1581,7 +1622,11 @@ package body Scng is
or else Prev_Token in Token_Class_Literal or else Prev_Token in Token_Class_Literal
then then
Token := Tok_Apostrophe; Token := Tok_Apostrophe;
if Style_Check then Style.Check_Apostrophe; end if;
if Style_Check then
Style.Check_Apostrophe;
end if;
return; return;
-- Otherwise the apostrophe starts a character literal -- Otherwise the apostrophe starts a character literal
...@@ -1686,7 +1731,11 @@ package body Scng is ...@@ -1686,7 +1731,11 @@ package body Scng is
Accumulate_Checksum (')'); Accumulate_Checksum (')');
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren; 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; return;
-- Right bracket or right brace, treated as right paren -- Right bracket or right brace, treated as right paren
...@@ -1717,7 +1766,11 @@ package body Scng is ...@@ -1717,7 +1766,11 @@ package body Scng is
Accumulate_Checksum (';'); Accumulate_Checksum (';');
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Semicolon; Token := Tok_Semicolon;
if Style_Check then Style.Check_Semicolon; end if;
if Style_Check then
Style.Check_Semicolon;
end if;
return; return;
-- Vertical bar -- Vertical bar
...@@ -1736,7 +1789,11 @@ package body Scng is ...@@ -1736,7 +1789,11 @@ package body Scng is
else else
Scan_Ptr := Scan_Ptr + 1; Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar; 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; return;
end if; end if;
end Vertical_Bar_Case; end Vertical_Bar_Case;
...@@ -1749,7 +1806,7 @@ package body Scng is ...@@ -1749,7 +1806,7 @@ package body Scng is
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
Error_Msg_S 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 Error_Msg_S
("\use ""'|"" instead?"); ("\use ""'|"" instead?");
end if; end if;
...@@ -2321,32 +2378,43 @@ package body Scng is ...@@ -2321,32 +2378,43 @@ package body Scng is
if Is_Keyword_Name (Token_Name) then if Is_Keyword_Name (Token_Name) then
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
-- Deal with possible style check for non-lower case keyword, but -- Keyword style checks
-- we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords for
-- this purpose if they appear as attribute designators. Actually if Style_Check then
-- we only check the first character for speed.
-- Deal with possible style check for non-lower case keyword,
-- Ada 2005 (AI-284): Do not apply the style check in case of -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
-- "pragma Interface" -- for this purpose if they appear as attribute designators.
-- Actually we only check the first character for speed.
-- Ada 2005 (AI-340): Do not apply the style check in case of
-- MOD attribute. -- Ada 2005 (AI-284): Do not apply the style check in case of
-- "pragma Interface"
if Style_Check
and then Source (Token_Ptr) <= 'Z' -- Ada 2005 (AI-340): Do not apply the style check in case of
and then (Prev_Token /= Tok_Apostrophe -- MOD attribute.
or else
(Token /= Tok_Access and then if Source (Token_Ptr) <= 'Z'
Token /= Tok_Delta and then and then (Prev_Token /= Tok_Apostrophe
Token /= Tok_Digits and then or else
Token /= Tok_Mod and then (Token /= Tok_Access and then
Token /= Tok_Range)) Token /= Tok_Delta and then
and then (Token /= Tok_Interface Token /= Tok_Digits and then
or else Token /= Tok_Mod and then
(Token = Tok_Interface Token /= Tok_Range))
and then Prev_Token /= Tok_Pragma)) and then (Token /= Tok_Interface
then or else
Style.Non_Lower_Case_Keyword; (Token = Tok_Interface
and then Prev_Token /= Tok_Pragma))
then
Style.Non_Lower_Case_Keyword;
end if;
if (Token = Tok_Then and then Prev_Token /= Tok_And)
or else
(Token = Tok_Else and then Prev_Token /= Tok_Or)
then
Style.Check_Separate_Stmt_Lines;
end if;
end if; end if;
-- We must reset Token_Name since this is not an identifier and -- We must reset Token_Name since this is not an identifier and
...@@ -2470,7 +2538,10 @@ package body Scng is ...@@ -2470,7 +2538,10 @@ package body Scng is
-- Outer loop keeps going only if a horizontal tab follows -- Outer loop keeps going only if a horizontal tab follows
if Source (Scan_Ptr) = HT then 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; Scan_Ptr := Scan_Ptr + 1;
Start_Column := (Start_Column / 8) * 8 + 8; Start_Column := (Start_Column / 8) * 8 + 8;
else else
......
gcc/ada/sem.adb
...@@ -53,6 +53,8 @@ with Sinfo; use Sinfo; ...@@ -53,6 +53,8 @@ with Sinfo; use Sinfo;
with Stand; use Stand; with Stand; use Stand;
with Uintp; use Uintp; with Uintp; use Uintp;
with Unchecked_Deallocation;
pragma Warnings (Off, Sem_Util); pragma Warnings (Off, Sem_Util);
-- Suppress warnings of unused with for Sem_Util (used only in asserts) -- Suppress warnings of unused with for Sem_Util (used only in asserts)
...@@ -448,8 +450,8 @@ package body Sem is ...@@ -448,8 +450,8 @@ package body Sem is
when N_Requeue_Statement => when N_Requeue_Statement =>
Analyze_Requeue (N); Analyze_Requeue (N);
when N_Return_Statement => when N_Simple_Return_Statement =>
Analyze_Return_Statement (N); Analyze_Simple_Return_Statement (N);
when N_Selected_Component => when N_Selected_Component =>
Find_Selected_Component (N); Find_Selected_Component (N);
...@@ -724,65 +726,73 @@ package body Sem is ...@@ -724,65 +726,73 @@ package body Sem is
From : Entity_Id; From : Entity_Id;
To : Entity_Id) To : Entity_Id)
is 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 begin
if not Checks_May_Be_Suppressed (From) then if not Checks_May_Be_Suppressed (From) then
return; return;
end if; 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 -- reverse order so that we get the innermost entry that applies to
-- this case if there are nested entries. Note that for the purpose -- this case if there are nested entries. Note that for the purpose
-- of this procedure we are ONLY looking for entries corresponding -- of this procedure we are ONLY looking for entries corresponding
-- to a two-argument Suppress, where the second argument matches From. -- to a two-argument Suppress, where the second argument matches From.
for J in Search_Stack (Global_Suppress_Stack_Top, Found);
reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
loop
declare
R : Entity_Check_Suppress_Record
renames Local_Entity_Suppress.Table (J);
begin if Found then
if R.Entity = From return;
and then (R.Check = All_Checks or else R.Check = C) end if;
then
if R.Suppress then
Set_Checks_May_Be_Suppressed (To, True);
Local_Entity_Suppress.Append
((Entity => To,
Check => C,
Suppress => True));
return;
end if;
end if;
end;
end loop;
-- Now search the global entity suppress table for a matching entry -- 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 in reverse order so that if there are multiple
-- pragmas for the same entity, the last one applies. -- pragmas for the same entity, the last one applies.
for J in Search_Stack (Local_Suppress_Stack_Top, Found);
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;
end Copy_Suppress_Status; end Copy_Suppress_Status;
------------------------- -------------------------
...@@ -812,29 +822,26 @@ package body Sem is ...@@ -812,29 +822,26 @@ package body Sem is
----------------------- -----------------------
function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
Ptr : Suppress_Stack_Entry_Ptr;
begin begin
if not Checks_May_Be_Suppressed (E) then if not Checks_May_Be_Suppressed (E) then
return False; return False;
else else
for J in Ptr := Global_Suppress_Stack_Top;
reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last while Ptr /= null loop
loop if Ptr.Entity = E
declare and then (Ptr.Check = All_Checks or else Ptr.Check = C)
R : Entity_Check_Suppress_Record then
renames Global_Entity_Suppress.Table (J); return Ptr.Suppress;
end if;
begin
if R.Entity = E
and then (R.Check = All_Checks or else R.Check = C)
then
return R.Suppress;
end if;
end;
end loop;
return False; Ptr := Ptr.Prev;
end loop;
end if; end if;
return False;
end Explicit_Suppress; end Explicit_Suppress;
----------------------------- -----------------------------
...@@ -880,9 +887,26 @@ package body Sem is ...@@ -880,9 +887,26 @@ package body Sem is
---------------- ----------------
procedure Initialize is procedure Initialize is
Next : Suppress_Stack_Entry_Ptr;
procedure Free is new Unchecked_Deallocation
(Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
begin begin
Local_Entity_Suppress.Init; -- Free any global suppress stack entries from a previous invocation
Global_Entity_Suppress.Init; -- 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; Scope_Stack.Init;
Unloaded_Subunits := False; Unloaded_Subunits := False;
end Initialize; end Initialize;
...@@ -1136,53 +1160,52 @@ package body Sem is ...@@ -1136,53 +1160,52 @@ package body Sem is
------------------------- -------------------------
function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean 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 Ptr : Suppress_Stack_Entry_Ptr;
reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
loop
declare
R : Entity_Check_Suppress_Record
renames Local_Entity_Suppress.Table (J);
begin begin
if (R.Entity = Empty or else R.Entity = E) -- First search the local entity suppress stack, we search this from the
and then (R.Check = All_Checks or else R.Check = C) -- top of the stack down, so that we get the innermost entry that
then -- applies to this case if there are nested entries.
return R.Suppress;
end if; Ptr := Local_Suppress_Stack_Top;
end; while Ptr /= null loop
if (Ptr.Entity = Empty or else Ptr.Entity = E)
and then (Ptr.Check = All_Checks or else Ptr.Check = C)
then
return Ptr.Suppress;
end if;
Ptr := Ptr.Prev;
end loop; end loop;
-- Now search the global entity suppress table for a matching entry -- 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 -- pragmas for the same entity, the last one applies (not clear what
-- or whether the RM specifies this handling, but it seems reasonable). -- or whether the RM specifies this handling, but it seems reasonable).
for J in Ptr := Global_Suppress_Stack_Top;
reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last while Ptr /= null loop
loop if (Ptr.Entity = Empty or else Ptr.Entity = E)
declare and then (Ptr.Check = All_Checks or else Ptr.Check = C)
R : Entity_Check_Suppress_Record then
renames Global_Entity_Suppress.Table (J); return Ptr.Suppress;
end if;
begin Ptr := Ptr.Prev;
if R.Entity = E
and then (R.Check = All_Checks or else R.Check = C)
then
return R.Suppress;
end if;
end;
end loop; end loop;
-- If we did not find a matching entry, then use the normal scope -- If we did not find a matching entry, then use the normal scope
-- suppress value after all (actually this will be the global setting -- suppress value after all (actually this will be the global setting
-- since it clearly was not overridden at any point) -- since it clearly was not overridden at any point). For a predefined
-- check, we test the specific flag. For a user defined check, we check
-- the All_Checks flag.
return Scope_Suppress (C); if C in Predefined_Check_Id then
return Scope_Suppress (C);
else
return Scope_Suppress (All_Checks);
end if;
end Is_Check_Suppressed; end Is_Check_Suppressed;
---------- ----------
...@@ -1191,14 +1214,54 @@ package body Sem is ...@@ -1191,14 +1214,54 @@ package body Sem is
procedure Lock is procedure Lock is
begin begin
Local_Entity_Suppress.Locked := True;
Global_Entity_Suppress.Locked := True;
Scope_Stack.Locked := True; Scope_Stack.Locked := True;
Local_Entity_Suppress.Release;
Global_Entity_Suppress.Release;
Scope_Stack.Release; Scope_Stack.Release;
end Lock; 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 -- -- Semantics --
--------------- ---------------
......
gcc/ada/sem.ads
...@@ -211,26 +211,27 @@ package Sem is ...@@ -211,26 +211,27 @@ package Sem is
----------------------------- -----------------------------
Full_Analysis : Boolean := True; Full_Analysis : Boolean := True;
-- Switch to indicate whether we are doing a full analysis or a -- Switch to indicate if we are doing a full analysis or a pre-analysis.
-- pre-analysis. In normal analysis mode (Analysis-Expansion for -- In normal analysis mode (Analysis-Expansion for instructions or
-- instructions or declarations) or (Analysis-Resolution-Expansion for -- declarations) or (Analysis-Resolution-Expansion for expressions) this
-- expressions) this flag is set. Note that if we are not generating -- flag is set. Note that if we are not generating code the expansion phase
-- code the expansion phase merely sets the Analyzed flag to True in -- merely sets the Analyzed flag to True in this case. If we are in
-- this case. If we are in Pre-Analysis mode (see above) this flag is -- Pre-Analysis mode (see above) this flag is set to False then the
-- set to False then the expansion phase is skipped. -- 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 -- When this flag is False the flag Expander_Active is also False (the
-- tells you whether expansion is currently enabled). -- Expander_Activer flag defined in the spec of package Expander tells you
-- You should really regard this as a read only flag. -- whether expansion is currently enabled). You should really regard this
-- as a read only flag.
In_Default_Expression : Boolean := False; In_Default_Expression : Boolean := False;
-- Switch to indicate that we are in a default expression, as described -- Switch to indicate that we are in a default expression, as described
-- above. Note that this must be recursively saved on a Semantics call -- 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 -- since it is possible for the analysis of an expression to result in a
-- a recursive call (e.g. to get the entity for System.Address as part -- recursive call (e.g. to get the entity for System.Address as part of the
-- of the processing of an Address attribute reference). -- processing of an Address attribute reference). When this switch is True
-- When this switch is True then Full_Analysis above must be False. -- then Full_Analysis above must be False. You should really regard this as
-- You should really regard this as a read only flag. -- a read only flag.
In_Deleted_Code : Boolean := False; In_Deleted_Code : Boolean := False;
-- If the condition in an if-statement is statically known, the branch -- If the condition in an if-statement is statically known, the branch
...@@ -259,6 +260,121 @@ package Sem is ...@@ -259,6 +260,121 @@ package Sem is
-- about unused variables, since these warnings are unreliable in this -- about unused variables, since these warnings are unreliable in this
-- case. We could perhaps do a more accurate job and retain some of the -- 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. -- 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 -- -- Scope Stack --
...@@ -324,8 +440,8 @@ package Sem is ...@@ -324,8 +440,8 @@ package Sem is
Save_Scope_Suppress : Suppress_Array; Save_Scope_Suppress : Suppress_Array;
-- Save contents of Scope_Suppress on entry -- Save contents of Scope_Suppress on entry
Save_Local_Entity_Suppress : Int; Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
-- Save contents of Local_Entity_Suppress.Last on entry -- Save contents of Local_Suppress_Stack on entry to restore on exit
Is_Transient : Boolean; Is_Transient : Boolean;
-- Marks Transient Scopes (See Exp_Ch7 body for details) -- Marks Transient Scopes (See Exp_Ch7 body for details)
...@@ -383,92 +499,6 @@ package Sem is ...@@ -383,92 +499,6 @@ package Sem is
Table_Increment => Alloc.Scope_Stack_Increment, Table_Increment => Alloc.Scope_Stack_Increment,
Table_Name => "Sem.Scope_Stack"); 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 -- -- Subprograms --
----------------- -----------------
......
gcc/ada/sem_eval.adb
...@@ -1501,7 +1501,7 @@ package body Sem_Eval is ...@@ -1501,7 +1501,7 @@ package body Sem_Eval is
Set_Etype (N, Etype (Right)); Set_Etype (N, Etype (Right));
end if; end if;
Fold_Str (N, End_String, True); Fold_Str (N, End_String, Static => True);
end if; end if;
end; end;
end Eval_Concatenation; end Eval_Concatenation;
...@@ -2732,7 +2732,7 @@ package body Sem_Eval is ...@@ -2732,7 +2732,7 @@ package body Sem_Eval is
-- Fold conversion, case of string type. The result is not static -- Fold conversion, case of string type. The result is not static
if Is_String_Type (Target_Type) then 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; return;
...@@ -4450,7 +4450,7 @@ package body Sem_Eval is ...@@ -4450,7 +4450,7 @@ package body Sem_Eval is
if Raises_Constraint_Error (Expr) then if Raises_Constraint_Error (Expr) then
Error_Msg_N Error_Msg_N
("expression raises exception, cannot be static " & ("expression raises exception, cannot be static " &
"('R'M 4.9(34))!", N); "(RM 4.9(34))!", N);
return; return;
end if; end if;
...@@ -4469,7 +4469,7 @@ package body Sem_Eval is ...@@ -4469,7 +4469,7 @@ package body Sem_Eval is
then then
Error_Msg_N Error_Msg_N
("static expression must have scalar or string type " & ("static expression must have scalar or string type " &
"('R'M 4.9(2))!", N); "(RM 4.9(2))!", N);
return; return;
end if; end if;
end if; end if;
...@@ -4486,19 +4486,19 @@ package body Sem_Eval is ...@@ -4486,19 +4486,19 @@ package body Sem_Eval is
elsif Ekind (E) = E_Constant then elsif Ekind (E) = E_Constant then
if not Is_Static_Expression (Constant_Value (E)) then if not Is_Static_Expression (Constant_Value (E)) then
Error_Msg_NE 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; end if;
else else
Error_Msg_NE Error_Msg_NE
("& is not static constant or named number " & ("& is not static constant or named number " &
"('R'M 4.9(5))!", N, E); "(RM 4.9(5))!", N, E);
end if; end if;
when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
if Nkind (N) in N_Op_Shift then if Nkind (N) in N_Op_Shift then
Error_Msg_N 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 else
Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Left_Opnd (N));
...@@ -4522,7 +4522,7 @@ package body Sem_Eval is ...@@ -4522,7 +4522,7 @@ package body Sem_Eval is
if Attribute_Name (N) = Name_Size then if Attribute_Name (N) = Name_Size then
Error_Msg_N Error_Msg_N
("size attribute is only static for scalar type " & ("size attribute is only static for scalar type " &
"('R'M 4.9(7,8))", N); "(RM 4.9(7,8))", N);
-- Flag array cases -- Flag array cases
...@@ -4535,14 +4535,14 @@ package body Sem_Eval is ...@@ -4535,14 +4535,14 @@ package body Sem_Eval is
then then
Error_Msg_N Error_Msg_N
("static array attribute must be Length, First, or Last " & ("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 -- Since we know the expression is not-static (we already
-- tested for this, must mean array is not static). -- tested for this, must mean array is not static).
else else
Error_Msg_N 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; end if;
return; return;
...@@ -4556,7 +4556,7 @@ package body Sem_Eval is ...@@ -4556,7 +4556,7 @@ package body Sem_Eval is
then then
Error_Msg_N Error_Msg_N
("attribute of generic type is never static " & ("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 elsif Is_Static_Subtype (E) then
null; null;
...@@ -4564,43 +4564,43 @@ package body Sem_Eval is ...@@ -4564,43 +4564,43 @@ package body Sem_Eval is
elsif Is_Scalar_Type (E) then elsif Is_Scalar_Type (E) then
Error_Msg_N Error_Msg_N
("prefix type for attribute is not static scalar subtype " & ("prefix type for attribute is not static scalar subtype " &
"('R'M 4.9(7))!", N); "(RM 4.9(7))!", N);
else else
Error_Msg_N Error_Msg_N
("static attribute must apply to array/scalar type " & ("static attribute must apply to array/scalar type " &
"('R'M 4.9(7,8))!", N); "(RM 4.9(7,8))!", N);
end if; end if;
when N_String_Literal => when N_String_Literal =>
Error_Msg_N 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 => when N_Explicit_Dereference =>
Error_Msg_N 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 => when N_Function_Call =>
Why_Not_Static_List (Parameter_Associations (N)); 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 => when N_Parameter_Association =>
Why_Not_Static (Explicit_Actual_Parameter (N)); Why_Not_Static (Explicit_Actual_Parameter (N));
when N_Indexed_Component => when N_Indexed_Component =>
Error_Msg_N 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 => when N_Procedure_Call_Statement =>
Error_Msg_N 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 => when N_Qualified_Expression =>
Why_Not_Static (Expression (N)); Why_Not_Static (Expression (N));
when N_Aggregate | N_Extension_Aggregate => when N_Aggregate | N_Extension_Aggregate =>
Error_Msg_N 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 => when N_Range =>
Why_Not_Static (Low_Bound (N)); Why_Not_Static (Low_Bound (N));
...@@ -4614,11 +4614,11 @@ package body Sem_Eval is ...@@ -4614,11 +4614,11 @@ package body Sem_Eval is
when N_Selected_Component => when N_Selected_Component =>
Error_Msg_N 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 => when N_Slice =>
Error_Msg_N Error_Msg_N
("slice is never static ('R'M 4.9)!", N); ("slice is never static (RM 4.9)!", N);
when N_Type_Conversion => when N_Type_Conversion =>
Why_Not_Static (Expression (N)); Why_Not_Static (Expression (N));
...@@ -4628,12 +4628,12 @@ package body Sem_Eval is ...@@ -4628,12 +4628,12 @@ package body Sem_Eval is
then then
Error_Msg_N Error_Msg_N
("static conversion requires static scalar subtype result " & ("static conversion requires static scalar subtype result " &
"('R'M 4.9(9))!", N); "(RM 4.9(9))!", N);
end if; end if;
when N_Unchecked_Type_Conversion => when N_Unchecked_Type_Conversion =>
Error_Msg_N 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 => when others =>
null; null;
......
gcc/ada/sem_maps.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -55,7 +55,7 @@ package body Sem_Maps is ...@@ -55,7 +55,7 @@ package body Sem_Maps is
--------------------- ---------------------
procedure Add_Association procedure Add_Association
(M : in out Map; (M : Map;
O_Id : Entity_Id; O_Id : Entity_Id;
N_Id : Entity_Id; N_Id : Entity_Id;
Kind : Scope_Kind := S_Local) Kind : Scope_Kind := S_Local)
...@@ -318,7 +318,7 @@ package body Sem_Maps is ...@@ -318,7 +318,7 @@ package body Sem_Maps is
------------------------ ------------------------
procedure Update_Association procedure Update_Association
(M : in out Map; (M : Map;
O_Id : Entity_Id; O_Id : Entity_Id;
N_Id : Entity_Id; N_Id : Entity_Id;
Kind : Scope_Kind := S_Local) Kind : Scope_Kind := S_Local)
......
gcc/ada/sem_maps.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -64,14 +64,14 @@ package Sem_Maps is ...@@ -64,14 +64,14 @@ package Sem_Maps is
-- Retrieve image of E under M, Empty if undefined -- Retrieve image of E under M, Empty if undefined
procedure Add_Association procedure Add_Association
(M : in out Map; (M : Map;
O_Id : Entity_Id; O_Id : Entity_Id;
N_Id : Entity_Id; N_Id : Entity_Id;
Kind : Scope_Kind := S_Local); Kind : Scope_Kind := S_Local);
-- Update M in place. On entry M (O_Id) must not be defined -- Update M in place. On entry M (O_Id) must not be defined
procedure Update_Association procedure Update_Association
(M : in out Map; (M : Map;
O_Id : Entity_Id; O_Id : Entity_Id;
N_Id : Entity_Id; N_Id : Entity_Id;
Kind : Scope_Kind := S_Local); 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