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
for VMS and Windows, and 1 for all other platforms.
* adaint.h: New function __gnat_get_env_vars_case_sensitive
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);
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);
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);
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);
-- Is_Primitive_Wrapper Flag195
-- Was_Hidden Flag196
-- Is_Limited_Interface Flag197
+ -- Has_Pragma_Ordered Flag198
-- Has_Anon_Block_Suffix Flag201
-- Itype_Printed Flag202
-- Is_Underlying_Record_View Flag246
-- OK_To_Rename Flag247
- -- (unused) Flag198
-- (unused) Flag199
-- (unused) Flag200
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;
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));
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));
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));
-- 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
-- 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
-- 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)
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;
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);
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);
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);
-- --
-- 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- --
-- 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;
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;
-- 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;
* Pragma Normalize_Scalars::
* Pragma Obsolescent::
* Pragma Optimize_Alignment::
+* Pragma Ordered::
* Pragma Passive::
* Pragma Persistent_BSS::
* Pragma Polling::
* Pragma Normalize_Scalars::
* Pragma Obsolescent::
* Pragma Optimize_Alignment::
+* Pragma Ordered::
* Pragma Passive::
* Pragma Persistent_BSS::
* Pragma Polling::
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
@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
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})
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
-- 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.
-- 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
-- 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;
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;
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 |
-- --
-- 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- --
-- 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.
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;
-- reopen.
if Mode = File.Mode
- and then Mode <= Inout_File
+ and then Mode in Read_File_Mode
then
rewind (File.Stream);
-- --
-- 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- --
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
-- --
-- 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- --
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
-- --
-- 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- --
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);
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
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);
-- 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);
-- 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 --
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.
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
+ Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
-- 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).
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 --
----------------------------
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;
------------------------------------
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);
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;
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;
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;
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;
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
Pragma_No_Return,
Pragma_Obsolescent,
Pragma_Optimize,
+ Pragma_Ordered,
Pragma_Pack,
Pragma_Page,
Pragma_Passive,
-- 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
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
end OK_Boolean_Operand;
-- Start of processig for Check_Boolean_Operator
+
begin
if Style_Check_Boolean_And_Or
and then Comes_From_Source (Node)
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 --
---------------
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
-- not yet have the whole tool suite clean with respect to this.
-- "B" & -- check boolean operators
- -- "E" & -- check enumeration ranges
-------------------------------
-- Reset_Style_Check_Options --
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;
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);
when 'e' =>
Style_Check_End_Labels := True;
- when 'E' =>
- Style_Check_Enumeration_Subranges := True;
-
when 'f' =>
Style_Check_Form_Feeds := True;
when 'e' =>
Style_Check_End_Labels := False;
- when 'E' =>
- Style_Check_Enumeration_Subranges := False;
-
when 'f' =>
Style_Check_Form_Feeds := False;
-- 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.
-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
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");
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");
"-gnatye " &
"NOEND " &
"-gnaty-e " &
- "ENUMERATION_RANGES " &
- "-gnatyE " &
- "NOENUMERATION_RANGES " &
- "-gnaty-E " &
"VTABS " &
"-gnatyf " &
"NOVTABS " &
"-gnatwu " &
"NOUNUSED " &
"-gnatwU " &
+ "UNORDERED_ENUMERATIONS " &
+ "-gnatw.u " &
+ "NOUNORDERED_ENUMERATIONS " &
+ "-gnatw.U " &
"VARIABLES_UNINITIALIZED " &
"-gnatwv " &
"NOVARIABLES_UNINITIALIZED " &
OSDN Git Service
