===================================================================
@@ -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);
===================================================================
@@ -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));
===================================================================
@@ -632,8 +632,8 @@ package Einfo is
-- where Comes_From_Source is always False.
-- Corresponding_Protected_Entry (Node18)
+-- 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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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.
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;
===================================================================
@@ -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
===================================================================
@@ -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 |
===================================================================
@@ -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
===================================================================
@@ -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);
===================================================================
@@ -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,
===================================================================
@@ -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;
+ 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
- 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);
+ 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);
===================================================================
@@ -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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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.
===================================================================
@@ -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);
===================================================================
@@ -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,
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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.
-
- -- 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.
-
- -- 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.
-
- -- 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:
+ -- 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_.
+
+ -- 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.
+
+ -- 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:
-- 1) Once State >= Done, we can rely that the call has been
-- completed. If State >= Done, it will not
===================================================================
@@ -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
===================================================================
@@ -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 --
---------------
===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -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.
===================================================================
@@ -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");
===================================================================
@@ -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 " &
===================================================================
@@ -5627,6 +5627,23 @@ This switch suppresses warnings for unus
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
===================================================================
@@ -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
===================================================================
@@ -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
* 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 c
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 i
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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_Ob
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
+ 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;
+ 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;
+ Block.Cancelled := Entry_Call.State = Cancelled;
- else
- pragma Assert (False);
- null;
+ when Asynchronous_Call | Timed_Call =>
+ pragma Assert (False);
+ null;
+ end case;
end if;
Initialization.Undefer_Abort_Nestable (Self_ID);
The warning flag -gnatw.u replaces the style switch -gnatyE to cause warnings on comparisons and subranges of unordered enumeration types. If the switch -gnatw.u is not given, then no enumeration types are considered unordered, and no warnings are issued. If this warning switch is present, then any enumeration types not marked by pragma Ordered (a new pragma included in this patch), are considered to be unordered, and comparisons and ranges will be flagged as shown in the following test: 1. package OrderedP is 2. type E1 is (Red, Blue, Green); 3. type E2 is (Mon, Tue, Wed, Thu, Fri, Sat, Sun); 4. pragma Ordered (E2); 5. end OrderedP; 1. with OrderedP; use OrderedP; 2. package Ordered is 3. B1 : Boolean := Red in Green .. Blue; | >>> warning: subrange of unordered enumeration type 4. B2 : Boolean := Tue in Mon .. Fri; 5. B3 : Boolean := Red > Green; | >>> warning: comparison on unordered enumeration type 6. B4 : Boolean := Tue > Wed; 7. end; Tested on x86_64-pc-linux-gnu, committed on trunk 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.