1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
-- Fixed-length lists.
-- Copyright (C) 2017 Tristan Gingold
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 2 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <gnu.org/licenses>.
with Tables;
package body Flists is
-- Index of elements.
type El_Index_Type is new Int32;
-- Describe an flist.
type Entry_Type is record
-- Index of the first element (in the element table).
Els : El_Index_Type;
-- Length of the list.
Len : Nat32;
end record;
-- Flists descriptors.
package Flistt is new Tables
(Table_Component_Type => Entry_Type,
Table_Index_Type => Flist_Type,
Table_Low_Bound => 4,
Table_Initial => 32);
-- Table of all elements.
package Els is new Tables
(Table_Component_Type => El_Type,
Table_Index_Type => El_Index_Type,
Table_Low_Bound => 0,
Table_Initial => 128);
type Flist_Array is array (Natural range <>) of Flist_Type;
-- Linked list of free flist. For length less than the last index, the
-- index corresponds to the length. All free lists whose length is equal
-- or greater than the last index are grouped to the last index.
Free_Flists : Flist_Array (0 .. 16) := (others => Null_Flist);
-- Get the chain for a free flist for large length. It is stored at the
-- first element of the list.
function Free_Next (Flist : Flist_Type) return Flist_Type is
begin
return Flist_Type (Els.Table (Flistt.Table (Flist).Els));
end Free_Next;
function Create_Flist (Len : Natural) return Flist_Type
is
Res : Flist_Type;
Prev : Flist_Type;
Next : Flist_Type;
begin
if Len >= Free_Flists'Last then
-- Large length.
Res := Free_Flists (Free_Flists'Last);
Prev := Null_Flist;
while Res /= Null_Flist and then Length (Res) /= Len loop
Prev := Res;
Res := Free_Next (Res);
end loop;
if Res /= Null_Flist then
Next := Free_Next (Res);
if Prev = Null_Flist then
Free_Flists (Free_Flists'Last) := Next;
else
Els.Table (Flistt.Table (Prev).Els) := El_Type (Next);
end if;
end if;
else
-- Small length. The Len field contains the next free list.
Res := Free_Flists (Len);
if Res /= Null_Flist then
Free_Flists (Len) := Flist_Type (Flistt.Table (Res).Len);
Flistt.Table (Res).Len := Nat32 (Len);
elsif Len = 0 then
-- Quick case for len = 0.
Res := Flistt.Allocate (1);
Flistt.Table (Res) := (Els => 0, Len => 0);
return Res;
end if;
end if;
if Res = Null_Flist then
Res := Flistt.Allocate (1);
Flistt.Table (Res) := (Els => Els.Allocate (Len),
Len => Nat32 (Len));
end if;
-- Clear the list.
declare
Idx : constant El_Index_Type := Flistt.Table (Res).Els;
begin
Els.Table (Idx .. Idx + El_Index_Type (Len) - 1) := (others => 0);
end;
return Res;
end Create_Flist;
procedure Destroy_Flist (Flist : in out Flist_Type)
is
Len : constant Natural := Length (Flist);
Prev : Flist_Type;
begin
-- Prepend to the array of free flists.
if Len >= Free_Flists'Last then
Prev := Free_Flists (Free_Flists'Last);
Free_Flists (Free_Flists'Last) := Flist;
Els.Table (Flistt.Table (Flist).Els) := El_Type (Prev);
else
Prev := Free_Flists (Len);
Free_Flists (Len) := Flist;
Flistt.Table (Flist).Len := Nat32 (Prev);
end if;
Flist := Null_Flist;
end Destroy_Flist;
function Flast (Flist : Flist_Type) return Integer is
begin
return Integer (Flistt.Table (Flist).Len - 1);
end Flast;
function Length (Flist : Flist_Type) return Natural is
begin
return Natural (Flistt.Table (Flist).Len);
end Length;
function Get_Nth_Element (Flist : Flist_Type; N : Natural) return El_Type
is
E : Entry_Type renames Flistt.Table (Flist);
begin
pragma Assert (N < Natural (E.Len));
return Els.Table (E.Els + El_Index_Type (N));
end Get_Nth_Element;
procedure Set_Nth_Element (Flist : Flist_Type; N : Natural; V : El_Type)
is
E : Entry_Type renames Flistt.Table (Flist);
begin
pragma Assert (N < Natural (E.Len));
Els.Table (E.Els + El_Index_Type (N)) := V;
end Set_Nth_Element;
end Flists;
|
