git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2016-10-12 14:55:47 +02:00
parent 6e8323274a
commit 84a62ce88b
6 changed files with 563 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
gcc/ada/ChangeLog
View File

@ -1,3 +1,29 @@
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>
* init.c: Make sure to call finit on x86_64-vx7 to reinitialize

378
gcc/ada/g-dyntab.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -32,33 +32,23 @@
pragma Compiler_Unit_Warning;
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
Min : constant Integer := Integer (Table_Low_Bound);
-- Subscript of the minimum entry in the currently allocated table
Empty : constant Table_Ptr :=
Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-----------------------
-- Local Subprograms --
-----------------------
procedure Reallocate (T : in out Instance);
-- Reallocate the existing table according to the current value stored
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
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);
procedure Grow (T : in out Instance; New_Last : Table_Count_Type);
-- This is called when we are about to set the value of Last to a value
-- that is larger than Last_Allocated. This reallocates the table to the
-- larger size, as indicated by New_Last. At the time this is called,
-- T.P.Last is still the old value.
--------------
-- Allocate --
@ -66,11 +56,9 @@ package body GNAT.Dynamic_Tables is
procedure Allocate (T : in out Instance; Num : Integer := 1) is
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
Reallocate (T);
end if;
Set_Last (T, T.P.Last + Table_Index_Type'Base (Num));
end Allocate;
------------
@ -79,7 +67,7 @@ package body GNAT.Dynamic_Tables is
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
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;
----------------
@ -99,9 +87,18 @@ package body GNAT.Dynamic_Tables is
procedure Decrement_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val - 1;
Allocate (T, -1);
end Decrement_Last;
-----------
-- First --
-----------
function First return Table_Index_Type is
begin
return Table_Low_Bound;
end First;
--------------
-- For_Each --
--------------
@ -109,7 +106,7 @@ package body GNAT.Dynamic_Tables is
procedure For_Each (Table : Instance) is
Quit : Boolean := False;
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);
exit when Quit;
end loop;
@ -120,23 +117,119 @@ package body GNAT.Dynamic_Tables 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
Free (To_Address (T.Table));
T.Table := null;
T.P.Length := 0;
if T.Table = Empty then
pragma Assert (T.P.Last_Allocated = First - 1);
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;
----------
-- 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 --
--------------------
procedure Increment_Last (T : in out Instance) is
begin
T.P.Last_Val := T.P.Last_Val + 1;
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
Allocate (T, 1);
end Increment_Last;
----------
@ -144,100 +237,57 @@ package body GNAT.Dynamic_Tables is
----------
procedure Init (T : in out Instance) is
Old_Length : constant Integer := T.P.Length;
begin
T.P.Last_Val := Min - 1;
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;
Free (T);
end Init;
----------
-- Last --
----------
function Last (T : Instance) return Table_Index_Type is
function Last (T : Instance) return Table_Count_Type is
begin
return Table_Index_Type (T.P.Last_Val);
return T.P.Last;
end Last;
----------------
-- Reallocate --
----------------
procedure Reallocate (T : in out Instance) is
New_Length : Integer;
New_Size : size_t;
begin
if T.P.Max < T.P.Last_Val then
-- Now increment table length until it is sufficiently large. Use
-- 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
T.P.Length := New_Length;
else
T.P.Length := T.P.Length + 10;
end if;
T.P.Max := Min + T.P.Length - 1;
end loop;
end if;
New_Size :=
size_t ((T.P.Max - Min + 1) *
(Table_Type'Component_Size / Storage_Unit));
if T.Table = null then
T.Table := To_Pointer (Alloc (New_Size));
elsif New_Size > 0 then
T.Table :=
To_Pointer (Realloc (Ptr => To_Address (T.Table),
Size => New_Size));
end if;
if T.P.Length /= 0 and then T.Table = null then
raise Storage_Error;
end if;
end Reallocate;
-------------
-- Release --
-------------
procedure Release (T : in out Instance) is
pragma Assert (not T.Locked);
Old_Last_Allocated : constant Table_Count_Type := 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);
if T.P.Last /= T.P.Last_Allocated then
pragma Assert (T.P.Last < T.P.Last_Allocated);
pragma Assert (T.Table /= Empty);
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 + T.P.Last - 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'(Old_Table.all);
begin
T.P.Last_Allocated := T.P.Last;
Free (Old_Table);
T.Table := To_Table_Ptr (New_Table);
end;
end if;
pragma Assert (T.P.Last = T.P.Last_Allocated);
end Release;
--------------
@ -245,60 +295,18 @@ package body GNAT.Dynamic_Tables is
--------------
procedure Set_Item
(T : in out Instance;
Index : Table_Index_Type;
Item : Table_Component_Type)
(T : in out Instance;
Index : Valid_Table_Index_Type;
Item : Table_Component_Type)
is
-- If Item is a value within the current allocation, and we are going to
-- 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).
Item_Copy : constant Table_Component_Type := Item;
begin
-- If we're going to reallocate, check whether Item references an
-- element of the currently allocated table.
if Need_Realloc
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 Set_Last is going to reallocate the table, we make a copy of Item,
-- 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
-- containing Item, leaving a dangling pointer.
if Index > T.P.Last_Allocated then
declare
Item_Copy : constant Table_Component_Type := Item;
begin
@ -306,34 +314,28 @@ package body GNAT.Dynamic_Tables is
T.Table (Index) := Item_Copy;
end;
else
-- Here we know that either we won't reallocate (case of Index < Max)
-- or that Item is not in the currently allocated table.
if Integer (Index) > T.P.Last_Val then
Set_Last (T, Index);
end if;
T.Table (Index) := Item;
return;
end if;
if Index > T.P.Last then
Set_Last (T, Index);
end if;
T.Table (Index) := Item_Copy;
end Set_Item;
--------------
-- 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
if Integer (New_Val) < T.P.Last_Val then
T.P.Last_Val := Integer (New_Val);
else
T.P.Last_Val := Integer (New_Val);
if T.P.Last_Val > T.P.Max then
Reallocate (T);
end if;
if New_Val > T.P.Last_Allocated then
Grow (T, New_Val);
end if;
T.P.Last := New_Val;
end Set_Last;
----------------
@ -341,13 +343,12 @@ package body GNAT.Dynamic_Tables is
----------------
procedure Sort_Table (Table : in out Instance) is
Temp : Table_Component_Type;
-- A temporary position to simulate index 0
-- 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
function Lower_Than (Op1, Op2 : Natural) return Boolean;
@ -362,11 +363,11 @@ package body GNAT.Dynamic_Tables is
-- 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 :=
Table_Index_Type'Pos (First) + Idx - 1;
Table_Index_Type'Base'Pos (First) + Idx - 1;
begin
return Table_Index_Type'Val (J);
return Table_Index_Type'Base'Val (J);
end Index_Of;
----------
@ -401,8 +402,7 @@ package body GNAT.Dynamic_Tables is
else
return
Lt (Table.Table (Index_Of (Op1)),
Table.Table (Index_Of (Op2)));
Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2)));
end if;
end Lower_Than;

172
gcc/ada/g-dyntab.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -41,40 +41,49 @@
-- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type.
-- Note that this interface should remain synchronized with those in
-- GNAT.Table and the GNAT compiler source unit Table to keep as much
-- coherency as possible between these three related units.
-- Note that these three interfaces should remain synchronized to keep as much
-- coherency as possible among these three related units:
--
-- GNAT.Dynamic_Tables
-- GNAT.Table
-- Table (the compiler unit)
pragma Compiler_Unit_Warning;
with Ada.Unchecked_Conversion;
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
Table_Initial : Positive;
Table_Increment : Natural;
Table_Initial : Positive := 8;
Table_Increment : Natural := 100;
package GNAT.Dynamic_Tables is
-- Table_Component_Type and Table_Index_Type specify the type of the
-- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an
-- integer type. The effect is roughly to declare:
-- Table_Component_Type and Table_Index_Type specify the type of the array,
-- Table_Low_Bound is the lower bound. The effect is roughly to declare:
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
-- Note: since the upper bound can be one less than the lower
-- 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
-- Table_Index_Type should be Natural rather than Positive.
-- The lower bound of Table_Index_Type is ignored.
-- Table_Component_Type may be any Ada type, except that controlled
-- types are not supported. Note however that default initialization
-- will NOT occur for array components.
pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First);
-- The Table_Initial values controls the allocation of the table when
-- it is first allocated, either by default, or by an explicit Init
-- call.
function First return Table_Index_Type;
pragma Inline (First);
-- Export First as synonym for Table_Low_Bound (parallel with use of Last)
subtype Valid_Table_Index_Type is Table_Index_Type'Base
range Table_Low_Bound .. Table_Index_Type'Base'Last;
subtype Table_Count_Type is Table_Index_Type'Base
range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last;
-- Table_Component_Type must not be a type with controlled parts.
-- 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
-- table has to be increased in size. The value given is a percentage
@ -90,97 +99,114 @@ package GNAT.Dynamic_Tables is
-- to take the access of a table element, use Unrestricted_Access.
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
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
-- the maximum possible range bound. This means that the pointer is a thin
-- pointer, which is more efficient. Since subscript checks in any case
-- must be on the logical, rather than physical bounds, safety is not
-- compromised by this approach. These types should not be used by the
-- client.
-- compromised by this approach.
-- 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;
for Table_Ptr'Storage_Size use 0;
-- The table is actually represented as a pointer to allow reallocation.
-- This type should not be used by the client.
-- The table is actually represented as a pointer to allow reallocation
type Table_Private is private;
-- 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
Table : aliased Table_Ptr := null;
-- The table itself. The lower bound is the value of Low_Bound.
-- Logically the upper bound is the current value of Last (although
-- the actual size of the allocated table may be larger than this).
-- The program may only access and modify Table entries in the
-- range First .. Last.
Table : aliased Table_Ptr :=
Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-- The table itself. The lower bound is the value of First. Logically
-- the upper bound is the current value of Last (although the actual
-- size of the allocated table may be larger than this). The program may
-- 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;
end record;
procedure Init (T : in out Instance);
-- This procedure allocates a new table of size Initial (freeing any
-- previously allocated larger table). Init must be called before using
-- the table. Init is convenient in reestablishing a table for new use.
-- Reinitializes the table to empty. There is no need to call this before
-- using a table; tables default to empty.
function Last (T : Instance) return Table_Index_Type;
function Last (T : Instance) return Table_Count_Type;
pragma Inline (Last);
-- Returns the current value of the last used entry in the table,
-- which can then be used as a subscript for Table. Note that the
-- only way to modify Last is to call the Set_Last procedure. Last
-- must always be used to determine the logically last entry.
-- Returns the current value of the last used entry in the table, which can
-- then be used as a subscript for Table.
procedure Release (T : in out Instance);
-- Storage is allocated in chunks according to the values given in the
-- Initial and Increment parameters. A call to Release releases all
-- storage that is allocated, but is not logically part of the current
-- Table_Initial and Table_Increment parameters. A call to Release releases
-- all storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call.
procedure Free (T : in out Instance);
-- Free all allocated memory for the table. A call to init is required
-- before any use of this table after calling Free.
-- Same as Init
First : constant Table_Index_Type := Table_Low_Bound;
-- Export First as synonym for Low_Bound (parallel with use of Last)
procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type);
procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type);
pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the
-- table is reallocated to accommodate the new value (i.e. on return
-- the allocated table has an upper bound of at least Last). If
-- Set_Last reduces the size of the table, then logically entries are
-- removed from the table. If Set_Last increases the size of the
-- table, then new entries are logically added to the table.
-- This procedure sets Last to the indicated value. If necessary the table
-- is reallocated to accommodate the new value (i.e. on return the
-- allocated table has an upper bound of at least Last). If Set_Last
-- reduces the size of the table, then logically entries are removed from
-- the table. If Set_Last increases the size of the table, then new entries
-- are logically added to the table.
procedure Increment_Last (T : in out Instance);
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);
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);
pragma Inline (Append);
-- Appends New_Val onto the end of the table
-- Equivalent to:
-- Increment_Last (T);
-- 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);
-- Appends all components of New_Vals
procedure Set_Item
(T : in out Instance;
Index : Table_Index_Type;
Index : Valid_Table_Index_Type;
Item : Table_Component_Type);
pragma Inline (Set_Item);
-- Put Item in the table at position Index. The table is expanded if
-- current table length is less than Index and in that case Last is set to
-- Index. Item will replace any value already present in the table at this
-- position.
-- Put Item in the table at position Index. If Index points to an existing
-- item (i.e. it is in the range First .. Last (T)), the item is replaced.
-- Otherwise (i.e. Index > Last (T), the table is expanded, and Last is set
-- to Index.
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
@ -188,17 +214,17 @@ package GNAT.Dynamic_Tables is
generic
with procedure Action
(Index : Table_Index_Type;
(Index : Valid_Table_Index_Type;
Item : Table_Component_Type;
Quit : in out Boolean) is <>;
procedure For_Each (Table : Instance);
-- Calls procedure Action for each component of the table Table, or until
-- one of these calls set Quit to True.
-- Calls procedure Action for each component of the table, or until one of
-- these calls set Quit to True.
generic
with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
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
-- assignments to move components around. The Lt function returns True
-- if Comp1 is less than Comp2 (in the sense of the desired sort), and
@ -208,16 +234,16 @@ package GNAT.Dynamic_Tables is
-- in the table is not preserved).
private
type Table_Private is record
Max : Integer;
-- Subscript of the maximum entry in the currently allocated table
Last_Allocated : Table_Count_Type := Table_Low_Bound - 1;
-- Subscript of the maximum entry in the currently allocated table.
-- Initial value ensures that we initially allocate the table.
Length : Integer := 0;
-- Number of entries in currently allocated table. The value of zero
-- ensures that we initially allocate the table.
Last : Table_Count_Type := Table_Low_Bound - 1;
-- Current value of Last function
Last_Val : Integer;
-- Current value of Last
-- Invariant: Last <= Last_Allocated
end record;
end GNAT.Dynamic_Tables;

146
gcc/ada/sem_attr.adb
View File

@ -68,6 +68,7 @@ with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with System;
with System.CRC32; use System.CRC32;
with Stringt; use Stringt;
with Style;
with Stylesw; use Stylesw;
@ -6139,37 +6140,142 @@ package body Sem_Attr is
Check_E0;
Check_Type;
-- This processing belongs in Eval_Attribute ???
declare
function Type_Key return String_Id;
-- A very preliminary implementation. For now, a signature
-- consists of only the type name. This is clearly incomplete
-- (e.g., adding a new field to a record type should change the
-- type's Type_Key attribute).
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (Entity (P));
Deref : Boolean;
-- 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 --
--------------
function Type_Key return String_Id is
Full_Name : constant String_Id :=
Fully_Qualified_Name_String (Entity (P));
procedure Compute_Type_Key (T : Entity_Id) is
SFI : Source_File_Index;
Buffer : Source_Buffer_Ptr;
P_Min, P_Max : Source_Ptr;
Rep : Node_Id;
begin
-- Copy all characters in Full_Name but the trailing NUL
procedure Process_One_Declaration;
-- Update CRC with the characters of one type declaration,
-- or a representation pragma that applies to the type.
Start_String;
for J in 1 .. String_Length (Full_Name) - 1 loop
Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
-----------------------------
-- Process_One_Declaration --
-----------------------------
procedure Process_One_Declaration is
Ptr : Source_Ptr;
begin
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;
Store_String_Chars ("'Type_Key");
return End_String;
end Type_Key;
end Compute_Type_Key;
begin
Rewrite (N, Make_String_Literal (Loc, Type_Key));
Start_String;
Deref := False;
-- Copy all characters in Full_Name but the trailing NUL
for J in 1 .. String_Length (Full_Name) - 1 loop
Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
end loop;
-- For standard type return the name of the type. as there is
-- no explicit source declaration to use. Otherwise compute
-- CRC and convert it to string one character at a time. so as
-- not to use Image within the compiler.
if Scope (Entity (P)) /= Standard_Standard then
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;
Analyze_And_Resolve (N, Standard_String);

166
gcc/ada/sem_case.adb
View File

@ -114,10 +114,12 @@ package body Sem_Case is
Others_Present : Boolean;
Case_Node : Node_Id)
is
Predicate_Error : Boolean;
Predicate_Error : Boolean := False;
-- Flag to prevent cascaded errors when a static predicate is known to
-- be violated by one choice.
Num_Choices : constant Nat := Choice_Table'Last;
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
@ -130,6 +132,10 @@ package body Sem_Case is
-- choice that covered a predicate set. Error denotes whether the check
-- 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);
-- Post message "duplication of choice value(s) bla bla at xx". Message
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
@ -236,8 +242,7 @@ package body Sem_Case is
Val : Uint) return Boolean
is
begin
return
Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
return Lo <= Val and then Val <= Hi;
end Inside_Range;
-- Local variables
@ -276,14 +281,12 @@ package body Sem_Case is
return;
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
Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
then
Error := True;
-- Step 2: Detect full coverage
@ -447,6 +450,59 @@ package body Sem_Case is
end if;
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 --
----------------
@ -709,17 +765,13 @@ package body Sem_Case is
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
Num_Choices : constant Nat := Choice_Table'Last;
Has_Predicate : constant Boolean :=
Is_OK_Static_Subtype (Bounds_Type)
and then Has_Static_Predicate (Bounds_Type);
Choice : Node_Id;
Choice_Hi : Uint;
Choice_Lo : Uint;
Error : Boolean;
Pred : Node_Id;
Prev_Choice : Node_Id;
Prev_Lo : Uint;
Prev_Hi : Uint;
@ -735,8 +787,6 @@ package body Sem_Case is
return;
end if;
Predicate_Error := False;
-- Choice_Table must start at 0 which is an unused location used by the
-- sorting algorithm. However the first valid position for a discrete
-- choice is 1.
@ -756,16 +806,22 @@ package body Sem_Case is
Sorting.Sort (Positive (Choice_Table'Last));
-- The type covered by the list of choices is actually a static subtype
-- subject to a static predicate. The predicate defines subsets of legal
-- values and requires finer grained analysis.
-- First check for duplicates. This involved the choices; predicates, if
-- any, are irrelevant.
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
-- expression is static, independently of whether the aspect mentions
-- Static explicitly.
if Has_Predicate then
Pred := First (Static_Discrete_Predicate (Bounds_Type));
Pred := First (Static_Discrete_Predicate (Bounds_Type));
-- Make initial value smaller than 'First of type, so that first
-- range comparison succeeds. This applies both to integer types
@ -774,28 +830,30 @@ package body Sem_Case is
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
Prev_Hi := Prev_Lo;
Error := False;
declare
Error : Boolean := False;
begin
for Index in 1 .. Num_Choices loop
Check_Against_Predicate
(Pred => Pred,
Choice => Choice_Table (Index),
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
for Index in 1 .. Num_Choices loop
Check_Against_Predicate
(Pred => Pred,
Choice => Choice_Table (Index),
Prev_Lo => Prev_Lo,
Prev_Hi => Prev_Hi,
Error => Error);
-- The analysis detected an illegal intersection between a
-- choice and a static predicate set. Do not examine other
-- choices unless all errors are requested.
-- The analysis detected an illegal intersection between a choice
-- and a static predicate set. Do not examine other choices unless
-- all errors are requested.
if Error then
Predicate_Error := True;
if Error then
Predicate_Error := True;
if not All_Errors_Mode then
return;
if not All_Errors_Mode then
return;
end if;
end if;
end if;
end loop;
end loop;
end;
if Predicate_Error then
return;
@ -826,35 +884,11 @@ package body Sem_Case is
end if;
end if;
for Outer_Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
for Index in 2 .. Num_Choices loop
Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
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);
end if;

37
gcc/ada/xref_lib.adb
View File

@ -401,8 +401,9 @@ package body Xref_Lib is
(File : ALI_File;
Num : Positive) return File_Reference
is
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin
return File.Dep.Table (Num);
return Table (Num);
end File_Name;
--------------------
@ -642,10 +643,15 @@ package body Xref_Lib is
Token := Gnatchop_Name + 1;
end if;
File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
(Ali (File_Start .. File_End),
Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset);
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),
Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset);
end;
elsif W_Lines and then Ali (Ptr) = 'W' then
@ -854,6 +860,8 @@ package body Xref_Lib is
Ptr := Ptr + 1;
end Skip_To_Matching_Closing_Bracket;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
-- Start of processing for Parse_Identifier_Info
begin
@ -976,9 +984,9 @@ package body Xref_Lib is
-- We don't have a unit number specified, so we set P_Eun to
-- the current unit.
for K in Dependencies_Tables.First .. Last (File.Dep) loop
for K in Table'Range loop
P_Eun := K;
exit when File.Dep.Table (K) = File_Ref;
exit when Table (K) = File_Ref;
end loop;
end if;
@ -1011,7 +1019,7 @@ package body Xref_Lib is
Symbol,
P_Line,
P_Column,
File.Dep.Table (P_Eun));
Table (P_Eun));
end if;
end;
end if;
@ -1029,7 +1037,7 @@ package body Xref_Lib is
Add_Entity
(Pattern,
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_Column (Get_Parent (Decl_Ref)),
False);
@ -1080,11 +1088,10 @@ package body Xref_Lib is
if Wide_Search then
declare
File_Ref : File_Reference;
pragma Unreferenced (File_Ref);
File_Name : constant String := Get_Gnatchop_File (File.X_File);
Ignored : File_Reference;
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 if;
@ -1252,6 +1259,8 @@ package body Xref_Lib is
Ptr : Positive renames File.Current_Line;
File_Nr : Natural;
Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin
while Ali (Ptr) = 'X' loop
@ -1267,8 +1276,8 @@ package body Xref_Lib is
-- If the referenced file is unknown, we simply ignore it
if File_Nr in Dependencies_Tables.First .. Last (File.Dep) then
File.X_File := File.Dep.Table (File_Nr);
if File_Nr in Table'Range then
File.X_File := Table (File_Nr);
else
File.X_File := Empty_File;
end if;