1-- Efficient expandable one dimensional array. 2-- Copyright (C) 2015 - 2016 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with Interfaces.C; use Interfaces.C; 18with System; 19 20package body Dyn_Tables is 21 -- Size of an element in storage units (bytes). 22 El_Size : constant size_t := 23 size_t (Table_Type'Component_Size / System.Storage_Unit); 24 25 -- Expand the table by doubling its size. The table must have been 26 -- initialized. 27 procedure Expand (T : in out Instance; Num : Unsigned) 28 is 29 -- For efficiency, directly call realloc. 30 function Crealloc (Ptr : Table_Thin_Ptr; Size : size_t) 31 return Table_Thin_Ptr; 32 pragma Import (C, Crealloc, "realloc"); 33 34 New_Len : Unsigned; 35 New_Last : Unsigned; 36 begin 37 pragma Assert (T.Priv.Length /= 0); 38 pragma Assert (T.Table /= null); 39 40 -- Expand the bound. 41 New_Last := T.Priv.Last_Pos + Num; 42 if New_Last < T.Priv.Last_Pos then 43 raise Constraint_Error; 44 end if; 45 T.Priv.Last_Pos := New_Last; 46 47 -- Check if need to reallocate. 48 if T.Priv.Last_Pos < T.Priv.Length then 49 return; 50 end if; 51 52 -- Double the length. 53 loop 54 New_Len := T.Priv.Length * 2; 55 56 -- Check overflow. 57 if New_Len < T.Priv.Length then 58 raise Constraint_Error; 59 end if; 60 61 T.Priv.Length := New_Len; 62 exit when New_Len > T.Priv.Last_Pos; 63 end loop; 64 65 -- Realloc and check result. 66 if size_t (T.Priv.Length) > size_t'Last / El_Size then 67 raise Constraint_Error; 68 end if; 69 T.Table := Crealloc (T.Table, size_t (T.Priv.Length) * El_Size); 70 if T.Table = null then 71 raise Storage_Error; 72 end if; 73 end Expand; 74 75 procedure Allocate (T : in out Instance; Num : Natural := 1) is 76 begin 77 Expand (T, Unsigned (Num)); 78 end Allocate; 79 80 procedure Increment_Last (T : in out Instance) is 81 begin 82 -- Increase by 1. 83 Expand (T, 1); 84 end Increment_Last; 85 86 procedure Decrement_Last (T : in out Instance) is 87 begin 88 T.Priv.Last_Pos := T.Priv.Last_Pos - 1; 89 end Decrement_Last; 90 91 procedure Set_Last (T : in out Instance; Index : Table_Index_Type) 92 is 93 New_Last : constant Unsigned := 94 (Table_Index_Type'Pos (Index) 95 - Table_Index_Type'Pos (Table_Low_Bound) + 1); 96 begin 97 if New_Last < T.Priv.Last_Pos then 98 -- Decrease length. 99 T.Priv.Last_Pos := New_Last; 100 else 101 -- Increase length. 102 Expand (T, New_Last - T.Priv.Last_Pos); 103 end if; 104 end Set_Last; 105 106 procedure Init (T : in out Instance; Table_Initial : Positive) 107 is 108 -- Direct interface to malloc. 109 function Cmalloc (Size : size_t) return Table_Thin_Ptr; 110 pragma Import (C, Cmalloc, "malloc"); 111 begin 112 if T.Table = null then 113 -- Allocate memory if not already allocated. 114 T.Priv.Length := Unsigned (Table_Initial); 115 T.Table := Cmalloc (size_t (T.Priv.Length) * El_Size); 116 end if; 117 118 -- Table is initially empty. 119 T.Priv.Last_Pos := 0; 120 end Init; 121 122 function Last (T : Instance) return Table_Index_Type is 123 begin 124 return Table_Index_Type'Val 125 (Table_Index_Type'Pos (Table_Low_Bound) 126 + Unsigned'Pos (T.Priv.Last_Pos) - 1); 127 end Last; 128 129 function Next (T : Instance) return Table_Index_Type is 130 begin 131 return Table_Index_Type'Val 132 (Table_Index_Type'Pos (Table_Low_Bound) + T.Priv.Last_Pos); 133 end Next; 134 135 procedure Free (T : in out Instance) is 136 -- Direct interface to free. 137 procedure Cfree (Ptr : Table_Thin_Ptr); 138 pragma Import (C, Cfree, "free"); 139 begin 140 Cfree (T.Table); 141 T := (Table => null, 142 Priv => (Length => 0, 143 Last_Pos => 0)); 144 end Free; 145 146 procedure Append (T : in out Instance; Val : Table_Component_Type) is 147 begin 148 Increment_Last (T); 149 T.Table (Last (T)) := Val; 150 end Append; 151end Dyn_Tables; 152