2010-09-09 Robert Dewar <dewar@adacore.com>
+ * a-calfor.adb, sem_ch3.adb: Minor reformatting.
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * bindgen.adb (Gen_Restrictions_Ada): Avoid explicit enumeration ranges
+ (Gen_Restrictions_C): Avoid explicit enumeration ranges
+ (Set_String_Replace): New procedure
+ * casing.ads (Known_Casing): New subtype declaration
+ * prj-attr.ads (All_Case_Insensitive_Associative_Array): New subtype
+ declaration
+ * prj-dect.adb (Parse_Attribute_Declaration): Avoid enumeration range
+ * prj-nmsc.adb (Check_Naming): Avoid unnecessary enumeration range
+ * prj-strt.adb (Attribute_Reference): Avoid enumeration range test
+ * prj.adb (Known_Casing): Moved to Casing spec (avoid enum range)
+ * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order): Avoid enumeration
+ ranges
+ * sem_res.adb (Resolve_Range): Check for enumeration subrange style rule
+ * sem_type.adb (Is_Array_Class_Record_Type): New.
+ * style.ads (Check_Enumeration_Subrange): New procedure
+ * styleg.adb (Check_Enumeration_Subrange): New procedure
+ * styleg.ads (Check_Enumeration_Subrange): New procedure
+ * stylesw.adb Add handling for Style_Check_Enumeration_Subranges
+ * stylesw.ads (Style_Check_Enumeration_Subranges): New flag
+ * usage.adb: Add line for -gnatyE
+ * vms_data.ads: Add entries for [NO]ENUMERATION_RANGES
+ Add missing entry for NOBOOLEAN_OPERATORS
+ * gnat_ugn.texi: Add documentation for -gnatyE
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * namet.adb (Initialize): Is now a dummy procedure
+ (Reinitialize): New procedure
+ Call Reinitialize from package initialization
+ * namet.ads (Initialize): Is now a dummy procedure
+ (Reinitialize): New procedure
+ * clean.adb, gnat1drv.adb, gnatbind.adb, gnatcmd.adb, gnatlink.adb,
+ gnatls.adb, gprep.adb, make.adb, prj-makr.adb: Remove obsolete call to
+ Namet.Initialize.
+
+2010-09-09 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb, s-os_lib.ads: Minor comment fixes.
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * s-bitops.adb (Raise_Error): Add exception message
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
* par-ch5.adb (Test_Statement_Required): Deal with Ada 2012 allowing no
null statement after label.
* sinfo.ads: Minor comment updates.
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- independent, thus only one source file is needed for multiple targets.
procedure Check_Char (S : String; C : Character; Index : Integer);
- -- Subsidiary to the two versions of Value. Determine whether the
- -- input string S has character C at position Index. Raise
- -- Constraint_Error if there is a mismatch.
+ -- Subsidiary to the two versions of Value. Determine whether the input
+ -- string S has character C at position Index. Raise Constraint_Error if
+ -- there is a mismatch.
procedure Check_Digit (S : String; Index : Integer);
- -- Subsidiary to the two versions of Value. Determine whether the
- -- character of string S at position Index is a digit. This catches
- -- invalid input such as 1983-*1-j3 u5:n7:k9 which should be
- -- 1983-01-03 05:07:09. Raise Constraint_Error if there is a mismatch.
+ -- Subsidiary to the two versions of Value. Determine whether the character
+ -- of string S at position Index is a digit. This catches invalid input
+ -- such as 1983-*1-j3 u5:n7:k9 which should be 1983-01-03 05:07:09. Raise
+ -- Constraint_Error if there is a mismatch.
----------------
-- Check_Char --
raise Constraint_Error;
end if;
- -- After the correct length has been determined, it is safe to
- -- copy the Date in order to avoid Date'First + N indexing.
+ -- After the correct length has been determined, it is safe to copy the
+ -- Date in order to avoid Date'First + N indexing.
D (1 .. Date'Length) := Date;
raise Constraint_Error;
end if;
- -- After the correct length has been determined, it is safe to
- -- copy the Elapsed_Time in order to avoid Date'First + N indexing.
+ -- After the correct length has been determined, it is safe to copy the
+ -- Elapsed_Time in order to avoid Date'First + N indexing.
D (1 .. Elapsed_Time'Length) := Elapsed_Time;
-- Sets characters of given string in Statement_Buffer, starting at the
-- Last + 1 position, and updating last past the string value.
+ procedure Set_String_Replace (S : String);
+ -- Replaces the last S'Length characters in the Statement_Buffer with
+ -- the characters of S. The caller must ensure that these characters do
+ -- in fact exist in the Statement_Buffer.
+
procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
-- starting at the Last + 1 position, and updating last past the value.
Count := 0;
- for J in Cumulative_Restrictions.Set'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Set'Last)
- loop
+ for J in Cumulative_Restrictions.Set'Range loop
Set_Boolean (Cumulative_Restrictions.Set (J));
Set_String (", ");
Count := Count + 1;
end if;
end loop;
- Set_Boolean
- (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last));
- Set_String ("),");
+ Set_String_Replace ("),");
Write_Statement_Buffer;
Set_String (" Value => (");
- for J in Cumulative_Restrictions.Value'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Value'Last)
- loop
+ for J in Cumulative_Restrictions.Value'Range loop
Set_Int (Int (Cumulative_Restrictions.Value (J)));
Set_String (", ");
end loop;
- Set_Int (Int (Cumulative_Restrictions.Value
- (Cumulative_Restrictions.Value'Last)));
- Set_String ("),");
+ Set_String_Replace ("),");
Write_Statement_Buffer;
WBI (" Violated =>");
Set_String (" (");
Count := 0;
- for J in Cumulative_Restrictions.Violated'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last)
- loop
+ for J in Cumulative_Restrictions.Violated'Range loop
Set_Boolean (Cumulative_Restrictions.Violated (J));
Set_String (", ");
Count := Count + 1;
end if;
end loop;
- Set_Boolean (Cumulative_Restrictions.Violated
- (Cumulative_Restrictions.Violated'Last));
- Set_String ("),");
+ Set_String_Replace ("),");
Write_Statement_Buffer;
Set_String (" Count => (");
- for J in Cumulative_Restrictions.Count'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Count'Last)
- loop
+ for J in Cumulative_Restrictions.Count'Range loop
Set_Int (Int (Cumulative_Restrictions.Count (J)));
Set_String (", ");
end loop;
- Set_Int (Int (Cumulative_Restrictions.Count
- (Cumulative_Restrictions.Count'Last)));
- Set_String ("),");
+ Set_String_Replace ("),");
Write_Statement_Buffer;
Set_String (" Unknown => (");
- for J in Cumulative_Restrictions.Unknown'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last)
- loop
+ for J in Cumulative_Restrictions.Unknown'Range loop
Set_Boolean (Cumulative_Restrictions.Unknown (J));
Set_String (", ");
end loop;
- Set_Boolean
- (Cumulative_Restrictions.Unknown
- (Cumulative_Restrictions.Unknown'Last));
- Set_String ("));");
+ Set_String_Replace ("))");
+ Set_String (";");
Write_Statement_Buffer;
end Gen_Restrictions_Ada;
WBI (" restrictions r = {");
Set_String (" {");
- for J in Cumulative_Restrictions.Set'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Set'Last)
- loop
+ for J in Cumulative_Restrictions.Set'Range loop
Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J)));
Set_String (", ");
end loop;
- Set_Int (Boolean'Pos
- (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last)));
- Set_String ("},");
+ Set_String_Replace ("},");
Write_Statement_Buffer;
Set_String (" {");
- for J in Cumulative_Restrictions.Value'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Value'Last)
- loop
+ for J in Cumulative_Restrictions.Value'Range loop
Set_Int (Int (Cumulative_Restrictions.Value (J)));
Set_String (", ");
end loop;
- Set_Int (Int (Cumulative_Restrictions.Value
- (Cumulative_Restrictions.Value'Last)));
- Set_String ("},");
+ Set_String_Replace ("},");
Write_Statement_Buffer;
Set_String (" {");
- for J in Cumulative_Restrictions.Violated'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last)
- loop
+ for J in Cumulative_Restrictions.Violated'Range loop
Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J)));
Set_String (", ");
end loop;
- Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated
- (Cumulative_Restrictions.Violated'Last)));
- Set_String ("},");
+ Set_String_Replace ("},");
Write_Statement_Buffer;
Set_String (" {");
- for J in Cumulative_Restrictions.Count'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Count'Last)
- loop
+ for J in Cumulative_Restrictions.Count'Range loop
Set_Int (Int (Cumulative_Restrictions.Count (J)));
Set_String (", ");
end loop;
- Set_Int (Int (Cumulative_Restrictions.Count
- (Cumulative_Restrictions.Count'Last)));
- Set_String ("},");
+ Set_String_Replace ("},");
Write_Statement_Buffer;
Set_String (" {");
- for J in Cumulative_Restrictions.Unknown'First ..
- Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last)
- loop
+ for J in Cumulative_Restrictions.Unknown'Range loop
Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J)));
Set_String (", ");
end loop;
- Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown
- (Cumulative_Restrictions.Unknown'Last)));
- Set_String ("}};");
+ Set_String_Replace ("}}");
+ Set_String (";");
Write_Statement_Buffer;
WBI (" system__restrictions__run_time_restrictions = r;");
end Gen_Restrictions_C;
Last := Last + S'Length;
end Set_String;
+ ------------------------
+ -- Set_String_Replace --
+ ------------------------
+
+ procedure Set_String_Replace (S : String) is
+ begin
+ Statement_Buffer (Last - S'Length + 1 .. Last) := S;
+ end Set_String_Replace;
+
-------------------
-- Set_Unit_Name --
-------------------
-- --
-- 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- --
-- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def).
);
+ subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
+ -- Exclude Unknown casing
+
------------------------------
-- Case Control Subprograms --
------------------------------
-- Initialize some packages
Csets.Initialize;
- Namet.Initialize;
Snames.Initialize;
Project_Node_Tree := new Project_Node_Tree_Data;
Uintp.Initialize;
Urealp.Initialize;
Errout.Initialize;
- Namet.Initialize;
SCOs.Initialize;
Snames.Initialize;
Stringt.Initialize;
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
Osint.Add_Default_Search_Dirs;
-- Carry out package initializations. These are initializations which
- -- might logically be performed at elaboration time, but Namet at least
- -- can't be done that way (because it is used in the Compiler), and we
- -- decide to be consistent. Like elaboration, the order in which these
- -- calls are made is in some cases important.
+ -- might logically be performed at elaboration time, and we decide to be
+ -- consistent. Like elaboration, the order in which these calls are made
+ -- is in some cases important.
Csets.Initialize;
- Namet.Initialize;
Snames.Initialize;
-- Acquire target parameters
begin
-- Initializations
- Namet.Initialize;
Csets.Initialize;
-
Snames.Initialize;
Project_Node_Tree := new Project_Node_Tree_Data;
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Initialize packages to be used
- Namet.Initialize;
Csets.Initialize;
Snames.Initialize;
-- the binder generated file
if Compile_Bind_File and then Standard_Gcc then
-
Initialize_ALI;
Name_Len := Ali_File_Name'Length;
Name_Buffer (1 .. Name_Len) := Ali_File_Name.all;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
begin
-- Initialize standard packages
- Namet.Initialize;
Csets.Initialize;
Snames.Initialize;
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Do some initializations (order is important here!)
Csets.Initialize;
- Namet.Initialize;
Snames.Initialize;
Stringt.Initialize;
Prep.Initialize;
Check_Object_Consistency := True;
- -- Package initializations. The order of calls is important here
+ -- Package initializations (the order of calls is important here)
Output.Set_Standard_Error;
Linker_Switches.Init;
Csets.Initialize;
- Namet.Initialize;
-
Snames.Initialize;
Prj.Initialize (Project_Tree);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Initialize is
begin
- Name_Chars.Init;
- Name_Entries.Init;
-
- -- Initialize entries for one character names
-
- for C in Character loop
- Name_Entries.Append
- ((Name_Chars_Index => Name_Chars.Last,
- Name_Len => 1,
- Byte_Info => 0,
- Int_Info => 0,
- Name_Has_No_Encodings => True,
- Hash_Link => No_Name));
-
- Name_Chars.Append (C);
- Name_Chars.Append (ASCII.NUL);
- end loop;
-
- -- Clear hash table
-
- for J in Hash_Index_Type loop
- Hash_Table (J) := No_Name;
- end loop;
+ null;
end Initialize;
----------------------
end if;
end Name_Find;
+ ------------------
+ -- Reinitialize --
+ ------------------
+
+ procedure Reinitialize is
+ begin
+ Name_Chars.Init;
+ Name_Entries.Init;
+
+ -- Initialize entries for one character names
+
+ for C in Character loop
+ Name_Entries.Append
+ ((Name_Chars_Index => Name_Chars.Last,
+ Name_Len => 1,
+ Byte_Info => 0,
+ Int_Info => 0,
+ Name_Has_No_Encodings => True,
+ Hash_Link => No_Name));
+
+ Name_Chars.Append (C);
+ Name_Chars.Append (ASCII.NUL);
+ end loop;
+
+ -- Clear hash table
+
+ for J in Hash_Index_Type loop
+ Hash_Table (J) := No_Name;
+ end loop;
+ end Reinitialize;
+
----------------------
-- Reset_Name_Table --
----------------------
end if;
end Write_Name_Decoded;
+-- Package initialization, initialize tables
+
+begin
+ Reinitialize;
end Namet;
-- --
-- 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- --
-- is, it starts with an upper case O).
procedure Initialize;
- -- Initializes the names table, including initializing the first 26
- -- entries in the table (for the 1-character lower case names a-z) Note
- -- that Initialize must not be called if Tree_Read is used.
+ -- This is a dummy procedure. It is retained for easy compatibility with
+ -- clients who used to call Initialize when this call was required. Now
+ -- initialization is performed automatically during package elaboration.
+ -- Note that this change fixes problems which existed prior to the change
+ -- of Initialize being called more than once. See also Reinitialize which
+ -- allows reinitialiation of the tables.
procedure Lock;
-- Lock name tables before calling back end. We reserve some extra space
-- before locking to avoid unnecessary inefficiencies when we unlock.
+ procedure Reinitialize;
+ -- Clears the name tables and removes all existing entries from the table.
+
procedure Unlock;
-- Unlocks the name table to allow use of the extra space reserved by the
-- call to Lock. See gnat1drv for details of the need for this.
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- packages and their attribute. This procedure should be called by
-- Prj.Initialize.
- type Attribute_Kind is
- (Unknown,
+ type Attribute_Kind is (
+ Unknown,
-- The attribute does not exist
Single,
Case_Insensitive_Associative_Array,
-- Associative array attribute with a case insensitive index
- Optional_Index_Case_Insensitive_Associative_Array);
+ Optional_Index_Case_Insensitive_Associative_Array
-- Associative array attribute with a case insensitive index and an
-- optional source index.
+ );
-- Characteristics of an attribute. Optional_Index indicates that there
-- may be an optional index in the index of the associative array, as in
-- for Switches ("files.ada" at 2) use ...
-- Subset of Attribute_Kinds that may be used for the attributes that is
-- used when defining a new package.
+ subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range
+ Case_Insensitive_Associative_Array ..
+ Optional_Index_Case_Insensitive_Associative_Array;
+ -- Subtype including both cases of Case_Insensitive_Associative_Array
+
Max_Attribute_Name_Length : constant := 64;
-- The maximum length of attribute names
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
if Attribute_Kind_Of (Current_Attribute) in
- Case_Insensitive_Associative_Array ..
- Optional_Index_Case_Insensitive_Associative_Array
+ All_Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, In_Tree, To => True);
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Do some needed initializations
Csets.Initialize;
- Namet.Initialize;
Snames.Initialize;
Prj.Initialize (No_Project_Tree);
Prj.Tree.Initialize (Tree);
-- Get the naming exceptions for all languages
- for Kind in Spec .. Impl loop
+ for Kind in Spec_Or_Body loop
Lang_Id := Project.Languages;
while Lang_Id /= No_Language_Index loop
case Lang_Id.Config.Kind is
Set_Case_Insensitive
(Reference, In_Tree,
To => Attribute_Kind_Of (Current_Attribute) in
- Case_Insensitive_Associative_Array ..
- Optional_Index_Case_Insensitive_Associative_Array);
+ All_Case_Insensitive_Associative_Array);
-- Scan past the attribute name
The_Empty_String : Name_Id := No_Name;
- subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
-
type Cst_String_Access is access constant String;
All_Lower_Case_Image : aliased constant String := "lowercase";
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with System; use System;
with System.Unsigned_Types; use System.Unsigned_Types;
+with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
package body System.Bit_Ops is
-----------------------
procedure Raise_Error;
+ pragma No_Return (Raise_Error);
-- Raise Constraint_Error, complaining about unequal lengths
-------------
procedure Raise_Error is
begin
- raise Constraint_Error;
+ Raise_Exception
+ (Constraint_Error'Identity, "operand lengths are unequal");
end Raise_Error;
end System.Bit_Ops;
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
(Name : String;
Fmode : Mode) return File_Descriptor;
-- Creates new file with given name for writing, returning file descriptor
- -- for subsequent use in Write calls. File descriptor returned is
- -- Invalid_FD if file cannot be successfully created.
+ -- for subsequent use in Write calls. If the file already exists, it is
+ -- overwritten. File descriptor returned is Invalid_FD if file cannot be
+ -- successfully created.
function Create_Output_Text_File (Name : String) return File_Descriptor;
-- Creates new text file with given name suitable to redirect standard
begin
-- Processing depends on version of Ada
- case Ada_Version is
+ -- For Ada 95, we just renumber bits within a storage unit. We do the
+ -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83,
+ -- and are free to add this extension.
- -- For Ada 95, we just renumber bits within a storage unit. We do
- -- the same for Ada 83 mode, since we recognize pragma Bit_Order
- -- in Ada 83, and are free to add this extension.
+ if Ada_Version < Ada_2005 then
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ CC := Component_Clause (Comp);
- when Ada_83 | Ada_95 =>
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- CC := Component_Clause (Comp);
+ -- If component clause is present, then deal with the non-default
+ -- bit order case for Ada 95 mode.
- -- If component clause is present, then deal with the non-
- -- default bit order case for Ada 95 mode.
+ -- We only do this processing for the base type, and in fact that
+ -- is important, since otherwise if there are record subtypes, we
+ -- could reverse the bits once for each subtype, which is wrong.
- -- We only do this processing for the base type, and in
- -- fact that's important, since otherwise if there are
- -- record subtypes, we could reverse the bits once for
- -- each subtype, which would be incorrect.
+ if Present (CC)
+ and then Ekind (R) = E_Record_Type
+ then
+ declare
+ CFB : constant Uint := Component_Bit_Offset (Comp);
+ CSZ : constant Uint := Esize (Comp);
+ CLC : constant Node_Id := Component_Clause (Comp);
+ Pos : constant Node_Id := Position (CLC);
+ FB : constant Node_Id := First_Bit (CLC);
- if Present (CC)
- and then Ekind (R) = E_Record_Type
- then
- declare
- CFB : constant Uint := Component_Bit_Offset (Comp);
- CSZ : constant Uint := Esize (Comp);
- CLC : constant Node_Id := Component_Clause (Comp);
- Pos : constant Node_Id := Position (CLC);
- FB : constant Node_Id := First_Bit (CLC);
+ Storage_Unit_Offset : constant Uint :=
+ CFB / System_Storage_Unit;
- Storage_Unit_Offset : constant Uint :=
- CFB / System_Storage_Unit;
+ Start_Bit : constant Uint :=
+ CFB mod System_Storage_Unit;
- Start_Bit : constant Uint :=
- CFB mod System_Storage_Unit;
+ begin
+ -- Cases where field goes over storage unit boundary
- begin
- -- Cases where field goes over storage unit boundary
+ if Start_Bit + CSZ > System_Storage_Unit then
- if Start_Bit + CSZ > System_Storage_Unit then
+ -- Allow multi-byte field but generate warning
- -- Allow multi-byte field but generate warning
+ if Start_Bit mod System_Storage_Unit = 0
+ and then CSZ mod System_Storage_Unit = 0
+ then
+ Error_Msg_N
+ ("multi-byte field specified with non-standard"
+ & " Bit_Order?", CLC);
- if Start_Bit mod System_Storage_Unit = 0
- and then CSZ mod System_Storage_Unit = 0
- then
+ if Bytes_Big_Endian then
Error_Msg_N
- ("multi-byte field specified with non-standard"
- & " Bit_Order?", CLC);
-
- if Bytes_Big_Endian then
- Error_Msg_N
- ("bytes are not reversed "
- & "(component is big-endian)?", CLC);
- else
- Error_Msg_N
- ("bytes are not reversed "
- & "(component is little-endian)?", CLC);
- end if;
-
- -- Do not allow non-contiguous field
-
+ ("bytes are not reversed "
+ & "(component is big-endian)?", CLC);
else
Error_Msg_N
- ("attempt to specify non-contiguous field "
- & "not permitted", CLC);
- Error_Msg_N
- ("\caused by non-standard Bit_Order "
- & "specified", CLC);
- Error_Msg_N
- ("\consider possibility of using "
- & "Ada 2005 mode here", CLC);
+ ("bytes are not reversed "
+ & "(component is little-endian)?", CLC);
end if;
- -- Case where field fits in one storage unit
+ -- Do not allow non-contiguous field
else
- -- Give warning if suspicious component clause
+ Error_Msg_N
+ ("attempt to specify non-contiguous field "
+ & "not permitted", CLC);
+ Error_Msg_N
+ ("\caused by non-standard Bit_Order "
+ & "specified", CLC);
+ Error_Msg_N
+ ("\consider possibility of using "
+ & "Ada 2005 mode here", CLC);
+ end if;
- if Intval (FB) >= System_Storage_Unit
- and then Warn_On_Reverse_Bit_Order
- then
- Error_Msg_N
- ("?Bit_Order clause does not affect " &
- "byte ordering", Pos);
- Error_Msg_Uint_1 :=
- Intval (Pos) + Intval (FB) /
- System_Storage_Unit;
- Error_Msg_N
- ("?position normalized to ^ before bit " &
- "order interpreted", Pos);
- end if;
+ -- Case where field fits in one storage unit
+
+ else
+ -- Give warning if suspicious component clause
+
+ if Intval (FB) >= System_Storage_Unit
+ and then Warn_On_Reverse_Bit_Order
+ then
+ Error_Msg_N
+ ("?Bit_Order clause does not affect " &
+ "byte ordering", Pos);
+ Error_Msg_Uint_1 :=
+ Intval (Pos) + Intval (FB) /
+ System_Storage_Unit;
+ Error_Msg_N
+ ("?position normalized to ^ before bit " &
+ "order interpreted", Pos);
+ end if;
- -- Here is where we fix up the Component_Bit_Offset
- -- value to account for the reverse bit order.
- -- Some examples of what needs to be done are:
+ -- Here is where we fix up the Component_Bit_Offset value
+ -- to account for the reverse bit order. Some examples of
+ -- what needs to be done are:
- -- First_Bit .. Last_Bit Component_Bit_Offset
- -- old new old new
+ -- First_Bit .. Last_Bit Component_Bit_Offset
+ -- old new old new
- -- 0 .. 0 7 .. 7 0 7
- -- 0 .. 1 6 .. 7 0 6
- -- 0 .. 2 5 .. 7 0 5
- -- 0 .. 7 0 .. 7 0 4
+ -- 0 .. 0 7 .. 7 0 7
+ -- 0 .. 1 6 .. 7 0 6
+ -- 0 .. 2 5 .. 7 0 5
+ -- 0 .. 7 0 .. 7 0 4
- -- 1 .. 1 6 .. 6 1 6
- -- 1 .. 4 3 .. 6 1 3
- -- 4 .. 7 0 .. 3 4 0
+ -- 1 .. 1 6 .. 6 1 6
+ -- 1 .. 4 3 .. 6 1 3
+ -- 4 .. 7 0 .. 3 4 0
- -- The general rule is that the first bit is
- -- is obtained by subtracting the old ending bit
- -- from storage_unit - 1.
+ -- The rule is that the first bit is is obtained by
+ -- subtracting the old ending bit from storage_unit - 1.
- Set_Component_Bit_Offset
- (Comp,
- (Storage_Unit_Offset * System_Storage_Unit) +
- (System_Storage_Unit - 1) -
- (Start_Bit + CSZ - 1));
+ Set_Component_Bit_Offset
+ (Comp,
+ (Storage_Unit_Offset * System_Storage_Unit) +
+ (System_Storage_Unit - 1) -
+ (Start_Bit + CSZ - 1));
- Set_Normalized_First_Bit
- (Comp,
- Component_Bit_Offset (Comp) mod
- System_Storage_Unit);
- end if;
- end;
- end if;
+ Set_Normalized_First_Bit
+ (Comp,
+ Component_Bit_Offset (Comp) mod
+ System_Storage_Unit);
+ end if;
+ end;
+ end if;
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
- -- For Ada 2005, we do machine scalar processing, as fully described
- -- In AI-133. This involves gathering all components which start at
- -- the same byte offset and processing them together
+ -- For Ada 2005, we do machine scalar processing, as fully described In
+ -- AI-133. This involves gathering all components which start at the
+ -- same byte offset and processing them together. Same approach is still
+ -- valid in later versions including Ada 2012.
- when Ada_05 .. Ada_Version_Type'Last =>
- declare
- Max_Machine_Scalar_Size : constant Uint :=
- UI_From_Int
- (Standard_Long_Long_Integer_Size);
+ else
+ declare
+ Max_Machine_Scalar_Size : constant Uint :=
+ UI_From_Int
+ (Standard_Long_Long_Integer_Size);
-- We use this as the maximum machine scalar size
- Num_CC : Natural;
- SSU : constant Uint := UI_From_Int (System_Storage_Unit);
+ Num_CC : Natural;
+ SSU : constant Uint := UI_From_Int (System_Storage_Unit);
- begin
- -- This first loop through components does two things. First it
- -- deals with the case of components with component clauses
- -- whose length is greater than the maximum machine scalar size
- -- (either accepting them or rejecting as needed). Second, it
- -- counts the number of components with component clauses whose
- -- length does not exceed this maximum for later processing.
+ begin
+ -- This first loop through components does two things. First it
+ -- deals with the case of components with component clauses whose
+ -- length is greater than the maximum machine scalar size (either
+ -- accepting them or rejecting as needed). Second, it counts the
+ -- number of components with component clauses whose length does
+ -- not exceed this maximum for later processing.
+
+ Num_CC := 0;
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ CC := Component_Clause (Comp);
- Num_CC := 0;
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- CC := Component_Clause (Comp);
+ if Present (CC) then
+ declare
+ Fbit : constant Uint :=
+ Static_Integer (First_Bit (CC));
- if Present (CC) then
- declare
- Fbit : constant Uint :=
- Static_Integer (First_Bit (CC));
+ begin
+ -- Case of component with size > max machine scalar
- begin
- -- Case of component with size > max machine scalar
+ if Esize (Comp) > Max_Machine_Scalar_Size then
- if Esize (Comp) > Max_Machine_Scalar_Size then
+ -- Must begin on byte boundary
- -- Must begin on byte boundary
+ if Fbit mod SSU /= 0 then
+ Error_Msg_N
+ ("illegal first bit value for "
+ & "reverse bit order",
+ First_Bit (CC));
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
- if Fbit mod SSU /= 0 then
- Error_Msg_N
- ("illegal first bit value for "
- & "reverse bit order",
- First_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ Error_Msg_N
+ ("\must be a multiple of ^ "
+ & "if size greater than ^",
+ First_Bit (CC));
- Error_Msg_N
- ("\must be a multiple of ^ "
- & "if size greater than ^",
- First_Bit (CC));
+ -- Must end on byte boundary
- -- Must end on byte boundary
+ elsif Esize (Comp) mod SSU /= 0 then
+ Error_Msg_N
+ ("illegal last bit value for "
+ & "reverse bit order",
+ Last_Bit (CC));
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
- elsif Esize (Comp) mod SSU /= 0 then
- Error_Msg_N
- ("illegal last bit value for "
- & "reverse bit order",
- Last_Bit (CC));
- Error_Msg_Uint_1 := SSU;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ Error_Msg_N
+ ("\must be a multiple of ^ if size "
+ & "greater than ^",
+ Last_Bit (CC));
- Error_Msg_N
- ("\must be a multiple of ^ if size "
- & "greater than ^",
- Last_Bit (CC));
+ -- OK, give warning if enabled
- -- OK, give warning if enabled
+ elsif Warn_On_Reverse_Bit_Order then
+ Error_Msg_N
+ ("multi-byte field specified with "
+ & " non-standard Bit_Order?", CC);
- elsif Warn_On_Reverse_Bit_Order then
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is big-endian)?", CC);
+ else
Error_Msg_N
- ("multi-byte field specified with "
- & " non-standard Bit_Order?", CC);
-
- if Bytes_Big_Endian then
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is big-endian)?", CC);
- else
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is little-endian)?", CC);
- end if;
+ ("\bytes are not reversed "
+ & "(component is little-endian)?", CC);
end if;
+ end if;
- -- Case where size is not greater than max machine
- -- scalar. For now, we just count these.
+ -- Case where size is not greater than max machine
+ -- scalar. For now, we just count these.
- else
- Num_CC := Num_CC + 1;
- end if;
- end;
- end if;
+ else
+ Num_CC := Num_CC + 1;
+ end if;
+ end;
+ end if;
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
- -- We need to sort the component clauses on the basis of the
- -- Position values in the clause, so we can group clauses with
- -- the same Position. together to determine the relevant
- -- machine scalar size.
+ -- We need to sort the component clauses on the basis of the
+ -- Position values in the clause, so we can group clauses with
+ -- the same Position. together to determine the relevant machine
+ -- scalar size.
- Sort_CC : declare
- Comps : array (0 .. Num_CC) of Entity_Id;
- -- Array to collect component and discriminant entities. The
- -- data starts at index 1, the 0'th entry is for the sort
- -- routine.
+ Sort_CC : declare
+ Comps : array (0 .. Num_CC) of Entity_Id;
+ -- Array to collect component and discriminant entities. The
+ -- data starts at index 1, the 0'th entry is for the sort
+ -- routine.
- function CP_Lt (Op1, Op2 : Natural) return Boolean;
- -- Compare routine for Sort
+ function CP_Lt (Op1, Op2 : Natural) return Boolean;
+ -- Compare routine for Sort
- procedure CP_Move (From : Natural; To : Natural);
- -- Move routine for Sort
+ procedure CP_Move (From : Natural; To : Natural);
+ -- Move routine for Sort
- package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
+ package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
- Start : Natural;
- Stop : Natural;
- -- Start and stop positions in component list of set of
- -- components with the same starting position (that
- -- constitute components in a single machine scalar).
+ Start : Natural;
+ Stop : Natural;
+ -- Start and stop positions in the component list of the set of
+ -- components with the same starting position (that constitute
+ -- components in a single machine scalar).
- MaxL : Uint;
- -- Maximum last bit value of any component in this set
+ MaxL : Uint;
+ -- Maximum last bit value of any component in this set
- MSS : Uint;
- -- Corresponding machine scalar size
+ MSS : Uint;
+ -- Corresponding machine scalar size
- -----------
- -- CP_Lt --
- -----------
+ -----------
+ -- CP_Lt --
+ -----------
- function CP_Lt (Op1, Op2 : Natural) return Boolean is
- begin
- return Position (Component_Clause (Comps (Op1))) <
- Position (Component_Clause (Comps (Op2)));
- end CP_Lt;
+ function CP_Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return Position (Component_Clause (Comps (Op1))) <
+ Position (Component_Clause (Comps (Op2)));
+ end CP_Lt;
- -------------
- -- CP_Move --
- -------------
+ -------------
+ -- CP_Move --
+ -------------
- procedure CP_Move (From : Natural; To : Natural) is
- begin
- Comps (To) := Comps (From);
- end CP_Move;
+ procedure CP_Move (From : Natural; To : Natural) is
+ begin
+ Comps (To) := Comps (From);
+ end CP_Move;
-- Start of processing for Sort_CC
- begin
- -- Collect the component clauses
+ begin
+ -- Collect the component clauses
- Num_CC := 0;
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- if Present (Component_Clause (Comp))
- and then Esize (Comp) <= Max_Machine_Scalar_Size
- then
- Num_CC := Num_CC + 1;
- Comps (Num_CC) := Comp;
- end if;
+ Num_CC := 0;
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ if Present (Component_Clause (Comp))
+ and then Esize (Comp) <= Max_Machine_Scalar_Size
+ then
+ Num_CC := Num_CC + 1;
+ Comps (Num_CC) := Comp;
+ end if;
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
- -- Sort by ascending position number
+ -- Sort by ascending position number
- Sorting.Sort (Num_CC);
+ Sorting.Sort (Num_CC);
- -- We now have all the components whose size does not exceed
- -- the max machine scalar value, sorted by starting
- -- position. In this loop we gather groups of clauses
- -- starting at the same position, to process them in
- -- accordance with Ada 2005 AI-133.
+ -- We now have all the components whose size does not exceed
+ -- the max machine scalar value, sorted by starting position.
+ -- In this loop we gather groups of clauses starting at the
+ -- same position, to process them in accordance with AI-133.
- Stop := 0;
+ Stop := 0;
+ while Stop < Num_CC loop
+ Start := Stop + 1;
+ Stop := Start;
+ MaxL :=
+ Static_Integer
+ (Last_Bit (Component_Clause (Comps (Start))));
while Stop < Num_CC loop
- Start := Stop + 1;
- Stop := Start;
- MaxL :=
- Static_Integer
- (Last_Bit (Component_Clause (Comps (Start))));
- while Stop < Num_CC loop
- if Static_Integer
- (Position (Component_Clause (Comps (Stop + 1)))) =
- Static_Integer
- (Position (Component_Clause (Comps (Stop))))
- then
- Stop := Stop + 1;
- MaxL :=
- UI_Max
- (MaxL,
- Static_Integer
- (Last_Bit
- (Component_Clause (Comps (Stop)))));
- else
- exit;
- end if;
- end loop;
+ if Static_Integer
+ (Position (Component_Clause (Comps (Stop + 1)))) =
+ Static_Integer
+ (Position (Component_Clause (Comps (Stop))))
+ then
+ Stop := Stop + 1;
+ MaxL :=
+ UI_Max
+ (MaxL,
+ Static_Integer
+ (Last_Bit
+ (Component_Clause (Comps (Stop)))));
+ else
+ exit;
+ end if;
+ end loop;
- -- Now we have a group of component clauses from Start to
- -- Stop whose positions are identical, and MaxL is the
- -- maximum last bit value of any of these components.
-
- -- We need to determine the corresponding machine scalar
- -- size. This loop assumes that machine scalar sizes are
- -- even, and that each possible machine scalar has twice
- -- as many bits as the next smaller one.
-
- MSS := Max_Machine_Scalar_Size;
- while MSS mod 2 = 0
- and then (MSS / 2) >= SSU
- and then (MSS / 2) > MaxL
- loop
- MSS := MSS / 2;
- end loop;
+ -- Now we have a group of component clauses from Start to
+ -- Stop whose positions are identical, and MaxL is the
+ -- maximum last bit value of any of these components.
- -- Here is where we fix up the Component_Bit_Offset value
- -- to account for the reverse bit order. Some examples of
- -- what needs to be done for the case of a machine scalar
- -- size of 8 are:
+ -- We need to determine the corresponding machine scalar
+ -- size. This loop assumes that machine scalar sizes are
+ -- even, and that each possible machine scalar has twice
+ -- as many bits as the next smaller one.
- -- First_Bit .. Last_Bit Component_Bit_Offset
- -- old new old new
+ MSS := Max_Machine_Scalar_Size;
+ while MSS mod 2 = 0
+ and then (MSS / 2) >= SSU
+ and then (MSS / 2) > MaxL
+ loop
+ MSS := MSS / 2;
+ end loop;
- -- 0 .. 0 7 .. 7 0 7
- -- 0 .. 1 6 .. 7 0 6
- -- 0 .. 2 5 .. 7 0 5
- -- 0 .. 7 0 .. 7 0 4
+ -- Here is where we fix up the Component_Bit_Offset value
+ -- to account for the reverse bit order. Some examples of
+ -- what needs to be done for the case of a machine scalar
+ -- size of 8 are:
- -- 1 .. 1 6 .. 6 1 6
- -- 1 .. 4 3 .. 6 1 3
- -- 4 .. 7 0 .. 3 4 0
+ -- First_Bit .. Last_Bit Component_Bit_Offset
+ -- old new old new
- -- The general rule is that the first bit is obtained by
- -- subtracting the old ending bit from machine scalar
- -- size - 1.
+ -- 0 .. 0 7 .. 7 0 7
+ -- 0 .. 1 6 .. 7 0 6
+ -- 0 .. 2 5 .. 7 0 5
+ -- 0 .. 7 0 .. 7 0 4
- for C in Start .. Stop loop
- declare
- Comp : constant Entity_Id := Comps (C);
- CC : constant Node_Id :=
- Component_Clause (Comp);
- LB : constant Uint :=
- Static_Integer (Last_Bit (CC));
- NFB : constant Uint := MSS - Uint_1 - LB;
- NLB : constant Uint := NFB + Esize (Comp) - 1;
- Pos : constant Uint :=
- Static_Integer (Position (CC));
+ -- 1 .. 1 6 .. 6 1 6
+ -- 1 .. 4 3 .. 6 1 3
+ -- 4 .. 7 0 .. 3 4 0
- begin
- if Warn_On_Reverse_Bit_Order then
- Error_Msg_Uint_1 := MSS;
- Error_Msg_N
- ("info: reverse bit order in machine " &
- "scalar of length^?", First_Bit (CC));
- Error_Msg_Uint_1 := NFB;
- Error_Msg_Uint_2 := NLB;
-
- if Bytes_Big_Endian then
- Error_Msg_NE
- ("?\info: big-endian range for "
- & "component & is ^ .. ^",
- First_Bit (CC), Comp);
- else
- Error_Msg_NE
- ("?\info: little-endian range "
- & "for component & is ^ .. ^",
- First_Bit (CC), Comp);
- end if;
+ -- The rule is that the first bit is obtained by subtracting
+ -- the old ending bit from machine scalar size - 1.
+
+ for C in Start .. Stop loop
+ declare
+ Comp : constant Entity_Id := Comps (C);
+ CC : constant Node_Id :=
+ Component_Clause (Comp);
+ LB : constant Uint :=
+ Static_Integer (Last_Bit (CC));
+ NFB : constant Uint := MSS - Uint_1 - LB;
+ NLB : constant Uint := NFB + Esize (Comp) - 1;
+ Pos : constant Uint :=
+ Static_Integer (Position (CC));
+
+ begin
+ if Warn_On_Reverse_Bit_Order then
+ Error_Msg_Uint_1 := MSS;
+ Error_Msg_N
+ ("info: reverse bit order in machine " &
+ "scalar of length^?", First_Bit (CC));
+ Error_Msg_Uint_1 := NFB;
+ Error_Msg_Uint_2 := NLB;
+
+ if Bytes_Big_Endian then
+ Error_Msg_NE
+ ("?\info: big-endian range for "
+ & "component & is ^ .. ^",
+ First_Bit (CC), Comp);
+ else
+ Error_Msg_NE
+ ("?\info: little-endian range "
+ & "for component & is ^ .. ^",
+ First_Bit (CC), Comp);
end if;
+ end if;
- Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
- Set_Normalized_First_Bit (Comp, NFB mod SSU);
- end;
- end loop;
+ Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
+ Set_Normalized_First_Bit (Comp, NFB mod SSU);
+ end;
end loop;
- end Sort_CC;
- end;
- end case;
+ end loop;
+ end Sort_CC;
+ end;
+ end if;
end Adjust_Record_For_Reverse_Bit_Order;
--------------------------------------
end if;
-- If we did not have a range constraint, then set the range from the
- -- parent type. Otherwise, the call to Process_Subtype has set the
- -- bounds.
+ -- parent type. Otherwise, the Process_Subtype call has set the bounds.
if No_Constraint
or else not Has_Range_Constraint (Indic)
N_Subtype_Declaration);
-- Create an Itype that is a duplicate of Entity (S) but with the
- -- null-exclusion attribute
+ -- null-exclusion attribute.
if May_Have_Null_Exclusion
and then Is_Access_Type (Entity (S))
-- Here is where we give the warning
- -- All OK if warnings suppressed on the entity
+ -- All OK if warnings suppressed on the entity
if not Has_Warnings_Off (Ent) then
Error_Msg_Sloc := Sloc (Ent);
Resolve (L, Typ);
Resolve (H, Typ);
+ if Style_Check then
+ Check_Enumeration_Subrange (N);
+ end if;
+
Check_Unset_Reference (L);
Check_Unset_Reference (H);
-- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
-- abstract interpretation which yields type Typ.
+ function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean;
+ -- This function tests if entity E is in Array_Kind, or Class_Wide_Kind,
+ -- or is E_Record_Type or E_Record_Subtype, and returns True for these
+ -- cases, and False for all others. Note that other record entity kinds
+ -- such as E_Record_Type_With_Private return False.
+ --
+ -- This is a bit of an odd category, maybe it is wrong or a better name
+ -- could be found for the class of entities being tested. The history
+ -- is that this used to be done with an explicit range test for the range
+ -- E_Array_Type .. E_Record_Subtype, which was itself suspicious and is
+ -- now prohibited by the -gnatyE style check ???
+
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have
-- An aggregate is compatible with an array or record type
elsif T2 = Any_Composite
- and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
+ and then Is_Array_Class_Record_Type (T1)
then
return True;
end if;
end Is_Ancestor;
+ --------------------------------
+ -- Is_Array_Class_Record_Type --
+ --------------------------------
+
+ function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean is
+ begin
+ return Is_Array_Type (E)
+ or else Is_Class_Wide_Type (E)
+ or else Ekind (E) = E_Record_Type
+ or else Ekind (E) = E_Record_Subtype;
+ end Is_Array_Class_Record_Type;
+
---------------------------
-- Is_Invisible_Operator --
---------------------------
return T1;
elsif T2 = Any_Composite
- and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
+ and then Is_Array_Class_Record_Type (T1)
then
return T1;
elsif T1 = Any_Composite
- and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
+ and then Is_Array_Class_Record_Type (T2)
then
return T2;
-- --
-- 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- --
-- 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 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 --
---------------
-- --
-- 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- --
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
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
"u" & -- check no unnecessary blank lines
"x"; -- check extra parentheses around conditionals
+ -- Note: we intend GNAT_Style to also include the following, but we do
+ -- not yet have the whole tool suite clean with respect to this.
+
+ -- "B" & -- check boolean operators
+ -- "E" & -- check enumeration ranges
+
-------------------------------
-- Reset_Style_Check_Options --
-------------------------------
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;
-- --
-- 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- --
-- 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.
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");
"-gnaty-A " &
"BLANKS " &
"-gnatyb " &
- "BOOLEAN_OPERATORS " &
- "-gnatyB " &
"NOBLANKS " &
"-gnaty-b " &
+ "BOOLEAN_OPERATORS " &
+ "-gnatyB " &
+ "NOBOOLEAN_OPERATORS " &
+ "-gnaty-B " &
"COMMENTS " &
"-gnatyc " &
"NOCOMMENTS " &
"-gnatye " &
"NOEND " &
"-gnaty-e " &
+ "ENUMERATION_RANGES " &
+ "-gnatyE " &
+ "NOENUMERATION_RANGES " &
+ "-gnaty-E " &
"VTABS " &
"-gnatyf " &
"NOVTABS " &
projects / platform / upstream / linaro-gcc.git / commitdiff