Skip to content

R
riscv-gcc-1
Commit 84a62ce8 by Arnaud Charlet
Options

[multiple changes] 

2016-10-12  Bob Duff  <duff@adacore.com>

	* xref_lib.adb: Use renamings-of-slices to ensure
	that all references to Tables are properly bounds checked (when
	checks are turned on).
	* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
	components, so we don't get uninitialized pointers in case
	of Tables containing access types.  Misc cleanup of the code
	and comments.

2016-10-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
	functionality of attribute, to provide a reasonably unique key
	for a given type and detect any changes in the semantics of the
	type or any of its subcomponents from version to version.

2016-10-12  Bob Duff  <duff@adacore.com>

	* sem_case.adb (Check_Choice_Set): Separate
	checking for duplicates out into a separate pass from checking
	full coverage, because the check for duplicates does not depend
	on predicates. Therefore, we shouldn't do it separately for the
	predicate vs. no-predicate case; we should share code. The code
	for the predicate case was wrong.

From-SVN: r241039
parent 6e832327
Showing with 534 additions and 333 deletions
gcc/ada/ChangeLog
2016-10-12 Bob Duff <duff@adacore.com>
* xref_lib.adb: Use renamings-of-slices to ensure
that all references to Tables are properly bounds checked (when
checks are turned on).
* g-dyntab.ads, g-dyntab.adb: Default-initialize the array
components, so we don't get uninitialized pointers in case
of Tables containing access types. Misc cleanup of the code
and comments.
2016-10-12 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
functionality of attribute, to provide a reasonably unique key
for a given type and detect any changes in the semantics of the
type or any of its subcomponents from version to version.
2016-10-12 Bob Duff <duff@adacore.com>
* sem_case.adb (Check_Choice_Set): Separate
checking for duplicates out into a separate pass from checking
full coverage, because the check for duplicates does not depend
on predicates. Therefore, we shouldn't do it separately for the
predicate vs. no-predicate case; we should share code. The code
for the predicate case was wrong.
2016-10-12 Jerome Lambourg <lambourg@adacore.com> 2016-10-12 Jerome Lambourg <lambourg@adacore.com>
* init.c: Make sure to call finit on x86_64-vx7 to reinitialize * init.c: Make sure to call finit on x86_64-vx7 to reinitialize
......
gcc/ada/g-dyntab.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2014, AdaCore -- -- Copyright (C) 2000-2016, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,33 +32,23 @@ ...@@ -32,33 +32,23 @@
pragma Compiler_Unit_Warning; pragma Compiler_Unit_Warning;
with GNAT.Heap_Sort_G; with GNAT.Heap_Sort_G;
with System; use System;
with System.Memory; use System.Memory;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation;
package body GNAT.Dynamic_Tables is package body GNAT.Dynamic_Tables is
Min : constant Integer := Integer (Table_Low_Bound); Empty : constant Table_Ptr :=
-- Subscript of the minimum entry in the currently allocated table Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Reallocate (T : in out Instance); procedure Grow (T : in out Instance; New_Last : Table_Count_Type);
-- Reallocate the existing table according to the current value stored -- This is called when we are about to set the value of Last to a value
-- in Max. Works correctly to do an initial allocation if the table -- that is larger than Last_Allocated. This reallocates the table to the
-- is currently null. -- larger size, as indicated by New_Last. At the time this is called,
-- T.P.Last is still the old value.
pragma Warnings (Off);
-- These unchecked conversions are in fact safe, since they never
-- generate improperly aliased pointer values.
function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
pragma Warnings (On);
-------------- --------------
-- Allocate -- -- Allocate --
...@@ -66,11 +56,9 @@ package body GNAT.Dynamic_Tables is ...@@ -66,11 +56,9 @@ package body GNAT.Dynamic_Tables is
procedure Allocate (T : in out Instance; Num : Integer := 1) is procedure Allocate (T : in out Instance; Num : Integer := 1) is
begin begin
T.P.Last_Val := T.P.Last_Val + Num; -- Note that Num can be negative
if T.P.Last_Val > T.P.Max then Set_Last (T, T.P.Last + Table_Index_Type'Base (Num));
Reallocate (T);
end if;
end Allocate; end Allocate;
------------ ------------
...@@ -79,7 +67,7 @@ package body GNAT.Dynamic_Tables is ...@@ -79,7 +67,7 @@ package body GNAT.Dynamic_Tables is
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
begin begin
Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val); Set_Item (T, T.P.Last + 1, New_Val);
end Append; end Append;
---------------- ----------------
...@@ -99,9 +87,18 @@ package body GNAT.Dynamic_Tables is ...@@ -99,9 +87,18 @@ package body GNAT.Dynamic_Tables is
procedure Decrement_Last (T : in out Instance) is procedure Decrement_Last (T : in out Instance) is
begin begin
T.P.Last_Val := T.P.Last_Val - 1; Allocate (T, -1);
end Decrement_Last; end Decrement_Last;
-----------
-- First --
-----------
function First return Table_Index_Type is
begin
return Table_Low_Bound;
end First;
-------------- --------------
-- For_Each -- -- For_Each --
-------------- --------------
...@@ -109,7 +106,7 @@ package body GNAT.Dynamic_Tables is ...@@ -109,7 +106,7 @@ package body GNAT.Dynamic_Tables is
procedure For_Each (Table : Instance) is procedure For_Each (Table : Instance) is
Quit : Boolean := False; Quit : Boolean := False;
begin begin
for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop for Index in Table_Low_Bound .. Table.P.Last loop
Action (Index, Table.Table (Index), Quit); Action (Index, Table.Table (Index), Quit);
exit when Quit; exit when Quit;
end loop; end loop;
...@@ -120,23 +117,119 @@ package body GNAT.Dynamic_Tables is ...@@ -120,23 +117,119 @@ package body GNAT.Dynamic_Tables is
---------- ----------
procedure Free (T : in out Instance) is procedure Free (T : in out Instance) is
subtype Alloc_Type is Table_Type (First .. T.P.Last_Allocated);
type Alloc_Ptr is access all Alloc_Type;
procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr);
function To_Alloc_Ptr is
new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr);
Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table);
begin begin
Free (To_Address (T.Table)); if T.Table = Empty then
T.Table := null; pragma Assert (T.P.Last_Allocated = First - 1);
T.P.Length := 0; pragma Assert (T.P.Last = First - 1);
null;
else
Free (Temp);
T.Table := Empty;
T.P.Last_Allocated := First - 1;
T.P.Last := First - 1;
end if;
end Free; end Free;
----------
-- Grow --
----------
procedure Grow (T : in out Instance; New_Last : Table_Count_Type) is
-- Note: Type Alloc_Ptr below needs to be declared locally so we know
-- the bounds. That means that the collection is local, so is finalized
-- when leaving Grow. That's why this package doesn't support controlled
-- types; the table elements would be finalized prematurely. An Ada
-- implementation would also be within its rights to reclaim the
-- storage. Fortunately, GNAT doesn't do that.
pragma Assert (not T.Locked);
pragma Assert (New_Last > T.P.Last_Allocated);
subtype Table_Length_Type is Table_Index_Type'Base
range 0 .. Table_Index_Type'Base'Last;
Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated;
Old_Allocated_Length : constant Table_Length_Type :=
Old_Last_Allocated - First + 1;
New_Length : constant Table_Length_Type := New_Last - First + 1;
New_Allocated_Length : Table_Length_Type;
begin
if T.Table = Empty then
New_Allocated_Length := Table_Length_Type (Table_Initial);
else
New_Allocated_Length :=
Table_Length_Type
(Long_Long_Integer (Old_Allocated_Length) *
(100 + Long_Long_Integer (Table_Increment)) / 100);
end if;
-- Make sure it really did grow
if New_Allocated_Length <= Old_Allocated_Length then
New_Allocated_Length := Old_Allocated_Length + 10;
end if;
if New_Allocated_Length <= New_Length then
New_Allocated_Length := New_Length + 10;
end if;
pragma Assert (New_Allocated_Length > Old_Allocated_Length);
pragma Assert (New_Allocated_Length > New_Length);
T.P.Last_Allocated := First + New_Allocated_Length - 1;
declare
subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
type Old_Alloc_Ptr is access all Old_Alloc_Type;
procedure Free is
new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr);
function To_Old_Alloc_Ptr is
new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr);
subtype Alloc_Type is
Table_Type (First .. First + New_Allocated_Length - 1);
type Alloc_Ptr is access all Alloc_Type;
function To_Table_Ptr is
new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr);
Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table);
New_Table : constant Alloc_Ptr := new Alloc_Type;
begin
if T.Table /= Empty then
New_Table (First .. T.P.Last) := Old_Table (First .. T.P.Last);
Free (Old_Table);
end if;
T.Table := To_Table_Ptr (New_Table);
end;
pragma Assert (New_Last <= T.P.Last_Allocated);
pragma Assert (T.Table /= null);
pragma Assert (T.Table /= Empty);
end Grow;
-------------------- --------------------
-- Increment_Last -- -- Increment_Last --
-------------------- --------------------
procedure Increment_Last (T : in out Instance) is procedure Increment_Last (T : in out Instance) is
begin begin
T.P.Last_Val := T.P.Last_Val + 1; Allocate (T, 1);
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end Increment_Last; end Increment_Last;
---------- ----------
...@@ -144,100 +237,57 @@ package body GNAT.Dynamic_Tables is ...@@ -144,100 +237,57 @@ package body GNAT.Dynamic_Tables is
---------- ----------
procedure Init (T : in out Instance) is procedure Init (T : in out Instance) is
Old_Length : constant Integer := T.P.Length;
begin begin
T.P.Last_Val := Min - 1; Free (T);
T.P.Max := Min + Table_Initial - 1;
T.P.Length := T.P.Max - Min + 1;
-- If table is same size as before (happens when table is never
-- expanded which is a common case), then simply reuse it. Note
-- that this also means that an explicit Init call right after
-- the implicit one in the package body is harmless.
if Old_Length = T.P.Length then
return;
-- Otherwise we can use Reallocate to get a table of the right size.
-- Note that Reallocate works fine to allocate a table of the right
-- initial size when it is first allocated.
else
Reallocate (T);
end if;
end Init; end Init;
---------- ----------
-- Last -- -- Last --
---------- ----------
function Last (T : Instance) return Table_Index_Type is function Last (T : Instance) return Table_Count_Type is
begin begin
return Table_Index_Type (T.P.Last_Val); return T.P.Last;
end Last; end Last;
---------------- -------------
-- Reallocate -- -- Release --
---------------- -------------
procedure Reallocate (T : in out Instance) is
New_Length : Integer;
New_Size : size_t;
procedure Release (T : in out Instance) is
pragma Assert (not T.Locked);
Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated;
begin begin
if T.P.Max < T.P.Last_Val then if T.P.Last /= T.P.Last_Allocated then
pragma Assert (T.P.Last < T.P.Last_Allocated);
-- Now increment table length until it is sufficiently large. Use pragma Assert (T.Table /= Empty);
-- the increment value or 10, which ever is larger (the reason
-- for the use of 10 here is to ensure that the table does really
-- increase in size (which would not be the case for a table of
-- length 10 increased by 3% for instance). Do the intermediate
-- calculation in Long_Long_Integer to avoid overflow.
while T.P.Max < T.P.Last_Val loop
New_Length :=
Integer
(Long_Long_Integer (T.P.Length) *
(100 + Long_Long_Integer (Table_Increment)) / 100);
if New_Length > T.P.Length then declare
T.P.Length := New_Length; subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
else type Old_Alloc_Ptr is access all Old_Alloc_Type;
T.P.Length := T.P.Length + 10;
end if;
T.P.Max := Min + T.P.Length - 1;
end loop;
end if;
New_Size := procedure Free is
size_t ((T.P.Max - Min + 1) * new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr);
(Table_Type'Component_Size / Storage_Unit)); function To_Old_Alloc_Ptr is
new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr);
if T.Table = null then subtype Alloc_Type is
T.Table := To_Pointer (Alloc (New_Size)); Table_Type (First .. First + T.P.Last - 1);
type Alloc_Ptr is access all Alloc_Type;
elsif New_Size > 0 then function To_Table_Ptr is
T.Table := new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr);
To_Pointer (Realloc (Ptr => To_Address (T.Table),
Size => New_Size));
end if;
if T.P.Length /= 0 and then T.Table = null then Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table);
raise Storage_Error; New_Table : constant Alloc_Ptr := new Alloc_Type'(Old_Table.all);
begin
T.P.Last_Allocated := T.P.Last;
Free (Old_Table);
T.Table := To_Table_Ptr (New_Table);
end;
end if; end if;
end Reallocate;
-------------
-- Release --
-------------
procedure Release (T : in out Instance) is pragma Assert (T.P.Last = T.P.Last_Allocated);
begin
T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
T.P.Max := T.P.Last_Val;
Reallocate (T);
end Release; end Release;
-------------- --------------
...@@ -246,59 +296,17 @@ package body GNAT.Dynamic_Tables is ...@@ -246,59 +296,17 @@ package body GNAT.Dynamic_Tables is
procedure Set_Item procedure Set_Item
(T : in out Instance; (T : in out Instance;
Index : Table_Index_Type; Index : Valid_Table_Index_Type;
Item : Table_Component_Type) Item : Table_Component_Type)
is is
-- If Item is a value within the current allocation, and we are going to Item_Copy : constant Table_Component_Type := Item;
-- reallocate, then we must preserve an intermediate copy here before
-- calling Increment_Last. Otherwise, if Table_Component_Type is passed
-- by reference, we are going to end up copying from storage that might
-- have been deallocated from Increment_Last calling Reallocate.
subtype Allocated_Table_T is
Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1));
-- A constrained table subtype one element larger than the currently
-- allocated table.
Allocated_Table_Address : constant System.Address :=
T.Table.all'Address;
-- Used for address clause below (we can't use non-static expression
-- Table.all'Address directly in the clause because some older versions
-- of the compiler do not allow it).
Allocated_Table : Allocated_Table_T;
pragma Import (Ada, Allocated_Table);
pragma Suppress (Range_Check, On => Allocated_Table);
for Allocated_Table'Address use Allocated_Table_Address;
-- Allocated_Table represents the currently allocated array, plus one
-- element (the supplementary element is used to have a convenient way
-- to the address just past the end of the current allocation). Range
-- checks are suppressed because this unit uses direct calls to
-- System.Memory for allocation, and this can yield misaligned storage
-- (and we cannot rely on the bootstrap compiler supporting specifically
-- disabling alignment checks, so we need to suppress all range checks).
-- It is safe to suppress this check here because we know that a
-- (possibly misaligned) object of that type does actually exist at that
-- address.
-- ??? We should really improve the allocation circuitry here to
-- guarantee proper alignment.
Need_Realloc : constant Boolean := Integer (Index) > T.P.Max;
-- True if this operation requires storage reallocation (which may
-- involve moving table contents around).
begin begin
-- If we're going to reallocate, check whether Item references an -- If Set_Last is going to reallocate the table, we make a copy of Item,
-- element of the currently allocated table. -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is
-- passed by reference. Without the copy, we would deallocate the array
if Need_Realloc -- containing Item, leaving a dangling pointer.
and then Allocated_Table'Address <= Item'Address
and then Item'Address <
Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address
then
-- If so, save a copy on the stack because Increment_Last will
-- reallocate storage and might deallocate the current table.
if Index > T.P.Last_Allocated then
declare declare
Item_Copy : constant Table_Component_Type := Item; Item_Copy : constant Table_Component_Type := Item;
begin begin
...@@ -306,34 +314,28 @@ package body GNAT.Dynamic_Tables is ...@@ -306,34 +314,28 @@ package body GNAT.Dynamic_Tables is
T.Table (Index) := Item_Copy; T.Table (Index) := Item_Copy;
end; end;
else return;
-- Here we know that either we won't reallocate (case of Index < Max) end if;
-- or that Item is not in the currently allocated table.
if Integer (Index) > T.P.Last_Val then if Index > T.P.Last then
Set_Last (T, Index); Set_Last (T, Index);
end if; end if;
T.Table (Index) := Item; T.Table (Index) := Item_Copy;
end if;
end Set_Item; end Set_Item;
-------------- --------------
-- Set_Last -- -- Set_Last --
-------------- --------------
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type) is
pragma Assert (not T.Locked);
begin begin
if Integer (New_Val) < T.P.Last_Val then if New_Val > T.P.Last_Allocated then
T.P.Last_Val := Integer (New_Val); Grow (T, New_Val);
else
T.P.Last_Val := Integer (New_Val);
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
end if; end if;
T.P.Last := New_Val;
end Set_Last; end Set_Last;
---------------- ----------------
...@@ -341,13 +343,12 @@ package body GNAT.Dynamic_Tables is ...@@ -341,13 +343,12 @@ package body GNAT.Dynamic_Tables is
---------------- ----------------
procedure Sort_Table (Table : in out Instance) is procedure Sort_Table (Table : in out Instance) is
Temp : Table_Component_Type; Temp : Table_Component_Type;
-- A temporary position to simulate index 0 -- A temporary position to simulate index 0
-- Local subprograms -- Local subprograms
function Index_Of (Idx : Natural) return Table_Index_Type; function Index_Of (Idx : Natural) return Table_Index_Type'Base;
-- Return index of Idx'th element of table -- Return index of Idx'th element of table
function Lower_Than (Op1, Op2 : Natural) return Boolean; function Lower_Than (Op1, Op2 : Natural) return Boolean;
...@@ -362,11 +363,11 @@ package body GNAT.Dynamic_Tables is ...@@ -362,11 +363,11 @@ package body GNAT.Dynamic_Tables is
-- Index_Of -- -- Index_Of --
-------------- --------------
function Index_Of (Idx : Natural) return Table_Index_Type is function Index_Of (Idx : Natural) return Table_Index_Type'Base is
J : constant Integer'Base := J : constant Integer'Base :=
Table_Index_Type'Pos (First) + Idx - 1; Table_Index_Type'Base'Pos (First) + Idx - 1;
begin begin
return Table_Index_Type'Val (J); return Table_Index_Type'Base'Val (J);
end Index_Of; end Index_Of;
---------- ----------
...@@ -401,8 +402,7 @@ package body GNAT.Dynamic_Tables is ...@@ -401,8 +402,7 @@ package body GNAT.Dynamic_Tables is
else else
return return
Lt (Table.Table (Index_Of (Op1)), Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2)));
Table.Table (Index_Of (Op2)));
end if; end if;
end Lower_Than; end Lower_Than;
......
gcc/ada/g-dyntab.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2000-2015, AdaCore -- -- Copyright (C) 2000-2016, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -41,40 +41,49 @@ ...@@ -41,40 +41,49 @@
-- instances of the table, while an instantiation of GNAT.Table creates a -- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type. -- single instance of the table type.
-- Note that this interface should remain synchronized with those in -- Note that these three interfaces should remain synchronized to keep as much
-- GNAT.Table and the GNAT compiler source unit Table to keep as much -- coherency as possible among these three related units:
-- coherency as possible between these three related units. --
-- GNAT.Dynamic_Tables
-- GNAT.Table
-- Table (the compiler unit)
pragma Compiler_Unit_Warning; pragma Compiler_Unit_Warning;
with Ada.Unchecked_Conversion;
generic generic
type Table_Component_Type is private; type Table_Component_Type is private;
type Table_Index_Type is range <>; type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type; Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive; Table_Initial : Positive := 8;
Table_Increment : Natural; Table_Increment : Natural := 100;
package GNAT.Dynamic_Tables is package GNAT.Dynamic_Tables is
-- Table_Component_Type and Table_Index_Type specify the type of the -- Table_Component_Type and Table_Index_Type specify the type of the array,
-- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an -- Table_Low_Bound is the lower bound. The effect is roughly to declare:
-- integer type. The effect is roughly to declare:
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
-- Note: since the upper bound can be one less than the lower -- The lower bound of Table_Index_Type is ignored.
-- bound for an empty array, the table index type must be able
-- to cover this range, e.g. if the lower bound is 1, then the pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First);
-- Table_Index_Type should be Natural rather than Positive.
function First return Table_Index_Type;
pragma Inline (First);
-- Export First as synonym for Table_Low_Bound (parallel with use of Last)
-- Table_Component_Type may be any Ada type, except that controlled subtype Valid_Table_Index_Type is Table_Index_Type'Base
-- types are not supported. Note however that default initialization range Table_Low_Bound .. Table_Index_Type'Base'Last;
-- will NOT occur for array components. subtype Table_Count_Type is Table_Index_Type'Base
range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last;
-- The Table_Initial values controls the allocation of the table when -- Table_Component_Type must not be a type with controlled parts.
-- it is first allocated, either by default, or by an explicit Init
-- call. -- The Table_Initial value controls the allocation of the table when
-- it is first allocated.
-- The Table_Increment value controls the amount of increase, if the -- The Table_Increment value controls the amount of increase, if the
-- table has to be increased in size. The value given is a percentage -- table has to be increased in size. The value given is a percentage
...@@ -90,97 +99,114 @@ package GNAT.Dynamic_Tables is ...@@ -90,97 +99,114 @@ package GNAT.Dynamic_Tables is
-- to take the access of a table element, use Unrestricted_Access. -- to take the access of a table element, use Unrestricted_Access.
type Table_Type is type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type; array (Valid_Table_Index_Type range <>) of Table_Component_Type;
subtype Big_Table_Type is subtype Big_Table_Type is
Table_Type (Table_Low_Bound .. Table_Index_Type'Last); Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained with -- We work with pointers to a bogus array type that is constrained with
-- the maximum possible range bound. This means that the pointer is a thin -- the maximum possible range bound. This means that the pointer is a thin
-- pointer, which is more efficient. Since subscript checks in any case -- pointer, which is more efficient. Since subscript checks in any case
-- must be on the logical, rather than physical bounds, safety is not -- must be on the logical, rather than physical bounds, safety is not
-- compromised by this approach. These types should not be used by the -- compromised by this approach.
-- client.
-- To get subscript checking, rename a slice of the Table, like this:
-- Table : Table_Type renames T.Table (First .. Last (T));
-- and the refer to components of Table.
type Table_Ptr is access all Big_Table_Type; type Table_Ptr is access all Big_Table_Type;
for Table_Ptr'Storage_Size use 0; for Table_Ptr'Storage_Size use 0;
-- The table is actually represented as a pointer to allow reallocation. -- The table is actually represented as a pointer to allow reallocation
-- This type should not be used by the client.
type Table_Private is private; type Table_Private is private;
-- Table private data that is not exported in Instance -- Table private data that is not exported in Instance
-- Private use only:
subtype Empty_Table_Array_Type is
Table_Type (Table_Low_Bound .. Table_Low_Bound - 1);
type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type;
Empty_Table_Array : aliased Empty_Table_Array_Type;
function Empty_Table_Array_Ptr_To_Table_Ptr is
new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr);
-- End private use only. The above are used to initialize Table to point to
-- an empty array.
type Instance is record type Instance is record
Table : aliased Table_Ptr := null; Table : aliased Table_Ptr :=
-- The table itself. The lower bound is the value of Low_Bound. Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-- Logically the upper bound is the current value of Last (although -- The table itself. The lower bound is the value of First. Logically
-- the actual size of the allocated table may be larger than this). -- the upper bound is the current value of Last (although the actual
-- The program may only access and modify Table entries in the -- size of the allocated table may be larger than this). The program may
-- range First .. Last. -- only access and modify Table entries in the range First .. Last.
--
-- It's a good idea to access this via a renaming of a slice, in order
-- to ensure bounds checking, as in:
--
-- Tab : Table_Type renames X.Table (First .. X.Last);
Locked : Boolean := False;
-- Table expansion is permitted only if this switch is set to False. A
-- client may set Locked to True, in which case any attempt to expand
-- the table will cause an assertion failure. Note that while a table
-- is locked, its address in memory remains fixed and unchanging.
P : Table_Private; P : Table_Private;
end record; end record;
procedure Init (T : in out Instance); procedure Init (T : in out Instance);
-- This procedure allocates a new table of size Initial (freeing any -- Reinitializes the table to empty. There is no need to call this before
-- previously allocated larger table). Init must be called before using -- using a table; tables default to empty.
-- the table. Init is convenient in reestablishing a table for new use.
function Last (T : Instance) return Table_Index_Type; function Last (T : Instance) return Table_Count_Type;
pragma Inline (Last); pragma Inline (Last);
-- Returns the current value of the last used entry in the table, -- Returns the current value of the last used entry in the table, which can
-- which can then be used as a subscript for Table. Note that the -- then be used as a subscript for Table.
-- only way to modify Last is to call the Set_Last procedure. Last
-- must always be used to determine the logically last entry.
procedure Release (T : in out Instance); procedure Release (T : in out Instance);
-- Storage is allocated in chunks according to the values given in the -- Storage is allocated in chunks according to the values given in the
-- Initial and Increment parameters. A call to Release releases all -- Table_Initial and Table_Increment parameters. A call to Release releases
-- storage that is allocated, but is not logically part of the current -- all storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call. -- array value. Current array values are not affected by this call.
procedure Free (T : in out Instance); procedure Free (T : in out Instance);
-- Free all allocated memory for the table. A call to init is required -- Same as Init
-- before any use of this table after calling Free.
First : constant Table_Index_Type := Table_Low_Bound; procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type);
-- Export First as synonym for Low_Bound (parallel with use of Last)
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type);
pragma Inline (Set_Last); pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the -- This procedure sets Last to the indicated value. If necessary the table
-- table is reallocated to accommodate the new value (i.e. on return -- is reallocated to accommodate the new value (i.e. on return the
-- the allocated table has an upper bound of at least Last). If -- allocated table has an upper bound of at least Last). If Set_Last
-- Set_Last reduces the size of the table, then logically entries are -- reduces the size of the table, then logically entries are removed from
-- removed from the table. If Set_Last increases the size of the -- the table. If Set_Last increases the size of the table, then new entries
-- table, then new entries are logically added to the table. -- are logically added to the table.
procedure Increment_Last (T : in out Instance); procedure Increment_Last (T : in out Instance);
pragma Inline (Increment_Last); pragma Inline (Increment_Last);
-- Adds 1 to Last (same as Set_Last (Last + 1) -- Adds 1 to Last (same as Set_Last (Last + 1))
procedure Decrement_Last (T : in out Instance); procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last); pragma Inline (Decrement_Last);
-- Subtracts 1 from Last (same as Set_Last (Last - 1) -- Subtracts 1 from Last (same as Set_Last (Last - 1))
procedure Append (T : in out Instance; New_Val : Table_Component_Type); procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append); pragma Inline (Append);
-- Appends New_Val onto the end of the table
-- Equivalent to: -- Equivalent to:
-- Increment_Last (T); -- Increment_Last (T);
-- T.Table (T.Last) := New_Val; -- T.Table (T.Last) := New_Val;
-- i.e. the table size is increased by one, and the given new item
-- stored in the newly created table element.
procedure Append_All (T : in out Instance; New_Vals : Table_Type); procedure Append_All (T : in out Instance; New_Vals : Table_Type);
-- Appends all components of New_Vals -- Appends all components of New_Vals
procedure Set_Item procedure Set_Item
(T : in out Instance; (T : in out Instance;
Index : Table_Index_Type; Index : Valid_Table_Index_Type;
Item : Table_Component_Type); Item : Table_Component_Type);
pragma Inline (Set_Item); pragma Inline (Set_Item);
-- Put Item in the table at position Index. The table is expanded if -- Put Item in the table at position Index. If Index points to an existing
-- current table length is less than Index and in that case Last is set to -- item (i.e. it is in the range First .. Last (T)), the item is replaced.
-- Index. Item will replace any value already present in the table at this -- Otherwise (i.e. Index > Last (T), the table is expanded, and Last is set
-- position. -- to Index.
procedure Allocate (T : in out Instance; Num : Integer := 1); procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate); pragma Inline (Allocate);
...@@ -188,17 +214,17 @@ package GNAT.Dynamic_Tables is ...@@ -188,17 +214,17 @@ package GNAT.Dynamic_Tables is
generic generic
with procedure Action with procedure Action
(Index : Table_Index_Type; (Index : Valid_Table_Index_Type;
Item : Table_Component_Type; Item : Table_Component_Type;
Quit : in out Boolean) is <>; Quit : in out Boolean) is <>;
procedure For_Each (Table : Instance); procedure For_Each (Table : Instance);
-- Calls procedure Action for each component of the table Table, or until -- Calls procedure Action for each component of the table, or until one of
-- one of these calls set Quit to True. -- these calls set Quit to True.
generic generic
with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
procedure Sort_Table (Table : in out Instance); procedure Sort_Table (Table : in out Instance);
-- This procedure sorts the components of table Table into ascending -- This procedure sorts the components of the table into ascending
-- order making calls to Lt to do required comparisons, and using -- order making calls to Lt to do required comparisons, and using
-- assignments to move components around. The Lt function returns True -- assignments to move components around. The Lt function returns True
-- if Comp1 is less than Comp2 (in the sense of the desired sort), and -- if Comp1 is less than Comp2 (in the sense of the desired sort), and
...@@ -208,16 +234,16 @@ package GNAT.Dynamic_Tables is ...@@ -208,16 +234,16 @@ package GNAT.Dynamic_Tables is
-- in the table is not preserved). -- in the table is not preserved).
private private
type Table_Private is record type Table_Private is record
Max : Integer; Last_Allocated : Table_Count_Type := Table_Low_Bound - 1;
-- Subscript of the maximum entry in the currently allocated table -- Subscript of the maximum entry in the currently allocated table.
-- Initial value ensures that we initially allocate the table.
Length : Integer := 0; Last : Table_Count_Type := Table_Low_Bound - 1;
-- Number of entries in currently allocated table. The value of zero -- Current value of Last function
-- ensures that we initially allocate the table.
Last_Val : Integer; -- Invariant: Last <= Last_Allocated
-- Current value of Last
end record; end record;
end GNAT.Dynamic_Tables; end GNAT.Dynamic_Tables;
gcc/ada/sem_attr.adb
...@@ -68,6 +68,7 @@ with Stand; use Stand; ...@@ -68,6 +68,7 @@ with Stand; use Stand;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with System; with System;
with System.CRC32; use System.CRC32;
with Stringt; use Stringt; with Stringt; use Stringt;
with Style; with Style;
with Stylesw; use Stylesw; with Stylesw; use Stylesw;
...@@ -6139,37 +6140,142 @@ package body Sem_Attr is ...@@ -6139,37 +6140,142 @@ package body Sem_Attr is
Check_E0; Check_E0;
Check_Type; Check_Type;
-- This processing belongs in Eval_Attribute ???
declare declare
function Type_Key return String_Id; Full_Name : constant String_Id :=
-- A very preliminary implementation. For now, a signature Fully_Qualified_Name_String (Entity (P));
-- consists of only the type name. This is clearly incomplete
-- (e.g., adding a new field to a record type should change the Deref : Boolean;
-- type's Type_Key attribute). -- To simplify the handling of mutually recursive types, follow
-- a single dereference link in a composite type.
CRC : CRC32;
-- The computed signature for the type.
procedure Compute_Type_Key (T : Entity_Id);
-- Create a CRC integer from the declaration of the type, For
-- a composite type, fold in the representation of its components
-- in recursive fashion. We use directly the source representation
-- of the types involved.
-------------- --------------
-- Type_Key -- -- Type_Key --
-------------- --------------
function Type_Key return String_Id is procedure Compute_Type_Key (T : Entity_Id) is
Full_Name : constant String_Id := SFI : Source_File_Index;
Fully_Qualified_Name_String (Entity (P)); Buffer : Source_Buffer_Ptr;
P_Min, P_Max : Source_Ptr;
Rep : Node_Id;
procedure Process_One_Declaration;
-- Update CRC with the characters of one type declaration,
-- or a representation pragma that applies to the type.
-----------------------------
-- Process_One_Declaration --
-----------------------------
procedure Process_One_Declaration is
Ptr : Source_Ptr;
begin begin
-- Copy all characters in Full_Name but the trailing NUL Ptr := P_Min;
-- Scan type declaration, skipping blanks,
while Ptr <= P_Max loop
if Buffer (Ptr) /= ' ' then
System.CRC32.Update (CRC, Buffer (Ptr));
end if;
Ptr := Ptr + 1;
end loop;
end Process_One_Declaration;
begin -- Start of processing for Compute_Type_Key
if Is_Itype (T) then
return;
end if;
Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
SFI := Get_Source_File_Index (P_Min);
Buffer := Source_Text (SFI);
Process_One_Declaration;
-- Recurse on relevant component types.
if Is_Array_Type (T) then
Compute_Type_Key (Component_Type (T));
elsif Is_Access_Type (T) then
if not Deref then
Deref := True;
Compute_Type_Key (Designated_Type (T));
end if;
elsif Is_Derived_Type (T) then
Compute_Type_Key (Etype (T));
elsif Is_Record_Type (T) then
declare
Comp : Entity_Id;
begin
Comp := First_Component (T);
while Present (Comp) loop
Compute_Type_Key (Etype (Comp));
Next_Component (Comp);
end loop;
end;
end if;
-- Fold in representation aspects for the type, which
-- appear in the same source buffer.
Rep := First_Rep_Item (T);
while Present (Rep) loop
if Comes_From_Source (Rep) then
Sloc_Range (Rep, P_Min, P_Max);
Process_One_Declaration;
end if;
Rep := Next_Rep_Item (Rep);
end loop;
end Compute_Type_Key;
begin
Start_String; Start_String;
Deref := False;
-- Copy all characters in Full_Name but the trailing NUL
for J in 1 .. String_Length (Full_Name) - 1 loop for J in 1 .. String_Length (Full_Name) - 1 loop
Store_String_Char (Get_String_Char (Full_Name, Pos (J))); Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
end loop; end loop;
Store_String_Chars ("'Type_Key"); -- For standard type return the name of the type. as there is
return End_String; -- no explicit source declaration to use. Otherwise compute
end Type_Key; -- CRC and convert it to string one character at a time. so as
-- not to use Image within the compiler.
begin if Scope (Entity (P)) /= Standard_Standard then
Rewrite (N, Make_String_Literal (Loc, Type_Key)); Initialize (CRC);
Compute_Type_Key (Entity (P));
if not Is_Frozen (Entity (P)) then
Error_Msg_N ("premature usage of Type_Key?", N);
end if;
while CRC > 0 loop
Store_String_Char (Character'Val (48 + (CRC rem 10)));
CRC := CRC / 10;
end loop;
end if;
Rewrite (N, Make_String_Literal (Loc, End_String));
end; end;
Analyze_And_Resolve (N, Standard_String); Analyze_And_Resolve (N, Standard_String);
......
gcc/ada/sem_case.adb
...@@ -114,10 +114,12 @@ package body Sem_Case is ...@@ -114,10 +114,12 @@ package body Sem_Case is
Others_Present : Boolean; Others_Present : Boolean;
Case_Node : Node_Id) Case_Node : Node_Id)
is is
Predicate_Error : Boolean; Predicate_Error : Boolean := False;
-- Flag to prevent cascaded errors when a static predicate is known to -- Flag to prevent cascaded errors when a static predicate is known to
-- be violated by one choice. -- be violated by one choice.
Num_Choices : constant Nat := Choice_Table'Last;
procedure Check_Against_Predicate procedure Check_Against_Predicate
(Pred : in out Node_Id; (Pred : in out Node_Id;
Choice : Choice_Bounds; Choice : Choice_Bounds;
...@@ -130,6 +132,10 @@ package body Sem_Case is ...@@ -130,6 +132,10 @@ package body Sem_Case is
-- choice that covered a predicate set. Error denotes whether the check -- choice that covered a predicate set. Error denotes whether the check
-- found an illegal intersection. -- found an illegal intersection.
procedure Check_Duplicates;
-- Check for duplicate choices, and call Dup_Choice is there are any
-- such errors. Note that predicates are irrelevant here.
procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id); procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
-- Post message "duplication of choice value(s) bla bla at xx". Message -- Post message "duplication of choice value(s) bla bla at xx". Message
-- is posted at location C. Caller sets Error_Msg_Sloc for xx. -- is posted at location C. Caller sets Error_Msg_Sloc for xx.
...@@ -236,8 +242,7 @@ package body Sem_Case is ...@@ -236,8 +242,7 @@ package body Sem_Case is
Val : Uint) return Boolean Val : Uint) return Boolean
is is
begin begin
return return Lo <= Val and then Val <= Hi;
Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
end Inside_Range; end Inside_Range;
-- Local variables -- Local variables
...@@ -276,14 +281,12 @@ package body Sem_Case is ...@@ -276,14 +281,12 @@ package body Sem_Case is
return; return;
end if; end if;
-- Step 1: Detect duplicate choices -- Step 1: Ignore duplicate choices, other than to set the flag,
-- because these were already detected by Check_Duplicates.
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
Error := True;
elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN); or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
then
Error := True; Error := True;
-- Step 2: Detect full coverage -- Step 2: Detect full coverage
...@@ -447,6 +450,59 @@ package body Sem_Case is ...@@ -447,6 +450,59 @@ package body Sem_Case is
end if; end if;
end Check_Against_Predicate; end Check_Against_Predicate;
----------------------
-- Check_Duplicates --
----------------------
procedure Check_Duplicates is
Prev_Hi : Uint := Expr_Value (Choice_Table (1).Hi);
begin
for Outer_Index in 2 .. Num_Choices loop
declare
Choice_Lo : constant Uint :=
Expr_Value (Choice_Table (Outer_Index).Lo);
Choice_Hi : constant Uint :=
Expr_Value (Choice_Table (Outer_Index).Hi);
begin
if Choice_Lo <= Prev_Hi then
-- Choices overlap; this is an error
declare
Choice : constant Node_Id :=
Choice_Table (Outer_Index).Node;
Prev_Choice : Node_Id;
begin
-- Find first previous choice that overlaps
for Inner_Index in 1 .. Outer_Index - 1 loop
if Choice_Lo <=
Expr_Value (Choice_Table (Inner_Index).Hi)
then
Prev_Choice := Choice_Table (Inner_Index).Node;
exit;
end if;
end loop;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi),
Prev_Choice);
end if;
end;
end if;
if Choice_Hi > Prev_Hi then
Prev_Hi := Choice_Hi;
end if;
end;
end loop;
end Check_Duplicates;
---------------- ----------------
-- Dup_Choice -- -- Dup_Choice --
---------------- ----------------
...@@ -709,17 +765,13 @@ package body Sem_Case is ...@@ -709,17 +765,13 @@ package body Sem_Case is
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Num_Choices : constant Nat := Choice_Table'Last;
Has_Predicate : constant Boolean := Has_Predicate : constant Boolean :=
Is_OK_Static_Subtype (Bounds_Type) Is_OK_Static_Subtype (Bounds_Type)
and then Has_Static_Predicate (Bounds_Type); and then Has_Static_Predicate (Bounds_Type);
Choice : Node_Id;
Choice_Hi : Uint; Choice_Hi : Uint;
Choice_Lo : Uint; Choice_Lo : Uint;
Error : Boolean;
Pred : Node_Id; Pred : Node_Id;
Prev_Choice : Node_Id;
Prev_Lo : Uint; Prev_Lo : Uint;
Prev_Hi : Uint; Prev_Hi : Uint;
...@@ -735,8 +787,6 @@ package body Sem_Case is ...@@ -735,8 +787,6 @@ package body Sem_Case is
return; return;
end if; end if;
Predicate_Error := False;
-- Choice_Table must start at 0 which is an unused location used by the -- Choice_Table must start at 0 which is an unused location used by the
-- sorting algorithm. However the first valid position for a discrete -- sorting algorithm. However the first valid position for a discrete
-- choice is 1. -- choice is 1.
...@@ -756,9 +806,15 @@ package body Sem_Case is ...@@ -756,9 +806,15 @@ package body Sem_Case is
Sorting.Sort (Positive (Choice_Table'Last)); Sorting.Sort (Positive (Choice_Table'Last));
-- The type covered by the list of choices is actually a static subtype -- First check for duplicates. This involved the choices; predicates, if
-- subject to a static predicate. The predicate defines subsets of legal -- any, are irrelevant.
-- values and requires finer grained analysis.
Check_Duplicates;
-- Then check for overlaps
-- If the subtype has a static predicate, the predicate defines subsets
-- of legal values and requires finer grained analysis.
-- Note that in GNAT the predicate is considered static if the predicate -- Note that in GNAT the predicate is considered static if the predicate
-- expression is static, independently of whether the aspect mentions -- expression is static, independently of whether the aspect mentions
...@@ -774,8 +830,9 @@ package body Sem_Case is ...@@ -774,8 +830,9 @@ package body Sem_Case is
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1; Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
Prev_Hi := Prev_Lo; Prev_Hi := Prev_Lo;
Error := False; declare
Error : Boolean := False;
begin
for Index in 1 .. Num_Choices loop for Index in 1 .. Num_Choices loop
Check_Against_Predicate Check_Against_Predicate
(Pred => Pred, (Pred => Pred,
...@@ -784,9 +841,9 @@ package body Sem_Case is ...@@ -784,9 +841,9 @@ package body Sem_Case is
Prev_Hi => Prev_Hi, Prev_Hi => Prev_Hi,
Error => Error); Error => Error);
-- The analysis detected an illegal intersection between a choice -- The analysis detected an illegal intersection between a
-- and a static predicate set. Do not examine other choices unless -- choice and a static predicate set. Do not examine other
-- all errors are requested. -- choices unless all errors are requested.
if Error then if Error then
Predicate_Error := True; Predicate_Error := True;
...@@ -796,6 +853,7 @@ package body Sem_Case is ...@@ -796,6 +853,7 @@ package body Sem_Case is
end if; end if;
end if; end if;
end loop; end loop;
end;
if Predicate_Error then if Predicate_Error then
return; return;
...@@ -826,35 +884,11 @@ package body Sem_Case is ...@@ -826,35 +884,11 @@ package body Sem_Case is
end if; end if;
end if; end if;
for Outer_Index in 2 .. Num_Choices loop for Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo); Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi); Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
if Choice_Lo <= Prev_Hi then
Choice := Choice_Table (Outer_Index).Node;
-- Find first previous choice that overlaps
for Inner_Index in 1 .. Outer_Index - 1 loop
if Choice_Lo <=
Expr_Value (Choice_Table (Inner_Index).Hi)
then
Prev_Choice := Choice_Table (Inner_Index).Node;
exit;
end if;
end loop;
if Sloc (Prev_Choice) <= Sloc (Choice) then
Error_Msg_Sloc := Sloc (Prev_Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
else
Error_Msg_Sloc := Sloc (Choice);
Dup_Choice
(Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
end if;
elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
end if; end if;
......
gcc/ada/xref_lib.adb
...@@ -401,8 +401,9 @@ package body Xref_Lib is ...@@ -401,8 +401,9 @@ package body Xref_Lib is
(File : ALI_File; (File : ALI_File;
Num : Positive) return File_Reference Num : Positive) return File_Reference
is is
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin begin
return File.Dep.Table (Num); return Table (Num);
end File_Name; end File_Name;
-------------------- --------------------
...@@ -642,10 +643,15 @@ package body Xref_Lib is ...@@ -642,10 +643,15 @@ package body Xref_Lib is
Token := Gnatchop_Name + 1; Token := Gnatchop_Name + 1;
end if; end if;
File.Dep.Table (Num_Dependencies) := Add_To_Xref_File declare
Table : Table_Type renames
File.Dep.Table (1 .. Last (File.Dep));
begin
Table (Num_Dependencies) := Add_To_Xref_File
(Ali (File_Start .. File_End), (Ali (File_Start .. File_End),
Gnatchop_File => Ali (Token .. Ptr - 1), Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset); Gnatchop_Offset => Gnatchop_Offset);
end;
elsif W_Lines and then Ali (Ptr) = 'W' then elsif W_Lines and then Ali (Ptr) = 'W' then
...@@ -854,6 +860,8 @@ package body Xref_Lib is ...@@ -854,6 +860,8 @@ package body Xref_Lib is
Ptr := Ptr + 1; Ptr := Ptr + 1;
end Skip_To_Matching_Closing_Bracket; end Skip_To_Matching_Closing_Bracket;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
-- Start of processing for Parse_Identifier_Info -- Start of processing for Parse_Identifier_Info
begin begin
...@@ -976,9 +984,9 @@ package body Xref_Lib is ...@@ -976,9 +984,9 @@ package body Xref_Lib is
-- We don't have a unit number specified, so we set P_Eun to -- We don't have a unit number specified, so we set P_Eun to
-- the current unit. -- the current unit.
for K in Dependencies_Tables.First .. Last (File.Dep) loop for K in Table'Range loop
P_Eun := K; P_Eun := K;
exit when File.Dep.Table (K) = File_Ref; exit when Table (K) = File_Ref;
end loop; end loop;
end if; end if;
...@@ -1011,7 +1019,7 @@ package body Xref_Lib is ...@@ -1011,7 +1019,7 @@ package body Xref_Lib is
Symbol, Symbol,
P_Line, P_Line,
P_Column, P_Column,
File.Dep.Table (P_Eun)); Table (P_Eun));
end if; end if;
end; end;
end if; end if;
...@@ -1029,7 +1037,7 @@ package body Xref_Lib is ...@@ -1029,7 +1037,7 @@ package body Xref_Lib is
Add_Entity Add_Entity
(Pattern, (Pattern,
Get_Symbol_Name (P_Eun, P_Line, P_Column) Get_Symbol_Name (P_Eun, P_Line, P_Column)
& ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun)) & ':' & Get_Gnatchop_File (Table (P_Eun))
& ':' & Get_Line (Get_Parent (Decl_Ref)) & ':' & Get_Line (Get_Parent (Decl_Ref))
& ':' & Get_Column (Get_Parent (Decl_Ref)), & ':' & Get_Column (Get_Parent (Decl_Ref)),
False); False);
...@@ -1080,11 +1088,10 @@ package body Xref_Lib is ...@@ -1080,11 +1088,10 @@ package body Xref_Lib is
if Wide_Search then if Wide_Search then
declare declare
File_Ref : File_Reference;
pragma Unreferenced (File_Ref);
File_Name : constant String := Get_Gnatchop_File (File.X_File); File_Name : constant String := Get_Gnatchop_File (File.X_File);
Ignored : File_Reference;
begin begin
File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False); Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end; end;
end if; end if;
...@@ -1252,6 +1259,8 @@ package body Xref_Lib is ...@@ -1252,6 +1259,8 @@ package body Xref_Lib is
Ptr : Positive renames File.Current_Line; Ptr : Positive renames File.Current_Line;
File_Nr : Natural; File_Nr : Natural;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin begin
while Ali (Ptr) = 'X' loop while Ali (Ptr) = 'X' loop
...@@ -1267,8 +1276,8 @@ package body Xref_Lib is ...@@ -1267,8 +1276,8 @@ package body Xref_Lib is
-- If the referenced file is unknown, we simply ignore it -- If the referenced file is unknown, we simply ignore it
if File_Nr in Dependencies_Tables.First .. Last (File.Dep) then if File_Nr in Table'Range then
File.X_File := File.Dep.Table (File_Nr); File.X_File := Table (File_Nr);
else else
File.X_File := Empty_File; File.X_File := Empty_File;
end if; end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment