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 390 additions and 272 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-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,12 +79,16 @@ __gnat_arg_count (void) ...@@ -79,12 +79,16 @@ __gnat_arg_count (void)
int int
__gnat_len_arg (int arg_num) __gnat_len_arg (int arg_num)
{ {
if (gnat_argv != NULL)
return strlen (gnat_argv[arg_num]); 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)
{ {
if (gnat_argv != NULL)
strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); strncpy (a, gnat_argv[i], strlen(gnat_argv[i]));
} }
...@@ -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)
{ {
if (gnat_envp != NULL)
return strlen (gnat_envp[env_num]); 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)
{ {
if (gnat_envp != NULL)
strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); 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,6 +86,7 @@ package body Exp_Ch13 is ...@@ -86,6 +86,7 @@ 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
......
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
...@@ -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
...@@ -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
...@@ -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
...@@ -353,6 +353,7 @@ package body System.Stack_Usage is ...@@ -353,6 +353,7 @@ 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,10 +2378,14 @@ package body Scng is ...@@ -2321,10 +2378,14 @@ 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,
-- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
-- for this purpose if they appear as attribute designators.
-- Actually we only check the first character for speed.
-- Ada 2005 (AI-284): Do not apply the style check in case of -- Ada 2005 (AI-284): Do not apply the style check in case of
-- "pragma Interface" -- "pragma Interface"
...@@ -2332,8 +2393,7 @@ package body Scng is ...@@ -2332,8 +2393,7 @@ package body Scng is
-- Ada 2005 (AI-340): Do not apply the style check in case of -- Ada 2005 (AI-340): Do not apply the style check in case of
-- MOD attribute. -- MOD attribute.
if Style_Check if Source (Token_Ptr) <= 'Z'
and then Source (Token_Ptr) <= 'Z'
and then (Prev_Token /= Tok_Apostrophe and then (Prev_Token /= Tok_Apostrophe
or else or else
(Token /= Tok_Access and then (Token /= Tok_Access and then
...@@ -2349,6 +2409,14 @@ package body Scng is ...@@ -2349,6 +2409,14 @@ package body Scng is
Style.Non_Lower_Case_Keyword; Style.Non_Lower_Case_Keyword;
end if; end if;
if (Token = Tok_Then and then Prev_Token /= Tok_And)
or else
(Token = Tok_Else and then Prev_Token /= Tok_Or)
then
Style.Check_Separate_Stmt_Lines;
end if;
end if;
-- We must reset Token_Name since this is not an identifier and -- We must reset Token_Name since this is not an identifier and
-- if we leave Token_Name set, the parser gets confused because -- if we leave Token_Name set, the parser gets confused because
-- it thinks it is dealing with an identifier instead of the -- it thinks it is dealing with an identifier instead of the
...@@ -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_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