OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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

From-SVN: r164058
This commit is contained in:
Arnaud Charlet 2010-09-09 11:44:34 +02:00
parent 821b8ef47b
commit 498d1b808e
35 changed files with 708 additions and 526 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
gcc/ada/ChangeLog
View File

@ -1,3 +1,52 @@
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

24
gcc/ada/a-calfor.adb
View File

@ -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;

97
gcc/ada/bindgen.adb
View File

@ -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 --
-------------------

5
gcc/ada/casing.ads
View File

@ -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 --
------------------------------

1
gcc/ada/clean.adb
View File

@ -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;

1
gcc/ada/gnat1drv.adb
View File

@ -610,7 +610,6 @@ begin
Uintp.Initialize;
Urealp.Initialize;
Errout.Initialize;
Namet.Initialize;
SCOs.Initialize;
Snames.Initialize;
Stringt.Initialize;

8
gcc/ada/gnat_ugn.texi
View File

@ -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

8
gcc/ada/gnatbind.adb
View File

@ -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

2
gcc/ada/gnatcmd.adb
View File

@ -1320,9 +1320,7 @@ procedure GNATCmd is
begin
-- Initializations
Namet.Initialize;
Csets.Initialize;
Snames.Initialize;
Project_Node_Tree := new Project_Node_Tree_Data;

4
gcc/ada/gnatlink.adb
View File

@ -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;

3
gcc/ada/gnatls.adb
View File

@ -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;

3
gcc/ada/gprep.adb
View File

@ -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;

4
gcc/ada/make.adb
View File

@ -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);

61
gcc/ada/namet.adb
View File

@ -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;

14
gcc/ada/namet.ads
View File

@ -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.

14
gcc/ada/prj-attr.ads
View File

@ -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

5
gcc/ada/prj-dect.adb
View File

@ -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;

3
gcc/ada/prj-makr.adb
View File

@ -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);

2
gcc/ada/prj-nmsc.adb
View File

@ -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

3
gcc/ada/prj-strt.adb
View File

@ -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

2
gcc/ada/prj.adb
View File

@ -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";

7
gcc/ada/s-bitops.adb
View File

@ -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;

7
gcc/ada/s-os_lib.ads
View File

@ -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

741
gcc/ada/sem_ch13.adb
View File

@ -184,356 +184,98 @@ 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;
begin
-- Cases where field goes over storage unit boundary
if Start_Bit + CSZ > System_Storage_Unit then
-- 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 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
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);
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:
-- 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
-- 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.
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;
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
when Ada_05 .. Ada_Version_Type'Last =>
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);
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);
if Present (CC) then
declare
Fbit : constant Uint :=
Static_Integer (First_Bit (CC));
begin
-- Case of component with size > max machine scalar
if Esize (Comp) > Max_Machine_Scalar_Size then
-- 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;
Error_Msg_N
("\must be a multiple of ^ "
& "if size greater than ^",
First_Bit (CC));
-- 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;
Error_Msg_N
("\must be a multiple of ^ if size "
& "greater than ^",
Last_Bit (CC));
-- 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);
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;
end if;
-- 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;
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.
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
procedure CP_Move (From : Natural; To : Natural);
-- Move routine for Sort
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).
MaxL : Uint;
-- Maximum last bit value of any component in this set
MSS : Uint;
-- Corresponding machine scalar size
-----------
-- 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 --
-------------
procedure CP_Move (From : Natural; To : Natural) is
begin
Comps (To) := Comps (From);
end CP_Move;
-- Start of processing for Sort_CC
Start_Bit : constant Uint :=
CFB mod System_Storage_Unit;
begin
-- Collect the component clauses
-- Cases where field goes over storage unit boundary
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
if Start_Bit + CSZ > System_Storage_Unit then
-- Allow multi-byte field but generate warning
if Start_Bit mod System_Storage_Unit = 0
and then CSZ mod System_Storage_Unit = 0
then
Num_CC := Num_CC + 1;
Comps (Num_CC) := Comp;
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
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);
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
-- Case where field fits in one storage unit
-- Sort by ascending position number
else
-- Give warning if suspicious component clause
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.
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
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;
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 for the case of a machine scalar
-- size of 8 are:
-- what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
@ -547,52 +289,305 @@ package body Sem_Ch13 is
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The general rule is that the first bit is obtained by
-- subtracting the old ending bit from machine scalar
-- size - 1.
-- The rule is that the first bit is is obtained by
-- subtracting the old ending bit from storage_unit - 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));
Set_Component_Bit_Offset
(Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
begin
if Warn_On_Reverse_Bit_Order then
Error_Msg_Uint_1 := MSS;
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;
-- 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.
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);
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);
if Present (CC) then
declare
Fbit : constant Uint :=
Static_Integer (First_Bit (CC));
begin
-- Case of component with size > max machine scalar
if Esize (Comp) > Max_Machine_Scalar_Size then
-- 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;
Error_Msg_N
("\must be a multiple of ^ "
& "if size greater than ^",
First_Bit (CC));
-- 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;
Error_Msg_N
("\must be a multiple of ^ if size "
& "greater than ^",
Last_Bit (CC));
-- 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);
if Bytes_Big_Endian then
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;
("\bytes are not reversed "
& "(component is big-endian)?", CC);
else
Error_Msg_N
("\bytes are not reversed "
& "(component is little-endian)?", CC);
end if;
end if;
Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
Set_Normalized_First_Bit (Comp, NFB mod SSU);
end;
end loop;
-- 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;
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.
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
procedure CP_Move (From : Natural; To : Natural);
-- Move routine for Sort
package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
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
MSS : Uint;
-- Corresponding machine scalar size
-----------
-- 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 --
-------------
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
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;
-- Sort by ascending position number
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 AI-133.
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
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;
end Sort_CC;
end;
end case;
-- 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;
-- 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:
-- 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
-- 1 .. 1 6 .. 6 1 6
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- 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;
end loop;
end Sort_CC;
end;
end if;
end Adjust_Record_For_Reverse_Bit_Order;
--------------------------------------

5
gcc/ada/sem_ch3.adb
View File

@ -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))

2
gcc/ada/sem_elab.adb
View File

@ -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);

4
gcc/ada/sem_res.adb
View File

@ -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);

30
gcc/ada/sem_type.adb
View File

@ -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;

5
gcc/ada/style.ads
View File

@ -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

79
gcc/ada/styleg.adb
View File

@ -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 --
---------------

6
gcc/ada/styleg.ads
View File

@ -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

16
gcc/ada/stylesw.adb
View File

@ -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;

8
gcc/ada/stylesw.ads
View File

@ -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.

1
gcc/ada/usage.adb
View File

@ -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");

10
gcc/ada/vms_data.ads
View File

@ -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 " &