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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2001 by the Free Pascal development team
Include file with set operations called by the compiler
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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.
**********************************************************************}
{****************************************************************************
Var sets
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_LOAD_SMALL}
{
convert sets
}
{$ifdef FPC_SETBASE_USED}
procedure fpc_varset_load(const l;sourcesize : longint;var dest;size,srcminusdstbase : ptrint); compilerproc;
var
srcptr, dstptr: pointer;
begin
srcptr:=@l;
dstptr:=@dest;
{ going from a higher base to a lower base, e.g.
src: 001f0000, base=2,size=4 -> 0000001f0000 in base 0
dstr in base = 1 (-> srcminusdstbase = 1) -> to
00001f0000, base=1 -> need to prepend "srcminusdstbase" zero bytes
}
if (srcminusdstbase>0) then
begin
{ fill the skipped part with 0 }
fillchar(dstptr^,srcminusdstbase,0);
inc(dstptr,srcminusdstbase);
dec(size,srcminusdstbase);
end
else if (srcminusdstbase<0) then
begin
{ inc/dec switched since srcminusdstbase < 0 }
dec(srcptr,srcminusdstbase);
inc(sourcesize,srcminusdstbase);
end;
if sourcesize>size then
sourcesize:=size;
move(srcptr^,dstptr^,sourcesize);
{ fill the leftover (if any) with 0 }
FillChar((dstptr+sourcesize)^,size-sourcesize,0);
end;
{$else FPC_SETBASE_USED}
procedure fpc_varset_load(const l;sourcesize : longint;var dest;size : ptrint); compilerproc;
begin
if sourcesize>size then
sourcesize:=size;
move(l,plongint(@dest)^,sourcesize);
FillChar((@dest+sourcesize)^,size-sourcesize,0);
end;
{$endif FPC_SETBASE_USED}
{$endif ndef FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_CREATE_ELEMENT}
{
create a new set in p from an element b
}
procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
type
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
begin
FillChar(data,size,0);
tbsetarray(data)[b]:=1;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_CREATE_ELEMENT}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_SET_BYTE}
{
add the element b to the set "source"
}
procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
type
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
begin
move(source,dest,size);
tbsetarray(dest)[b]:=1;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_UNSET_BYTE}
{
suppresses the element b to the set pointed by p
used for exclude(set,element)
}
procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc;
type
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
begin
move(source,dest,size);
tbsetarray(dest)[b]:=0;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_UNSET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_SET_RANGE}
{
adds the range [l..h] to the set orgset
}
procedure fpc_varset_set_range(const orgset; var dest;l,h,size : ptrint); compilerproc;
type
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
var
i : ptrint;
begin
move(orgset,dest,size);
for i:=l to h do
tbsetarray(dest)[i]:=1;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SET_RANGE}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_ADD_SETS}
{
adds set1 and set2 into set dest
}
procedure fpc_varset_add_sets(const set1,set2; var dest;size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
for i:=0 to size-1 do
tbytearray(dest)[i]:=tbytearray(set1)[i] or tbytearray(set2)[i];
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_ADD_SETS}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_MUL_SETS}
{
multiplies (takes common elements of) set1 and set2 result put in dest
}
procedure fpc_varset_mul_sets(const set1,set2; var dest;size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
for i:=0 to size-1 do
tbytearray(dest)[i]:=tbytearray(set1)[i] and tbytearray(set2)[i];
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_MUL_SETS}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_SUB_SETS}
{
computes the diff from set1 to set2 result in dest
}
procedure fpc_varset_sub_sets(const set1,set2; var dest;size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
for i:=0 to size-1 do
tbytearray(dest)[i]:=tbytearray(set1)[i] and not tbytearray(set2)[i];
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SUB_SETS}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_SYMDIF_SETS}
{
computes the symetric diff from set1 to set2 result in dest
}
procedure fpc_varset_symdif_sets(const set1,set2; var dest;size : ptrint); compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
for i:=0 to size-1 do
tbytearray(dest)[i]:=tbytearray(set1)[i] xor tbytearray(set2)[i];
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SYMDIF_SETS}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_COMP_SETS}
{
compares set1 and set2 zeroflag is set if they are equal
}
function fpc_varset_comp_sets(const set1,set2;size : ptrint):boolean; compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
fpc_varset_comp_sets:= false;
for i:=0 to size-1 do
if tbytearray(set1)[i]<>tbytearray(set2)[i] then
exit;
fpc_varset_comp_sets:=true;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_COMP_SETS}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_CONTAINS_SET}
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
function fpc_varset_contains_sets(const set1,set2;size : ptrint):boolean; compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
var
i : ptrint;
begin
fpc_varset_contains_sets:= false;
for i:=0 to size-1 do
if (tbytearray(set1)[i] and not tbytearray(set2)[i])<>0 then
exit;
fpc_varset_contains_sets:=true;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_CONTAINS_SET}
|
