{****************************************************************************
This is a source file of FreeVision
Copyright (c) 1992,96 by FP Klaempfl
Copyright (c) 1995 by MH Spiegel
****************************************************************************}
{$E-}
{$define NOEXCEPTIONS}
{$define SSTRING}
unit objects;
interface
const
maxcollectionsize = 16*1024*1024; { maybe for the next five years ;-) }
coindexerror = -1;
cooverflow = -2;
{$ifdef VER060}
vmtheadersize = 12;
{$endif}
type
tcharset = set of char;
pcharset = ^tcharset;
tbytearray = array[0..16*1024*1024-1] of byte;
pbytearray = ^tbytearray;
twordarray = array[0..16*1024*1024-1] of word;
pwordarray = ^twordarray;
wordrec = record
lo,hi : byte;
end;
longrec = record
lo,hi : word;
end;
{ this is a problem }
ptrrec = record
ofs,seg : word;
end;
pstring = ^string;
plongint = ^longint;
pword = ^word;
pbyte = ^byte;
fnamestr = string; { for linux, OS/2 ... }
ppoint = ^tpoint;
tpoint = record
x,y : longint;
end;
prect = ^trect;
trect = object
a,b : tpoint;
procedure assign(xa,ya,xb,yb : longint);
procedure copy(r : trect);
procedure move(adx,ady : longint);
procedure grow(adx,ady : longint);
procedure intersect(r : trect);
procedure union(r : trect);
procedure checkempty;
function contains(p : tpoint) : boolean;
function equals(r : trect) : boolean;
function empty : boolean;
end;
pobject = ^tobject;
tobject = object
constructor init;
destructor done;virtual;
procedure free;virtual;
end;
pstreamrec = ^tstreamrec;
tstreamrec = record
{ we never need really this, but ...}
objtype : longint;
vmtlink : pointer;
load : pointer;
store : pointer;
next : pointer;
end;
pstream = ^tstream;
tstream = object(tobject)
errorinfo : longint;
status : longint;
procedure copyfrom(var s : tstream;count : longint);
procedure error(code,info : longint);virtual;
procedure flush;virtual;
function get : pobject;
function getpos : longint;virtual;
function getsize : longint;virtual;
procedure put(p : pobject);
procedure read(var buf;count : longint);virtual;
function readstr : pstring;
procedure reset;
procedure seek(pos : longint);virtual;
procedure truncate;virtual;
procedure write(var buf;count : longint);virtual;
procedure writestr(p : pstring);
end;
pdosstream = ^tdosstream;
tdosstream = object(tstream)
handle : file;
constructor init(const filename : fnamestr;mode : word);
destructor done;virtual;
function getpos : longint;virtual;
function getsize : longint;virtual;
procedure read(var buf;count : longint);virtual;
procedure seek(pos : longint);virtual;
procedure truncate;virtual;
procedure write(var buf;count : longint);virtual;
end;
titemlist = array[0..maxcollectionsize-1] of pointer;
pitemlist = ^titemlist;
pcollection = ^tcollection;
tcollection = object(tobject)
{ don't modify this !!! }
count : longint;
limit : longint;
delta : longint;
items : pitemlist;
constructor init(alimit,adelta : longint);
constructor load(var s : tstream);
destructor done;virtual;
function at(index : longint) : pointer;
procedure atdelete(index : longint);
procedure atfree(index : longint);
procedure atinsert(index : longint;item : pointer);
procedure atput(index : longint;item : pointer);
procedure delete(item : pointer);
procedure deleteall;
procedure error(code,info : longint);virtual;
function firstthat(test : pointer) : pointer;
procedure foreach(action : pointer);
procedure free(item : pointer);
procedure freeall;
procedure freeitem(item : pointer);virtual;
function getitem(var s : tstream) : pointer;virtual;
function indexof(item : pointer) : longint;virtual;
procedure insert(item : pointer);virtual;
function lastthat(test : pointer) : pointer;
procedure pack;
procedure putitem(var s : tstream;item : pointer);virtual;
procedure setlimit(alimit : longint);virtual;
procedure store(var s : tstream);
end;
psortedcollection = ^tsortedcollection;
tsortedcollection = object(tcollection)
duplicates : boolean;
constructor load(var s : tstream);
function compare(key1,key2 : pointer) : integer;virtual;
function indexof(item : pointer) : longint;virtual;
procedure insert(item : pointer);virtual;
function keyof(item : pointer) : pointer;virtual;
function search(key : pointer;var index : longint) : boolean;virtual;
procedure store(var s : tstream);
end;
pstringcollection = ^tstringcollection;
tstringcollection = object(tsortedcollection)
function compare(key1,key2 : pointer) : integer;virtual;
procedure freeitem(item : pointer);virtual;
function getitem(var s : tstream) : pointer;virtual;
procedure putitem(var s : tstream;item : pointer);virtual;
end;
presourcecollection = ^tresourcecollection;
tresourcecollection = object(tstringcollection)
procedure freeitem(item : pointer);virtual;
function getitem(var s : tstream) : pointer;virtual;
function keyof(item : pointer) : pointer;virtual;
procedure putitem(var s : tstream;item : pointer);virtual;
end;
procedure registertype(var s : tstreamrec);
procedure registerobjects;
function newstr(const s : string) : pstring;
procedure disposestr(p : pstring);
function longmul(x,y : longint) : longint;
function longdiv(x,y : longint) : longint;
procedure abstract;
const
{ stream consts }
stcreate = $3c00;
stopenread = $3d00;
stopenwrite = $3d01;
stopen = $3d02;
stok = 0;
sterror = -1;
stiniterror = -2;
streaderror = -3;
stwriteerror = -4;
stgeterror = -5;
stputerror = -6;
{ only for backward compatibality }
emscurhandle : word = $ffff;
emscurpage : word = $ffff;
streamerror : pointer = nil;
rcollection : tstreamrec = (
objtype : 50;
{!!!!!!!}
);
rstringcollection : tstreamrec = (
objtype : 51;
{!!!!!!!}
);
rstringlist : tstreamrec = (
objtype : 52;
{!!!!!!!}
);
rstrlistmaker : tstreamrec = (
objtype : 53;
{!!!!!!!}
);
implementation
const
streamrecs : pstreamrec = nil;
procedure registertype(var s : tstreamrec);
begin
s.next:=streamrecs;
{ better do a type conversation }
streamrecs:=pstreamrec(@s);
end;
procedure registerobjects;
begin
registertype(rcollection);
registertype(rstringcollection);
registertype(rstringlist);
registertype(rstrlistmaker);
end;
procedure abstract;
begin
runerror(211);
end;
function newstr(const s : string) : pstring;
var
p : pstring;
begin
getmem(p,length(s)+1);
p^:=s;
newstr:=p;
end;
procedure disposestr(p : pstring);
begin
if assigned(p) then
freemem(p,length(p^)+1);
end;
function longmul(x,y : longint) : longint;
begin
exit(x*y);
end;
function longdiv(x,y : longint) : longint;
begin
exit(x div y);
end;
{****************************************************************************
TRECT
****************************************************************************}
procedure trect.checkempty;
begin
if (a.x>b.x) or (a.y>b.y) then
begin
a.x:=0;
a.y:=0;
b.x:=0;
b.y:=0;
end;
end;
procedure trect.assign(xa,ya,xb,yb : longint);
begin
a.x:=xa;
a.y:=ya;
b.x:=xb;
b.y:=yb;
end;
procedure trect.copy(r : trect);
begin
a:=r.a;
b:=r.b;
end;
procedure trect.move(adx,ady : longint);
begin
inc(a.x,adx);
inc(a.y,ady);
inc(b.x,adx);
inc(b.y,ady);
end;
procedure trect.grow(adx,ady : longint);
begin
dec(a.x,adx);
dec(a.y,ady);
inc(b.x,adx);
inc(b.y,ady);
checkempty;
end;
procedure trect.intersect(r : trect);
begin
if r.a.x>a.x then
a.x:=r.a.x;
if r.a.y>a.y then
a.y:=r.a.y;
if r.b.x<=b.x then
b.x:=r.b.x;
if r.b.y<=b.y then
b.y:=r.b.y;
checkempty;
end;
procedure trect.union(r : trect);
begin
if r.a.x<a.x then
a.x:=r.a.x;
if r.a.y<a.y then
a.y:=r.a.y;
if r.b.x>b.x then
b.x:=r.b.x;
if r.b.y>b.y then
b.y:=r.b.y;
end;
function trect.contains(p: tpoint) : boolean;
begin
contains:=(p.x>=a.x) and (p.x<=b.x) and (p.y>=a.y) and (p.y<=b.y);
end;
function trect.equals(r : trect) : boolean;
begin
equals:=(a.x=r.a.x) and (a.y=r.a.y) and (b.x=r.b.x) and (b.y=r.b.y);
end;
function trect.empty : boolean;
begin
empty:=(a.x=b.x) and (a.y=b.y);
end;
{****************************************************************************
TOBJECT
****************************************************************************}
constructor tobject.init;
begin
{ init mem }
fillchar((@self+4)^,sizeof(self)-4,0);
end;
destructor tobject.done;
begin
end;
procedure tobject.free;
begin
{ stupid: }
dispose(@self,done);
{ (and generates stupid code) }
end;
{****************************************************************************
TSTREAM
****************************************************************************}
procedure tstream.copyfrom(var s : tstream;count : longint);
var
oldpos : longint;
p : pbytearray;
begin
if status<>stok then
exit;
{ alloc the buffer }
{ may be this defragments the heap }
getmem(p,count);
{ don't modify the source stream }
{ really ?? }
oldpos:=s.getpos;
s.read(p^,count);
s.seek(oldpos);
if s.status=stok then
write(p^,count)
else
error(sterror,s.status);
freemem(p,count);
end;
procedure tstream.error(code,info : longint);
type
tstreamerrorproc = procedure;
begin
status:=code;
errorinfo:=info;
if assigned(streamerror) then
begin
tstreamerrorproc(streamerror)();
end;
end;
procedure tstream.flush;
begin
abstract;
end;
function loadmethod(cons,vmt_link,stream : pointer) : pobject;
begin
asm
// push stream var
pushl 16(%ebp)
// call get mem
pushl $0
// vmt link
pushl 12(%ebp)
// do call
movl %eax,8(%ebp)
call (%eax)
movl %esi,%eax
leave
ret $12
end;
end;
function tstream.get : pobject;
var
l : longint;
hp : pstreamrec;
p : pobject;
begin
if status<>stok then
exit;
read(l,4);
if status<>stok then
exit;
if l=0 then
exit(nil);
hp:=streamrecs;
while hp^.objtype<>l do
begin
if hp=nil then
begin
error(stgeterror,l);
exit(nil);
end;
hp:=hp^.next;
end;
{ load object }
{ call constructor direct }
get:=loadmethod(hp^.load,hp^.vmtlink,@self);
end;
function tstream.getpos : longint;
begin
abstract;
end;
function tstream.getsize : longint;
begin
abstract;
end;
type
tstoremethod = procedure(_self : pointer;_stream : pointer);
procedure tstream.put(p : pobject);
var
hp : pstreamrec;
l : longint;
begin
if status<>stok then
exit;
{ may be write nil }
if p=nil then
begin
l:=0;
write(l,4);
exit;
end;
{ search object registration }
hp:=streamrecs;
while hp^.vmtlink<>typeof(p^) do
begin
if hp=nil then
begin
error(stputerror,longint(typeof(p^)));
exit;
end;
hp:=hp^.next;
end;
write(hp^.objtype,4);
if status<>stok then
exit;
{ you can call a method explicit too }
tstoremethod(hp^.store)(p,@self);
end;
procedure tstream.read(var buf;count : longint);
begin
abstract;
end;
function tstream.readstr : pstring;
{$ifdef SSTRING}
var
len : byte;
{$endif}
p : pstring;
begin
if status<>stok then
exit;
read(len,1);
getmem(p,len+1);
length(p^):=len;
read((p+1)^,len);
readstr:=p;
end;
procedure tstream.reset;
begin
status:=stok;
errorinfo:=0;
end;
procedure tstream.seek(pos : longint);
begin
abstract;
end;
procedure tstream.truncate;
begin
abstract;
end;
procedure tstream.write(var buf;count : longint);
begin
abstract;
end;
procedure tstream.writestr(p : pstring);
begin
if status<>stok then
exit;
write(p^,length(p^)+1);
end;
{****************************************************************************
TDOSSTREAM
****************************************************************************}
constructor tdosstream.init(const filename : fnamestr;mode : word);
begin
inherited init;
{!!!!!!!}
end;
destructor tdosstream.done;
begin
{!!!!!!!}
inherited done;
end;
function tdosstream.getpos : longint;
begin
{!!!!!!!}
end;
function tdosstream.getsize : longint;
begin
{!!!!!!!}
end;
procedure tdosstream.read(var buf;count : longint);
begin
{!!!!!!!}
end;
procedure tdosstream.seek(pos : longint);
begin
{!!!!!!!}
end;
procedure tdosstream.truncate;
begin
{!!!!!!!}
end;
procedure tdosstream.write(var buf;count : longint);
begin
{!!!!!!!}
end;
{****************************************************************************
TCOLLECTION
****************************************************************************}
constructor tcollection.init(alimit,adelta : longint);
begin
inherited init;
count:=0;
limit:=alimit;
delta:=adelta;
getmem(items,limit*sizeof(pointer));
end;
constructor tcollection.load(var s : tstream);
begin
{!!!!!!}
end;
destructor tcollection.done;
begin
freeall;
freemem(items,limit*sizeof(pointer));
inherited done;
end;
function tcollection.at(index : longint) : pointer;
begin
if (index<0) or (index>=count) then
begin
error(coindexerror,index);
at:=nil;
end
else
at:=items^[index];
end;
procedure tcollection.atdelete(index : longint);
begin
if (index<0) or (index>=count) then
error(coindexerror,index)
else
{ system.move tests for zero count }
begin
move(items^[index+1],items^[index],
(count-index-1)*sizeof(pointer));
dec(count);
end;
end;
procedure tcollection.atfree(index : longint);
var
p : pointer;
begin
p:=at(index);
if assigned(p) then
begin
atdelete(index);
freeitem(p);
end;
end;
procedure tcollection.atinsert(index : longint;item : pointer);
var
p : pitemlist;
begin
{!!!!!!!! use setlimit v---- this test ???? }
if (index<0) or (index>count) then
error(coindexerror,index)
else
begin
{ maybe extent the collection }
if count=limit then
begin
if (limit+delta>maxcollectionsize) or (delta=0) then
error(cooverflow,0)
else
begin
getmem(p,(limit+delta)*sizeof(pointer));
if assigned(p) then
begin
{ system.move checks count for zero }
move(items^[0],p^[0],index*sizeof(pointer));
p^[index]:=item;
inc(count);
move(items^[index],p^[index+1],
(count-index-2)*sizeof(pointer));
freemem(items,limit*sizeof(pointer));
inc(limit,delta);
items:=p;
end
else
error(cooverflow,0);
end;
end
else
{ insert with no extent }
begin
move(items^[index],items^[index+1],
(count-index-1)*sizeof(pointer));
items^[index]:=item;
inc(count);
end;
end;
end;
procedure tcollection.atput(index : longint;item : pointer);
begin
if (index<0) or (index>=count) then
error(coindexerror,index)
else
items^[index]:=item;
end;
procedure tcollection.delete(item : pointer);
begin
atdelete(indexof(item));
end;
procedure tcollection.deleteall;
begin
count:=0;
end;
procedure tcollection.error(code,info : longint);
begin
{ makes run error 213 and 214 }
runerror(212-code);
end;
function tcollection.firstthat(test : pointer) : pointer;
begin
{ sorry, but this doesn't work without asm }
asm
movl 12(%ebp),%ebx
{ !!!! load count }
movl 4(%esi),%ecx
leave
ret $4
end;
end;
procedure tcollection.foreach(action : pointer);
begin
{!!!!!}
end;
procedure tcollection.free(item : pointer);
begin
delete(item);
freeitem(item);
end;
procedure tcollection.freeall;
var
i : longint;
begin
for i:=0 to count-1 do
freeitem(items^[i]);
count:=0;
end;
procedure tcollection.freeitem(item : pointer);
begin
{!!!!!!! crashs the compiler
if assigned(item) then
dispose(pobject(item),done); }
end;
function tcollection.getitem(var s : tstream) : pointer;
begin
{!!!!!!!!}
end;
function tcollection.indexof(item : pointer) : longint;
var
i : longint;
begin
for i:=0 to count-1 do
begin
if items^[i]=item then
begin
indexof:=i;
exit;
end;
end;
indexof:=-1;
end;
procedure tcollection.insert(item : pointer);
begin
atinsert(count,item);
end;
function tcollection.lastthat(test : pointer) : pointer;
begin
{!!!!!!!}
end;
procedure tcollection.pack;
var
i : longint;
begin
while i<count do
begin
if items^[i]=nil then
atdelete(i)
else
inc(i);
end;
end;
procedure tcollection.putitem(var s : tstream;item : pointer);
begin
s.put(pobject(item));
end;
procedure tcollection.setlimit(alimit : longint);
begin
if alimit>count then
alimit:=count;
if alimit>maxcollectionsize then
alimit:=maxcollectionsize;
{!!!!!!!!}
end;
procedure tcollection.store(var s : tstream);
begin
end;
{****************************************************************************
TSORTEDCOLLECTION
****************************************************************************}
constructor tsortedcollection.load(var s : tstream);
begin
inherited load(s);
s.read(duplicates,1);
end;
function tsortedcollection.compare(key1,key2 : pointer) : integer;
begin
abstract;
end;
function tsortedcollection.indexof(item : pointer) : longint;
var
i : longint;
begin
indexof:=-1;
if search(keyof(item),i) then
begin
if duplicates then
begin
while (i<count) and
(compare(keyof(items^[i]),keyof(item))=0) do
begin
if items^[i]=item then
begin
indexof:=i;
exit;
end;
inc(i);
end;
end
else
begin
if items^[i]=item then
indexof:=-1;
end;
end;
end;
procedure tsortedcollection.insert(item : pointer);
begin
{!!!!!!}
end;
function tsortedcollection.keyof(item : pointer) : pointer;
begin
keyof:=item;
end;
function tsortedcollection.search(key : pointer;var index : longint) : boolean;
var
i : longint;
begin
end;
procedure tsortedcollection.store(var s : tstream);
begin
inherited store(s);
s.write(duplicates,1);
end;
{****************************************************************************
TSTRINGCOLLECTION
****************************************************************************}
function tstringcollection.compare(key1,key2 : pointer) : integer;
begin
if pstring(key1)^<pstring(key2)^ then
compare:=-1
else if pstring(key1)^>pstring(key2)^ then
compare:=1
else
compare:=0;
end;
procedure tstringcollection.freeitem(item : pointer);
begin
disposestr(pstring(item));
end;
function tstringcollection.getitem(var s : tstream) : pointer;
begin
getitem:=s.readstr;
end;
procedure tstringcollection.putitem(var s : tstream;item : pointer);
begin
s.writestr(pstring(item));
end;
{****************************************************************************
TRESOURCECOLLECTION
****************************************************************************}
type
presourceindexitem = ^tresourceindexitem;
tresourceindexitem = record
name : pstring;
pos : longint;
end;
procedure tresourcecollection.freeitem(item : pointer);
begin
disposestr(presourceindexitem(item)^.name);
dispose(presourceindexitem(item));
end;
function tresourcecollection.getitem(var s : tstream) : pointer;
var
p : presourceindexitem;
begin
new(p);
p^.name:=s.readstr;
s.read(p^.pos,sizeof(p^.pos));
getitem:=p;
end;
function tresourcecollection.keyof(item : pointer) : pointer;
begin
keyof:=presourceindexitem(item)^.name;
end;
procedure tresourcecollection.putitem(var s : tstream;item : pointer);
begin
s.writestr(presourceindexitem(item)^.name);
s.write(presourceindexitem(item)^.pos,
sizeof(presourceindexitem(item)^.pos));
end;
end.
