+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
-- --
-- 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- --
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 --
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;
------------
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;
----------------
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 --
--------------
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;
----------
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;
----------
----------
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;
+ -------------
+ -- 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
- 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;
+ if T.P.Last /= T.P.Last_Allocated then
+ pragma Assert (T.P.Last < T.P.Last_Allocated);
+ pragma Assert (T.Table /= Empty);
- New_Size :=
- size_t ((T.P.Max - Min + 1) *
- (Table_Type'Component_Size / Storage_Unit));
+ declare
+ subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
+ type Old_Alloc_Ptr is access all Old_Alloc_Type;
- if T.Table = null then
- T.Table := To_Pointer (Alloc (New_Size));
+ 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);
- elsif New_Size > 0 then
- T.Table :=
- To_Pointer (Realloc (Ptr => To_Address (T.Table),
- Size => New_Size));
- end if;
+ subtype Alloc_Type is
+ Table_Type (First .. First + T.P.Last - 1);
+ type Alloc_Ptr is access all Alloc_Type;
- if T.P.Length /= 0 and then T.Table = null then
- raise Storage_Error;
- end if;
- end Reallocate;
+ function To_Table_Ptr is
+ new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr);
- -------------
- -- Release --
- -------------
+ 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;
- procedure Release (T : in out Instance) is
- begin
- T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
- T.P.Max := T.P.Last_Val;
- Reallocate (T);
+ pragma Assert (T.P.Last = T.P.Last_Allocated);
end Release;
--------------
--------------
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
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;
+ return;
+ end if;
- T.Table (Index) := Item;
+ 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;
----------------
----------------
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;
-- 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;
----------
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;
-- --
-- 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- --
-- 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.
+
+ pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First);
+
+ 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
- -- types are not supported. Note however that default initialization
- -- will NOT occur for array components.
+ 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;
- -- The Table_Initial values controls the allocation of the table when
- -- it is first allocated, either by default, or by an explicit Init
- -- call.
+ -- 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
-- 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);
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
-- 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;
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;
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)));
- end loop;
+ -----------------------------
+ -- 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;
- Store_String_Chars ("'Type_Key");
- return End_String;
- end Type_Key;
+ 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
- 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);
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;
-- 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.
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
return;
end if;
- -- Step 1: Detect duplicate choices
-
- if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
- Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
- Error := True;
+ -- Step 1: Ignore duplicate choices, other than to set the flag,
+ -- because these were already detected by Check_Duplicates.
- 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
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 --
----------------
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;
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.
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
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
Prev_Hi := Prev_Lo;
- Error := False;
-
- 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.
-
- if Error then
- Predicate_Error := True;
-
- if not All_Errors_Mode then
- return;
+ 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);
+
+ -- 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 not All_Errors_Mode then
+ return;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
+ end;
if Predicate_Error then
return;
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);
-
- 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;
+ for Index in 2 .. Num_Choices loop
+ Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
+ Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
- 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;
(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;
--------------------
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
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
-- 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;
Symbol,
P_Line,
P_Column,
- File.Dep.Table (P_Eun));
+ Table (P_Eun));
end if;
end;
end if;
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);
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;
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
-- 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;
projects / thirdparty / gcc.git / commitdiff
