diff options
35 files changed, 662 insertions, 480 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6bdf3695674..fd0ab2a9b27 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,54 @@ 2010-09-09 Robert Dewar <dewar@adacore.com> + * a-calfor.adb, sem_ch3.adb: Minor reformatting. + +2010-09-09 Robert Dewar <dewar@adacore.com> + + * bindgen.adb (Gen_Restrictions_Ada): Avoid explicit enumeration ranges + (Gen_Restrictions_C): Avoid explicit enumeration ranges + (Set_String_Replace): New procedure + * casing.ads (Known_Casing): New subtype declaration + * prj-attr.ads (All_Case_Insensitive_Associative_Array): New subtype + declaration + * prj-dect.adb (Parse_Attribute_Declaration): Avoid enumeration range + * prj-nmsc.adb (Check_Naming): Avoid unnecessary enumeration range + * prj-strt.adb (Attribute_Reference): Avoid enumeration range test + * prj.adb (Known_Casing): Moved to Casing spec (avoid enum range) + * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Avoid enumeration + ranges + * sem_res.adb (Resolve_Range): Check for enumeration subrange style rule + * sem_type.adb (Is_Array_Class_Record_Type): New. + * style.ads (Check_Enumeration_Subrange): New procedure + * styleg.adb (Check_Enumeration_Subrange): New procedure + * styleg.ads (Check_Enumeration_Subrange): New procedure + * stylesw.adb Add handling for Style_Check_Enumeration_Subranges + * stylesw.ads (Style_Check_Enumeration_Subranges): New flag + * usage.adb: Add line for -gnatyE + * vms_data.ads: Add entries for [NO]ENUMERATION_RANGES + Add missing entry for NOBOOLEAN_OPERATORS + * gnat_ugn.texi: Add documentation for -gnatyE + +2010-09-09 Robert Dewar <dewar@adacore.com> + + * namet.adb (Initialize): Is now a dummy procedure + (Reinitialize): New procedure + Call Reinitialize from package initialization + * namet.ads (Initialize): Is now a dummy procedure + (Reinitialize): New procedure + * clean.adb, gnat1drv.adb, gnatbind.adb, gnatcmd.adb, gnatlink.adb, + gnatls.adb, gprep.adb, make.adb, prj-makr.adb: Remove obsolete call to + Namet.Initialize. + +2010-09-09 Bob Duff <duff@adacore.com> + + * sem_elab.adb, s-os_lib.ads: Minor comment fixes. + +2010-09-09 Robert Dewar <dewar@adacore.com> + + * s-bitops.adb (Raise_Error): Add exception message + +2010-09-09 Robert Dewar <dewar@adacore.com> + * par-ch5.adb (Test_Statement_Required): Deal with Ada 2012 allowing no null statement after label. * sinfo.ads: Minor comment updates. diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb index b8e6222475d..39c3c0a2f79 100644 --- a/gcc/ada/a-calfor.adb +++ b/gcc/ada/a-calfor.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2010, 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,15 +42,15 @@ package body Ada.Calendar.Formatting is -- independent, thus only one source file is needed for multiple targets. procedure Check_Char (S : String; C : Character; Index : Integer); - -- Subsidiary to the two versions of Value. Determine whether the - -- input string S has character C at position Index. Raise - -- Constraint_Error if there is a mismatch. + -- Subsidiary to the two versions of Value. Determine whether the input + -- string S has character C at position Index. Raise Constraint_Error if + -- there is a mismatch. procedure Check_Digit (S : String; Index : Integer); - -- Subsidiary to the two versions of Value. Determine whether the - -- character of string S at position Index is a digit. This catches - -- invalid input such as 1983-*1-j3 u5:n7:k9 which should be - -- 1983-01-03 05:07:09. Raise Constraint_Error if there is a mismatch. + -- Subsidiary to the two versions of Value. Determine whether the character + -- of string S at position Index is a digit. This catches invalid input + -- such as 1983-*1-j3 u5:n7:k9 which should be 1983-01-03 05:07:09. Raise + -- Constraint_Error if there is a mismatch. ---------------- -- Check_Char -- @@ -781,8 +781,8 @@ package body Ada.Calendar.Formatting is raise Constraint_Error; end if; - -- After the correct length has been determined, it is safe to - -- copy the Date in order to avoid Date'First + N indexing. + -- After the correct length has been determined, it is safe to copy the + -- Date in order to avoid Date'First + N indexing. D (1 .. Date'Length) := Date; @@ -865,8 +865,8 @@ package body Ada.Calendar.Formatting is raise Constraint_Error; end if; - -- After the correct length has been determined, it is safe to - -- copy the Elapsed_Time in order to avoid Date'First + N indexing. + -- After the correct length has been determined, it is safe to copy the + -- Elapsed_Time in order to avoid Date'First + N indexing. D (1 .. Elapsed_Time'Length) := Elapsed_Time; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 3d120161789..28a0453fb6c 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -349,6 +349,11 @@ package body Bindgen is -- Sets characters of given string in Statement_Buffer, starting at the -- Last + 1 position, and updating last past the string value. + procedure Set_String_Replace (S : String); + -- Replaces the last S'Length characters in the Statement_Buffer with + -- the characters of S. The caller must ensure that these characters do + -- in fact exist in the Statement_Buffer. + procedure Set_Unit_Name; -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer, -- starting at the Last + 1 position, and updating last past the value. @@ -2801,9 +2806,7 @@ package body Bindgen is Count := 0; - for J in Cumulative_Restrictions.Set'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Set'Last) - loop + for J in Cumulative_Restrictions.Set'Range loop Set_Boolean (Cumulative_Restrictions.Set (J)); Set_String (", "); Count := Count + 1; @@ -2815,30 +2818,22 @@ package body Bindgen is end if; end loop; - Set_Boolean - (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last)); - Set_String ("),"); + Set_String_Replace ("),"); Write_Statement_Buffer; Set_String (" Value => ("); - for J in Cumulative_Restrictions.Value'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Value'Last) - loop + for J in Cumulative_Restrictions.Value'Range loop Set_Int (Int (Cumulative_Restrictions.Value (J))); Set_String (", "); end loop; - Set_Int (Int (Cumulative_Restrictions.Value - (Cumulative_Restrictions.Value'Last))); - Set_String ("),"); + Set_String_Replace ("),"); Write_Statement_Buffer; WBI (" Violated =>"); Set_String (" ("); Count := 0; - for J in Cumulative_Restrictions.Violated'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last) - loop + for J in Cumulative_Restrictions.Violated'Range loop Set_Boolean (Cumulative_Restrictions.Violated (J)); Set_String (", "); Count := Count + 1; @@ -2850,36 +2845,26 @@ package body Bindgen is end if; end loop; - Set_Boolean (Cumulative_Restrictions.Violated - (Cumulative_Restrictions.Violated'Last)); - Set_String ("),"); + Set_String_Replace ("),"); Write_Statement_Buffer; Set_String (" Count => ("); - for J in Cumulative_Restrictions.Count'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Count'Last) - loop + for J in Cumulative_Restrictions.Count'Range loop Set_Int (Int (Cumulative_Restrictions.Count (J))); Set_String (", "); end loop; - Set_Int (Int (Cumulative_Restrictions.Count - (Cumulative_Restrictions.Count'Last))); - Set_String ("),"); + Set_String_Replace ("),"); Write_Statement_Buffer; Set_String (" Unknown => ("); - for J in Cumulative_Restrictions.Unknown'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last) - loop + for J in Cumulative_Restrictions.Unknown'Range loop Set_Boolean (Cumulative_Restrictions.Unknown (J)); Set_String (", "); end loop; - Set_Boolean - (Cumulative_Restrictions.Unknown - (Cumulative_Restrictions.Unknown'Last)); - Set_String ("));"); + Set_String_Replace ("))"); + Set_String (";"); Write_Statement_Buffer; end Gen_Restrictions_Ada; @@ -2926,68 +2911,49 @@ package body Bindgen is WBI (" restrictions r = {"); Set_String (" {"); - for J in Cumulative_Restrictions.Set'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Set'Last) - loop + for J in Cumulative_Restrictions.Set'Range loop Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J))); Set_String (", "); end loop; - Set_Int (Boolean'Pos - (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last))); - Set_String ("},"); + Set_String_Replace ("},"); Write_Statement_Buffer; Set_String (" {"); - for J in Cumulative_Restrictions.Value'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Value'Last) - loop + for J in Cumulative_Restrictions.Value'Range loop Set_Int (Int (Cumulative_Restrictions.Value (J))); Set_String (", "); end loop; - Set_Int (Int (Cumulative_Restrictions.Value - (Cumulative_Restrictions.Value'Last))); - Set_String ("},"); + Set_String_Replace ("},"); Write_Statement_Buffer; Set_String (" {"); - for J in Cumulative_Restrictions.Violated'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last) - loop + for J in Cumulative_Restrictions.Violated'Range loop Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J))); Set_String (", "); end loop; - Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated - (Cumulative_Restrictions.Violated'Last))); - Set_String ("},"); + Set_String_Replace ("},"); Write_Statement_Buffer; Set_String (" {"); - for J in Cumulative_Restrictions.Count'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Count'Last) - loop + for J in Cumulative_Restrictions.Count'Range loop Set_Int (Int (Cumulative_Restrictions.Count (J))); Set_String (", "); end loop; - Set_Int (Int (Cumulative_Restrictions.Count - (Cumulative_Restrictions.Count'Last))); - Set_String ("},"); + Set_String_Replace ("},"); Write_Statement_Buffer; Set_String (" {"); - for J in Cumulative_Restrictions.Unknown'First .. - Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last) - loop + for J in Cumulative_Restrictions.Unknown'Range loop Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J))); Set_String (", "); end loop; - Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown - (Cumulative_Restrictions.Unknown'Last))); - Set_String ("}};"); + Set_String_Replace ("}}"); + Set_String (";"); Write_Statement_Buffer; WBI (" system__restrictions__run_time_restrictions = r;"); end Gen_Restrictions_C; @@ -3475,6 +3441,15 @@ package body Bindgen is Last := Last + S'Length; end Set_String; + ------------------------ + -- Set_String_Replace -- + ------------------------ + + procedure Set_String_Replace (S : String) is + begin + Statement_Buffer (Last - S'Length + 1 .. Last) := S; + end Set_String_Replace; + ------------------- -- Set_Unit_Name -- ------------------- diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads index 6585a0299e9..8d169fbd3f1 100644 --- a/gcc/ada/casing.ads +++ b/gcc/ada/casing.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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,6 +61,9 @@ package Casing is -- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def). ); + subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; + -- Exclude Unknown casing + ------------------------------ -- Case Control Subprograms -- ------------------------------ diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 54497274f2d..f3a1e2fb7a7 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -1556,7 +1556,6 @@ package body Clean is -- Initialize some packages Csets.Initialize; - Namet.Initialize; Snames.Initialize; Project_Node_Tree := new Project_Node_Tree_Data; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 7af2d6436eb..5def2eb5cf0 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -610,7 +610,6 @@ begin Uintp.Initialize; Urealp.Initialize; Errout.Initialize; - Namet.Initialize; SCOs.Initialize; Snames.Initialize; Stringt.Initialize; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index ca67ed2924e..0a197df3e57 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -6255,6 +6255,14 @@ allowed). Optional labels on @code{end} statements ending subprograms and on @code{exit} statements exiting named loops, are required to be present. +@item ^E^ENUMERATION_RANGES^ +@emph{Check enumeration ranges.} +Explicit subranges of enumeration types (e.g. in loops or membership tests) +are not allowed unless the subrange occurs in the same package as the type +declaration, or its body or subunits. Standard types (such as Boolean and +Character) are excluded, allowing for example the range 'A'..'Z'. In addition +an explicit reference to X'First..X'Last (equivalent to X'Range) is allowed. + @item ^f^VTABS^ @emph{No form feeds or vertical tabs.} Neither form feeds nor vertical tab characters are permitted diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index cb234d262e6..d3882589fde 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -583,13 +583,11 @@ begin Osint.Add_Default_Search_Dirs; -- Carry out package initializations. These are initializations which - -- might logically be performed at elaboration time, but Namet at least - -- can't be done that way (because it is used in the Compiler), and we - -- decide to be consistent. Like elaboration, the order in which these - -- calls are made is in some cases important. + -- might logically be performed at elaboration time, and we decide to be + -- consistent. Like elaboration, the order in which these calls are made + -- is in some cases important. Csets.Initialize; - Namet.Initialize; Snames.Initialize; -- Acquire target parameters diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 0f3810144e4..24ee7a10bed 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1320,9 +1320,7 @@ procedure GNATCmd is begin -- Initializations - Namet.Initialize; Csets.Initialize; - Snames.Initialize; Project_Node_Tree := new Project_Node_Tree_Data; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 675d9a364e4..ad57a9d9eef 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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- -- @@ -1537,7 +1537,6 @@ begin -- Initialize packages to be used - Namet.Initialize; Csets.Initialize; Snames.Initialize; @@ -1561,7 +1560,6 @@ begin -- the binder generated file if Compile_Bind_File and then Standard_Gcc then - Initialize_ALI; Name_Len := Ali_File_Name'Length; Name_Buffer (1 .. Name_Len) := Ali_File_Name.all; diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index b5a3f49df16..98088d011ab 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -1524,7 +1524,6 @@ procedure Gnatls is begin -- Initialize standard packages - Namet.Initialize; Csets.Initialize; Snames.Initialize; diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index b5e6b063cac..eb6cdde8220 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2010, 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- -- @@ -172,7 +172,6 @@ package body GPrep is -- Do some initializations (order is important here!) Csets.Initialize; - Namet.Initialize; Snames.Initialize; Stringt.Initialize; Prep.Initialize; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index d1cafbf32d3..f0c03320c28 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6725,7 +6725,7 @@ package body Make is Check_Object_Consistency := True; - -- Package initializations. The order of calls is important here + -- Package initializations (the order of calls is important here) Output.Set_Standard_Error; @@ -6734,8 +6734,6 @@ package body Make is Linker_Switches.Init; Csets.Initialize; - Namet.Initialize; - Snames.Initialize; Prj.Initialize (Project_Tree); diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 799e48662ba..d13918cd60a 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -864,29 +864,7 @@ package body Namet is procedure Initialize is begin - Name_Chars.Init; - Name_Entries.Init; - - -- Initialize entries for one character names - - for C in Character loop - Name_Entries.Append - ((Name_Chars_Index => Name_Chars.Last, - Name_Len => 1, - Byte_Info => 0, - Int_Info => 0, - Name_Has_No_Encodings => True, - Hash_Link => No_Name)); - - Name_Chars.Append (C); - Name_Chars.Append (ASCII.NUL); - end loop; - - -- Clear hash table - - for J in Hash_Index_Type loop - Hash_Table (J) := No_Name; - end loop; + null; end Initialize; ---------------------- @@ -1133,6 +1111,37 @@ package body Namet is end if; end Name_Find; + ------------------ + -- Reinitialize -- + ------------------ + + procedure Reinitialize is + begin + Name_Chars.Init; + Name_Entries.Init; + + -- Initialize entries for one character names + + for C in Character loop + Name_Entries.Append + ((Name_Chars_Index => Name_Chars.Last, + Name_Len => 1, + Byte_Info => 0, + Int_Info => 0, + Name_Has_No_Encodings => True, + Hash_Link => No_Name)); + + Name_Chars.Append (C); + Name_Chars.Append (ASCII.NUL); + end loop; + + -- Clear hash table + + for J in Hash_Index_Type loop + Hash_Table (J) := No_Name; + end loop; + end Reinitialize; + ---------------------- -- Reset_Name_Table -- ---------------------- @@ -1399,4 +1408,8 @@ package body Namet is end if; end Write_Name_Decoded; +-- Package initialization, initialize tables + +begin + Reinitialize; end Namet; diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index f3383b168af..729fec1a5fa 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -239,14 +239,20 @@ package Namet is -- is, it starts with an upper case O). procedure Initialize; - -- Initializes the names table, including initializing the first 26 - -- entries in the table (for the 1-character lower case names a-z) Note - -- that Initialize must not be called if Tree_Read is used. + -- This is a dummy procedure. It is retained for easy compatibility with + -- clients who used to call Initialize when this call was required. Now + -- initialization is performed automatically during package elaboration. + -- Note that this change fixes problems which existed prior to the change + -- of Initialize being called more than once. See also Reinitialize which + -- allows reinitialiation of the tables. procedure Lock; -- Lock name tables before calling back end. We reserve some extra space -- before locking to avoid unnecessary inefficiencies when we unlock. + procedure Reinitialize; + -- Clears the name tables and removes all existing entries from the table. + procedure Unlock; -- Unlocks the name table to allow use of the extra space reserved by the -- call to Lock. See gnat1drv for details of the need for this. diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index 6fad3f0a0dc..a16e6f3d181 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -44,8 +44,8 @@ package Prj.Attr is -- packages and their attribute. This procedure should be called by -- Prj.Initialize. - type Attribute_Kind is - (Unknown, + type Attribute_Kind is ( + Unknown, -- The attribute does not exist Single, @@ -61,9 +61,10 @@ package Prj.Attr is Case_Insensitive_Associative_Array, -- Associative array attribute with a case insensitive index - Optional_Index_Case_Insensitive_Associative_Array); + Optional_Index_Case_Insensitive_Associative_Array -- Associative array attribute with a case insensitive index and an -- optional source index. + ); -- Characteristics of an attribute. Optional_Index indicates that there -- may be an optional index in the index of the associative array, as in -- for Switches ("files.ada" at 2) use ... @@ -73,6 +74,11 @@ package Prj.Attr is -- Subset of Attribute_Kinds that may be used for the attributes that is -- used when defining a new package. + subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range + Case_Insensitive_Associative_Array .. + Optional_Index_Case_Insensitive_Associative_Array; + -- Subtype including both cases of Case_Insensitive_Associative_Array + Max_Attribute_Name_Length : constant := 64; -- The maximum length of attribute names diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 5795061eacb..9cb86bdb880 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -247,8 +247,7 @@ package body Prj.Dect is end if; if Attribute_Kind_Of (Current_Attribute) in - Case_Insensitive_Associative_Array .. - Optional_Index_Case_Insensitive_Associative_Array + All_Case_Insensitive_Associative_Array then Set_Case_Insensitive (Attribute, In_Tree, To => True); end if; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index 50cd0703d67..0368237d5fe 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2010, 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- -- @@ -792,7 +792,6 @@ package body Prj.Makr is -- Do some needed initializations Csets.Initialize; - Namet.Initialize; Snames.Initialize; Prj.Initialize (No_Project_Tree); Prj.Tree.Initialize (Tree); diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 456db448408..63b24b3d6fd 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -3310,7 +3310,7 @@ package body Prj.Nmsc is -- Get the naming exceptions for all languages - for Kind in Spec .. Impl loop + for Kind in Spec_Or_Body loop Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop case Lang_Id.Config.Kind is diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index 9798fb9c60a..3120e172227 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -216,8 +216,7 @@ package body Prj.Strt is Set_Case_Insensitive (Reference, In_Tree, To => Attribute_Kind_Of (Current_Attribute) in - Case_Insensitive_Associative_Array .. - Optional_Index_Case_Insensitive_Associative_Array); + All_Case_Insensitive_Associative_Array); -- Scan past the attribute name diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index d6e9bd8abb9..17d544f6f35 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -48,8 +48,6 @@ package body Prj is The_Empty_String : Name_Id := No_Name; - subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; - type Cst_String_Access is access constant String; All_Lower_Case_Image : aliased constant String := "lowercase"; diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb index c49b829763d..dbf30ddd54e 100644 --- a/gcc/ada/s-bitops.adb +++ b/gcc/ada/s-bitops.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2010, 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,6 +34,7 @@ pragma Compiler_Unit; with System; use System; with System.Unsigned_Types; use System.Unsigned_Types; +with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; package body System.Bit_Ops is @@ -72,6 +73,7 @@ package body System.Bit_Ops is ----------------------- procedure Raise_Error; + pragma No_Return (Raise_Error); -- Raise Constraint_Error, complaining about unequal lengths ------------- @@ -211,7 +213,8 @@ package body System.Bit_Ops is procedure Raise_Error is begin - raise Constraint_Error; + Raise_Exception + (Constraint_Error'Identity, "operand lengths are unequal"); end Raise_Error; end System.Bit_Ops; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 341a27953ab..3b29ca93012 100755 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2010, 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- -- @@ -203,8 +203,9 @@ package System.OS_Lib is (Name : String; Fmode : Mode) return File_Descriptor; -- Creates new file with given name for writing, returning file descriptor - -- for subsequent use in Write calls. File descriptor returned is - -- Invalid_FD if file cannot be successfully created. + -- for subsequent use in Write calls. If the file already exists, it is + -- overwritten. File descriptor returned is Invalid_FD if file cannot be + -- successfully created. function Create_Output_Text_File (Name : String) return File_Descriptor; -- Creates new text file with given name suitable to redirect standard diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 67a913919e3..5f067ccc261 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -184,415 +184,410 @@ package body Sem_Ch13 is begin -- Processing depends on version of Ada - case Ada_Version is + -- For Ada 95, we just renumber bits within a storage unit. We do the + -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83, + -- and are free to add this extension. - -- For Ada 95, we just renumber bits within a storage unit. We do - -- the same for Ada 83 mode, since we recognize pragma Bit_Order - -- in Ada 83, and are free to add this extension. + if Ada_Version < Ada_2005 then + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - when Ada_83 | Ada_95 => - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - CC := Component_Clause (Comp); + -- If component clause is present, then deal with the non-default + -- bit order case for Ada 95 mode. - -- If component clause is present, then deal with the non- - -- default bit order case for Ada 95 mode. + -- We only do this processing for the base type, and in fact that + -- is important, since otherwise if there are record subtypes, we + -- could reverse the bits once for each subtype, which is wrong. - -- We only do this processing for the base type, and in - -- fact that's important, since otherwise if there are - -- record subtypes, we could reverse the bits once for - -- each subtype, which would be incorrect. + if Present (CC) + and then Ekind (R) = E_Record_Type + then + declare + CFB : constant Uint := Component_Bit_Offset (Comp); + CSZ : constant Uint := Esize (Comp); + CLC : constant Node_Id := Component_Clause (Comp); + Pos : constant Node_Id := Position (CLC); + FB : constant Node_Id := First_Bit (CLC); - if Present (CC) - and then Ekind (R) = E_Record_Type - then - declare - CFB : constant Uint := Component_Bit_Offset (Comp); - CSZ : constant Uint := Esize (Comp); - CLC : constant Node_Id := Component_Clause (Comp); - Pos : constant Node_Id := Position (CLC); - FB : constant Node_Id := First_Bit (CLC); + Storage_Unit_Offset : constant Uint := + CFB / System_Storage_Unit; - Storage_Unit_Offset : constant Uint := - CFB / System_Storage_Unit; + Start_Bit : constant Uint := + CFB mod System_Storage_Unit; - Start_Bit : constant Uint := - CFB mod System_Storage_Unit; + begin + -- Cases where field goes over storage unit boundary - begin - -- Cases where field goes over storage unit boundary + if Start_Bit + CSZ > System_Storage_Unit then - if Start_Bit + CSZ > System_Storage_Unit then + -- Allow multi-byte field but generate warning - -- Allow multi-byte field but generate warning + if Start_Bit mod System_Storage_Unit = 0 + and then CSZ mod System_Storage_Unit = 0 + then + Error_Msg_N + ("multi-byte field specified with non-standard" + & " Bit_Order?", CLC); - if Start_Bit mod System_Storage_Unit = 0 - and then CSZ mod System_Storage_Unit = 0 - then + if Bytes_Big_Endian then Error_Msg_N - ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); - - if Bytes_Big_Endian then - Error_Msg_N - ("bytes are not reversed " - & "(component is big-endian)?", CLC); - else - Error_Msg_N - ("bytes are not reversed " - & "(component is little-endian)?", CLC); - end if; - - -- Do not allow non-contiguous field - + ("bytes are not reversed " + & "(component is big-endian)?", CLC); else Error_Msg_N - ("attempt to specify non-contiguous field " - & "not permitted", CLC); - Error_Msg_N - ("\caused by non-standard Bit_Order " - & "specified", CLC); - Error_Msg_N - ("\consider possibility of using " - & "Ada 2005 mode here", CLC); + ("bytes are not reversed " + & "(component is little-endian)?", CLC); end if; - -- Case where field fits in one storage unit + -- Do not allow non-contiguous field else - -- Give warning if suspicious component clause + Error_Msg_N + ("attempt to specify non-contiguous field " + & "not permitted", CLC); + Error_Msg_N + ("\caused by non-standard Bit_Order " + & "specified", CLC); + Error_Msg_N + ("\consider possibility of using " + & "Ada 2005 mode here", CLC); + end if; - if Intval (FB) >= System_Storage_Unit - and then Warn_On_Reverse_Bit_Order - then - Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); - Error_Msg_Uint_1 := - Intval (Pos) + Intval (FB) / - System_Storage_Unit; - Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); - end if; + -- Case where field fits in one storage unit + + else + -- Give warning if suspicious component clause + + if Intval (FB) >= System_Storage_Unit + and then Warn_On_Reverse_Bit_Order + then + Error_Msg_N + ("?Bit_Order clause does not affect " & + "byte ordering", Pos); + Error_Msg_Uint_1 := + Intval (Pos) + Intval (FB) / + System_Storage_Unit; + Error_Msg_N + ("?position normalized to ^ before bit " & + "order interpreted", Pos); + end if; - -- Here is where we fix up the Component_Bit_Offset - -- value to account for the reverse bit order. - -- Some examples of what needs to be done are: + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done are: - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 - -- The general rule is that the first bit is - -- is obtained by subtracting the old ending bit - -- from storage_unit - 1. + -- The rule is that the first bit is is obtained by + -- subtracting the old ending bit from storage_unit - 1. - Set_Component_Bit_Offset - (Comp, - (Storage_Unit_Offset * System_Storage_Unit) + - (System_Storage_Unit - 1) - - (Start_Bit + CSZ - 1)); + Set_Component_Bit_Offset + (Comp, + (Storage_Unit_Offset * System_Storage_Unit) + + (System_Storage_Unit - 1) - + (Start_Bit + CSZ - 1)); - Set_Normalized_First_Bit - (Comp, - Component_Bit_Offset (Comp) mod - System_Storage_Unit); - end if; - end; - end if; + Set_Normalized_First_Bit + (Comp, + Component_Bit_Offset (Comp) mod + System_Storage_Unit); + end if; + end; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + Next_Component_Or_Discriminant (Comp); + end loop; - -- For Ada 2005, we do machine scalar processing, as fully described - -- In AI-133. This involves gathering all components which start at - -- the same byte offset and processing them together + -- For Ada 2005, we do machine scalar processing, as fully described In + -- AI-133. This involves gathering all components which start at the + -- same byte offset and processing them together. Same approach is still + -- valid in later versions including Ada 2012. - when Ada_05 .. Ada_Version_Type'Last => - declare - Max_Machine_Scalar_Size : constant Uint := - UI_From_Int - (Standard_Long_Long_Integer_Size); + else + declare + Max_Machine_Scalar_Size : constant Uint := + UI_From_Int + (Standard_Long_Long_Integer_Size); -- We use this as the maximum machine scalar size - Num_CC : Natural; - SSU : constant Uint := UI_From_Int (System_Storage_Unit); + Num_CC : Natural; + SSU : constant Uint := UI_From_Int (System_Storage_Unit); - begin - -- This first loop through components does two things. First it - -- deals with the case of components with component clauses - -- whose length is greater than the maximum machine scalar size - -- (either accepting them or rejecting as needed). Second, it - -- counts the number of components with component clauses whose - -- length does not exceed this maximum for later processing. + begin + -- This first loop through components does two things. First it + -- deals with the case of components with component clauses whose + -- length is greater than the maximum machine scalar size (either + -- accepting them or rejecting as needed). Second, it counts the + -- number of components with component clauses whose length does + -- not exceed this maximum for later processing. + + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + CC := Component_Clause (Comp); - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - CC := Component_Clause (Comp); + if Present (CC) then + declare + Fbit : constant Uint := + Static_Integer (First_Bit (CC)); - if Present (CC) then - declare - Fbit : constant Uint := - Static_Integer (First_Bit (CC)); + begin + -- Case of component with size > max machine scalar - begin - -- Case of component with size > max machine scalar + if Esize (Comp) > Max_Machine_Scalar_Size then - if Esize (Comp) > Max_Machine_Scalar_Size then + -- Must begin on byte boundary - -- Must begin on byte boundary + if Fbit mod SSU /= 0 then + Error_Msg_N + ("illegal first bit value for " + & "reverse bit order", + First_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; - if Fbit mod SSU /= 0 then - Error_Msg_N - ("illegal first bit value for " - & "reverse bit order", - First_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Error_Msg_N + ("\must be a multiple of ^ " + & "if size greater than ^", + First_Bit (CC)); - Error_Msg_N - ("\must be a multiple of ^ " - & "if size greater than ^", - First_Bit (CC)); + -- Must end on byte boundary - -- Must end on byte boundary + elsif Esize (Comp) mod SSU /= 0 then + Error_Msg_N + ("illegal last bit value for " + & "reverse bit order", + Last_Bit (CC)); + Error_Msg_Uint_1 := SSU; + Error_Msg_Uint_2 := Max_Machine_Scalar_Size; - elsif Esize (Comp) mod SSU /= 0 then - Error_Msg_N - ("illegal last bit value for " - & "reverse bit order", - Last_Bit (CC)); - Error_Msg_Uint_1 := SSU; - Error_Msg_Uint_2 := Max_Machine_Scalar_Size; + Error_Msg_N + ("\must be a multiple of ^ if size " + & "greater than ^", + Last_Bit (CC)); - Error_Msg_N - ("\must be a multiple of ^ if size " - & "greater than ^", - Last_Bit (CC)); + -- OK, give warning if enabled - -- OK, give warning if enabled + elsif Warn_On_Reverse_Bit_Order then + Error_Msg_N + ("multi-byte field specified with " + & " non-standard Bit_Order?", CC); - elsif Warn_On_Reverse_Bit_Order then + if Bytes_Big_Endian then + Error_Msg_N + ("\bytes are not reversed " + & "(component is big-endian)?", CC); + else Error_Msg_N - ("multi-byte field specified with " - & " non-standard Bit_Order?", CC); - - if Bytes_Big_Endian then - Error_Msg_N - ("\bytes are not reversed " - & "(component is big-endian)?", CC); - else - Error_Msg_N - ("\bytes are not reversed " - & "(component is little-endian)?", CC); - end if; + ("\bytes are not reversed " + & "(component is little-endian)?", CC); end if; + end if; - -- Case where size is not greater than max machine - -- scalar. For now, we just count these. + -- Case where size is not greater than max machine + -- scalar. For now, we just count these. - else - Num_CC := Num_CC + 1; - end if; - end; - end if; + else + Num_CC := Num_CC + 1; + end if; + end; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + Next_Component_Or_Discriminant (Comp); + end loop; - -- We need to sort the component clauses on the basis of the - -- Position values in the clause, so we can group clauses with - -- the same Position. together to determine the relevant - -- machine scalar size. + -- We need to sort the component clauses on the basis of the + -- Position values in the clause, so we can group clauses with + -- the same Position. together to determine the relevant machine + -- scalar size. - Sort_CC : declare - Comps : array (0 .. Num_CC) of Entity_Id; - -- Array to collect component and discriminant entities. The - -- data starts at index 1, the 0'th entry is for the sort - -- routine. + Sort_CC : declare + Comps : array (0 .. Num_CC) of Entity_Id; + -- Array to collect component and discriminant entities. The + -- data starts at index 1, the 0'th entry is for the sort + -- routine. - function CP_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + function CP_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - procedure CP_Move (From : Natural; To : Natural); - -- Move routine for Sort + procedure CP_Move (From : Natural; To : Natural); + -- Move routine for Sort - package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); + package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); - Start : Natural; - Stop : Natural; - -- Start and stop positions in component list of set of - -- components with the same starting position (that - -- constitute components in a single machine scalar). + Start : Natural; + Stop : Natural; + -- Start and stop positions in the component list of the set of + -- components with the same starting position (that constitute + -- components in a single machine scalar). - MaxL : Uint; - -- Maximum last bit value of any component in this set + MaxL : Uint; + -- Maximum last bit value of any component in this set - MSS : Uint; - -- Corresponding machine scalar size + MSS : Uint; + -- Corresponding machine scalar size - ----------- - -- CP_Lt -- - ----------- + ----------- + -- CP_Lt -- + ----------- - function CP_Lt (Op1, Op2 : Natural) return Boolean is - begin - return Position (Component_Clause (Comps (Op1))) < - Position (Component_Clause (Comps (Op2))); - end CP_Lt; + function CP_Lt (Op1, Op2 : Natural) return Boolean is + begin + return Position (Component_Clause (Comps (Op1))) < + Position (Component_Clause (Comps (Op2))); + end CP_Lt; - ------------- - -- CP_Move -- - ------------- + ------------- + -- CP_Move -- + ------------- - procedure CP_Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end CP_Move; + procedure CP_Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end CP_Move; -- Start of processing for Sort_CC - begin - -- Collect the component clauses + begin + -- Collect the component clauses - Num_CC := 0; - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop - if Present (Component_Clause (Comp)) - and then Esize (Comp) <= Max_Machine_Scalar_Size - then - Num_CC := Num_CC + 1; - Comps (Num_CC) := Comp; - end if; + Num_CC := 0; + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop + if Present (Component_Clause (Comp)) + and then Esize (Comp) <= Max_Machine_Scalar_Size + then + Num_CC := Num_CC + 1; + Comps (Num_CC) := Comp; + end if; - Next_Component_Or_Discriminant (Comp); - end loop; + Next_Component_Or_Discriminant (Comp); + end loop; - -- Sort by ascending position number + -- Sort by ascending position number - Sorting.Sort (Num_CC); + Sorting.Sort (Num_CC); - -- We now have all the components whose size does not exceed - -- the max machine scalar value, sorted by starting - -- position. In this loop we gather groups of clauses - -- starting at the same position, to process them in - -- accordance with Ada 2005 AI-133. + -- We now have all the components whose size does not exceed + -- the max machine scalar value, sorted by starting position. + -- In this loop we gather groups of clauses starting at the + -- same position, to process them in accordance with AI-133. - Stop := 0; + Stop := 0; + while Stop < Num_CC loop + Start := Stop + 1; + Stop := Start; + MaxL := + Static_Integer + (Last_Bit (Component_Clause (Comps (Start)))); while Stop < Num_CC loop - Start := Stop + 1; - Stop := Start; - MaxL := - Static_Integer - (Last_Bit (Component_Clause (Comps (Start)))); - while Stop < Num_CC loop - if Static_Integer - (Position (Component_Clause (Comps (Stop + 1)))) = - Static_Integer - (Position (Component_Clause (Comps (Stop)))) - then - Stop := Stop + 1; - MaxL := - UI_Max - (MaxL, - Static_Integer - (Last_Bit - (Component_Clause (Comps (Stop))))); - else - exit; - end if; - end loop; + if Static_Integer + (Position (Component_Clause (Comps (Stop + 1)))) = + Static_Integer + (Position (Component_Clause (Comps (Stop)))) + then + Stop := Stop + 1; + MaxL := + UI_Max + (MaxL, + Static_Integer + (Last_Bit + (Component_Clause (Comps (Stop))))); + else + exit; + end if; + end loop; - -- Now we have a group of component clauses from Start to - -- Stop whose positions are identical, and MaxL is the - -- maximum last bit value of any of these components. - - -- We need to determine the corresponding machine scalar - -- size. This loop assumes that machine scalar sizes are - -- even, and that each possible machine scalar has twice - -- as many bits as the next smaller one. - - MSS := Max_Machine_Scalar_Size; - while MSS mod 2 = 0 - and then (MSS / 2) >= SSU - and then (MSS / 2) > MaxL - loop - MSS := MSS / 2; - end loop; + -- Now we have a group of component clauses from Start to + -- Stop whose positions are identical, and MaxL is the + -- maximum last bit value of any of these components. - -- Here is where we fix up the Component_Bit_Offset value - -- to account for the reverse bit order. Some examples of - -- what needs to be done for the case of a machine scalar - -- size of 8 are: + -- We need to determine the corresponding machine scalar + -- size. This loop assumes that machine scalar sizes are + -- even, and that each possible machine scalar has twice + -- as many bits as the next smaller one. - -- First_Bit .. Last_Bit Component_Bit_Offset - -- old new old new + MSS := Max_Machine_Scalar_Size; + while MSS mod 2 = 0 + and then (MSS / 2) >= SSU + and then (MSS / 2) > MaxL + loop + MSS := MSS / 2; + end loop; - -- 0 .. 0 7 .. 7 0 7 - -- 0 .. 1 6 .. 7 0 6 - -- 0 .. 2 5 .. 7 0 5 - -- 0 .. 7 0 .. 7 0 4 + -- Here is where we fix up the Component_Bit_Offset value + -- to account for the reverse bit order. Some examples of + -- what needs to be done for the case of a machine scalar + -- size of 8 are: - -- 1 .. 1 6 .. 6 1 6 - -- 1 .. 4 3 .. 6 1 3 - -- 4 .. 7 0 .. 3 4 0 + -- First_Bit .. Last_Bit Component_Bit_Offset + -- old new old new - -- The general rule is that the first bit is obtained by - -- subtracting the old ending bit from machine scalar - -- size - 1. + -- 0 .. 0 7 .. 7 0 7 + -- 0 .. 1 6 .. 7 0 6 + -- 0 .. 2 5 .. 7 0 5 + -- 0 .. 7 0 .. 7 0 4 - for C in Start .. Stop loop - declare - Comp : constant Entity_Id := Comps (C); - CC : constant Node_Id := - Component_Clause (Comp); - LB : constant Uint := - Static_Integer (Last_Bit (CC)); - NFB : constant Uint := MSS - Uint_1 - LB; - NLB : constant Uint := NFB + Esize (Comp) - 1; - Pos : constant Uint := - Static_Integer (Position (CC)); + -- 1 .. 1 6 .. 6 1 6 + -- 1 .. 4 3 .. 6 1 3 + -- 4 .. 7 0 .. 3 4 0 - begin - if Warn_On_Reverse_Bit_Order then - Error_Msg_Uint_1 := MSS; - Error_Msg_N - ("info: reverse bit order in machine " & - "scalar of length^?", First_Bit (CC)); - Error_Msg_Uint_1 := NFB; - Error_Msg_Uint_2 := NLB; - - if Bytes_Big_Endian then - Error_Msg_NE - ("?\info: big-endian range for " - & "component & is ^ .. ^", - First_Bit (CC), Comp); - else - Error_Msg_NE - ("?\info: little-endian range " - & "for component & is ^ .. ^", - First_Bit (CC), Comp); - end if; + -- The rule is that the first bit is obtained by subtracting + -- the old ending bit from machine scalar size - 1. + + for C in Start .. Stop loop + declare + Comp : constant Entity_Id := Comps (C); + CC : constant Node_Id := + Component_Clause (Comp); + LB : constant Uint := + Static_Integer (Last_Bit (CC)); + NFB : constant Uint := MSS - Uint_1 - LB; + NLB : constant Uint := NFB + Esize (Comp) - 1; + Pos : constant Uint := + Static_Integer (Position (CC)); + + begin + if Warn_On_Reverse_Bit_Order then + Error_Msg_Uint_1 := MSS; + Error_Msg_N + ("info: reverse bit order in machine " & + "scalar of length^?", First_Bit (CC)); + Error_Msg_Uint_1 := NFB; + Error_Msg_Uint_2 := NLB; + + if Bytes_Big_Endian then + Error_Msg_NE + ("?\info: big-endian range for " + & "component & is ^ .. ^", + First_Bit (CC), Comp); + else + Error_Msg_NE + ("?\info: little-endian range " + & "for component & is ^ .. ^", + First_Bit (CC), Comp); end if; + end if; - Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); - Set_Normalized_First_Bit (Comp, NFB mod SSU); - end; - end loop; + Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); + Set_Normalized_First_Bit (Comp, NFB mod SSU); + end; end loop; - end Sort_CC; - end; - end case; + end loop; + end Sort_CC; + end; + end if; end Adjust_Record_For_Reverse_Bit_Order; -------------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0e9329c9185..6015eaec696 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5553,8 +5553,7 @@ package body Sem_Ch3 is end if; -- If we did not have a range constraint, then set the range from the - -- parent type. Otherwise, the call to Process_Subtype has set the - -- bounds. + -- parent type. Otherwise, the Process_Subtype call has set the bounds. if No_Constraint or else not Has_Range_Constraint (Indic) @@ -17275,7 +17274,7 @@ package body Sem_Ch3 is N_Subtype_Declaration); -- Create an Itype that is a duplicate of Entity (S) but with the - -- null-exclusion attribute + -- null-exclusion attribute. if May_Have_Null_Exclusion and then Is_Access_Type (Entity (S)) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 7ed76f61ee8..1c55b3016f7 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1676,7 +1676,7 @@ package body Sem_Elab is -- Here is where we give the warning - -- All OK if warnings suppressed on the entity + -- All OK if warnings suppressed on the entity if not Has_Warnings_Off (Ent) then Error_Msg_Sloc := Sloc (Ent); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 0917ccecf43..e07754e86c2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7611,6 +7611,10 @@ package body Sem_Res is Resolve (L, Typ); Resolve (H, Typ); + if Style_Check then + Check_Enumeration_Subrange (N); + end if; + Check_Unset_Reference (L); Check_Unset_Reference (H); diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 12d1327b3c2..8f771578718 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -184,6 +184,18 @@ package body Sem_Type is -- Interp_Has_Abstract_Op. Determine whether an overloaded node has an -- abstract interpretation which yields type Typ. + function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean; + -- This function tests if entity E is in Array_Kind, or Class_Wide_Kind, + -- or is E_Record_Type or E_Record_Subtype, and returns True for these + -- cases, and False for all others. Note that other record entity kinds + -- such as E_Record_Type_With_Private return False. + -- + -- This is a bit of an odd category, maybe it is wrong or a better name + -- could be found for the class of entities being tested. The history + -- is that this used to be done with an explicit range test for the range + -- E_Array_Type .. E_Record_Subtype, which was itself suspicious and is + -- now prohibited by the -gnatyE style check ??? + procedure New_Interps (N : Node_Id); -- Initialize collection of interpretations for the given node, which is -- either an overloaded entity, or an operation whose arguments have @@ -900,7 +912,7 @@ package body Sem_Type is -- An aggregate is compatible with an array or record type elsif T2 = Any_Composite - and then Ekind (T1) in E_Array_Type .. E_Record_Subtype + and then Is_Array_Class_Record_Type (T1) then return True; @@ -2615,6 +2627,18 @@ package body Sem_Type is end if; end Is_Ancestor; + -------------------------------- + -- Is_Array_Class_Record_Type -- + -------------------------------- + + function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean is + begin + return Is_Array_Type (E) + or else Is_Class_Wide_Type (E) + or else Ekind (E) = E_Record_Type + or else Ekind (E) = E_Record_Subtype; + end Is_Array_Class_Record_Type; + --------------------------- -- Is_Invisible_Operator -- --------------------------- @@ -3033,12 +3057,12 @@ package body Sem_Type is return T1; elsif T2 = Any_Composite - and then Ekind (T1) in E_Array_Type .. E_Record_Subtype + and then Is_Array_Class_Record_Type (T1) then return T1; elsif T1 = Any_Composite - and then Ekind (T2) in E_Array_Type .. E_Record_Subtype + and then Is_Array_Class_Record_Type (T2) then return T2; diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads index b61cd08bbf9..dcade7ba86f 100644 --- a/gcc/ada/style.ads +++ b/gcc/ada/style.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -103,6 +103,9 @@ package Style is -- Called after scanning out a binary operator other than a plus, minus -- or exponentiation operator. Intended for checking spacing rules. + procedure Check_Enumeration_Subrange (N : Node_Id) + renames Style_Inst.Check_Enumeration_Subrange; + procedure Check_Exponentiation_Operator renames Style_Inst.Check_Exponentiation_Operator; -- Called after scanning out an exponentiation operator. Intended for diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb index 1c22dbcf707..c19a0969c51 100644 --- a/gcc/ada/styleg.adb +++ b/gcc/ada/styleg.adb @@ -32,10 +32,13 @@ with Casing; use Casing; with Csets; use Csets; with Einfo; use Einfo; with Err_Vars; use Err_Vars; +with Lib; use Lib; +with Namet; use Namet; with Opt; use Opt; with Scans; use Scans; with Sinfo; use Sinfo; with Sinput; use Sinput; +with Snames; use Snames; with Stylesw; use Stylesw; package body Styleg is @@ -550,6 +553,82 @@ package body Styleg is end if; end Check_Dot_Dot; + -------------------------------- + -- Check_Enumeration_Subrange -- + -------------------------------- + + procedure Check_Enumeration_Subrange (N : Node_Id) is + function First_Last_Ref return Boolean; + -- Returns True if N is of the form X'First .. X'Last where X is the + -- same entity for both attributes. N is already known to be N_Range. + + -------------------- + -- First_Last_Ref -- + -------------------- + + function First_Last_Ref return Boolean is + L : constant Node_Id := Low_Bound (N); + H : constant Node_Id := High_Bound (N); + + begin + if Nkind (L) = N_Attribute_Reference + and then Nkind (H) = N_Attribute_Reference + and then Attribute_Name (L) = Name_First + and then Attribute_Name (H) = Name_Last + then + declare + PL : constant Node_Id := Prefix (L); + PH : constant Node_Id := Prefix (H); + begin + if Is_Entity_Name (PL) + and then Is_Entity_Name (PH) + and then Entity (PL) = Entity (PH) + then + return True; + end if; + end; + end if; + + return False; + end First_Last_Ref; + + -- Start of processing for Check_Enumeration_Subrange + + begin + if Style_Check_Enumeration_Subranges then + + if Nkind (N) = N_Range + + -- Only consider ranges that are explicit in the source + + and then Comes_From_Source (N) + + -- Only consider enumeration types + + and then Is_Enumeration_Type (Etype (N)) + + -- Exclude standard types. Most importantly we want to exclude the + -- standard character types, since we want to allow ranges like + -- '0' .. '9'. But also exclude Boolean since False .. True is OK. + + and then Sloc (Root_Type (Etype (N))) /= Standard_Location + + -- Exclude X'First .. X'Last if X is the same entity for both + + and then not First_Last_Ref + + -- Allow the range if in same unit as type declaration (or the + -- corresponding body or any of its subunits). + + and then not In_Same_Extended_Unit (N, Etype (N)) + then + Error_Msg + ("(style) explicit enumeration subrange not allowed", + Sloc (N)); + end if; + end if; + end Check_Enumeration_Subrange; + --------------- -- Check_EOF -- --------------- diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads index 91c90d2ae81..ea78f6ed473 100644 --- a/gcc/ada/styleg.ads +++ b/gcc/ada/styleg.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -92,6 +92,10 @@ package Styleg is procedure Check_Dot_Dot; -- Called after scanning out dot dot to check spacing + procedure Check_Enumeration_Subrange (N : Node_Id); + -- Called to check a node that may be an N_Range node for an enumeration + -- subtype occurring other than in the defining unit of the type. + procedure Check_EOF; -- Called after scanning out EOF mark diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb index 2f987fda28c..7d3c5cef613 100644 --- a/gcc/ada/stylesw.adb +++ b/gcc/ada/stylesw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -59,6 +59,12 @@ package body Stylesw is "u" & -- check no unnecessary blank lines "x"; -- check extra parentheses around conditionals + -- Note: we intend GNAT_Style to also include the following, but we do + -- not yet have the whole tool suite clean with respect to this. + + -- "B" & -- check boolean operators + -- "E" & -- check enumeration ranges + ------------------------------- -- Reset_Style_Check_Options -- ------------------------------- @@ -73,6 +79,7 @@ package body Stylesw is Style_Check_Boolean_And_Or := False; Style_Check_Comments := False; Style_Check_DOS_Line_Terminator := False; + Style_Check_Enumeration_Subranges := False; Style_Check_End_Labels := False; Style_Check_Form_Feeds := False; Style_Check_Horizontal_Tabs := False; @@ -158,6 +165,7 @@ package body Stylesw is Add ('c', Style_Check_Comments); Add ('d', Style_Check_DOS_Line_Terminator); Add ('e', Style_Check_End_Labels); + Add ('E', Style_Check_Enumeration_Subranges); Add ('f', Style_Check_Form_Feeds); Add ('h', Style_Check_Horizontal_Tabs); Add ('i', Style_Check_If_Then_Layout); @@ -324,6 +332,9 @@ package body Stylesw is when 'e' => Style_Check_End_Labels := True; + when 'E' => + Style_Check_Enumeration_Subranges := True; + when 'f' => Style_Check_Form_Feeds := True; @@ -488,6 +499,9 @@ package body Stylesw is when 'e' => Style_Check_End_Labels := False; + when 'E' => + Style_Check_Enumeration_Subranges := False; + when 'f' => Style_Check_Form_Feeds := False; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index 744706380c8..7d5a461ded9 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -113,6 +113,12 @@ package Stylesw is -- This can be set True by using the -gnatye switch. If it is True, then -- optional END labels must always be present. + Style_Check_Enumeration_Subranges : Boolean := False; + -- This can be set True by using the -gnatyE switch. If it is True, then + -- explicit subranges (using .. notation) on enumeration subtypes are not + -- permitted in other than the same source unit in which the enumeration + -- subtype is declared. + Style_Check_Form_Feeds : Boolean := False; -- This can be set True by using the -gnatyf switch. If it is True, then -- form feeds and vertical tabs are not allowed in the source text. diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 2121b7f20e4..1bd22b5045c 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -533,6 +533,7 @@ begin Write_Line (" c check comment format"); Write_Line (" d check no DOS line terminators"); Write_Line (" e check end/exit labels present"); + Write_Line (" E check no explicit enumeration subranges"); Write_Line (" f check no form feeds/vertical tabs in source"); Write_Line (" g check standard GNAT style rules"); Write_Line (" h check no horizontal tabs in source"); diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 84571bb3bac..5fbf775988b 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -2259,10 +2259,12 @@ package VMS_Data is "-gnaty-A " & "BLANKS " & "-gnatyb " & - "BOOLEAN_OPERATORS " & - "-gnatyB " & "NOBLANKS " & "-gnaty-b " & + "BOOLEAN_OPERATORS " & + "-gnatyB " & + "NOBOOLEAN_OPERATORS " & + "-gnaty-B " & "COMMENTS " & "-gnatyc " & "NOCOMMENTS " & @@ -2275,6 +2277,10 @@ package VMS_Data is "-gnatye " & "NOEND " & "-gnaty-e " & + "ENUMERATION_RANGES " & + "-gnatyE " & + "NOENUMERATION_RANGES " & + "-gnaty-E " & "VTABS " & "-gnatyf " & "NOVTABS " & |