diff options
73 files changed, 786 insertions, 581 deletions
diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb index 4aa9ed3b22e..2667871b9bc 100644 --- a/gcc/ada/a-chtgke.adb +++ b/gcc/ada/a-chtgke.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -268,7 +268,7 @@ package body Ada.Containers.Hash_Tables.Generic_Keys is return; end if; - -- The node is a bucket different from the bucket implied by Key. + -- The node is a bucket different from the bucket implied by Key if HT.Busy > 0 then raise Program_Error with diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 8b9c545422c..2a3e1b58c1d 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb index 8e9b9749f68..d7b5eb1de79 100644 --- a/gcc/ada/a-strunb.adb +++ b/gcc/ada/a-strunb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -847,10 +847,12 @@ package body Ada.Strings.Unbounded is (Target : out Unbounded_String; Source : String) is + Old : String_Access := Target.Reference; begin Target.Last := Source'Length; Target.Reference := new String (1 .. Source'Length); Target.Reference.all := Source; + Free (Old); end Set_Unbounded_String; ----------- diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index 3bace41794a..82b2df2f823 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -126,23 +126,22 @@ -- might result in dangling references. -- Another problem with instantiations deeper than the library level is that --- there is risk of storage leakage, or dangling references to reused --- storage. That is, if an instantiation of Ada.Task_Attributes is made --- within a procedure, what happens to the storage allocated for attributes, --- when the procedure call returns? Apparently (RM 7.6.1 (4)) any such --- objects must be finalized, since they will no longer be accessible, and in --- general one would expect that the storage they occupy would be recovered --- for later reuse. (If not, we would have a case of storage leakage.) --- Assuming the storage is recovered and later reused, we have potentially --- dangerous dangling references. When the procedure containing the --- instantiation of Ada.Task_Attributes returns, there may still be --- unterminated tasks with associated attribute values for that instantiation. --- When such tasks eventually terminate, the RTS will attempt to call the --- Deallocate procedure on them. If the corresponding storage has already --- been deallocated, when the master of the access type was left, we have a --- potential disaster. This disaster is compounded since the pointer to --- Deallocate is probably through a "trampoline" which will also have been --- destroyed. +-- there is risk of storage leakage, or dangling references to reused storage. +-- That is, if an instantiation of Ada.Task_Attributes is made within a +-- procedure, what happens to the storage allocated for attributes, when the +-- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be +-- finalized, since they will no longer be accessible, and in general one +-- would expect that the storage they occupy would be recovered for later +-- reuse. (If not, we would have a case of storage leakage.) Assuming the +-- storage is recovered and later reused, we have potentially dangerous +-- dangling references. When the procedure containing the instantiation of +-- Ada.Task_Attributes returns, there may still be unterminated tasks with +-- associated attribute values for that instantiation. When such tasks +-- eventually terminate, the RTS will attempt to call the Deallocate procedure +-- on them. If the corresponding storage has already been deallocated, when +-- the master of the access type was left, we have a potential disaster. This +-- disaster is compounded since the pointer to Deallocate is probably through +-- a "trampoline" which will also have been destroyed. -- For this reason, we arrange to remove all dangling references before -- leaving the scope of an instantiation. This is ugly, since it requires @@ -156,38 +155,36 @@ -- the default initial one. This allows a potential savings in allocation, -- for attributes that are not used by all tasks. --- For efficiency, we reserve space in the TCB for a fixed number of --- direct-access attributes. These are required to be of a size that fits in --- the space of an object of type System.Address. Because we must use --- unchecked bitwise copy operations on these values, they cannot be of a --- controlled type, but that is covered automatically since controlled --- objects are too large to fit in the spaces. - --- We originally deferred the initialization of these direct-access --- attributes, just as we do for the indirect-access attributes, and used a --- per-task bit vector to keep track of which attributes were currently --- defined for that task. We found that the overhead of maintaining this --- bit-vector seriously slowed down access to the attributes, and made the --- fetch operation non-atomic, so that even to read an attribute value --- required locking the TCB. Therefore, we now initialize such attributes for --- all existing tasks at the time of the attribute instantiation, and --- initialize existing attributes for each new task at the time it is --- created. +-- For efficiency, we reserve space in the TCB for a fixed number of direct- +-- access attributes. These are required to be of a size that fits in the +-- space of an object of type System.Address. Because we must use unchecked +-- bitwise copy operations on these values, they cannot be of a controlled +-- type, but that is covered automatically since controlled objects are too +-- large to fit in the spaces. + +-- We originally deferred initialization of these direct-access attributes, +-- just as we do for the indirect-access attributes, and used a per-task bit +-- vector to keep track of which attributes were currently defined for that +-- task. We found that the overhead of maintaining this bit-vector seriously +-- slowed down access to the attributes, and made the fetch operation non- +-- atomic, so that even to read an attribute value required locking the TCB. +-- Therefore, we now initialize such attributes for all existing tasks at the +-- time of the attribute instantiation, and initialize existing attributes for +-- each new task at the time it is created. -- The latter initialization requires a list of all the instantiation -- descriptors. Updates to this list, as well as the bit-vector that is used -- to reserve slots for attributes in the TCB, require mutual exclusion. That -- is provided by the Lock/Unlock_RTS. --- One special problem that added complexity to the design is that the --- per-task list of indirect attributes contains objects of different types. --- We use unchecked pointer conversion to link these nodes together and --- access them, but the records may not have identical internal structure. --- Initially, we thought it would be enough to allocate all the common --- components of the records at the front of each record, so that their --- positions would correspond. Unfortunately, GNAT adds "dope" information at --- the front of a record, if the record contains any controlled-type --- components. +-- One special problem that added complexity to the design is that the per- +-- task list of indirect attributes contains objects of different types. We +-- use unchecked pointer conversion to link these nodes together and access +-- them, but the records may not have identical internal structure. Initially, +-- we thought it would be enough to allocate all the common components of +-- the records at the front of each record, so that their positions would +-- correspond. Unfortunately, GNAT adds "dope" information at the front +-- of a record, if the record contains any controlled-type components. -- -- This means that the offset of the fields we use to link the nodes is at -- different positions on nodes of different types. To get around this, each @@ -211,15 +208,14 @@ -- Value : aliased Attribute; -- the generic formal type -- end record; --- Another interesting problem is with the initialization of the --- instantiation descriptors. Originally, we did this all via the Initialize --- procedure of the descriptor type and code in the package body. It turned --- out that the Initialize procedure needed quite a bit of information, --- including the size of the attribute type, the initial value of the --- attribute (if it fits in the TCB), and a pointer to the deallocator --- procedure. These needed to be "passed" in via access discriminants. GNAT --- was having trouble with access discriminants, so all this work was moved --- to the package body. +-- Another interesting problem is with the initialization of the instantiation +-- descriptors. Originally, we did this all via the Initialize procedure of +-- the descriptor type and code in the package body. It turned out that the +-- Initialize procedure needed quite a bit of information, including the size +-- of the attribute type, the initial value of the attribute (if it fits in +-- the TCB), and a pointer to the deallocator procedure. These needed to be +-- "passed" in via access discriminants. GNAT was having trouble with access +-- discriminants, so all this work was moved to the package body. with System.Error_Reporting; -- Used for Shutdown; @@ -284,11 +280,11 @@ package body Ada.Task_Attributes is type Access_Wrapper is access all Wrapper; pragma Warnings (Off); - -- We turn warnings off for the following declarations of the - -- To_Attribute_Handle conversions, since these are used only for small - -- attributes where we know that there are no problems with alignment, but - -- the compiler will generate warnings for the occurrences in the large - -- attribute case, even though they will not actually be used. + -- We turn warnings off for the following To_Attribute_Handle conversions, + -- since these are used only for small attributes where we know that there + -- are no problems with alignment, but the compiler will generate warnings + -- for the occurrences in the large attribute case, even though they will + -- not actually be used. function To_Attribute_Handle is new Ada.Unchecked_Conversion (System.Address, Attribute_Handle); @@ -342,8 +338,8 @@ package body Ada.Task_Attributes is ------------------------ procedure Deallocate (P : in out Access_Node); - -- Passed to the RTS via unchecked conversion of a pointer to - -- permit finalization and deallocation of attribute storage nodes + -- Passed to the RTS via unchecked conversion of a pointer to permit + -- finalization and deallocation of attribute storage nodes. -------------------------- -- Instantiation Record -- @@ -359,9 +355,9 @@ package body Ada.Task_Attributes is -- The generic formal type, may be controlled end record; - -- A number of unchecked conversions involving Wrapper_Access sources - -- are performed in this unit. We have to ensure that the designated - -- object is always strictly enough aligned. + -- A number of unchecked conversions involving Wrapper_Access sources are + -- performed in this unit. We have to ensure that the designated object is + -- always strictly enough aligned. for Wrapper'Alignment use Standard'Maximum_Alignment; @@ -598,8 +594,7 @@ package body Ada.Task_Attributes is end loop; -- Unlock RTS here to follow the lock ordering rule that prevent us - -- from using new (i.e the Global_Lock) while holding any other - -- lock. + -- from using new (i.e the Global_Lock) while holding any other lock. POP.Unlock_RTS; W := new Wrapper'((null, Local'Unchecked_Access, null), Val); @@ -652,7 +647,7 @@ package body Ada.Task_Attributes is if Local.Index /= 0 then - -- Get value of attribute. Warnings off, because for large + -- Get value of attribute. We turn Warnings off, because for large -- attributes, this code can generate alignment warnings. But of -- course large attributes are never directly addressed so in fact -- we will never execute the code in this case. @@ -708,9 +703,9 @@ package body Ada.Task_Attributes is -- Start of elaboration code for package Ada.Task_Attributes begin - -- This unchecked conversion can give warnings when alignments - -- are incorrect, but they will not be used in such cases anyway, - -- so the warnings can be safely ignored. + -- This unchecked conversion can give warnings when alignments are + -- incorrect, but they will not be used in such cases anyway, so the + -- warnings can be safely ignored. pragma Warnings (Off); Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access); @@ -789,8 +784,7 @@ begin -- Attribute goes into a node onto a linked list else - -- Replace stub for finalization routine that is called at task - -- termination. + -- Replace stub for finalization routine called at task termination Initialization.Finalize_Attributes_Link := System.Tasking.Task_Attributes.Finalize_Attributes'Access; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb index 86a4986be37..c8d58437fd2 100644 --- a/gcc/ada/a-textio.adb +++ b/gcc/ada/a-textio.adb @@ -1810,6 +1810,9 @@ package body Ada.Text_IO is (File : in out Text_AFCB; Item : Stream_Element_Array) is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + function Has_Translated_Characters return Boolean; -- return True if Item array contains a character which will be -- translated under the text file mode. There is only one such @@ -1822,6 +1825,10 @@ package body Ada.Text_IO is Siz : constant size_t := Item'Length; + ------------------------------- + -- Has_Translated_Characters -- + ------------------------------- + function Has_Translated_Characters return Boolean is begin for K in Item'Range loop @@ -1833,7 +1840,10 @@ package body Ada.Text_IO is end Has_Translated_Characters; Needs_Binary_Write : constant Boolean := - text_translation_required and then Has_Translated_Characters; + text_translation_required + and then Has_Translated_Characters; + + -- Start of processing for Write begin if File.Mode = FCB.In_File then @@ -1853,7 +1863,6 @@ package body Ada.Text_IO is -- with text mode if needed. if Needs_Binary_Write then - if fflush (File.Stream) = -1 then raise Device_Error; end if; @@ -1869,7 +1878,6 @@ package body Ada.Text_IO is -- we reset to text mode. if Needs_Binary_Write then - if fflush (File.Stream) = -1 then raise Device_Error; end if; @@ -1887,6 +1895,7 @@ package body Ada.Text_IO is Err_Name : aliased String := "*stderr" & ASCII.Nul; In_Name : aliased String := "*stdin" & ASCII.Nul; Out_Name : aliased String := "*stdout" & ASCII.Nul; + begin ------------------------------- -- Initialize Standard Files -- diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads index 5e8ae4d0829..38b4cb178ea 100644 --- a/gcc/ada/a-textio.ads +++ b/gcc/ada/a-textio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -391,13 +391,13 @@ private Null_Str : aliased constant String := ""; -- Used as name and form of standard files - Standard_Err_AFCB : aliased Text_AFCB; Standard_In_AFCB : aliased Text_AFCB; Standard_Out_AFCB : aliased Text_AFCB; + Standard_Err_AFCB : aliased Text_AFCB; - Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; Standard_In : aliased File_Type := Standard_In_AFCB'Access; Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; -- Standard files Current_In : aliased File_Type := Standard_In; diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb index ab057950ae8..c83230cdea7 100644 --- a/gcc/ada/a-witeio.adb +++ b/gcc/ada/a-witeio.adb @@ -1806,6 +1806,9 @@ package body Ada.Wide_Text_IO is (File : in out Wide_Text_AFCB; Item : Stream_Element_Array) is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + Siz : constant size_t := Item'Length; begin diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb index 2134bd63541..cd4970a554e 100644 --- a/gcc/ada/a-ztexio.adb +++ b/gcc/ada/a-ztexio.adb @@ -1807,6 +1807,9 @@ package body Ada.Wide_Wide_Text_IO is (File : in out Wide_Wide_Text_AFCB; Item : Stream_Element_Array) is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + Siz : constant size_t := Item'Length; begin diff --git a/gcc/ada/ada-tree.h b/gcc/ada/ada-tree.h index fb4f7481f53..5abad09641a 100644 --- a/gcc/ada/ada-tree.h +++ b/gcc/ada/ada-tree.h @@ -37,7 +37,6 @@ enum gnat_tree_code { union lang_tree_node GTY((desc ("0"), chain_next ("(union lang_tree_node *)GENERIC_NEXT (&%h.t)"))) - { union tree_node GTY((tag ("0"))) t; }; diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb index f908cfa002a..fb5eb609234 100644 --- a/gcc/ada/ali-util.adb +++ b/gcc/ada/ali-util.adb @@ -26,7 +26,6 @@ with Debug; use Debug; with Binderr; use Binderr; -with Lib; use Lib; with Opt; use Opt; with Output; use Output; with Osint; use Osint; @@ -248,21 +247,17 @@ package body ALI.Util is then Text := Read_Library_Info (Afile); - -- Return with an error if source cannot be found and if this - -- is not a library generic (now we can, but does not have to - -- compile library generics) + -- Return with an error if source cannot be found. We used to + -- skip this check when we did not compile library generics + -- separately, but we now always do, so there is no special + -- case here anymore. if Text = null then - if Generic_Separately_Compiled (Withs.Table (W).Sfile) then - Error_Msg_File_1 := Afile; - Error_Msg_File_2 := Withs.Table (W).Sfile; - Error_Msg ("{ not found, { must be compiled"); - Set_Name_Table_Info (Afile, Int (No_Unit_Id)); - return; - - else - goto Skip_Library_Generics; - end if; + Error_Msg_File_1 := Afile; + Error_Msg_File_2 := Withs.Table (W).Sfile; + Error_Msg ("{ not found, { must be compiled"); + Set_Name_Table_Info (Afile, Int (No_Unit_Id)); + return; end if; -- Enter in ALIs table @@ -307,8 +302,6 @@ package body ALI.Util is Read_ALI (Idread); end if; - <<Skip_Library_Generics>> null; - -- If the ALI file has already been processed and is an interface, -- set the flag in the entry of the Withs table. diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 12bb7325804..bfb2a0ae943 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -261,16 +261,16 @@ package ALI is -- have an elaboration routine (since it has no elaboration code). Pure : Boolean; - -- Indicates presence of PU parameter for a pure package + -- Indicates presence of PU parameter for a package having pragma Pure Dynamic_Elab : Boolean; - -- Set to True if the unit was compiled with dynamic elaboration - -- checks (i.e. either -gnatE or pragma Elaboration_Checks (RM) - -- was used to compile the unit). + -- Set to True if the unit was compiled with dynamic elaboration checks + -- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to + -- compile the unit). Elaborate_Body : Boolean; - -- Indicates presence of EB parameter for a package which has a - -- pragma Preelaborate_Body. + -- Indicates presence of EB parameter for a package which has a pragma + -- Elaborate_Body, and also for generic package instantiations. Set_Elab_Entity : Boolean; -- Indicates presence of EE parameter for a unit which has an @@ -278,20 +278,20 @@ package ALI is -- elaboration of the entity. Has_RACW : Boolean; - -- Indicates presence of RA parameter for a package that declares - -- at least one Remote Access to Class_Wide (RACW) object. + -- Indicates presence of RA parameter for a package that declares at + -- least one Remote Access to Class_Wide (RACW) object. Remote_Types : Boolean; -- Indicates presence of RT parameter for a package which has a -- pragma Remote_Types. Shared_Passive : Boolean; - -- Indicates presence of SP parameter for a package which has a - -- pragma Shared_Passive. + -- Indicates presence of SP parameter for a package which has a pragma + -- Shared_Passive. RCI : Boolean; - -- Indicates presence of RC parameter for a package which has a - -- pragma Remote_Call_Interface. + -- Indicates presence of RC parameter for a package which has a pragma + -- Remote_Call_Interface. Predefined : Boolean; -- Indicates if unit is language predefined (or a child of such a unit) @@ -327,13 +327,13 @@ package ALI is Icasing : Casing_Type; -- Indicates casing of identifiers in source file for this unit. This - -- is used for informational output, and also for constructing the - -- main unit if it is being built in Ada. + -- is used for informational output, and also for constructing the main + -- unit if it is being built in Ada. Kcasing : Casing_Type; - -- Indicates casing of keyowords in source file for this unit. This - -- is used for informational output, and also for constructing the - -- main unit if it is being built in Ada. + -- Indicates casing of keywords in source file for this unit. This is + -- used for informational output, and also for constructing the main + -- unit if it is being built in Ada. Elab_Position : aliased Natural; -- Initialized to zero. Set non-zero when a unit is chosen and diff --git a/gcc/ada/argv.c b/gcc/ada/argv.c index fa54bcecaac..276edf7e0f2 100644 --- a/gcc/ada/argv.c +++ b/gcc/ada/argv.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2003 Free Software Foundation, Inc. * + * Copyright (C) 1992-2007, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -79,13 +79,17 @@ __gnat_arg_count (void) int __gnat_len_arg (int arg_num) { - return strlen (gnat_argv[arg_num]); + if (gnat_argv != NULL) + return strlen (gnat_argv[arg_num]); + else + return 0; } void __gnat_fill_arg (char *a, int i) { - strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); + if (gnat_argv != NULL) + strncpy (a, gnat_argv[i], strlen(gnat_argv[i])); } int @@ -101,11 +105,15 @@ __gnat_env_count (void) int __gnat_len_env (int env_num) { - return strlen (gnat_envp[env_num]); + if (gnat_envp != NULL) + return strlen (gnat_envp[env_num]); + else + return 0; } void __gnat_fill_env (char *a, int i) { - strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); + if (gnat_envp != NULL) + strncpy (a, gnat_envp[i], strlen (gnat_envp[i])); } diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb index 15b6b1ebb0e..e157e8c1720 100644 --- a/gcc/ada/bcheck.adb +++ b/gcc/ada/bcheck.adb @@ -202,7 +202,7 @@ package body Bcheck is elsif Tolerate_Consistency_Errors then Error_Msg - ("?% should be recompiled (% has been modified)"); + ("?{ should be recompiled ({ has been modified)"); else Error_Msg ("{ must be recompiled ({ has been modified)"); diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index 565c36870e6..9c4209fa64c 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -948,7 +948,8 @@ package body CStand is Set_Ekind (Any_Id, E_Variable); Set_Scope (Any_Id, Standard_Standard); Set_Etype (Any_Id, Any_Type); - Init_Size_Align (Any_Id); + Init_Esize (Any_Id); + Init_Alignment (Any_Id); Make_Name (Any_Id, "any id"); Any_Access := New_Standard_Entity; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index a9dc657daed..52bd105456d 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -86,7 +86,8 @@ package body Exp_Ch13 is -- original node is in the source. An exception though is the case -- of an access variable which is default initialized to null, and -- such initialization is retained. - -- Furthermore, if the initialization is the equivalent aggregate + + -- Furthermore, if the initialization is the equivalent aggregate -- of the type initialization procedure, it replaces an implicit -- call to the init proc, and must be respected. Note that for -- packed types we do not build equivalent aggregates. diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads index a052a84d6fc..e74eb9f628f 100644 --- a/gcc/ada/exp_ch5.ads +++ b/gcc/ada/exp_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,5 +37,5 @@ package Exp_Ch5 is procedure Expand_N_Goto_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_Loop_Statement (N : Node_Id); - procedure Expand_N_Return_Statement (N : Node_Id); + procedure Expand_N_Simple_Return_Statement (N : Node_Id); end Exp_Ch5; diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 367ed2d6775..959284a5caa 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -673,7 +673,7 @@ package body Exp_Dbug is -- If the front end has already computed a fully qualified name, -- then it is also the case that no further qualification is - -- required + -- required. if Present (Scope (Scope (Entity))) and then not Has_Fully_Qualified_Name (Entity) @@ -1331,6 +1331,9 @@ package body Exp_Dbug is procedure Strip_Suffixes (BNPE_Suffix_Found : in out Boolean) is SL : Natural; + pragma Warnings (Off, BNPE_Suffix_Found); + -- Since this procedure only ever sets the flag + begin -- Search for and strip BNPE suffix diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 7c9812cec33..475d8394efd 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -219,7 +219,7 @@ package body Exp_Strm is Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_V))), - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Identifier (Loc, Name_V))); Fnam := @@ -1158,7 +1158,7 @@ package body Exp_Strm is Make_Identifier (Loc, Name_S), Make_Identifier (Loc, Name_V))), - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Identifier (Loc, Name_V))); Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input); diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 103716a98b3..04809098abb 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -379,8 +379,8 @@ package body Expander is when N_Requeue_Statement => Expand_N_Requeue_Statement (N); - when N_Return_Statement => - Expand_N_Return_Statement (N); + when N_Simple_Return_Statement => + Expand_N_Simple_Return_Statement (N); when N_Selected_Component => Expand_N_Selected_Component (N); diff --git a/gcc/ada/g-altcon.adb b/gcc/ada/g-altcon.adb index a1f2d3f3e58..f04745ac172 100644 --- a/gcc/ada/g-altcon.adb +++ b/gcc/ada/g-altcon.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -78,7 +78,7 @@ package body GNAT.Altivec.Conversions is -- relying on internal knowledge about the bits layout in the different -- types (all 128 value bits blocks). - -- View<->Vector straight bitwise conversions on BE targets. + -- View<->Vector straight bitwise conversions on BE targets function UNC_To_Vector is new Ada.Unchecked_Conversion (View_Type, Vector_Type); @@ -86,7 +86,7 @@ package body GNAT.Altivec.Conversions is function UNC_To_View is new Ada.Unchecked_Conversion (Vector_Type, View_Type); - -- Varray->Vector/View for returning mirrored results on LE targets. + -- Varray->Vector/View for returning mirrored results on LE targets function UNC_To_Vector is new Ada.Unchecked_Conversion (Varray_Type, Vector_Type); @@ -94,7 +94,7 @@ package body GNAT.Altivec.Conversions is function UNC_To_View is new Ada.Unchecked_Conversion (Varray_Type, View_Type); - -- Vector/View->Varray for to-be-permuted source on LE targets. + -- Vector/View->Varray for to-be-permuted source on LE targets function UNC_To_Varray is new Ada.Unchecked_Conversion (Vector_Type, Varray_Type); diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb index 3ba99353e42..bb8ff93fb20 100644 --- a/gcc/ada/g-dirope.adb +++ b/gcc/ada/g-dirope.adb @@ -647,7 +647,7 @@ package body GNAT.Directory_Operations is ---------- procedure Read - (Dir : in out Dir_Type; + (Dir : Dir_Type; Str : out String; Last : out Natural) is diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads index 11d90704846..060c3c439d9 100644 --- a/gcc/ada/g-dirope.ads +++ b/gcc/ada/g-dirope.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2005, AdaCore -- +-- Copyright (C) 1998-2007, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -230,7 +230,7 @@ package GNAT.Directory_Operations is -- Returns True if Dir is open, or False otherwise procedure Read - (Dir : in out Dir_Type; + (Dir : Dir_Type; Str : out String; Last : out Natural); -- Reads the next entry from the directory and sets Str to the name diff --git a/gcc/ada/g-eacodu.adb b/gcc/ada/g-eacodu.adb index e586f3b0564..a9a71648c69 100644 --- a/gcc/ada/g-eacodu.adb +++ b/gcc/ada/g-eacodu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003 Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the default (Unix) version. +-- This is the default (Unix) version separate (GNAT.Exception_Actions) procedure Core_Dump (Occurrence : Exception_Occurrence) is diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index 453a35b218f..a10b097c196 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -74,6 +74,12 @@ package Itypes is -- call to New_Copy_Tree is to create a complete duplicate of a tree, -- as though it had appeared separately in the source), the Itype in -- question is duplicated as part of the New_Copy_Tree processing. + -- As a consequence of this copying mechanism, the association between + -- itypes and associated nodes must be one-to-one: several itypes must + -- not share an associated node. For example, the semantic decoration + -- of an array aggregate generates several itypes: for each index subtype + -- and for the array subtype. The associated node of each index subtype + -- is the corresponding range expression. ----------------- -- Subprograms -- diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index d71b40d8f8e..9082a453f40 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -332,7 +332,7 @@ package body Ch12 is begin Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); - -- Ada2005: an association can be given by: others => <>. + -- Ada2005: an association can be given by: others => <> if Token = Tok_Others then if Ada_Version < Ada_05 then @@ -375,7 +375,7 @@ package body Ch12 is end if; end if; - -- In Ada 2005 the actual can be a box. + -- In Ada 2005 the actual can be a box if Token = Tok_Box then Scan; diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index e2863bf332a..4e0c5c4a1b3 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -177,7 +177,7 @@ package body Ch2 is -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' - -- Handled by the scanner and returned as Tok_Character_Literal + -- Handled by the scanner and returned as Tok_Char_Literal ------------------------- -- 2.6 String Literal -- @@ -185,7 +185,7 @@ package body Ch2 is -- STRING LITERAL ::= "{STRING_ELEMENT}" - -- Handled by the scanner and returned as Tok_Character_Literal + -- Handled by the scanner and returned as Tok_String_Literal -- or if the string looks like an operator as Tok_Operator_Symbol. ------------------------- @@ -479,7 +479,7 @@ package body Ch2 is if Identifier_Seen then Error_Msg_SC - ("|pragma argument identifier required here ('R'M' 2.8(4))"); + ("|pragma argument identifier required here (RM 2.8(4))"); end if; end if; end if; diff --git a/gcc/ada/s-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb index 867aafd183a..b6b8395d498 100644 --- a/gcc/ada/s-asthan-vms-alpha.adb +++ b/gcc/ada/s-asthan-vms-alpha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is the OpenVMS/Alpha version. +-- This is the OpenVMS/Alpha version with System; use System; @@ -205,7 +205,7 @@ package body System.AST_Handling is end record; AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null. + -- Initial value, treated as constant, Vector will be null package AST_Attribute is new Ada.Task_Attributes (Attribute => AST_Vector_Ptr, @@ -241,7 +241,7 @@ package body System.AST_Handling is AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests. + -- The circular buffer used to store active AST requests AST_Service_Queue_Put : AST_Service_Queue_Index := 0; AST_Service_Queue_Get : AST_Service_Queue_Index := 0; @@ -583,7 +583,7 @@ package body System.AST_Handling is if Is_Waiting (J) then Is_Waiting (J) := False; - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. + -- Sleeps are handled by ASTs on VMS, so don't call Wakeup STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); exit; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index 2dac1b1a178..d7d94957c0b 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.adb @@ -319,6 +319,10 @@ package body System.Direct_IO is procedure Do_Write; -- Do the actual write + -------------- + -- Do_Write -- + -------------- + procedure Do_Write is begin FIO.Write_Buf (AP (File), Item, Size); diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads index 34ff065c7bf..5dc5c1fa563 100644 --- a/gcc/ada/s-except.ads +++ b/gcc/ada/s-except.ads @@ -42,7 +42,7 @@ package System.Exceptions is pragma Warnings (Off); pragma Preelaborate_05; pragma Warnings (On); - -- To let Ada.Exceptions "with" us and let us "with" Standard_Library. + -- To let Ada.Exceptions "with" us and let us "with" Standard_Library package SSL renames System.Standard_Library; -- To let some of the hooks below have formal parameters typed in diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads index 762690bab33..95622aea7c5 100644 --- a/gcc/ada/s-htable.ads +++ b/gcc/ada/s-htable.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2005 AdaCore -- +-- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -54,7 +54,7 @@ package System.HTable is generic type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers. + -- An integer type indicating the number and range of hash headers type Element is private; -- The type of element to be stored @@ -120,7 +120,7 @@ package System.HTable is generic type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers. + -- An integer type indicating the number and range of hash headers type Element (<>) is limited private; -- The type of element to be stored. This is historically part of the @@ -137,7 +137,7 @@ package System.HTable is -- type, but could be some other form of type such as an integer type). Null_Ptr : Elmt_Ptr; - -- The null value of the Elmt_Ptr type. + -- The null value of the Elmt_Ptr type with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); with function Next (E : Elmt_Ptr) return Elmt_Ptr; diff --git a/gcc/ada/s-imgboo.ads b/gcc/ada/s-imgboo.ads index 3723f585fca..c632d4d36b3 100644 --- a/gcc/ada/s-imgboo.ads +++ b/gcc/ada/s-imgboo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -37,6 +37,6 @@ package System.Img_Bool is pragma Pure; function Image_Boolean (V : Boolean) return String; - -- Computes Boolean'Image (V) and returns the result. + -- Computes Boolean'Image (V) and returns the result end System.Img_Bool; diff --git a/gcc/ada/s-imglli.ads b/gcc/ada/s-imglli.ads index 8137f3d43dd..6401674fa0b 100644 --- a/gcc/ada/s-imglli.ads +++ b/gcc/ada/s-imglli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -39,7 +39,7 @@ package System.Img_LLI is pragma Preelaborate; function Image_Long_Long_Integer (V : Long_Long_Integer) return String; - -- Computes Long_Long_Integer'Image (V) and returns the result. + -- Computes Long_Long_Integer'Image (V) and returns the result procedure Set_Image_Long_Long_Integer (V : Long_Long_Integer; diff --git a/gcc/ada/s-imgllu.ads b/gcc/ada/s-imgllu.ads index 318152ca960..5c17399ba5c 100644 --- a/gcc/ada/s-imgllu.ads +++ b/gcc/ada/s-imgllu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package System.Img_LLU is function Image_Long_Long_Unsigned (V : System.Unsigned_Types.Long_Long_Unsigned) return String; - -- Computes Long_Long_Unsigned'Image (V) and returns the result. + -- Computes Long_Long_Unsigned'Image (V) and returns the result procedure Set_Image_Long_Long_Unsigned (V : System.Unsigned_Types.Long_Long_Unsigned; diff --git a/gcc/ada/s-imguns.ads b/gcc/ada/s-imguns.ads index 6ce8898a171..6ec636b4fe1 100644 --- a/gcc/ada/s-imguns.ads +++ b/gcc/ada/s-imguns.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -43,7 +43,7 @@ package System.Img_Uns is function Image_Unsigned (V : System.Unsigned_Types.Unsigned) return String; - -- Computes Unsigned'Image (V) and returns the result. + -- Computes Unsigned'Image (V) and returns the result procedure Set_Image_Unsigned (V : System.Unsigned_Types.Unsigned; diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb index ebd66950652..3c04bb0e074 100644 --- a/gcc/ada/s-inmaop-vms.adb +++ b/gcc/ada/s-inmaop-vms.adb @@ -283,6 +283,8 @@ package body System.Interrupt_Management.Operations is P1 => To_unsigned_long (Interrupt'Address), P2 => Interrupt_ID'Size / 8); + -- The following could use a comment ??? + pragma Assert ((Status and 1) = 1); end Interrupt_Self_Process; diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb index f5eb510558a..6b0037fe771 100644 --- a/gcc/ada/s-interr.adb +++ b/gcc/ada/s-interr.adb @@ -257,7 +257,7 @@ package body System.Interrupts is Registered_Handler_Tail : R_Link := null; Access_Hold : Server_Task_Access; - -- variable used to allocate Server_Task using "new". + -- Variable used to allocate Server_Task using "new" ----------------------- -- Local Subprograms -- @@ -920,7 +920,7 @@ package body System.Interrupts is if New_Handler = null then - -- The null handler means we are detaching the handler. + -- The null handler means we are detaching the handler User_Handler (Interrupt).Static := False; @@ -1267,18 +1267,18 @@ package body System.Interrupts is System.Tasking.Utilities.Make_Independent; - -- Install default action in system level. + -- Install default action in system level IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - -- Note: All tasks in RTS will have all the Reserve Interrupts - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. + -- Note: All tasks in RTS will have all the Reserve Interrupts being + -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked when + -- created. - -- Abort_Task_Interrupt is one of the Interrupt unmasked - -- in all tasks. We mask the Interrupt in this particular task - -- so that "sigwait" is possible to catch an explicitely sent - -- Abort_Task_Interrupt from the Interrupt_Manager. + -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. + -- We mask the Interrupt in this particular task so that "sigwait" is + -- possible to catch an explicitely sent Abort_Task_Interrupt from the + -- Interrupt_Manager. -- There are two Interrupt interrupts that this task catch through -- "sigwait." One is the Interrupt this task is designated to catch @@ -1287,7 +1287,7 @@ package body System.Interrupts is -- Interrupt_Manager to inform status changes (e.g: become Blocked, -- Handler or Entry is to be detached). - -- Prepare a mask to used for sigwait. + -- Prepare a mask to used for sigwait IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); @@ -1361,7 +1361,7 @@ package body System.Interrupts is if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then - -- Inform the Interrupt_Manager of wakeup from above sigwait. + -- Inform the Interrupt_Manager of wakeup from above sigwait POP.Abort_Task (Interrupt_Manager_ID); @@ -1397,7 +1397,7 @@ package body System.Interrupts is if User_Handler (Interrupt).H /= null then Tmp_Handler := User_Handler (Interrupt).H; - -- RTS calls should not be made with self being locked. + -- RTS calls should not be made with self being locked POP.Unlock (Self_ID); @@ -1417,7 +1417,7 @@ package body System.Interrupts is Tmp_ID := User_Entry (Interrupt).T; Tmp_Entry_Index := User_Entry (Interrupt).E; - -- RTS calls should not be made with self being locked. + -- RTS calls should not be made with self being locked if Single_Lock then POP.Unlock_RTS; @@ -1470,7 +1470,7 @@ package body System.Interrupts is -- Elaboration code for package System.Interrupts begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads index 6481fc2bd06..a01b4c0b4fd 100644 --- a/gcc/ada/s-interr.ads +++ b/gcc/ada/s-interr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -134,7 +134,7 @@ package System.Interrupts is -- already bound to another entry, Program_Error will be raised. procedure Detach_Interrupt_Entries (T : System.Tasking.Task_Id); - -- This procedure detaches all the Interrupt Entries bound to a task. + -- This procedure detaches all the Interrupt Entries bound to a task ------------------------------ -- POSIX.5 Signals Services -- @@ -157,7 +157,7 @@ package System.Interrupts is -- Comment needed ??? procedure Ignore_Interrupt (Interrupt : Interrupt_ID); - -- Set the sigacion for the interrupt to SIG_IGN. + -- Set the sigacion for the interrupt to SIG_IGN procedure Unignore_Interrupt (Interrupt : Interrupt_ID); -- Comment needed ??? diff --git a/gcc/ada/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb index 9a115106672..382ccb3e2e5 100644 --- a/gcc/ada/s-intman-dummy.adb +++ b/gcc/ada/s-intman-dummy.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a NO tasking version of this package. +-- This is a NO tasking version of this package package body System.Interrupt_Management is diff --git a/gcc/ada/s-intman-irix.adb b/gcc/ada/s-intman-irix.adb index 71efec9721b..ccd91bfa7c8 100644 --- a/gcc/ada/s-intman-irix.adb +++ b/gcc/ada/s-intman-irix.adb @@ -6,8 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-1994, Florida State University -- ---- Copyright (C) 1995-2006, AdaCore -- +-- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,13 +31,11 @@ -- -- ------------------------------------------------------------------------------ --- This is a SGI Pthread version of this package. +-- This is a SGI Pthread version of this package --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. --- Be on the lookout for special signals that --- may be used by the thread library. +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. package body System.Interrupt_Management is diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb index d4d80089bf3..bf4e004bab9 100644 --- a/gcc/ada/s-intman-vms.adb +++ b/gcc/ada/s-intman-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- This is a OpenVMS/Alpha version of this package. +-- This is a OpenVMS/Alpha version of this package package body System.Interrupt_Management is diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads index 028facc79fd..ff0c8240193 100644 --- a/gcc/ada/s-intman-vms.ads +++ b/gcc/ada/s-intman-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -67,11 +67,9 @@ package System.Interrupt_Management is -- all systems, but is always reserved when it is defined. If we have the -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can - -- write - + -- write: -- Reserved (SIGRARE) := true; - - -- Then the initialization code will be portable + -- Then the initialization code will be portable. Abort_Task_Interrupt : Interrupt_ID; -- The interrupt that is used to implement task abort, if an interrupt is diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb index faf71e7e2a3..89071e7d1e2 100644 --- a/gcc/ada/s-intman-vxworks.adb +++ b/gcc/ada/s-intman-vxworks.adb @@ -31,13 +31,11 @@ -- -- ------------------------------------------------------------------------------ --- This is the VxWorks version of this package. +-- This is the VxWorks version of this package --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. --- Be on the lookout for special signals that --- may be used by the thread library. +-- Make a careful study of all signals available under the OS, to see which +-- need to be reserved, kept always unmasked, or kept always unmasked. Be on +-- the lookout for special signals that may be used by the thread library. package body System.Interrupt_Management is @@ -62,9 +60,8 @@ package body System.Interrupt_Management is function State (Int : Interrupt_ID) return Character; pragma Import (C, State, "__gnat_get_interrupt_state"); - -- Get interrupt state. Defined in init.c - -- The input argument is the interrupt number, - -- and the result is one of the following: + -- Get interrupt state. Defined in init.c The input argument is the + -- interrupt number, and the result is one of the following: Runtime : constant Character := 'r'; Default : constant Character := 's'; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads index 3bddb5d0ee6..ec332684521 100644 --- a/gcc/ada/s-intman-vxworks.ads +++ b/gcc/ada/s-intman-vxworks.ads @@ -78,9 +78,7 @@ package System.Interrupt_Management is -- convention that ID zero is not used for any "real" signals, and SIGRARE -- = 0 when SIGRARE is not one of the locally supported signals, we can -- write: - -- Reserved (SIGRARE) := true; - -- and the initialization code will be portable. Abort_Task_Interrupt : Signal_ID; diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads index 95f0da5da8b..c60cae66385 100644 --- a/gcc/ada/s-mastop.ads +++ b/gcc/ada/s-mastop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,8 +88,17 @@ package System.Machine_State_Operations is -- Some architectures (notably VMS) use a descriptor to describe -- a subprogram address. This function computes the actual starting -- address of the code from Loc. - -- Do not add pragma Inline, see 9116-002. + -- -- ??? This function will go away when 'Code_Address is fixed on VMS. + -- + -- Do not add pragma Inline to this function: there is a curious + -- interaction between rtsfind and front-end inlining. The exception + -- declaration in s-auxdec calls rtsfind, which forces several other system + -- packages to be compiled. Some of those have a pragma Inline, and we + -- compile the corresponding bodies so that inlining can take place. One + -- of these packages is s-mastop, which depends on s-auxdec, which is still + -- being compiled: we have not seen all the declarations in it yet, so we + -- get confused semantic errors. procedure Set_Machine_State (M : Machine_State); -- This routine sets M from the current machine state. It is called diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index 7b7dcf28968..843b3b18049 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -32,14 +32,13 @@ -- -- ------------------------------------------------------------------------------ --- This is Darwin pthreads version of this package. +-- This is Darwin pthreads version of this package --- This package includes all direct interfaces to OS services --- that are needed by children of System. +-- This package includes all direct interfaces to OS services that are needed +-- by children of System. --- PLEASE DO NOT add any with-clauses to this package --- or remove the pragma Elaborate_Body. --- It is designed to be a bottom-level (leaf) package. +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Elaborate_Body. It is designed to be a bottom-level (leaf) package. with Interfaces.C; package System.OS_Interface is @@ -115,10 +114,10 @@ package System.OS_Interface is type Signal_Set is array (Natural range <>) of Signal; - Unmasked : constant Signal_Set := + Unmasked : constant Signal_Set := (SIGTTIN, SIGTTOU, SIGSTOP, SIGTSTP); - Reserved : constant Signal_Set := + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); type sigset_t is private; @@ -174,7 +173,7 @@ package System.OS_Interface is ---------- Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported. + -- Indicates wether time slicing is supported type timespec is private; @@ -210,7 +209,7 @@ package System.OS_Interface is function To_Target_Priority (Prio : System.Any_Priority) return Interfaces.C.int; - -- Maps System.Any_Priority to a POSIX priority. + -- Maps System.Any_Priority to a POSIX priority ------------- -- Process -- diff --git a/gcc/ada/s-osinte-hpux-dce.adb b/gcc/ada/s-osinte-hpux-dce.adb index ddbeabf2b02..ea8f80810b0 100644 --- a/gcc/ada/s-osinte-hpux-dce.adb +++ b/gcc/ada/s-osinte-hpux-dce.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2005, AdaCore -- +-- Copyright (C) 1995-2007, AdaCore -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -126,7 +126,7 @@ package body System.OS_Interface is return 0; end sigwait; - -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it. + -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it function pthread_kill (thread : pthread_t; sig : Signal) return int is pragma Unreferenced (thread, sig); diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads index 716668939c1..dbc8589d44f 100644 --- a/gcc/ada/s-osinte-hpux-dce.ads +++ b/gcc/ada/s-osinte-hpux-dce.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -291,9 +291,8 @@ package System.OS_Interface is (how : int; set : access sigset_t; oset : access sigset_t) return int; - -- DCE THREADS does not have pthread_sigmask. Instead, it uses - -- sigprocmask to do the signal handling when the thread library is - -- sucked in. + -- DCE THREADS does not have pthread_sigmask. Instead, it uses sigprocmask + -- to do the signal handling when the thread library is sucked in. pragma Import (C, pthread_sigmask, "sigprocmask"); -------------------------- @@ -302,7 +301,7 @@ package System.OS_Interface is function pthread_mutexattr_init (attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutexattr_init. + -- DCE_THREADS has a nonstandard pthread_mutexattr_init function pthread_mutexattr_destroy (attr : access pthread_mutexattr_t) return int; diff --git a/gcc/ada/s-osinte-irix.adb b/gcc/ada/s-osinte-irix.adb index cea0d9c4dd5..ce4e38cc683 100644 --- a/gcc/ada/s-osinte-irix.adb +++ b/gcc/ada/s-osinte-irix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,14 +31,14 @@ -- -- ------------------------------------------------------------------------------ --- This is the IRIX version of this package. +-- This is the IRIX version of this package --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. +-- This package encapsulates all direct interfaces to OS services that are +-- needed by children of System. pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. +-- Turn off polling, we do not want ATC polling to take place during tasking +-- operations. It causes infinite loops and other problems. with Interfaces.C; use Interfaces.C; diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads index 2159bb7b7c9..5ae83163812 100644 --- a/gcc/ada/s-osinte-irix.ads +++ b/gcc/ada/s-osinte-irix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -119,7 +119,7 @@ package System.OS_Interface is SIGCKPT : constant := 33; -- Checkpoint warning SIGRESTART : constant := 34; -- Restart warning SIGUME : constant := 35; -- Uncorrectable memory error - -- Signals defined for Posix 1003.1c. + -- Signals defined for Posix 1003.1c SIGPTINTR : constant := 47; SIGPTRESCHED : constant := 48; -- Posix 1003.1b signals diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 8807efffcbe..ff1c9a31baa 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -99,7 +99,7 @@ package body System.OS_Primitives is Base_Ticks : aliased LARGE_INTEGER; BTA : constant LIA := Base_Ticks'Access; - -- Holds the Tick count for the base time. + -- Holds the Tick count for the base time Base_Monotonic_Ticks : aliased LARGE_INTEGER; BMTA : constant LIA := Base_Monotonic_Ticks'Access; @@ -160,8 +160,8 @@ package body System.OS_Primitives is -- If we have a shift of more than Max_Shift seconds we resynchonize the -- Clock. This is probably due to a manual Clock adjustment, an DST - -- adjustment or an NTP synchronisation. And we want to adjust the - -- time for this system (non-monotonic) clock. + -- adjustment or an NTP synchronisation. And we want to adjust the time + -- for this system (non-monotonic) clock. if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then Get_Base_Time; @@ -180,7 +180,7 @@ package body System.OS_Primitives is procedure Get_Base_Time is - -- The resolution for GetSystemTime is 1 millisecond. + -- The resolution for GetSystemTime is 1 millisecond -- The time to get both base times should take less than 1 millisecond. -- Therefore, the elapsed time reported by GetSystemTime between both diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads index d4a561caab8..a2a5c0647e1 100644 --- a/gcc/ada/s-parame-ae653.ads +++ b/gcc/ada/s-parame-ae653.ads @@ -193,7 +193,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 32; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index 2bda354c18f..86bc0282e51 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,7 +191,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads index ee1297e2eb7..6df2a47aa12 100644 --- a/gcc/ada/s-parame-vms-alpha.ads +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,7 +191,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index 55c228d1ab0..10332527a68 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,7 +191,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads index 62ccb67944d..6cd04775023 100644 --- a/gcc/ada/s-parame-vms-restrict.ads +++ b/gcc/ada/s-parame-vms-restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,7 +191,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame-vxworks.adb b/gcc/ada/s-parame-vxworks.adb index fce8584d74c..e5152c75ed3 100644 --- a/gcc/ada/s-parame-vxworks.adb +++ b/gcc/ada/s-parame-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,7 @@ -- -- ------------------------------------------------------------------------------ --- Version used on all VxWorks targets. +-- Version used on all VxWorks targets package body System.Parameters is diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index b1505328904..4f7cc2c7fcb 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -193,7 +193,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 32; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index bbe0b9bde1b..20c95bea0c4 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -191,7 +191,7 @@ package System.Parameters is ----------------------- Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image. + -- This constant specifies the maximum length of a task's image ------------------------------ -- Exception Message Length -- diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index 278b935e17f..22d4a3d13f0 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -40,12 +40,11 @@ package body System.Pool_Size is package SSE renames System.Storage_Elements; use type SSE.Storage_Offset; - -- Even though these storage pools are typically only used - -- by a single task, if multiple tasks are declared at the - -- same or a more nested scope as the storage pool, there - -- still may be concurrent access. The current implementation - -- of Stack_Bounded_Pool always uses a global lock for protecting - -- access. This should eventually be replaced by an atomic + -- Even though these storage pools are typically only used by a single + -- task, if multiple tasks are declared at the same or a more nested scope + -- as the storage pool, there still may be concurrent access. The current + -- implementation of Stack_Bounded_Pool always uses a global lock for + -- protecting access. This should eventually be replaced by an atomic -- linked list implementation for efficiency reasons. package SSL renames System.Soft_Links; @@ -58,9 +57,9 @@ package body System.Pool_Size is package Variable_Size_Management is - -- Embedded pool that manages allocation of variable-size data. + -- Embedded pool that manages allocation of variable-size data - -- This pool is used as soon as the Elmt_sizS of the pool object is 0. + -- This pool is used as soon as the Elmt_sizS of the pool object is 0 -- Allocation is done on the first chunk long enough for the request. -- Deallocation just puts the freed chunk at the beginning of the list. diff --git a/gcc/ada/s-proinf-irix-athread.ads b/gcc/ada/s-proinf-irix-athread.ads index 40b0cb6443b..47f669ab8ea 100644 --- a/gcc/ada/s-proinf-irix-athread.ads +++ b/gcc/ada/s-proinf-irix-athread.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,20 +31,19 @@ -- -- ------------------------------------------------------------------------------ --- This package contains the definitions and routines used as parameters --- to the run-time system at program startup for the SGI implementation. +-- This package contains the definitions and routines used as parameters to +-- the run-time system at program startup for the SGI implementation. package System.Program_Info is pragma Preelaborate; function Initial_Sproc_Count return Integer; - -- The number of sproc created at program startup for scheduling - -- threads. + -- The number of sproc created at program startup for scheduling threads function Max_Sproc_Count return Integer; - -- The maximum number of sprocs that can be created by the program - -- for servicing threads. This limit includes both the pre-created - -- sprocs and those explicitly created under program control. + -- The maximum number of sprocs that can be created by the program for + -- servicing threads. This limit includes both the pre-created sprocs and + -- those explicitly created under program control. function Sproc_Stack_Size return Integer; -- The size, in bytes, of the sproc's initial stack. @@ -56,9 +55,9 @@ package System.Program_Info is -- Task_Info pragma. See s-tasinf.ads for more information. function Default_Task_Stack return Integer; - -- The default stack size for each created thread. This default value - -- can be overriden on a per-task basis by the language-defined - -- Storage_Size pragma. + -- The default stack size for each created thread. This default value can + -- be overriden on a per-task basis by the language-defined Storage_Size + -- pragma. function Stack_Guard_Pages return Integer; -- The number of non-writable, guard pages to append to the bottom of diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads index 7ccf95b57cd..8e5e9242721 100644 --- a/gcc/ada/s-stache.ads +++ b/gcc/ada/s-stache.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -73,7 +73,7 @@ private (Limit => System.Null_Address, Base => System.Null_Address, Size => 0); - -- Use explicit assignment to avoid elaboration code (call to init proc). + -- Use explicit assignment to avoid elaboration code (call to init proc) Null_Stack : constant Stack_Access := Null_Stack_Info'Access; -- Stack_Access value that will return a Stack_Base and Stack_Limit diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb index a76660dc6b9..9e354ae3015 100644 --- a/gcc/ada/s-stausa.adb +++ b/gcc/ada/s-stausa.adb @@ -352,7 +352,8 @@ package body System.Stack_Usage is Task_Name_Blanks : constant String (1 .. Task_Name_Length - Task_Name_Str'Length) := - (others => ' '); + (others => ' '); + begin Set_Output (Standard_Error); @@ -362,6 +363,7 @@ package body System.Stack_Usage is end if; if Result_Array'Length > 0 then + -- Computes the size of the largest strings that will get displayed, -- in order to do correct column alignment. diff --git a/gcc/ada/s-tasinf-solaris.adb b/gcc/ada/s-tasinf-solaris.adb index 5cbc1891965..4bad233ca2f 100644 --- a/gcc/ada/s-tasinf-solaris.adb +++ b/gcc/ada/s-tasinf-solaris.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -34,14 +34,13 @@ -- This package body contains the routines associated with the implementation -- of the Task_Info pragma. --- This is the Solaris (native) version of this module. +-- This is the Solaris (native) version of this module package body System.Task_Info is - function Unbound_Thread_Attributes return Thread_Attributes is - begin - return (False, False); - end Unbound_Thread_Attributes; + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- function Bound_Thread_Attributes return Thread_Attributes is begin @@ -54,10 +53,9 @@ package body System.Task_Info is return (True, True, CPU); end Bound_Thread_Attributes; - function New_Unbound_Thread_Attributes return Task_Info_Type is - begin - return new Thread_Attributes'(False, False); - end New_Unbound_Thread_Attributes; + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- function New_Bound_Thread_Attributes return Task_Info_Type is begin @@ -70,4 +68,22 @@ package body System.Task_Info is return new Thread_Attributes'(True, True, CPU); end New_Bound_Thread_Attributes; + ----------------------------------- + -- New_Unbound_Thread_Attributes -- + ----------------------------------- + + function New_Unbound_Thread_Attributes return Task_Info_Type is + begin + return new Thread_Attributes'(False, False); + end New_Unbound_Thread_Attributes; + + ------------------------------- + -- Unbound_Thread_Attributes -- + ------------------------------- + + function Unbound_Thread_Attributes return Thread_Attributes is + begin + return (False, False); + end Unbound_Thread_Attributes; + end System.Task_Info; diff --git a/gcc/ada/s-tasinf-solaris.ads b/gcc/ada/s-tasinf-solaris.ads index efa51b7e166..bebecd213df 100644 --- a/gcc/ada/s-tasinf-solaris.ads +++ b/gcc/ada/s-tasinf-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -41,7 +41,7 @@ -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. --- This is the Solaris (native) version of this module. +-- This is the Solaris (native) version of this module with System.OS_Interface; @@ -84,7 +84,7 @@ package System.Task_Info is -- The Task_Info pragma appears within a task definition (compare the -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma -- is present, then it supplies an alternative value. If the argument of -- the pragma is a discriminant reference, then the value can be set on -- a task by task basis by supplying the appropriate discriminant value. diff --git a/gcc/ada/s-tasinf-tru64.ads b/gcc/ada/s-tasinf-tru64.ads index 895fde49a62..9993db37bda 100644 --- a/gcc/ada/s-tasinf-tru64.ads +++ b/gcc/ada/s-tasinf-tru64.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Compiler Interface) -- -- -- --- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -42,7 +42,7 @@ -- This unit may be used directly from an application program by providing -- an appropriate WITH, and the interface can be expected to remain stable. --- This is a DEC Unix 4.0d version of this package. +-- This is a DEC Unix 4.0d version of this package package System.Task_Info is pragma Preelaborate; @@ -64,7 +64,7 @@ package System.Task_Info is -- The Task_Info pragma appears within a task definition (compare the -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma -- is present, then it supplies an alternative value. If the argument of -- the pragma is a discriminant reference, then the value can be set on -- a task by task basis by supplying the appropriate discriminant value. diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads index 8d8b2dd9da2..35a12ce4de9 100644 --- a/gcc/ada/s-tasinf.ads +++ b/gcc/ada/s-tasinf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -61,7 +61,7 @@ package System.Task_Info is -- The Task_Info pragma appears within a task definition (compare the -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- appears, then the value Unspecified_Task_Info is passed. If a pragma -- is present, then it supplies an alternative value. If the argument of -- the pragma is a discriminant reference, then the value can be set on -- a task by task basis by supplying the appropriate discriminant value. diff --git a/gcc/ada/s-tfsetr-vxworks.adb b/gcc/ada/s-tfsetr-vxworks.adb index edeafbf0181..8b3c204f8fb 100644 --- a/gcc/ada/s-tfsetr-vxworks.adb +++ b/gcc/ada/s-tfsetr-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,11 +31,11 @@ -- -- ------------------------------------------------------------------------------ --- This version is for VxWorks targets. +-- This version is for VxWorks targets --- Trace information is sent to WindView using the wvEvent function. +-- Trace information is sent to WindView using the wvEvent function --- Note that wvEvent is from the VxWorks API. +-- Note that wvEvent is from the VxWorks API -- When adding a new event, just give an Id to then event, and then modify -- the WindView events database. diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index e9a0e0284e1..fe23600ee28 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -571,7 +571,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S - ("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?"); + ("use of "":"" is an obsolescent feature (RM J.2(3))?"); Error_Msg_S ("\use ""'#"" instead?"); end if; @@ -1178,7 +1178,10 @@ package body Scng is -- Horizontal tab, just skip past it when HT => - if Style_Check then Style.Check_HT; end if; + if Style_Check then + Style.Check_HT; + end if; + Scan_Ptr := Scan_Ptr + 1; -- End of file character, treated as an end of file only if it is @@ -1187,7 +1190,11 @@ package body Scng is when EOF => if Scan_Ptr = Source_Last (Current_Source_File) then Check_End_Of_Line; - if Style_Check then Style.Check_EOF; end if; + + if Style_Check then + Style.Check_EOF; + end if; + Token := Tok_EOF; return; else @@ -1237,7 +1244,11 @@ package body Scng is if Double_Char_Token ('=') then Token := Tok_Colon_Equal; - if Style_Check then Style.Check_Colon_Equal; end if; + + if Style_Check then + Style.Check_Colon_Equal; + end if; + return; elsif Source (Scan_Ptr + 1) = '-' @@ -1251,7 +1262,11 @@ package body Scng is else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Colon; - if Style_Check then Style.Check_Colon; end if; + + if Style_Check then + Style.Check_Colon; + end if; + return; end if; @@ -1261,7 +1276,11 @@ package body Scng is Accumulate_Checksum ('('); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; - if Style_Check then Style.Check_Left_Paren; end if; + + if Style_Check then + Style.Check_Left_Paren; + end if; + return; -- Left bracket @@ -1291,7 +1310,11 @@ package body Scng is Accumulate_Checksum (','); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Comma; - if Style_Check then Style.Check_Comma; end if; + + if Style_Check then + Style.Check_Comma; + end if; + return; -- Dot, which is either an isolated period, or part of a double dot @@ -1303,7 +1326,11 @@ package body Scng is if Double_Char_Token ('.') then Token := Tok_Dot_Dot; - if Style_Check then Style.Check_Dot_Dot; end if; + + if Style_Check then + Style.Check_Dot_Dot; + end if; + return; elsif Source (Scan_Ptr + 1) in '0' .. '9' then @@ -1324,7 +1351,11 @@ package body Scng is if Double_Char_Token ('>') then Token := Tok_Arrow; - if Style_Check then Style.Check_Arrow; end if; + + if Style_Check then + Style.Check_Arrow; + end if; + return; elsif Source (Scan_Ptr + 1) = '=' then @@ -1369,7 +1400,11 @@ package body Scng is elsif Double_Char_Token ('>') then Token := Tok_Box; - if Style_Check then Style.Check_Box; end if; + + if Style_Check then + Style.Check_Box; + end if; + return; elsif Double_Char_Token ('<') then @@ -1401,7 +1436,10 @@ package body Scng is -- Comment else -- Source (Scan_Ptr + 1) = '-' then - if Style_Check then Style.Check_Comment; end if; + if Style_Check then + Style.Check_Comment; + end if; + Scan_Ptr := Scan_Ptr + 2; -- If we are in preprocessor mode with Replace_In_Comments set, @@ -1447,7 +1485,10 @@ package body Scng is -- Keep going if horizontal tab if Source (Scan_Ptr) = HT then - if Style_Check then Style.Check_HT; end if; + if Style_Check then + Style.Check_HT; + end if; + Scan_Ptr := Scan_Ptr + 1; -- Terminate scan of comment if line terminator @@ -1538,7 +1579,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S - ("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?"); + ("use of ""'%"" is an obsolescent feature (RM J.2(4))?"); Error_Msg_S ("\use """""" instead?"); end if; @@ -1581,7 +1622,11 @@ package body Scng is or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; - if Style_Check then Style.Check_Apostrophe; end if; + + if Style_Check then + Style.Check_Apostrophe; + end if; + return; -- Otherwise the apostrophe starts a character literal @@ -1686,7 +1731,11 @@ package body Scng is Accumulate_Checksum (')'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; - if Style_Check then Style.Check_Right_Paren; end if; + + if Style_Check then + Style.Check_Right_Paren; + end if; + return; -- Right bracket or right brace, treated as right paren @@ -1717,7 +1766,11 @@ package body Scng is Accumulate_Checksum (';'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Semicolon; - if Style_Check then Style.Check_Semicolon; end if; + + if Style_Check then + Style.Check_Semicolon; + end if; + return; -- Vertical bar @@ -1736,7 +1789,11 @@ package body Scng is else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; - if Style_Check then Style.Check_Vertical_Bar; end if; + + if Style_Check then + Style.Check_Vertical_Bar; + end if; + return; end if; end Vertical_Bar_Case; @@ -1749,7 +1806,7 @@ package body Scng is if Warn_On_Obsolescent_Feature then Error_Msg_S - ("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?"); + ("use of ""'!"" is an obsolescent feature (RM J.2(2))?"); Error_Msg_S ("\use ""'|"" instead?"); end if; @@ -2321,32 +2378,43 @@ package body Scng is if Is_Keyword_Name (Token_Name) then Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); - -- Deal with possible style check for non-lower case keyword, but - -- we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords for - -- this purpose if they appear as attribute designators. Actually - -- we only check the first character for speed. - - -- Ada 2005 (AI-284): Do not apply the style check in case of - -- "pragma Interface" - - -- Ada 2005 (AI-340): Do not apply the style check in case of - -- MOD attribute. - - if Style_Check - and then Source (Token_Ptr) <= 'Z' - and then (Prev_Token /= Tok_Apostrophe - or else - (Token /= Tok_Access and then - Token /= Tok_Delta and then - Token /= Tok_Digits and then - Token /= Tok_Mod and then - Token /= Tok_Range)) - and then (Token /= Tok_Interface - or else - (Token = Tok_Interface - and then Prev_Token /= Tok_Pragma)) - then - Style.Non_Lower_Case_Keyword; + -- Keyword style checks + + if Style_Check then + + -- Deal with possible style check for non-lower case keyword, + -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords + -- for this purpose if they appear as attribute designators. + -- Actually we only check the first character for speed. + + -- Ada 2005 (AI-284): Do not apply the style check in case of + -- "pragma Interface" + + -- Ada 2005 (AI-340): Do not apply the style check in case of + -- MOD attribute. + + if Source (Token_Ptr) <= 'Z' + and then (Prev_Token /= Tok_Apostrophe + or else + (Token /= Tok_Access and then + Token /= Tok_Delta and then + Token /= Tok_Digits and then + Token /= Tok_Mod and then + Token /= Tok_Range)) + and then (Token /= Tok_Interface + or else + (Token = Tok_Interface + and then Prev_Token /= Tok_Pragma)) + then + Style.Non_Lower_Case_Keyword; + end if; + + if (Token = Tok_Then and then Prev_Token /= Tok_And) + or else + (Token = Tok_Else and then Prev_Token /= Tok_Or) + then + Style.Check_Separate_Stmt_Lines; + end if; end if; -- We must reset Token_Name since this is not an identifier and @@ -2470,7 +2538,10 @@ package body Scng is -- Outer loop keeps going only if a horizontal tab follows if Source (Scan_Ptr) = HT then - if Style_Check then Style.Check_HT; end if; + if Style_Check then + Style.Check_HT; + end if; + Scan_Ptr := Scan_Ptr + 1; Start_Column := (Start_Column / 8) * 8 + 8; else diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 34e090761a9..7dab13496c1 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -53,6 +53,8 @@ with Sinfo; use Sinfo; with Stand; use Stand; with Uintp; use Uintp; +with Unchecked_Deallocation; + pragma Warnings (Off, Sem_Util); -- Suppress warnings of unused with for Sem_Util (used only in asserts) @@ -448,8 +450,8 @@ package body Sem is when N_Requeue_Statement => Analyze_Requeue (N); - when N_Return_Statement => - Analyze_Return_Statement (N); + when N_Simple_Return_Statement => + Analyze_Simple_Return_Statement (N); when N_Selected_Component => Find_Selected_Component (N); @@ -724,65 +726,73 @@ package body Sem is From : Entity_Id; To : Entity_Id) is + Found : Boolean; + + procedure Search_Stack + (Top : Suppress_Stack_Entry_Ptr; + Found : out Boolean); + -- Search given suppress stack for matching entry for entity. If found + -- then set Checks_May_Be_Suppressed on To, and push an appropriate + -- entry for To onto the local suppress stack. + + ------------------ + -- Search_Stack -- + ------------------ + + procedure Search_Stack + (Top : Suppress_Stack_Entry_Ptr; + Found : out Boolean) + is + Ptr : Suppress_Stack_Entry_Ptr; + + begin + Ptr := Top; + while Ptr /= null loop + if Ptr.Entity = From + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + if Ptr.Suppress then + Set_Checks_May_Be_Suppressed (To, True); + Push_Local_Suppress_Stack_Entry + (Entity => To, + Check => C, + Suppress => True); + Found := True; + return; + end if; + end if; + + Ptr := Ptr.Prev; + end loop; + + Found := False; + return; + end Search_Stack; + + -- Start of processing for Copy_Suppress_Status + begin if not Checks_May_Be_Suppressed (From) then return; end if; - -- First search the local entity suppress table, we search this in + -- First search the local entity suppress stack, we search this in -- reverse order so that we get the innermost entry that applies to -- this case if there are nested entries. Note that for the purpose -- of this procedure we are ONLY looking for entries corresponding -- to a two-argument Suppress, where the second argument matches From. - for J in - reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last - loop - declare - R : Entity_Check_Suppress_Record - renames Local_Entity_Suppress.Table (J); + Search_Stack (Global_Suppress_Stack_Top, Found); - begin - if R.Entity = From - and then (R.Check = All_Checks or else R.Check = C) - then - if R.Suppress then - Set_Checks_May_Be_Suppressed (To, True); - Local_Entity_Suppress.Append - ((Entity => To, - Check => C, - Suppress => True)); - return; - end if; - end if; - end; - end loop; + if Found then + return; + end if; -- Now search the global entity suppress table for a matching entry -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. - for J in - reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last - loop - declare - R : Entity_Check_Suppress_Record - renames Global_Entity_Suppress.Table (J); - - begin - if R.Entity = From - and then (R.Check = All_Checks or else R.Check = C) - then - if R.Suppress then - Set_Checks_May_Be_Suppressed (To, True); - Local_Entity_Suppress.Append - ((Entity => To, - Check => C, - Suppress => True)); - end if; - end if; - end; - end loop; + Search_Stack (Local_Suppress_Stack_Top, Found); end Copy_Suppress_Status; ------------------------- @@ -812,29 +822,26 @@ package body Sem is ----------------------- function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is + Ptr : Suppress_Stack_Entry_Ptr; + begin if not Checks_May_Be_Suppressed (E) then return False; else - for J in - reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last - loop - declare - R : Entity_Check_Suppress_Record - renames Global_Entity_Suppress.Table (J); - - begin - if R.Entity = E - and then (R.Check = All_Checks or else R.Check = C) - then - return R.Suppress; - end if; - end; - end loop; + Ptr := Global_Suppress_Stack_Top; + while Ptr /= null loop + if Ptr.Entity = E + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; - return False; + Ptr := Ptr.Prev; + end loop; end if; + + return False; end Explicit_Suppress; ----------------------------- @@ -880,9 +887,26 @@ package body Sem is ---------------- procedure Initialize is + Next : Suppress_Stack_Entry_Ptr; + + procedure Free is new Unchecked_Deallocation + (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr); + begin - Local_Entity_Suppress.Init; - Global_Entity_Suppress.Init; + -- Free any global suppress stack entries from a previous invocation + -- of the compiler (in the normal case this loop does nothing). + + while Suppress_Stack_Entries /= null loop + Next := Global_Suppress_Stack_Top.Next; + Free (Suppress_Stack_Entries); + Suppress_Stack_Entries := Next; + end loop; + + Local_Suppress_Stack_Top := null; + Global_Suppress_Stack_Top := null; + + -- Clear scope stack, and reset global variables + Scope_Stack.Init; Unloaded_Subunits := False; end Initialize; @@ -1136,53 +1160,52 @@ package body Sem is ------------------------- function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is - begin - -- First search the local entity suppress table, we search this in - -- reverse order so that we get the innermost entry that applies to - -- this case if there are nested entries. - for J in - reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last - loop - declare - R : Entity_Check_Suppress_Record - renames Local_Entity_Suppress.Table (J); + Ptr : Suppress_Stack_Entry_Ptr; - begin - if (R.Entity = Empty or else R.Entity = E) - and then (R.Check = All_Checks or else R.Check = C) - then - return R.Suppress; - end if; - end; + begin + -- First search the local entity suppress stack, we search this from the + -- top of the stack down, so that we get the innermost entry that + -- applies to this case if there are nested entries. + + Ptr := Local_Suppress_Stack_Top; + while Ptr /= null loop + if (Ptr.Entity = Empty or else Ptr.Entity = E) + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; + + Ptr := Ptr.Prev; end loop; -- Now search the global entity suppress table for a matching entry - -- We also search this in reverse order so that if there are multiple + -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). - for J in - reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last - loop - declare - R : Entity_Check_Suppress_Record - renames Global_Entity_Suppress.Table (J); + Ptr := Global_Suppress_Stack_Top; + while Ptr /= null loop + if (Ptr.Entity = Empty or else Ptr.Entity = E) + and then (Ptr.Check = All_Checks or else Ptr.Check = C) + then + return Ptr.Suppress; + end if; - begin - if R.Entity = E - and then (R.Check = All_Checks or else R.Check = C) - then - return R.Suppress; - end if; - end; + Ptr := Ptr.Prev; end loop; -- If we did not find a matching entry, then use the normal scope -- suppress value after all (actually this will be the global setting - -- since it clearly was not overridden at any point) + -- since it clearly was not overridden at any point). For a predefined + -- check, we test the specific flag. For a user defined check, we check + -- the All_Checks flag. - return Scope_Suppress (C); + if C in Predefined_Check_Id then + return Scope_Suppress (C); + else + return Scope_Suppress (All_Checks); + end if; end Is_Check_Suppressed; ---------- @@ -1191,14 +1214,54 @@ package body Sem is procedure Lock is begin - Local_Entity_Suppress.Locked := True; - Global_Entity_Suppress.Locked := True; Scope_Stack.Locked := True; - Local_Entity_Suppress.Release; - Global_Entity_Suppress.Release; Scope_Stack.Release; end Lock; + -------------------------------------- + -- Push_Global_Suppress_Stack_Entry -- + -------------------------------------- + + procedure Push_Global_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean) + is + begin + Global_Suppress_Stack_Top := + new Suppress_Stack_Entry' + (Entity => Entity, + Check => Check, + Suppress => Suppress, + Prev => Global_Suppress_Stack_Top, + Next => Suppress_Stack_Entries); + Suppress_Stack_Entries := Global_Suppress_Stack_Top; + return; + + end Push_Global_Suppress_Stack_Entry; + + ------------------------------------- + -- Push_Local_Suppress_Stack_Entry -- + ------------------------------------- + + procedure Push_Local_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean) + is + begin + Local_Suppress_Stack_Top := + new Suppress_Stack_Entry' + (Entity => Entity, + Check => Check, + Suppress => Suppress, + Prev => Local_Suppress_Stack_Top, + Next => Suppress_Stack_Entries); + Suppress_Stack_Entries := Local_Suppress_Stack_Top; + + return; + end Push_Local_Suppress_Stack_Entry; + --------------- -- Semantics -- --------------- diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 8b38c33a2ae..241ea5aab4f 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -211,26 +211,27 @@ package Sem is ----------------------------- Full_Analysis : Boolean := True; - -- Switch to indicate whether we are doing a full analysis or a - -- pre-analysis. In normal analysis mode (Analysis-Expansion for - -- instructions or declarations) or (Analysis-Resolution-Expansion for - -- expressions) this flag is set. Note that if we are not generating - -- code the expansion phase merely sets the Analyzed flag to True in - -- this case. If we are in Pre-Analysis mode (see above) this flag is - -- set to False then the expansion phase is skipped. - -- When this flag is False the flag Expander_Active is also False - -- (the Expander_Activer flag defined in the spec of package Expander - -- tells you whether expansion is currently enabled). - -- You should really regard this as a read only flag. + -- Switch to indicate if we are doing a full analysis or a pre-analysis. + -- In normal analysis mode (Analysis-Expansion for instructions or + -- declarations) or (Analysis-Resolution-Expansion for expressions) this + -- flag is set. Note that if we are not generating code the expansion phase + -- merely sets the Analyzed flag to True in this case. If we are in + -- Pre-Analysis mode (see above) this flag is set to False then the + -- expansion phase is skipped. + -- + -- When this flag is False the flag Expander_Active is also False (the + -- Expander_Activer flag defined in the spec of package Expander tells you + -- whether expansion is currently enabled). You should really regard this + -- as a read only flag. In_Default_Expression : Boolean := False; -- Switch to indicate that we are in a default expression, as described -- above. Note that this must be recursively saved on a Semantics call - -- since it is possible for the analysis of an expression to result in - -- a recursive call (e.g. to get the entity for System.Address as part - -- of the processing of an Address attribute reference). - -- When this switch is True then Full_Analysis above must be False. - -- You should really regard this as a read only flag. + -- since it is possible for the analysis of an expression to result in a + -- recursive call (e.g. to get the entity for System.Address as part of the + -- processing of an Address attribute reference). When this switch is True + -- then Full_Analysis above must be False. You should really regard this as + -- a read only flag. In_Deleted_Code : Boolean := False; -- If the condition in an if-statement is statically known, the branch @@ -259,6 +260,121 @@ package Sem is -- about unused variables, since these warnings are unreliable in this -- case. We could perhaps do a more accurate job and retain some of the -- warnings, but it is quite a tricky job. See test 4323-002. + -- Should not reference TN's in the source comments ??? + + ----------------------------------- + -- Handling of Check Suppression -- + ----------------------------------- + + -- There are two kinds of suppress checks: scope based suppress checks, + -- and entity based suppress checks. + + -- Scope based suppress checks for the predefined checks (from initial + -- command line arguments, or from Suppress pragmas not including an entity + -- entity name) are recorded in the Sem.Supress variable, and all that is + -- necessary is to save the state of this variable on scope entry, and + -- restore it on scope exit. This mechanism allows for fast checking of + -- the scope suppress state without needing complex data structures. + + -- Entity based checks, from Suppress/Unsuppress pragmas giving an + -- Entity_Id and scope based checks for non-predefined checks (introduced + -- using pragma Check_Name), are handled as follows. If a suppress or + -- unsuppress pragma is encountered for a given entity, then the flag + -- Checks_May_Be_Suppressed is set in the entity and an entry is made in + -- either the Local_Entity_Suppress stack (case of pragma that appears in + -- other than a package spec), or in the Global_Entity_Suppress stack (case + -- of pragma that appears in a package spec, which is by the rule of RM + -- 11.5(7) applicable throughout the life of the entity). Similarly, a + -- Suppress/Unsuppress pragma for a non-predefined check which does not + -- specify an entity is also stored in one of these stacks. + + -- If the Checks_May_Be_Suppressed flag is set in an entity then the + -- procedure is to search first the local and then the global suppress + -- stacks (we search these in reverse order, top element first). The only + -- other point is that we have to make sure that we have proper nested + -- interaction between such specific pragmas and locally applied general + -- pragmas applying to all entities. This is achieved by including in the + -- Local_Entity_Suppress table dummy entries with an empty Entity field + -- that are applicable to all entities. A similar search is needed for any + -- non-predefined check even if no specific entity is involved. + + Scope_Suppress : Suppress_Array := Suppress_Options; + -- This array contains the current scope based settings of the suppress + -- switches. It is initialized from the options as shown, and then modified + -- by pragma Suppress. On entry to each scope, the current setting is saved + -- the scope stack, and then restored on exit from the scope. This record + -- may be rapidly checked to determine the current status of a check if + -- no specific entity is involved or if the specific entity involved is + -- one for which no specific Suppress/Unsuppress pragma has been set (as + -- indicated by the Checks_May_Be_Suppressed flag being set). + + -- This scheme is a little complex, but serves the purpose of enabling + -- a very rapid check in the common case where no entity specific pragma + -- applies, and gives the right result when such pragmas are used even + -- in complex cases of nested Suppress and Unsuppress pragmas. + + -- The Local_Entity_Suppress and Global_Entity_Suppress stacks are handled + -- using dynamic allocation and linked lists. We do not often use this + -- approach in the compiler (preferring to use extensible tables instead). + -- The reason we do it here is that scope stack entries save a pointer to + -- the current local stack top, which is also saved and restored on scope + -- exit. Furthermore for processing of generics we save pointers to the + -- top of the stack, so that the local stack is actually a tree of stacks + -- rather than a single stack, a structure that is easy to represent using + -- linked lists, but impossible to represent using a single table. Note + -- that because of the generic issue, we never release entries in these + -- stacks, but that's no big deal, since we are unlikely to have a huge + -- number of Suppress/Unsuppress entries in a single compilation. + + type Suppress_Stack_Entry; + type Suppress_Stack_Entry_Ptr is access all Suppress_Stack_Entry; + + type Suppress_Stack_Entry is record + Entity : Entity_Id; + -- Entity to which the check applies, or Empty for a check that has + -- no entity name (and thus applies to all entities). + + Check : Check_Id; + -- Check which is set (can be All_Checks for the All_Checks case) + + Suppress : Boolean; + -- Set True for Suppress, and False for Unsuppress + + Prev : Suppress_Stack_Entry_Ptr; + -- Pointer to previous entry on stack + + Next : Suppress_Stack_Entry_Ptr; + -- All allocated Suppress_Stack_Entry records are chained together in + -- a linked list whose head is Suppress_Stack_Entries, and the Next + -- field is used as a forward pointer (null ends the list). This is + -- used to free all entries in Sem.Init (which will be important if + -- we ever setup the compiler to be reused). + end record; + + Suppress_Stack_Entries : Suppress_Stack_Entry_Ptr := null; + -- Pointer to linked list of records (see comments for Next above) + + Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Pointer to top element of local suppress stack. This is the entry that + -- is saved and restored in the scope stack, and also saved for generic + -- body expansion. + + Global_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Pointer to top element of global suppress stack + + procedure Push_Local_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean); + -- Push a new entry on to the top of the local suppress stack, updating + -- the value in Local_Suppress_Stack_Top; + + procedure Push_Global_Suppress_Stack_Entry + (Entity : Entity_Id; + Check : Check_Id; + Suppress : Boolean); + -- Push a new entry on to the top of the global suppress stack, updating + -- the value in Global_Suppress_Stack_Top; ----------------- -- Scope Stack -- @@ -324,8 +440,8 @@ package Sem is Save_Scope_Suppress : Suppress_Array; -- Save contents of Scope_Suppress on entry - Save_Local_Entity_Suppress : Int; - -- Save contents of Local_Entity_Suppress.Last on entry + Save_Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Save contents of Local_Suppress_Stack on entry to restore on exit Is_Transient : Boolean; -- Marks Transient Scopes (See Exp_Ch7 body for details) @@ -383,92 +499,6 @@ package Sem is Table_Increment => Alloc.Scope_Stack_Increment, Table_Name => "Sem.Scope_Stack"); - ----------------------------------- - -- Handling of Check Suppression -- - ----------------------------------- - - -- There are two kinds of suppress checks: scope based suppress checks, - -- and entity based suppress checks. - - -- Scope based suppress checks (from initial command line arguments, - -- or from Suppress pragmas not including an entity name) are recorded - -- in the Sem.Supress variable, and all that is necessary is to save the - -- state of this variable on scope entry, and restore it on scope exit. - - -- Entity based suppress checks, from Suppress pragmas giving an Entity_Id, - -- are handled as follows. If a suppress or unsuppress pragma is - -- encountered for a given entity, then the flag Checks_May_Be_Suppressed - -- is set in the entity and an entry is made in either the - -- Local_Entity_Suppress table (case of pragma that appears in other than - -- a package spec), or in the Global_Entity_Suppress table (case of pragma - -- that appears in a package spec, which is by the rule of RM 11.5(7) - -- applicable throughout the life of the entity). - - -- If the Checks_May_Be_Suppressed flag is set in an entity then the - -- procedure is to search first the local and then the global suppress - -- tables (the local one being searched in reverse order, i.e. last in - -- searched first). The only other point is that we have to make sure - -- that we have proper nested interaction between such specific pragmas - -- and locally applied general pragmas applying to all entities. This - -- is achieved by including in the Local_Entity_Suppress table dummy - -- entries with an empty Entity field that are applicable to all entities. - - Scope_Suppress : Suppress_Array := Suppress_Options; - -- This array contains the current scope based settings of the suppress - -- switches. It is initialized from the options as shown, and then modified - -- by pragma Suppress. On entry to each scope, the current setting is saved - -- the scope stack, and then restored on exit from the scope. This record - -- may be rapidly checked to determine the current status of a check if - -- no specific entity is involved or if the specific entity involved is - -- one for which no specific Suppress/Unsuppress pragma has been set (as - -- indicated by the Checks_May_Be_Suppressed flag being set). - - -- This scheme is a little complex, but serves the purpose of enabling - -- a very rapid check in the common case where no entity specific pragma - -- applies, and gives the right result when such pragmas are used even - -- in complex cases of nested Suppress and Unsuppress pragmas. - - type Entity_Check_Suppress_Record is record - Entity : Entity_Id; - -- Entity to which the check applies, or Empty for a local check - -- that has no entity name (and thus applies to all entities). - - Check : Check_Id; - -- Check which is set (note this cannot be All_Checks, if the All_Checks - -- case, a sequence of eentries appears for the individual checks. - - Suppress : Boolean; - -- Set True for Suppress, and False for Unsuppress - end record; - - -- The Local_Entity_Suppress table is a stack, to which new entries are - -- added for Suppress and Unsuppress pragmas appearing in other than - -- package specs. Such pragmas are effective only to the end of the scope - -- in which they appear. This is achieved by marking the stack on entry - -- to a scope and then cutting back the stack to that marked point on - -- scope exit. - - package Local_Entity_Suppress is new Table.Table ( - Table_Component_Type => Entity_Check_Suppress_Record, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => Alloc.Entity_Suppress_Initial, - Table_Increment => Alloc.Entity_Suppress_Increment, - Table_Name => "Local_Entity_Suppress"); - - -- The Global_Entity_Suppress table is used for entities which have - -- a Suppress or Unsuppress pragma naming a specific entity in a - -- package spec. Such pragmas always refer to entities in the package - -- spec and are effective throughout the lifetime of the named entity. - - package Global_Entity_Suppress is new Table.Table ( - Table_Component_Type => Entity_Check_Suppress_Record, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => Alloc.Entity_Suppress_Initial, - Table_Increment => Alloc.Entity_Suppress_Increment, - Table_Name => "Global_Entity_Suppress"); - ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 81729906d49..dba6ae83946 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1501,7 +1501,7 @@ package body Sem_Eval is Set_Etype (N, Etype (Right)); end if; - Fold_Str (N, End_String, True); + Fold_Str (N, End_String, Static => True); end if; end; end Eval_Concatenation; @@ -2732,7 +2732,7 @@ package body Sem_Eval is -- Fold conversion, case of string type. The result is not static if Is_String_Type (Target_Type) then - Fold_Str (N, Strval (Get_String_Val (Operand)), False); + Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False); return; @@ -4450,7 +4450,7 @@ package body Sem_Eval is if Raises_Constraint_Error (Expr) then Error_Msg_N ("expression raises exception, cannot be static " & - "('R'M 4.9(34))!", N); + "(RM 4.9(34))!", N); return; end if; @@ -4469,7 +4469,7 @@ package body Sem_Eval is then Error_Msg_N ("static expression must have scalar or string type " & - "('R'M 4.9(2))!", N); + "(RM 4.9(2))!", N); return; end if; end if; @@ -4486,19 +4486,19 @@ package body Sem_Eval is elsif Ekind (E) = E_Constant then if not Is_Static_Expression (Constant_Value (E)) then Error_Msg_NE - ("& is not a static constant ('R'M 4.9(5))!", N, E); + ("& is not a static constant (RM 4.9(5))!", N, E); end if; else Error_Msg_NE ("& is not static constant or named number " & - "('R'M 4.9(5))!", N, E); + "(RM 4.9(5))!", N, E); end if; when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => if Nkind (N) in N_Op_Shift then Error_Msg_N - ("shift functions are never static ('R'M 4.9(6,18))!", N); + ("shift functions are never static (RM 4.9(6,18))!", N); else Why_Not_Static (Left_Opnd (N)); @@ -4522,7 +4522,7 @@ package body Sem_Eval is if Attribute_Name (N) = Name_Size then Error_Msg_N ("size attribute is only static for scalar type " & - "('R'M 4.9(7,8))", N); + "(RM 4.9(7,8))", N); -- Flag array cases @@ -4535,14 +4535,14 @@ package body Sem_Eval is then Error_Msg_N ("static array attribute must be Length, First, or Last " & - "('R'M 4.9(8))!", N); + "(RM 4.9(8))!", N); -- Since we know the expression is not-static (we already -- tested for this, must mean array is not static). else Error_Msg_N - ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N)); + ("prefix is non-static array (RM 4.9(8))!", Prefix (N)); end if; return; @@ -4556,7 +4556,7 @@ package body Sem_Eval is then Error_Msg_N ("attribute of generic type is never static " & - "('R'M 4.9(7,8))!", N); + "(RM 4.9(7,8))!", N); elsif Is_Static_Subtype (E) then null; @@ -4564,43 +4564,43 @@ package body Sem_Eval is elsif Is_Scalar_Type (E) then Error_Msg_N ("prefix type for attribute is not static scalar subtype " & - "('R'M 4.9(7))!", N); + "(RM 4.9(7))!", N); else Error_Msg_N ("static attribute must apply to array/scalar type " & - "('R'M 4.9(7,8))!", N); + "(RM 4.9(7,8))!", N); end if; when N_String_Literal => Error_Msg_N - ("subtype of string literal is non-static ('R'M 4.9(4))!", N); + ("subtype of string literal is non-static (RM 4.9(4))!", N); when N_Explicit_Dereference => Error_Msg_N - ("explicit dereference is never static ('R'M 4.9)!", N); + ("explicit dereference is never static (RM 4.9)!", N); when N_Function_Call => Why_Not_Static_List (Parameter_Associations (N)); - Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N); + Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N); when N_Parameter_Association => Why_Not_Static (Explicit_Actual_Parameter (N)); when N_Indexed_Component => Error_Msg_N - ("indexed component is never static ('R'M 4.9)!", N); + ("indexed component is never static (RM 4.9)!", N); when N_Procedure_Call_Statement => Error_Msg_N - ("procedure call is never static ('R'M 4.9)!", N); + ("procedure call is never static (RM 4.9)!", N); when N_Qualified_Expression => Why_Not_Static (Expression (N)); when N_Aggregate | N_Extension_Aggregate => Error_Msg_N - ("an aggregate is never static ('R'M 4.9)!", N); + ("an aggregate is never static (RM 4.9)!", N); when N_Range => Why_Not_Static (Low_Bound (N)); @@ -4614,11 +4614,11 @@ package body Sem_Eval is when N_Selected_Component => Error_Msg_N - ("selected component is never static ('R'M 4.9)!", N); + ("selected component is never static (RM 4.9)!", N); when N_Slice => Error_Msg_N - ("slice is never static ('R'M 4.9)!", N); + ("slice is never static (RM 4.9)!", N); when N_Type_Conversion => Why_Not_Static (Expression (N)); @@ -4628,12 +4628,12 @@ package body Sem_Eval is then Error_Msg_N ("static conversion requires static scalar subtype result " & - "('R'M 4.9(9))!", N); + "(RM 4.9(9))!", N); end if; when N_Unchecked_Type_Conversion => Error_Msg_N - ("unchecked type conversion is never static ('R'M 4.9)!", N); + ("unchecked type conversion is never static (RM 4.9)!", N); when others => null; diff --git a/gcc/ada/sem_maps.adb b/gcc/ada/sem_maps.adb index 0a66a91f0b3..c3d4a2499b9 100644 --- a/gcc/ada/sem_maps.adb +++ b/gcc/ada/sem_maps.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,7 +55,7 @@ package body Sem_Maps is --------------------- procedure Add_Association - (M : in out Map; + (M : Map; O_Id : Entity_Id; N_Id : Entity_Id; Kind : Scope_Kind := S_Local) @@ -318,7 +318,7 @@ package body Sem_Maps is ------------------------ procedure Update_Association - (M : in out Map; + (M : Map; O_Id : Entity_Id; N_Id : Entity_Id; Kind : Scope_Kind := S_Local) diff --git a/gcc/ada/sem_maps.ads b/gcc/ada/sem_maps.ads index d6f51859651..90a64da920d 100644 --- a/gcc/ada/sem_maps.ads +++ b/gcc/ada/sem_maps.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2007, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -64,14 +64,14 @@ package Sem_Maps is -- Retrieve image of E under M, Empty if undefined procedure Add_Association - (M : in out Map; + (M : Map; O_Id : Entity_Id; N_Id : Entity_Id; Kind : Scope_Kind := S_Local); -- Update M in place. On entry M (O_Id) must not be defined procedure Update_Association - (M : in out Map; + (M : Map; O_Id : Entity_Id; N_Id : Entity_Id; Kind : Scope_Kind := S_Local); |
