mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-25 01:20:52 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-09-09  Vincent Celier  <celier@adacore.com>

	* osint.adb (Canonical_Case_File_Name): Use procedure To_Lower in
	System.Case_Util
	(Canonical_Case_Env_Var_Name): Ditto

2010-09-09  Bob Duff  <duff@adacore.com>

	* g-pehage.adb (Allocate): Initialize the allocated elements of IT.

2010-09-09  Robert Dewar  <dewar@adacore.com>

	* cstand.adb: Mark Boolean and Character types as Ordered
	* einfo.adb (Has_Pragma_Ordered): New flag
	* einfo.ads (Has_Pragma_Ordered): New flag
	* g-calend.ads: Mark Day_Name as Ordered
	* opt.ads: Mark Ada_Version_Type as Ordered
	(Warn_On_Unordered_Enumeration_Type): New flag
	* par-prag.adb: Add procdessing for pragma Ordered
	* s-ficobl.ads (Read_File_Mode): New subtype
	* s-fileio.adb: Use Read_File_Mode instead of explicit ranges
	* s-taskin.ads: Mark Entry_Call_State as ordered
	* sem_ch3.adb (Build_Derived_Enumeration_Type): Inherit
	Has_Pragma_Ordered.
	* sem_ch6.ads: Mark Conformance_Type as Ordered
	* sem_prag.adb: Implement pragma Ordered
	* sem_res.adb (Bad_Unordered_Enumeration_Reference): New function
	(Resolve_Comparison_Op): Diagnose unordered comparison
	(Resolve_Range): Diagnose unordered range
	* sem_warn.adb (Warn_On_Unordered_Enumeration_Type): New flag (from
	-gnatw.u/U)
	* snames.ads-tmpl: Add entry for pragma Ordered
	* style.ads (Check_Enumeration_Subrange): Removed
	* styleg.adb (Check_Enumeration_Subrange): Removed
	* styleg.ads (Check_Enumeration_Subrange): Removed
	* stylesw.adb: Remove handling of -gnatyE switch
	* stylesw.ads: (Style_Check_Enumeration_Subranges): Removed
	* vms_data.ads: Remove -gnatyE entries
	Add -gnatw.u entries
	* ug_words: Entries for -gnatw.u and -gnatw.U
	* gnat_ugn.texi: Document -gnatw.u/-gnatw.U switches
	* gnat_rm.texi: Document pragma Ordered.
	* s-tasren.adb: Avoid unnecessary comparison on unordered enumeration.
	* s-tpobop.adb: Remove comparison on unordered enumeration type.

From-SVN: r164070
This commit is contained in:
Arnaud Charlet 2010-09-09 12:32:50 +02:00
parent 0e35524dec
commit bd29d5193a
30 changed files with 441 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/ChangeLog
View File

@ -1,3 +1,48 @@
2010-09-09 Vincent Celier <celier@adacore.com>
* osint.adb (Canonical_Case_File_Name): Use procedure To_Lower in
System.Case_Util
(Canonical_Case_Env_Var_Name): Ditto
2010-09-09 Bob Duff <duff@adacore.com>
* g-pehage.adb (Allocate): Initialize the allocated elements of IT.
2010-09-09 Robert Dewar <dewar@adacore.com>
* cstand.adb: Mark Boolean and Character types as Ordered
* einfo.adb (Has_Pragma_Ordered): New flag
* einfo.ads (Has_Pragma_Ordered): New flag
* g-calend.ads: Mark Day_Name as Ordered
* opt.ads: Mark Ada_Version_Type as Ordered
(Warn_On_Unordered_Enumeration_Type): New flag
* par-prag.adb: Add procdessing for pragma Ordered
* s-ficobl.ads (Read_File_Mode): New subtype
* s-fileio.adb: Use Read_File_Mode instead of explicit ranges
* s-taskin.ads: Mark Entry_Call_State as ordered
* sem_ch3.adb (Build_Derived_Enumeration_Type): Inherit
Has_Pragma_Ordered.
* sem_ch6.ads: Mark Conformance_Type as Ordered
* sem_prag.adb: Implement pragma Ordered
* sem_res.adb (Bad_Unordered_Enumeration_Reference): New function
(Resolve_Comparison_Op): Diagnose unordered comparison
(Resolve_Range): Diagnose unordered range
* sem_warn.adb (Warn_On_Unordered_Enumeration_Type): New flag (from
-gnatw.u/U)
* snames.ads-tmpl: Add entry for pragma Ordered
* style.ads (Check_Enumeration_Subrange): Removed
* styleg.adb (Check_Enumeration_Subrange): Removed
* styleg.ads (Check_Enumeration_Subrange): Removed
* stylesw.adb: Remove handling of -gnatyE switch
* stylesw.ads: (Style_Check_Enumeration_Subranges): Removed
* vms_data.ads: Remove -gnatyE entries
Add -gnatw.u entries
* ug_words: Entries for -gnatw.u and -gnatw.U
* gnat_ugn.texi: Document -gnatw.u/-gnatw.U switches
* gnat_rm.texi: Document pragma Ordered.
* s-tasren.adb: Avoid unnecessary comparison on unordered enumeration.
* s-tpobop.adb: Remove comparison on unordered enumeration type.
2010-09-09 Vincent Celier <celier@adacore.com>
* adaint.c: New function __gnat_get_env_vars_case_sensitive, returns 0

4
gcc/ada/cstand.adb
View File

@ -446,6 +446,7 @@ package body CStand is
Set_Is_Unsigned_Type (Standard_Boolean);
Set_Size_Known_At_Compile_Time (Standard_Boolean);
Set_Has_Pragma_Ordered (Standard_Boolean);
Set_Ekind (Standard_True, E_Enumeration_Literal);
Set_Etype (Standard_True, Standard_Boolean);
@ -566,6 +567,7 @@ package body CStand is
Init_RM_Size (Standard_Character, 8);
Set_Elem_Alignment (Standard_Character);
Set_Has_Pragma_Ordered (Standard_Character);
Set_Is_Unsigned_Type (Standard_Character);
Set_Is_Character_Type (Standard_Character);
Set_Is_Known_Valid (Standard_Character);
@ -611,6 +613,7 @@ package body CStand is
Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size);
Set_Elem_Alignment (Standard_Wide_Character);
Set_Has_Pragma_Ordered (Standard_Wide_Character);
Set_Is_Unsigned_Type (Standard_Wide_Character);
Set_Is_Character_Type (Standard_Wide_Character);
Set_Is_Known_Valid (Standard_Wide_Character);
@ -658,6 +661,7 @@ package body CStand is
Standard_Wide_Wide_Character_Size);
Set_Elem_Alignment (Standard_Wide_Wide_Character);
Set_Has_Pragma_Ordered (Standard_Wide_Wide_Character);
Set_Is_Unsigned_Type (Standard_Wide_Wide_Character);
Set_Is_Character_Type (Standard_Wide_Wide_Character);
Set_Is_Known_Valid (Standard_Wide_Wide_Character);

19
gcc/ada/einfo.adb
View File

@ -456,6 +456,7 @@ package body Einfo is
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- Is_Limited_Interface Flag197
-- Has_Pragma_Ordered Flag198
-- Has_Anon_Block_Suffix Flag201
-- Itype_Printed Flag202
@ -509,7 +510,6 @@ package body Einfo is
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
-- (unused) Flag198
-- (unused) Flag199
-- (unused) Flag200
@ -726,8 +726,7 @@ package body Einfo is
function Corresponding_Protected_Entry (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Subprogram_Body);
pragma Assert (Ekind (Id) = E_Subprogram_Body);
return Node18 (Id);
end Corresponding_Protected_Entry;
@ -1344,6 +1343,12 @@ package body Einfo is
return Flag230 (Id);
end Has_Pragma_Inline_Always;
function Has_Pragma_Ordered (Id : E) return B is
begin
pragma Assert (Is_Enumeration_Type (Id));
return Flag198 (Implementation_Base_Type (Id));
end Has_Pragma_Ordered;
function Has_Pragma_Pack (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
@ -3753,6 +3758,13 @@ package body Einfo is
Set_Flag230 (Id, V);
end Set_Has_Pragma_Inline_Always;
procedure Set_Has_Pragma_Ordered (Id : E; V : B := True) is
begin
pragma Assert (Is_Enumeration_Type (Id));
pragma Assert (Id = Base_Type (Id));
Set_Flag198 (Id, V);
end Set_Has_Pragma_Ordered;
procedure Set_Has_Pragma_Pack (Id : E; V : B := True) is
begin
pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
@ -6901,6 +6913,7 @@ package body Einfo is
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
W ("Has_Pragma_Inline", Flag157 (Id));
W ("Has_Pragma_Inline_Always", Flag230 (Id));
W ("Has_Pragma_Ordered", Flag198 (Id));
W ("Has_Pragma_Pack", Flag121 (Id));
W ("Has_Pragma_Preelab_Init", Flag221 (Id));
W ("Has_Pragma_Pure", Flag203 (Id));

15
gcc/ada/einfo.ads
View File

@ -632,8 +632,8 @@ package Einfo is
-- where Comes_From_Source is always False.
-- Corresponding_Protected_Entry (Node18)
-- Present in subrogram bodies. Denotes the entry of a protected type
-- that is implemented by the subprogram body.
-- Present in subrogram bodies. Set for subprogram bodies that implement
-- a protected type entry to point to the entity for the entry.
-- Corresponding_Record_Type (Node18)
-- Present in protected and task types and subtypes. References the
@ -1578,6 +1578,12 @@ package Einfo is
-- pragma Inline_Always applies. Note that if this flag is set, the flag
-- Has_Pragma_Inline is also set.
-- Has_Pragma_Ordered (Flag198) [implementation base type only]
-- Present in entities for enumeration types. If set indicates that a
-- valid pragma Ordered was given for the type. This flag is inherited
-- by derived enumeration types. We don't need to distinguish the derived
-- case since we allow multiple occurrences of this pragma anyway.
-- Has_Pragma_Pack (Flag121) [implementation base type only]
-- Present in all entities. If set, indicates that a valid pragma Pack
-- was given for the type. Note that this flag is not inherited by
@ -4967,6 +4973,7 @@ package Einfo is
-- Has_Biased_Representation (Flag139)
-- Has_Contiguous_Rep (Flag181)
-- Has_Enumeration_Rep_Clause (Flag66)
-- Has_Pragma_Ordered (Flag198) (base type only)
-- Nonzero_Is_True (Flag162) (base type only)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
@ -5879,6 +5886,7 @@ package Einfo is
function Has_Pragma_Elaborate_Body (Id : E) return B;
function Has_Pragma_Inline (Id : E) return B;
function Has_Pragma_Inline_Always (Id : E) return B;
function Has_Pragma_Ordered (Id : E) return B;
function Has_Pragma_Pack (Id : E) return B;
function Has_Pragma_Preelab_Init (Id : E) return B;
function Has_Pragma_Pure (Id : E) return B;
@ -6438,6 +6446,7 @@ package Einfo is
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline (Id : E; V : B := True);
procedure Set_Has_Pragma_Inline_Always (Id : E; V : B := True);
procedure Set_Has_Pragma_Ordered (Id : E; V : B := True);
procedure Set_Has_Pragma_Pack (Id : E; V : B := True);
procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure (Id : E; V : B := True);
@ -7095,6 +7104,7 @@ package Einfo is
pragma Inline (Has_Pragma_Elaborate_Body);
pragma Inline (Has_Pragma_Inline);
pragma Inline (Has_Pragma_Inline_Always);
pragma Inline (Has_Pragma_Ordered);
pragma Inline (Has_Pragma_Pack);
pragma Inline (Has_Pragma_Preelab_Init);
pragma Inline (Has_Pragma_Pure);
@ -7526,6 +7536,7 @@ package Einfo is
pragma Inline (Set_Has_Pragma_Elaborate_Body);
pragma Inline (Set_Has_Pragma_Inline);
pragma Inline (Set_Has_Pragma_Inline_Always);
pragma Inline (Set_Has_Pragma_Ordered);
pragma Inline (Set_Has_Pragma_Pack);
pragma Inline (Set_Has_Pragma_Preelab_Init);
pragma Inline (Set_Has_Pragma_Pure);

13
gcc/ada/g-calend.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1999-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- --
@ -33,11 +33,11 @@
-- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time.
-- Second_Duration precision depends on the target clock precision.
--
-- GNAT.Calendar provides the same kind of abstraction found in
-- Ada.Calendar. It provides Split and Time_Of to build and split a Time
-- data. And it provides accessor functions to get only one of Hour, Minute,
-- Second, Second_Duration. Other functions are to access more advanced
-- values like Day_Of_Week, Day_In_Year and Week_In_Year.
-- GNAT.Calendar provides the same kind of abstraction found in Ada.Calendar.
-- It provides Split and Time_Of to build and split a Time data. And it
-- provides accessor functions to get only one of Hour, Minute, Second,
-- Second_Duration. Other functions are to access more advanced values like
-- Day_Of_Week, Day_In_Year and Week_In_Year.
with Ada.Calendar;
with Interfaces.C;
@ -46,6 +46,7 @@ package GNAT.Calendar is
type Day_Name is
(Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday);
pragma Ordered (Day_Name);
subtype Hour_Number is Natural range 0 .. 23;
subtype Minute_Number is Natural range 0 .. 59;

10
gcc/ada/g-pehage.adb
View File

@ -553,10 +553,18 @@ package body GNAT.Perfect_Hash_Generators is
-- Allocate --
--------------
function Allocate (N : Natural; S : Natural := 1) return Table_Id is
function Allocate (N : Natural; S : Natural := 1) return Table_Id is
L : constant Integer := IT.Last;
begin
IT.Set_Last (L + N * S);
-- Initialize, so debugging printouts don't trip over uninitialized
-- components.
for J in L + 1 .. IT.Last loop
IT.Table (J) := -1;
end loop;
return L + 1;
end Allocate;

96
gcc/ada/gnat_rm.texi
View File

@ -173,6 +173,7 @@ Implementation Defined Pragmas
* Pragma Normalize_Scalars::
* Pragma Obsolescent::
* Pragma Optimize_Alignment::
* Pragma Ordered::
* Pragma Passive::
* Pragma Persistent_BSS::
* Pragma Polling::
@ -789,6 +790,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Normalize_Scalars::
* Pragma Obsolescent::
* Pragma Optimize_Alignment::
* Pragma Ordered::
* Pragma Passive::
* Pragma Persistent_BSS::
* Pragma Polling::
@ -3731,6 +3733,96 @@ unit are excluded from the consistency check, as are all predefined units. The
latter are compiled by default in pragma Optimize_Alignment (Off) mode if no
pragma appears at the start of the file.
@node Pragma Ordered
@unnumberedsec Pragma Ordered
@findex Ordered
@noindent
Syntax:
@smallexample @c ada
pragma Ordered (enumeration_first_subtype_LOCAL_NAME);
@end smallexample
@noindent
Most enumeration types are from a conceptual point of view unordered.
For example, if we write:
@smallexample @c ada
type Color is (Red, Blue, Green, Yellow);
@end smallexample
@noindent
Then Ada semantics says that Blue > Red, and Green > Blue, but really
these relations make no sense, the enumeration type merely specifies
a set of possible colors, and the order is unimportant.
@noindent
For such unordered enumeration types, it is generally a good idea if
clients avoid comparisons (other than equality or inequality), or
explicit ranges. For example, if we have code buried in some client
that says:
@smallexample @c ada
if Current_Color < Yellow ....
if Current_Color in Blue .. Green
@end smallexample
@noindent
Then the code is relying on the order, which is undesriable in this case.
It makes the code hard to read and creates maintenance difficulties if
entries have to be added to the enumeration type. In cases like this,
we prefer if the code in the client lists the possibilities, or an
appropriate subtype is declared in the parent package, e.g. for the
above case, we might have in the parent package:
@smallexample @c ada
subtype RBG is Color range Red .. Green;
@end smallexample
@noindent
and then in the client we could write:
@smallexample @c ada
if Current_Color in RBG ....
if Current_Color = Blue or Current_Color = Green ...
@end smallexample
@noindent
However some enumeration types are legitimately ordered from a conceptual
point of view. For example, if you have:
@smallexample @c ada
type Day is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
@end smallexample
@noindent
then the ordering imposed by the language is reasonable, and it
is fine for clients to depend on this, writing for example:
@smallexample @c ada
if D in Mon .. Fri then
if D < Wed
@end smallexample
@noindent
pragma @option{Order} is provided to mark enumeration types that
are conceptually ordered, warning the reader that clients may depend
on the ordering. We provide a pragma to mark enumerations as Ordered
rather than one to mark them as Unordered, since in our experience,
the great majority of enumeration types are conceptually Unordered.
The types Boolean, Character, Wide_Character, and Wide_Wide_Character
are considered to be ordered types, so there is a pragma Ordered
present in Standard for these types.
Normally pragma Order serves as only documentation and a guide for
coding standards, but GNAT provides a warning switch -gnatw.u that
requests warnings for inappropriate uses (comparisons and explicit
subranges) for unordered types. If this switch is used, then any
enumeration type not marked with pragma Ordered will be considered
as unordered, and will generate warnings for inappropriate uses.
@node Pragma Passive
@unnumberedsec Pragma Passive
@findex Passive
@ -5745,11 +5837,11 @@ may raise @code{Constraint_Error}.
@cindex Representation of enums
@findex Enum_Val
@noindent
For every enumeration subtype @var{S}, @code{@var{S}'Enum_Rep} denotes a
For every enumeration subtype @var{S}, @code{@var{S}'Enum_Val} denotes a
function with the following spec:
@smallexample @c ada
function @var{S}'Enum_Rep (Arg : @i{Universal_Integer)
function @var{S}'Enum_Val (Arg : @i{Universal_Integer)
return @var{S}'Base};
@end smallexample

25
gcc/ada/gnat_ugn.texi
View File

@ -5627,6 +5627,23 @@ This switch suppresses warnings for unused entities and packages.
It also turns off warnings on unreferenced formals (and thus includes
the effect of @option{-gnatwF}).
@item -gnatw.u
@emph{Activate warnings on unordered enumeration types.}
@cindex @option{-gnatw.u} (@command{gcc})
This switch causes enumeration types to be considered as conceptually
unordered, unless an explicit pragma Order is given for the type. The
effect is to generate warnings in clients that use explicit comparisons
or subranges, since these constructs both treat objects of the type as
ordered. A client is defined as a unit that is other than the unit in
which the type is declared, or its body or subunits. See description
of pragma Order in the GNAT RM for further details.
@item -gnatw.U
@emph{Deactivate warnings on unordered enumeration types.}
@cindex @option{-gnatw.U} (@command{gcc})
This switch causes all enumeration types to be considered as ordered, so
that no warnings are given for comparisons or subranges for any type.
@item -gnatwv
@emph{Activate warnings on unassigned variables.}
@cindex @option{-gnatwv} (@command{gcc})
@ -6255,14 +6272,6 @@ 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/opt.ads
View File

@ -65,6 +65,7 @@ package Opt is
-- Set True if binder file to be generated in Ada rather than C
type Ada_Version_Type is (Ada_83, Ada_95, Ada_05, Ada_12);
pragma Ordered (Ada_Version_Type);
-- Versions of Ada for Ada_Version below. Note that these are ordered,
-- so that tests like Ada_Version >= Ada_95 are legitimate and useful.
@ -1456,6 +1457,13 @@ package Opt is
-- non-portable semantics (e.g. because sizes of types differ). The default
-- is that this warning is enabled.
Warn_On_Unordered_Enumeration_Type : Boolean := False;
-- GNAT
-- Set to True to generate warnings for inappropriate uses (comparisons
-- and explicit ranges) on unordered enumeration types (which includes
-- all enumeration types for which pragma Ordered is not given). The
-- default is that this warning is disabled.
Warn_On_Unrecognized_Pragma : Boolean := True;
-- GNAT
-- Set to True to generate warnings for unrecognized pragmas. The default

21
gcc/ada/osint.adb
View File

@ -688,20 +688,10 @@ package body Osint is
-- Canonical_Case_File_Name --
------------------------------
-- For now, we only deal with the case of a-z. Eventually we should
-- worry about other Latin-1 letters on systems that support this ???
procedure Canonical_Case_File_Name (S : in out String) is
begin
if not File_Names_Case_Sensitive then
for J in S'Range loop
if S (J) in 'A' .. 'Z' then
S (J) :=
Character'Val
(Character'Pos (S (J)) +
(Character'Pos ('a') - Character'Pos ('A')));
end if;
end loop;
To_Lower (S);
end if;
end Canonical_Case_File_Name;
@ -712,14 +702,7 @@ package body Osint is
procedure Canonical_Case_Env_Var_Name (S : in out String) is
begin
if not Env_Vars_Case_Sensitive then
for J in S'Range loop
if S (J) in 'A' .. 'Z' then
S (J) := Character'Val (
Character'Pos (S (J)) +
Character'Pos ('a') -
Character'Pos ('A'));
end if;
end loop;
To_Lower (S);
end if;
end Canonical_Case_Env_Var_Name;

3
gcc/ada/par-prag.adb
View File

@ -1156,10 +1156,11 @@ begin
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Return |
Pragma_Obsolescent |
Pragma_No_Run_Time |
Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Obsolescent |
Pragma_Ordered |
Pragma_Optimize |
Pragma_Optimize_Alignment |
Pragma_Pack |

3
gcc/ada/s-ficobl.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- --
@ -60,6 +60,7 @@ package System.File_Control_Block is
-- Used to hold name and form strings
type File_Mode is (In_File, Inout_File, Out_File, Append_File);
subtype Read_File_Mode is File_Mode range In_File .. Inout_File;
-- File mode (union of file modes permitted by individual packages,
-- the types File_Mode in the individual packages are declared to
-- allow easy conversion to and from this general type.

4
gcc/ada/s-fileio.adb
View File

@ -205,7 +205,7 @@ package body System.File_IO is
begin
if File = null then
raise Status_Error with "file not open";
elsif File.Mode > Inout_File then
elsif File.Mode not in Read_File_Mode then
raise Mode_Error with "file not readable";
end if;
end Check_Read_Status;
@ -1183,7 +1183,7 @@ package body System.File_IO is
-- reopen.
if Mode = File.Mode
and then Mode <= Inout_File
and then Mode in Read_File_Mode
then
rewind (File.Stream);

41
gcc/ada/s-taskin.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -282,32 +282,31 @@ package System.Tasking is
Cancelled
-- the call was asynchronous, and was cancelled
);
pragma Ordered (Entry_Call_State);
-- Never_Abortable is used for calls that are made in a abort
-- deferred region (see ARM 9.8(5-11), 9.8 (20)).
-- Such a call is never abortable.
-- Never_Abortable is used for calls that are made in a abort deferred
-- region (see ARM 9.8(5-11), 9.8 (20)). Such a call is never abortable.
-- The Was_ vs. Not_Yet_ distinction is needed to decide whether it
-- is OK to advance into the abortable part of an async. select stmt.
-- That is allowed iff the mode is Now_ or Was_.
-- The Was_ vs. Not_Yet_ distinction is needed to decide whether it is OK
-- to advance into the abortable part of an async. select stmt. That is
-- allowed iff the mode is Now_ or Was_.
-- Done indicates the call has been completed, without cancellation,
-- or no call has been made yet at this ATC nesting level,
-- and so aborting the call is no longer an issue.
-- Completion of the call does not necessarily indicate "success";
-- the call may be returning an exception if Exception_To_Raise is
-- non-null.
-- Done indicates the call has been completed, without cancellation, or no
-- call has been made yet at this ATC nesting level, and so aborting the
-- call is no longer an issue. Completion of the call does not necessarily
-- indicate "success"; the call may be returning an exception if
-- Exception_To_Raise is non-null.
-- Cancelled indicates the call was cancelled,
-- and so aborting the call is no longer an issue.
-- Cancelled indicates the call was cancelled, and so aborting the call is
-- no longer an issue.
-- The call is on an entry queue unless
-- State >= Done, in which case it may or may not be still Onqueue.
-- The call is on an entry queue unless State >= Done, in which case it may
-- or may not be still Onqueue.
-- Please do not modify the order of the values, without checking
-- all uses of this type. We rely on partial "monotonicity" of
-- Entry_Call_Record.State to avoid locking when we access this
-- value for certain tests. In particular:
-- Please do not modify the order of the values, without checking all uses
-- of this type. We rely on partial "monotonicity" of
-- Entry_Call_Record.State to avoid locking when we access this value for
-- certain tests. In particular:
-- 1) Once State >= Done, we can rely that the call has been
-- completed. If State >= Done, it will not

4
gcc/ada/s-tasren.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1268,7 +1268,7 @@ package body System.Tasking.Rendezvous is
if Old_State /= Entry_Call.State
and then Entry_Call.State = Now_Abortable
and then Entry_Call.Mode > Simple_Call
and then Entry_Call.Mode /= Simple_Call
and then Entry_Call.Self /= Self_ID
-- Asynchronous_Call or Conditional_Call

40
gcc/ada/s-tpobop.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -646,26 +646,26 @@ package body System.Tasking.Protected_Objects.Operations is
end if;
end if;
elsif Mode < Asynchronous_Call then
-- Simple_Call or Conditional_Call
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock_RTS;
else
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
end if;
Block.Cancelled := Entry_Call.State = Cancelled;
else
pragma Assert (False);
null;
case Mode is
when Simple_Call | Conditional_Call =>
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock_RTS;
else
STPO.Write_Lock (Self_ID);
Entry_Calls.Wait_For_Completion (Entry_Call);
STPO.Unlock (Self_ID);
end if;
Block.Cancelled := Entry_Call.State = Cancelled;
when Asynchronous_Call | Timed_Call =>
pragma Assert (False);
null;
end case;
end if;
Initialization.Undefer_Abort_Nestable (Self_ID);

5
gcc/ada/sem_ch3.adb
View File

@ -5375,9 +5375,14 @@ package body Sem_Ch3 is
Set_RM_Size (Implicit_Base, RM_Size (Parent_Type));
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Type));
-- Copy other flags from parent type
Set_Has_Non_Standard_Rep
(Implicit_Base, Has_Non_Standard_Rep
(Parent_Type));
Set_Has_Pragma_Ordered
(Implicit_Base, Has_Pragma_Ordered
(Parent_Type));
Set_Has_Delayed_Freeze (Implicit_Base);
-- Process the subtype indication including a validation check on the

4
gcc/ada/sem_ch6.ads
View File

@ -28,9 +28,11 @@ package Sem_Ch6 is
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
pragma Ordered (Conformance_Type);
-- Conformance type used in conformance checks between specs and bodies,
-- and for overriding. The literals match the RM definitions of the
-- corresponding terms.
-- corresponding terms. This is an ordered type, since each conformance
-- type is stronger than the ones preceding it.
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Extended_Return_Statement (N : Node_Id);

41
gcc/ada/sem_prag.adb
View File

@ -9707,7 +9707,7 @@ package body Sem_Prag is
-- pragma Optimize_Alignment (Time | Space | Off);
when Pragma_Optimize_Alignment =>
when Pragma_Optimize_Alignment => Optimize_Alignment : begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
@ -9733,6 +9733,42 @@ package body Sem_Prag is
-- switch will get reset anyway at the start of each unit.
Optimize_Alignment_Local := True;
end Optimize_Alignment;
-------------
-- Ordered --
-------------
-- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
when Pragma_Ordered => Ordered : declare
Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Expression (Assoc);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type then
return;
else
Typ := Underlying_Type (Typ);
end if;
if not Is_Enumeration_Type (Typ) then
Error_Pragma ("pragma% must specify enumeration type");
end if;
Check_First_Subtype (Arg1);
Set_Has_Pragma_Ordered (Base_Type (Typ));
end Ordered;
----------
-- Pack --
@ -9821,7 +9857,7 @@ package body Sem_Prag is
elsif VM_Target = No_VM then
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
-- If we ignore the pack, then warn about this, except
-- that we suppress the warning in GNAT mode.
@ -12818,6 +12854,7 @@ package body Sem_Prag is
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,

135
gcc/ada/sem_res.adb
View File

@ -91,6 +91,15 @@ package body Sem_Res is
-- Note that Resolve_Attribute is separated off in Sem_Attr
function Bad_Unordered_Enumeration_Reference
(N : Node_Id;
T : Entity_Id) return Boolean;
-- Node N contains a potentially dubious reference to type T, either an
-- explicit comparison, or an explicit range. This function returns True
-- if the type T is an enumeration type for which No pragma Order has been
-- given, and the reference N is not in the same extended source unit as
-- the declaration of T.
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
@ -400,6 +409,22 @@ package body Sem_Res is
end if;
end Analyze_And_Resolve;
----------------------------------------
-- Bad_Unordered_Enumeration_Reference --
----------------------------------------
function Bad_Unordered_Enumeration_Reference
(N : Node_Id;
T : Entity_Id) return Boolean
is
begin
return Is_Enumeration_Type (T)
and then Comes_From_Source (N)
and then Warn_On_Unordered_Enumeration_Type
and then not Has_Pragma_Ordered (T)
and then not In_Same_Extended_Unit (N, T);
end Bad_Unordered_Enumeration_Reference;
----------------------------
-- Check_Discriminant_Use --
----------------------------
@ -5658,30 +5683,49 @@ package body Sem_Res is
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T /= Any_Type then
if T = Any_String or else
T = Any_Composite or else
T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
else
Error_Msg_N ("ambiguous operands for comparison", N);
end if;
-- Skip remaining processing if already set to Any_Type
Set_Etype (N, Any_Type);
return;
else
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
Check_Low_Bound_Tested (N);
Eval_Relational_Op (N);
end if;
if T = Any_Type then
return;
end if;
-- Deal with other error cases
if T = Any_String or else
T = Any_Composite or else
T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
else
Error_Msg_N ("ambiguous operands for comparison", N);
end if;
Set_Etype (N, Any_Type);
return;
end if;
-- Resolve the operands if types OK
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
Check_Low_Bound_Tested (N);
-- Check comparison on unordered enumeration
if Comes_From_Source (N)
and then Bad_Unordered_Enumeration_Reference (N, Etype (L))
then
Error_Msg_N ("comparison on unordered enumeration type?", N);
end if;
-- Evaluate the relation (note we do this after the above check
-- since this Eval call may change N to True/False.
Eval_Relational_Op (N);
end Resolve_Comparison_Op;
------------------------------------
@ -7606,13 +7650,56 @@ package body Sem_Res is
L : constant Node_Id := Low_Bound (N);
H : constant Node_Id := High_Bound (N);
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.
--------------------
-- First_Last_Ref --
--------------------
function First_Last_Ref return Boolean is
Lorig : constant Node_Id := Original_Node (L);
Horig : constant Node_Id := Original_Node (H);
begin
if Nkind (Lorig) = N_Attribute_Reference
and then Nkind (Horig) = N_Attribute_Reference
and then Attribute_Name (Lorig) = Name_First
and then Attribute_Name (Horig) = Name_Last
then
declare
PL : constant Node_Id := Prefix (Lorig);
PH : constant Node_Id := Prefix (Horig);
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 Resolve_Range
begin
Set_Etype (N, Typ);
Resolve (L, Typ);
Resolve (H, Typ);
if Style_Check then
Check_Enumeration_Subrange (N);
-- Check for inappropriate range on unordered enumeration type
if Bad_Unordered_Enumeration_Reference (N, Typ)
-- Exclude X'First .. X'Last if X is the same entity for both
and then not First_Last_Ref
then
Error_Msg ("subrange of unordered enumeration type?", Sloc (N));
end if;
Check_Unset_Reference (L);

9
gcc/ada/sem_warn.adb
View File

@ -3088,6 +3088,7 @@ package body Sem_Warn is
Warn_On_Redundant_Constructs := True;
Warn_On_Reverse_Bit_Order := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unordered_Enumeration_Type := True;
Warn_On_Unrecognized_Pragma := True;
Warn_On_Unrepped_Components := True;
Warn_On_Warnings_Off := True;
@ -3125,6 +3126,12 @@ package body Sem_Warn is
when 'R' =>
Warn_On_Object_Renames_Function := False;
when 'u' =>
Warn_On_Unordered_Enumeration_Type := True;
when 'U' =>
Warn_On_Unordered_Enumeration_Type := False;
when 'v' =>
Warn_On_Reverse_Bit_Order := True;
@ -3186,6 +3193,7 @@ package body Sem_Warn is
Warn_On_Reverse_Bit_Order := False;
Warn_On_Object_Renames_Function := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unordered_Enumeration_Type := False;
Warn_On_Unrecognized_Pragma := True;
Warn_On_Unrepped_Components := False;
Warn_On_Warnings_Off := False;
@ -3256,6 +3264,7 @@ package body Sem_Warn is
Warn_On_Redundant_Constructs := False;
Warn_On_Reverse_Bit_Order := False;
Warn_On_Unchecked_Conversion := False;
Warn_On_Unordered_Enumeration_Type := False;
Warn_On_Unrecognized_Pragma := False;
Warn_On_Unrepped_Components := False;
Warn_On_Warnings_Off := False;

2
gcc/ada/snames.ads-tmpl
View File

@ -483,6 +483,7 @@ package Snames is
Name_No_Return : constant Name_Id := N + $; -- Ada 05
Name_Obsolescent : constant Name_Id := N + $; -- GNAT
Name_Optimize : constant Name_Id := N + $;
Name_Ordered : constant Name_Id := N + $; -- GNAT
Name_Pack : constant Name_Id := N + $;
Name_Page : constant Name_Id := N + $;
Name_Passive : constant Name_Id := N + $; -- GNAT
@ -1547,6 +1548,7 @@ package Snames is
Pragma_No_Return,
Pragma_Obsolescent,
Pragma_Optimize,
Pragma_Ordered,
Pragma_Pack,
Pragma_Page,
Pragma_Passive,

3
gcc/ada/style.ads
View File

@ -103,9 +103,6 @@ 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

80
gcc/ada/styleg.adb
View File

@ -32,13 +32,10 @@ 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
@ -205,6 +202,7 @@ package body Styleg is
end OK_Boolean_Operand;
-- Start of processig for Check_Boolean_Operator
begin
if Style_Check_Boolean_And_Or
and then Comes_From_Source (Node)
@ -553,82 +551,6 @@ 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 --
---------------

4
gcc/ada/styleg.ads
View File

@ -92,10 +92,6 @@ 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

9
gcc/ada/stylesw.adb
View File

@ -63,7 +63,6 @@ package body Stylesw is
-- not yet have the whole tool suite clean with respect to this.
-- "B" & -- check boolean operators
-- "E" & -- check enumeration ranges
-------------------------------
-- Reset_Style_Check_Options --
@ -79,7 +78,6 @@ 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;
@ -165,7 +163,6 @@ 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);
@ -332,9 +329,6 @@ 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;
@ -499,9 +493,6 @@ 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;

6
gcc/ada/stylesw.ads
View File

@ -113,12 +113,6 @@ 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.

2
gcc/ada/ug_words
View File

@ -170,6 +170,8 @@ gcc -c ^ GNAT COMPILE
-gnatwT ^ /WARNINGS=NODELETED_CODE
-gnatwu ^ /WARNINGS=UNUSED
-gnatwU ^ /WARNINGS=NOUNUSED
-gnatw.u ^ /WARNINGS=UNORDERED_ENUMERATIONS
-gnatw.U ^ /WARNINGS=NOUNORDERED_ENUMERATIONS
-gnatwv ^ /WARNINGS=VARIABLES_UNINITIALIZED
-gnatwV ^ /WARNINGS=NOVARIABLES_UNINITIALIZED
-gnatww ^ /WARNINGS=LOWBOUND_ASSUMED

3
gcc/ada/usage.adb
View File

@ -470,6 +470,8 @@ begin
Write_Line (" T* turn off warnings for tracking deleted code");
Write_Line (" u+ turn on warnings for unused entity");
Write_Line (" U* turn off warnings for unused entity");
Write_Line (" .u turn on warnings for unordered enumeration");
Write_Line (" .U* turn off warnings for unordered enumeration");
Write_Line (" v*+ turn on warnings for unassigned variable");
Write_Line (" V turn off warnings for unassigned variable");
Write_Line (" .v*+ turn on info messages for reverse bit order");
@ -533,7 +535,6 @@ 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");

8
gcc/ada/vms_data.ads
View File

@ -2277,10 +2277,6 @@ package VMS_Data is
"-gnatye " &
"NOEND " &
"-gnaty-e " &
"ENUMERATION_RANGES " &
"-gnatyE " &
"NOENUMERATION_RANGES " &
"-gnaty-E " &
"VTABS " &
"-gnatyf " &
"NOVTABS " &
@ -3005,6 +3001,10 @@ package VMS_Data is
"-gnatwu " &
"NOUNUSED " &
"-gnatwU " &
"UNORDERED_ENUMERATIONS " &
"-gnatw.u " &
"NOUNORDERED_ENUMERATIONS " &
"-gnatw.U " &
"VARIABLES_UNINITIALIZED " &
"-gnatwv " &
"NOVARIABLES_UNINITIALIZED " &