+2017-04-27 Bob Duff <duff@adacore.com>
+
+ * g-dyntab.ads, g-dyntab.adb: Default for Table_Low_Bound.
+ Rename Empty --> Empty_Table_Ptr, and don't duplicate code for it.
+ Free renames Init, since they do the same thing.
+ * g-table.ads: Default for Table_Low_Bound.
+ * table.ads: Default for Table_Low_Bound, Table_Initial, and
+ Table_Increment.
+
2017-04-27 Bob Duff <duff@adacore.com>
* g-dyntab.ads, g-dyntab.adb: Add assertions to subprograms that
package body GNAT.Dynamic_Tables is
- Empty : constant Table_Ptr :=
- Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-
-----------------------
-- Local Subprograms --
-----------------------
end loop;
end For_Each;
- ----------
- -- Free --
- ----------
-
- procedure Free (T : in out Instance) is
- pragma Assert (not T.Locked);
- 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
- if T.Table = Empty then
- pragma Assert (T.P = (Last_Allocated | Last => First - 1));
- null;
- else
- Free (Temp);
- T.Table := Empty;
- T.P := (Last_Allocated | Last => First - 1);
- end if;
- end Free;
-
----------
-- Grow --
----------
New_Allocated_Length : Table_Length_Type;
begin
- if T.Table = Empty then
+ if T.Table = Empty_Table_Ptr then
New_Allocated_Length := Table_Length_Type (Table_Initial);
else
New_Allocated_Length :=
New_Table : constant Alloc_Ptr := new Alloc_Type;
begin
- if T.Table /= Empty then
+ if T.Table /= Empty_Table_Ptr then
New_Table (First .. T.P.Last) := Old_Table (First .. T.P.Last);
Free (Old_Table);
end if;
pragma Assert (New_Last <= T.P.Last_Allocated);
pragma Assert (T.Table /= null);
- pragma Assert (T.Table /= Empty);
+ pragma Assert (T.Table /= Empty_Table_Ptr);
end Grow;
--------------------
----------
procedure Init (T : in out Instance) is
- begin
pragma Assert (not T.Locked);
- Free (T);
+ 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
+ if T.Table = Empty_Table_Ptr then
+ pragma Assert (T.P = (Last_Allocated | Last => First - 1));
+ null;
+ else
+ Free (Temp);
+ T.Table := Empty_Table_Ptr;
+ T.P := (Last_Allocated | Last => First - 1);
+ end if;
end Init;
--------------
function Is_Empty (T : Instance) return Boolean is
Result : constant Boolean := T.P.Last = Table_Low_Bound - 1;
begin
- pragma Assert (Result = (T.Table = Empty));
+ pragma Assert (Result = (T.Table = Empty_Table_Ptr));
return Result;
end Is_Empty;
pragma Assert (Is_Empty (To));
To := From;
- From.Table := Empty;
+ From.Table := Empty_Table_Ptr;
From.Locked := False;
From.P.Last_Allocated := Table_Low_Bound - 1;
From.P.Last := Table_Low_Bound - 1;
begin
if New_Last_Alloc < T.P.Last_Allocated then
pragma Assert (T.P.Last < T.P.Last_Allocated);
- pragma Assert (T.Table /= Empty);
+ pragma Assert (T.Table /= Empty_Table_Ptr);
declare
subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
type Table_Component_Type is private;
type Table_Index_Type is range <>;
- Table_Low_Bound : Table_Index_Type;
+ Table_Low_Bound : Table_Index_Type := Table_Index_Type'First;
Table_Initial : Positive := 8;
Table_Increment : Natural := 100;
Release_Threshold : Natural := 0; -- size in bytes
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);
+ Empty_Table_Ptr : constant Table_Ptr :=
+ Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-- End private use only. The above are used to initialize Table to point to
-- an empty array.
type Instance is record
- Table : Table_Ptr :=
- Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
+ Table : Table_Ptr := Empty_Table_Ptr;
-- 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
-- Reinitializes the table to empty. There is no need to call this before
-- using a table; tables default to empty.
+ procedure Free (T : in out Instance) renames Init;
+
function First return Table_Index_Type;
pragma Inline (First);
-- Export First as synonym for Table_Low_Bound (parallel with use of Last)
-- chunk of memory. In both cases current array values are not affected by
-- this call.
- procedure Free (T : in out Instance);
- -- Same as Init
-
procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type);
pragma Inline (Set_Last);
-- This procedure sets Last to the indicated value. If necessary the table
type Table_Component_Type is private;
type Table_Index_Type is range <>;
- Table_Low_Bound : Table_Index_Type;
+ Table_Low_Bound : Table_Index_Type := Table_Index_Type'First;
Table_Initial : Positive := 8;
Table_Increment : Natural := 100;
Table_Name : String := ""; -- for debugging printouts
subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type;
subtype Table_Last_Type is Tab.Table_Last_Type;
subtype Table_Type is Tab.Table_Type;
+ function "=" (X, Y : Table_Type) return Boolean renames Tab."=";
subtype Big_Table_Type is Tab.Big_Table_Type;
subtype Table_Ptr is Tab.Table_Ptr;
function Is_Empty return Boolean;
procedure Init;
+ procedure Free;
function First return Table_Index_Type;
pragma Inline (First);
procedure Release;
- procedure Free;
-
procedure Set_Last (New_Val : Table_Last_Type);
pragma Inline (Set_Last);
type Table_Component_Type is private;
type Table_Index_Type is range <>;
- Table_Low_Bound : Table_Index_Type;
- Table_Initial : Pos;
- Table_Increment : Nat;
+ Table_Low_Bound : Table_Index_Type := Table_Index_Type'First;
+ Table_Initial : Pos := 8;
+ Table_Increment : Nat := 100;
Table_Name : String; -- for debugging printouts
Release_Threshold : Nat := 0;
projects / gcc.git / commitdiff