home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
w3_prog
/
tpbind.arj
/
BIND.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-22
|
36KB
|
1,505 lines
unit bind;
{
bind
5-19-91
loose data binder
Copyright 1991
John W. Small
All rights reserved
PSW / Power SoftWare
P.O. Box 10072
McLean, Virginia 22102 8072
USA (703) 759-3838
}
interface
const
{ Binder default constants }
BMAXNODES = 65520 div sizeof(pointer);
BLIMIT = 20;
BDELTA = 10;
BNOTFOUND = BMAXNODES;
{ Binder result flags }
BdrOkay = $00;
BdrIndexError = $01;
BdrNoMemory = $02;
BdrNoVacancy = $04;
BdrNoLinks = $08;
BdrNoData = $10;
BdrOtherError = $20;
type
{ Binder search/sort compare procedure type }
BcomparE = function(D1, D2: pointer)
: integer;
{ Binder iterator procedure types }
BforEachBlocK = procedure(D, M, A : pointer);
BdetectBlocK = function(D, M : pointer)
: boolean;
BindPtR = ^Binder;
BcollectBlocK = procedure(D, M : pointer;
R : BindPtR);
{ Binder elastic array of pointers type }
PointerArray = array[0..BMAXNODES-1]
of pointer;
LinksVector = ^PointerArray;
{ Default Binder element }
BinderN = ^BinderNode;
BinderNode = object
constructor Init;
destructor Done; virtual;
end;
Binder = object
ok : boolean;
constructor Init;
destructor Done; virtual;
function getLimit : word;
procedure setLimit(newLimit : word);
procedure pack;
function getDelta : word;
procedure setDelta(newDelta : word);
function getNodes : word;
function getMaxNodes : word;
procedure setMaxNodes(newMaxNodes : word);
procedure atIns(n : word; D : pointer);
function atExt(n : word) : pointer;
procedure atDel(n : word);
procedure allDel;
procedure atFree(n : word);
procedure allFree;
procedure atPut(n : word; D : pointer);
function atGet(n : word) : pointer;
function index(D : pointer) : word;
procedure add(D : pointer);
procedure subtract(D : pointer);
procedure forEach (B : BforEachBlocK;
M, A : pointer);
function firstThat(B : BdetectBlocK;
M : pointer) : word;
function lastThat (B : BdetectBlocK;
M : pointer) : word;
procedure collect (B : BcollectBlocK;
M : pointer; R : BindPtR);
{ FlexList like primitives: }
function top : pointer;
function current : pointer;
function bottom : pointer;
function curNodeSet : boolean;
function getCurNode : word;
procedure setCurNode(n : word);
function getSorted : boolean;
procedure unSort;
procedure getComparE(var C : BcomparE);
procedure setComparE(C : BcomparE);
procedure push(D : pointer);
function popExt : pointer;
procedure popDel;
procedure popFree;
procedure insq(D : pointer);
function unqExt : pointer;
procedure unqDel;
procedure unqFree;
procedure ins(D : pointer);
procedure insSort(D : pointer);
function delExt : pointer;
procedure deldel;
procedure delFree;
function next : boolean;
function prev : boolean;
function findFirst(K : pointer) : word;
function findNext(K : pointer) : word;
function findLast(K : pointer) : word;
function findPrev(K : pointer) : word;
procedure sort;
private
lowLimit : word;
lowThreshold : word;
first : word;
linkS : LinkSVector;
limit : word;
delta : word;
nodes : word;
maxNodes : word;
curNode : word;
sorted : boolean;
comparE : BcomparE;
procedure Dfree(D: pointer); virtual;
procedure error(flags, info : word);
virtual;
end; { Binder }
const
CSTRING = 0;
type
CopyBindPtr = ^CopyBinder;
CopyBinder = Object(Binder)
sizeofData : word;
constructor Init(dataSize : word);
destructor Done; virtual;
procedure atInsC(n : word; D : pointer);
procedure atFreeC(n : word; D : pointer);
procedure atFreePutC(n : word;
D : pointer);
procedure atGetC(n : word; D : pointer);
procedure topC(D : pointer);
procedure currentC(D : pointer);
procedure bottomC(D : pointer);
procedure pushC(D : pointer);
procedure popFreeC(D : pointer);
procedure insqC(D : pointer);
procedure unqFreeC(D : pointer);
procedure insC(D : pointer);
procedure insSortC(D : pointer);
procedure delFreeC(D : pointer);
function nextC(D : pointer) : boolean;
function prevC(D : pointer) : boolean;
private
procedure Dfree(D: pointer); virtual;
function Dclone(D : pointer)
: pointer; virtual;
procedure Dcopy(D, S : pointer); virtual;
end;
implementation
function BnoComp(D1, D2 : pointer) : integer; far;
begin
BnoComp := -1;
end;
{ Binder Methods }
constructor Binder.Init;
var sizeofNewLinks : longint;
begin
curNode := 0;
first := 0;
nodes := 0;
comparE := BnoComp;
{
The following relationships are maintained
during operation of a binder:
1 <= delta <= lowLimit <= limit <= maxNodes
<= BMAXNODES
lowThreshold = lowLimit - delta;
}
sizeofNewLinks := sizeof(pointer)*BLIMIT;
if (MaxAvail < sizeofNewLinks) then begin
delta := 0;
limit := 0;
maxNodes := 0;
lowLimit := 0;
lowThreshold := 0;
sorted := false;
ok := false;
error(BdrNoMemory,word(sizeofNewLinks));
fail
end;
getmem(linkS,sizeofNewLinks);
delta := BDELTA;
limit := BLIMIT;
maxNodes := BMAXNODES;
lowLimit := limit;
lowThreshold := lowLimit - delta;
sorted := true;
ok := true
end;
destructor Binder.Done;
begin
allDel;
if (linkS <> nil) then
freemem(linkS,sizeof(pointer)*limit);
linkS := nil;
curNode := 0;
first := 0;
delta := 0;
limit := 0;
maxNodes := 0;
lowLimit := 0;
lowThreshold := 0;
sorted := false;
ok := false;
end;
function Binder.getLimit : word;
begin
ok := true;
getLimit := limit
end;
procedure Binder.setLimit(newLimit : word);
var
newLinkS : LinksVector;
sizeofNewLinks : longint;
flags, i : word;
begin
if (newLimit < nodes) then
newLimit := nodes
else if (newLimit > maxNodes) then
newLimit := maxNodes;
if (newLimit < delta) then
newLimit := delta;
if (linkS = nil) or (newLimit = 0)
or (newLimit = limit) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinkS;
if (newLimit = 0) then
flags := flags or BdrOtherError;
if (newLimit = limit) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
exit
end;
sizeofNewLinks := sizeof(pointer) * newLimit;
if (MaxAvail < sizeofNewLinks) then begin
ok := false;
error(BdrNoMemory,word(sizeofNewLinks));
exit
end;
getmem(newLinkS,sizeofNewLinks);
i := limit - first;
if (i > nodes) then
i := nodes;
move(linkS^[first],newLinkS^[0],
sizeof(linkS^[0])*i);
{ copy wrap around }
if (i < nodes) then
move(linkS^[0],newLinkS^[i],
sizeof(linkS^[0])*(nodes-i));
if (newLimit > limit) then
if ((newLimit - delta) > limit) then
lowLimit := newLimit - delta
else
lowLimit := limit
else
if ((newLimit - delta) > delta) then
lowLimit := newLimit - delta
else
lowLimit := delta;
lowThreshold := lowLimit - delta;
freemem(linkS,sizeof(pointer)*limit);
linkS := newLinkS;
limit := newLimit;
first := 0;
ok := true
end;
procedure Binder.pack;
begin
setLimit(nodes)
end;
function Binder.getDelta : word;
begin
ok := true;
getDelta := delta
end;
procedure Binder.setDelta(newDelta : word);
begin
if (newDelta = 0) or (newDelta > lowLimit)
then begin
ok := false;
error(BdrOtherError,0)
end
else begin
delta := newDelta;
ok := true
end
end;
function Binder.getNodes : word;
begin
ok := true;
getNodes := nodes
end;
function Binder.getMaxNodes : word;
begin
ok := true;
getMaxNodes := maxNodes
end;
procedure Binder.setMaxNodes(newMaxNodes : word);
begin
if newMaxNodes >= limit then begin
if newMaxNodes < BMAXNODES then
maxNodes := newMaxNodes
else
maxNodes := BMAXNODES;
ok := true
end
else begin
ok := false;
error(BdrOtherError,0)
end
end;
procedure Binder.atIns(n : word; D : pointer);
var newLinks : LinksVector;
sizeofNewLinks : longint;
i, flags, newLimit : word;
begin
if (linkS = nil) or (D = nil) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (D = nil) then
flags := flags or BdrNoData;
ok := false;
error(flags,0);
exit
end;
if (nodes = limit) then begin
if (limit = maxNodes) then begin
ok := false;
error(BdrNoVacancy,maxNodes);
exit
end;
if ((maxNodes - delta) > limit) then
newLimit := limit + delta
else
newLimit := maxNodes;
sizeofNewLinks := sizeof(pointer)*newLimit;
if (MaxAvail < sizeofNewLinks) then begin
ok := false;
error(BdrNoMemory,
word(sizeofNewLinks));
exit
end;
getmem(newLinkS,sizeofNewLinks);
i := limit - first;
if (i > nodes) then
i := nodes;
move(linkS^[first],newLinkS^[0],
sizeof(linkS^[0])*i);
{ copy wrap around }
if (i < nodes) then
move(linkS^[0],newLinkS^[i],
sizeof(linkS^[0])*(nodes-i));
{
Compute next smaller linkS size
and threshold for shrinking.
}
lowLimit := limit;
lowThreshold := lowLimit - delta;
{ swap new for old }
freemem(linkS,sizeof(pointer)*limit);
linkS := newLinkS;
limit := newLimit;
first := 0;
end;
if (n = 0) then begin { push }
if (first = 0) then
first := limit - 1
else
dec(first);
linkS^[first] := D
end
else if (n >= nodes) then begin { insq }
n := nodes;
linkS^[(first+n) mod limit] := D
end
else begin { insert interior }
i := (first + n) mod limit;
if (i < first) or (first = 0) then
{ move rear rightward }
move(linkS^[i],linkS^[i+1],
sizeof(linkS^[0])
* (nodes-n))
else begin { move front leftward }
dec(i); dec(first);
move(linkS^[i],linkS^[first],
sizeof(linkS^[0])*(n+1))
end;
linkS^[i] := D
end;
inc(nodes);
if (n <= curNode) then
inc(curNode);
sorted := false;
ok := true
end;
function Binder.atExt(n : word) : pointer;
var newLinkS : LinksVector;
sizeofNewLinks : longint;
i, flags, newLimit : word;
begin
if (linkS = nil) or (n >= nodes) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (n >= nodes) then
flags := flags or BdrIndexError;
ok := false;
error(flags,0);
atExt := nil;
exit
end;
atExt := linkS^[(first+n) mod limit];
ok := true;
if (n = 0) then begin { pop }
inc(first);
if (first >= limit) then
first := 0
end
else if (n <> (nodes-1)) then begin { del interior }
{ move front rightward }
move(linkS^[first],linkS^[first+1],
sizeof(linkS^[0])*n);
inc(first)
end;
dec(nodes);
if (nodes = 0) then
sorted := true;
if (n < curNode) then
dec(curNode)
else if (n = curNode) then
curNode := nodes;
if (nodes < lowThreshold) then begin
newLimit := lowLimit;
sizeofNewLinks := sizeof(pointer)*newLimit;
if (MaxAvail < sizeofNewLinks) then
exit;
getmem(newLinkS,sizeofNewLinks);
i := limit - first;
if (i > nodes) then
i := nodes;
move(linkS^[first],newLinkS^[0],
sizeof(linkS^[0])*i);
{ copy wrap around }
if (i < nodes) then
move(linkS^[0],newLinkS^[i],
sizeof(linkS^[0])*(nodes-i));
{
Compute next smaller linkS size
and threshold for shrinking.
}
if ((lowLimit - delta) > delta) then
dec(lowLimit,delta)
else
lowLimit := delta;
lowThreshold := lowLimit - delta;
{ swap new for old }
freemem(linkS,sizeof(pointer)*limit);
linkS := newLinkS;
limit := newLimit;
first := 0
end
end;
procedure Binder.atDel(n : word);
var D : pointer;
begin
D := atExt(n)
end;
procedure Binder.allDel;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0);
exit
end;
while (nodes > 0) do
atDel(0);
ok := true
end;
procedure Binder.atFree(n : word);
begin
Dfree(atExt(n))
end;
procedure Binder.allFree;
begin
if (links = nil) then begin
ok := false;
error(BdrNoLinks,0);
exit
end;
while (nodes > 0) do
atFree(0);
ok := true
end;
procedure Binder.atPut(n : word; D : pointer);
var flags : word;
begin
if (linkS = nil) or (D = nil) or (n >= nodes)
then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (D = nil) then
flags := flags or BdrNoData;
if (n >= nodes) then
flags := flags or BdrIndexError;
ok := false;
error(flags,0)
end
else begin
sorted := false;
linkS^[(first+n) mod limit] := D;
ok := true
end
end;
function Binder.atGet(n : word) : pointer;
var flags : word;
begin
if (linkS = nil) or (n >= nodes) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (n >= nodes) then
flags := flags or BdrIndexError;
ok := false;
error(flags,0);
atGet := nil
end
else begin
ok := true;
atGet := linkS^[(first+n) mod limit]
end
end;
function Binder.index(D : pointer) : word;
var i, flags : word;
begin
if (linkS = nil) or (D = nil) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (D = nil) then
flags := flags or BdrNoData;
ok := false;
error(flags,0);
end
else begin
for i := 0 to (nodes - 1) do
if (D = linkS^[(first+i) mod limit])
then begin
ok := true;
index := i;
exit
end;
ok := false
end;
index := BNOTFOUND
end;
procedure Binder.add(D : pointer);
begin
atIns(nodes,D)
end;
procedure Binder.subtract(D : pointer);
begin
atDel(index(D))
end;
procedure Binder.forEach(B : BforEachBlocK; M, A : pointer);
var i : word;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0)
end
else begin
for i := 0 to (nodes - 1) do
B(linkS^[(first+i) mod limit],M,A);
ok := true
end
end;
function Binder.firstThat(B : BdetectBlocK;
M : pointer) : word;
var i : word;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0)
end
else begin
ok := true;
for i := 0 to (nodes - 1) do
if (B(linkS^[(first+i)
mod limit],M)) then begin
firstThat := i;
exit
end
end;
firstThat := BNOTFOUND
end;
function Binder.lastThat(B : BdetectBlocK;
M : pointer) : word;
var i : word;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0)
end
else begin
ok := true;
for i := (nodes - 1) downto 0 do
if (B(linkS^[(first+i)
mod limit],M)) then begin
lastThat := i;
exit
end
end;
lastThat := BNOTFOUND
end;
procedure Binder.collect(B : BcollectBlocK; M : pointer;
R : BindPtR);
var i, flags : word;
begin
if (linkS = nil) or (R = nil)
then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (R = nil) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0)
end
else begin
for i := 0 to (nodes - 1) do
B(linkS^[(first+i) mod limit],M,R);
ok := true
end
end;
function Binder.top : pointer;
begin
top := atGet(0)
end;
function Binder.current : pointer;
begin
current := atGet(curNode)
end;
function Binder.bottom : pointer;
begin
bottom := atGet(nodes-1)
end;
function Binder.curNodeSet : boolean;
begin
ok := true;
curNodeSet := (curNode < nodes)
end;
function Binder.getCurNode : word;
begin
ok := true;
getCurNode := curNode
end;
procedure Binder.setCurNode(n : word);
begin
ok := true;
if (n > nodes) then
n := nodes;
curNode := n
end;
function Binder.getSorted : boolean;
begin
ok := true;
getSorted := sorted
end;
procedure Binder.unSort;
begin
ok := true;
sorted := false
end;
procedure Binder.getComparE(var C : BcomparE);
begin
ok := true;
C := comparE
end;
procedure Binder.setComparE(C : BcomparE);
begin
ok := true;
sorted := false;
comparE := C
end;
procedure Binder.push(D : pointer);
begin
atIns(0,D)
end;
function Binder.popExt : pointer;
begin
popExt := atExt(0)
end;
procedure Binder.popDel;
begin
atDel(0)
end;
procedure Binder.popFree;
begin
atFree(0)
end;
procedure Binder.insq(D : pointer);
begin
atIns(nodes,D)
end;
function Binder.unqExt : pointer;
begin
unqExt := atExt(nodes-1)
end;
procedure Binder.unqDel;
begin
atDel(nodes-1)
end;
procedure Binder.unqFree;
begin
atFree(nodes-1)
end;
procedure Binder.ins(D : pointer);
begin
atIns(curNode+1,D);
if ok then begin
inc(curNode);
if (curNode >= nodes) then
curNode := nodes - 1
end
end;
procedure Binder.insSort(D : pointer);
var flags, low, mid, high : word;
begin
{
The current node is left undefined if
anything fails, otherwise it is set to the
newly inserted node.
}
curNode := nodes;
if (linkS = nil) or (D = nil) or (nodes >= maxNodes)
or (@comparE = @BnoComp) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (D = nil) then
flags := flags or BdrNoData;
if (nodes >= maxNodes) then
flags := flags or BdrNoVacancy;
if (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
exit
end;
if (not sorted) then begin
sort;
if (not ok) then
exit
end;
low := 0;
high := nodes;
while (low < high) do begin
mid := low + ((high - low) shr 1);
if (comparE(D,linkS^[(first+mid) mod limit])
<= 0) then
high := mid
else
low := mid + 1
end;
atIns(high,D);
if ok then
curNode := high;
{ atIns() resets sorted to zero }
sorted := true
end;
function Binder.delExt : pointer;
var n : word;
begin
n := curNode;
delExt := atExt(n);
if ok then if (n > 0) then
curNode := n - 1
end;
procedure Binder.deldel;
var n : word;
begin
n := curNode;
atDel(n);
if ok then if (n > 0) then
curNode := n - 1
end;
procedure Binder.delFree;
var n : word;
begin
n := curNode;
atFree(n);
if ok then if (n > 0) then
curNode := n - 1
end;
function Binder.next : boolean;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0);
end
else begin
if (curNode >= nodes) then
curNode := 0
else
inc(curNode);
if (curNode < nodes) then
ok := true
else
ok := false
end;
next := ok
end;
function Binder.prev : boolean;
begin
if (linkS = nil) then begin
ok := false;
error(BdrNoLinks,0);
end
else
if (curNode > 0) then begin
if (curNode > nodes) then
curNode := nodes;
dec(curNode);
ok := true
end
else begin
curNode := nodes;
ok := false
end;
prev := ok
end;
function Binder.findFirst(K : pointer) : word;
var flags, low, mid, high : word;
begin
{
The current node is left undefined if
anything fails, otherwise it is set to the
newly found node.
}
curNode := nodes;
if (linkS = nil) or (K = nil)
or (@comparE = @BnoComp) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (K = nil) or (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
findFirst := BNOTFOUND;
exit
end;
if (sorted) then begin
low := 0;
high := nodes;
while (low < high) do begin
mid := low + ((high - low) shr 1);
if (comparE(K,linkS^[(first+mid)
mod limit]) <= 0) then
high := mid
else
low := mid + 1
end;
if (high < nodes) then
if (comparE(K,linkS^[(first+
high) mod limit]) = 0)
then begin
ok := true;
curNode := high;
findFirst := curNode;
exit
end
end
else { linear search! }
while (next) do
if (comparE(K,current) = 0) then begin
ok := true;
findFirst := curNode;
exit
end;
ok := false;
findFirst := BNOTFOUND
end;
function Binder.findNext(K : pointer) : word;
var flags : word;
begin
{
For sorted binders you must first call findFirst()
to insure consistent results!
The current node is left undefined if
anything fails, otherwise it is set to the
newly found node.
}
if (linkS = nil) or (K = nil)
or (@comparE = @BnoComp) then begin
curNode := nodes;
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (K = nil) or (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
findNext := BNOTFOUND;
exit
end;
while (next) do
if (comparE(K,current) = 0) then begin
ok := true;
findNext := curNode;
exit
end
else if (sorted) then begin
curNode := nodes;
ok := false;
findNext := BNOTFOUND;
exit
end;
ok := false;
findNext := BNOTFOUND
end;
function Binder.findLast(K : pointer) : word;
var flags, low, mid, high : word;
begin
{
The current node is left undefined if
anything fails, otherwise it is set to the
newly found node.
}
curNode := nodes;
if (linkS = nil) or (K = nil)
or (@comparE = @BnoComp) then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (K = nil) or (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
findLast := BNOTFOUND;
exit
end;
if (sorted) then begin
low := 0;
high := nodes;
while (low < high) do begin
mid := low + ((high - low) shr 1);
if (comparE(K,linkS^[(first+mid)
mod limit]) < 0) then
high := mid
else
low := mid + 1
end;
if (high < nodes) then
if (comparE(K,linkS^[(first+
high) mod limit]) = 0)
then begin
ok := true;
curNode := high;
findLast := curNode;
exit
end
end
else { linear search! }
while (prev) do
if (comparE(K,current) = 0) then begin
ok := true;
findLast := curNode;
exit
end;
ok := false;
findLast := BNOTFOUND
end;
function Binder.findPrev(K : pointer) : word;
var flags : word;
begin
{
For sorted binders you must first call findLast()
to insure consistent results!
The current node is left undefined if
anything fails, otherwise it is set to the
newly found node.
}
if (linkS = nil) or (K = nil)
or (@comparE = @BnoComp) then begin
curNode := nodes;
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (K = nil) or (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
findPrev := BNOTFOUND;
exit
end;
while (prev) do
if (comparE(K,current) = 0) then begin
ok := true;
findPrev := curNode;
exit
end
else if (sorted) then begin
curNode := nodes;
ok := false;
findPrev := BNOTFOUND;
exit
end;
ok := false;
findPrev := BNOTFOUND
end;
procedure Binder.sort;
var i, flags, low, mid, high : word;
D : pointer;
begin
{
The current node is always reset to undefined
regardless of the outcome of sort.
}
curNode := nodes;
if (sorted) then begin
ok := true;
exit
end;
if (nodes = 0) then begin
ok := true;
sorted := true;
exit
end;
if (linkS = nil) or (@comparE = @BnoComp)
then begin
flags := BdrOkay;
if (linkS = nil) then
flags := flags or BdrNoLinks;
if (@comparE = @BnoComp) then
flags := flags or BdrOtherError;
ok := false;
error(flags,0);
exit
end;
if (first > 0) then begin
{ form contiguous block at front }
i := (first + nodes) mod limit;
if (i > first) then
move(linkS^[first],linkS^[0],
sizeof(linkS^[0])*nodes)
else if (i < first) then
move(linkS^[first],linkS^[i],
sizeof(linkS^[0])
*(limit-first));
{ else array is full/contiguous }
first := 0;
end;
high := 1;
i := 1;
while (i < nodes) do begin
low := 0;
D := linkS^[i];
while (low < high) do begin
mid := low + ((high - low) shr 1);
if (comparE(D,linkS^[mid]) <= 0)
then high := mid
else
low := mid + 1
end;
if (high < i) then begin
move(linkS^[high],linkS^[high+1],
sizeof(linkS^[0])*(i-high));
linkS^[high] := D
end;
inc(i);
high := i
end;
sorted := true;
ok := true
end;
{ Private Binder methods }
procedure Binder.Dfree(D: pointer);
begin
if D = nil then begin
ok := false;
error(BdrNoData,0)
end
else begin
dispose(BinderN(D));
ok := true
end;
end;
procedure Binder.error(flags, info : word);
begin
write('Binder error: ');
if ((flags and BdrIndexError) = BdrIndexError) then
write('| index invalid ');
if ((flags and BdrNoMemory) = BdrNoMemory) then
write('| no memory ');
if ((flags and BdrNoVacancy) = BdrNoVacancy) then
write('| no vacancy ');
if ((flags and BdrNoLinks) = BdrNoLinks) then
write('| no links ');
if ((flags and BdrNoData) = BdrNoData) then
write('| no data ');
if ((flags and BdrOtherError) = BdrOtherError) then
write('| other ');
writeln('| info: ',info)
end;
{ Copy Binder Methods }
constructor CopyBinder.Init(dataSize : word);
begin
if not Binder.Init then begin
sizeofData := 0;
fail
end;
sizeofData := dataSize
end;
destructor CopyBinder.Done;
begin
allFree;
Binder.Done
end;
procedure CopyBinder.atInsC(n : word; D : pointer);
var cD : pointer;
begin
cD := Dclone(D);
if ok then begin
atIns(n,cD);
if not ok then begin
Dfree(cD);
ok := false
end
end
end;
procedure CopyBinder.atFreeC(n : word; D : pointer);
begin
Dcopy(D,atGet(n));
if ok then
atFree(n)
end;
procedure CopyBinder.atFreePutC(n : word; D : pointer);
var oldD, cD : pointer;
begin
oldD := atGet(n);
if ok then begin
cD := Dclone(D);
if ok then begin
atPut(n,cD);
Dfree(oldD)
end
end
end;
procedure CopyBinder.atGetC(n : word; D : pointer);
begin
Dcopy(D,atGet(n))
end;
procedure CopyBinder.topC(D : pointer);
begin
Dcopy(D,atGet(0))
end;
procedure CopyBinder.currentC(D : pointer);
begin
Dcopy(D,atGet(getCurNode))
end;
procedure CopyBinder.bottomC(D : pointer);
begin
Dcopy(D,atGet(getNodes-1))
end;
procedure CopyBinder.pushC(D : pointer);
var cD : pointer;
begin
cD := Dclone(D);
if ok then begin
push(cD);
if not ok then begin
Dfree(cD);
ok := false
end
end
end;
procedure CopyBinder.popFreeC(D : pointer);
begin
Dcopy(D,atGet(0));
if ok then
atFree(0)
end;
procedure CopyBinder.insqC(D : pointer);
var cD : pointer;
begin
cD := Dclone(D);
if ok then begin
insq(cD);
if not ok then begin
Dfree(cD);
ok := false
end
end
end;
procedure CopyBinder.unqFreeC(D : pointer);
begin
Dcopy(D,bottom);
if ok then
unqFree
end;
procedure CopyBinder.insC(D : pointer);
var cD : pointer;
begin
cD := Dclone(D);
if ok then begin
ins(cD);
if not ok then begin
Dfree(cD);
ok := false
end
end
end;
procedure CopyBinder.insSortC(D : pointer);
var cD : pointer;
begin
cD := Dclone(D);
if ok then begin
insSort(cD);
if not ok then begin
Dfree(cD);
ok := false
end
end
end;
procedure CopyBinder.delFreeC(D : pointer);
begin
Dcopy(D,current);
if ok then
delFree
end;
function CopyBinder.nextC(D : pointer) : boolean;
begin
if (D = nil) then begin
ok := false;
error(BdrNoData,0)
end
else if next then
currentC(D);
nextC := ok
end;
function CopyBinder.prevC(D : pointer) : boolean;
begin
if (D = nil) then begin
ok := false;
error(BdrNoData,0)
end
else if prev then
currentC(D);
prevC := ok
end;
{ Private CopyBinder methods }
procedure CopyBinder.Dfree(D: pointer);
begin
if D = nil then begin
ok := false;
error(BdrNoData,0)
end
else begin
if (sizeofData = 0) then
dispose(BinderN(D))
else
freemem(D,sizeofData);
ok := true
end;
end;
function CopyBinder.Dclone(D : pointer) : pointer;
type strPtr = ^string;
var cD : pointer;
len : integer;
begin
if (D = nil) then begin
ok := false;
error(BdrNoData,0);
exit
end;
if (sizeofData = 0) then
len := length(strPtr(D)^) + 1
else
len := sizeofData;
if (MaxAvail < len) then begin
ok := false;
error(BdrNoMemory,len);
exit
end;
getmem(cD,len);
move(D^,cD^,len);
ok := true;
Dclone := cD
end;
procedure CopyBinder.Dcopy(D, S : pointer);
type strPtr = ^string;
var len : integer;
begin
if (D = nil) or (S = nil) then begin
ok := false;
error(BdrNoData,0);
exit
end;
if (sizeofData > 0) then
move(S^,D^,sizeofData)
else
move(S^,D^,length(strPtr(S)^));
ok := true
end;
constructor BinderNode.Init;
begin
fail
end;
destructor BinderNode.Done;
begin
end;
end.