On Tue, 27 May 1997, Peter Gerwinski wrote:

...

If the VMT offset given is the same as the called constructor, then it is the first constructor called and the object is initialized. If the VMT parameter isn't the same as the called constructor, it is because it is being called from within another constructor and hence the object is already initialized. This is actually easy! ;-)

Sorry, but I don't understand this (perhaps it's too easy for me;). How can the VMT offset be the same as a constructor? AFAIK, BP passes a VMT offset of zero to constructors which shall *not* initialize an object.

Hmm... Maybe you're right, it's been a few months since I booted DOS to check this out... ;-) As far as I remember, it works like this:

o The code generated by New(TThatObject, Init) calls TThatObject.Init with TThatObject's VMT link and nil as the Self parameter. o TThatObject.Init does a "inherited Init", and since it is descended from TObject, it calls TObject.Init, with TThatObject's VMT link again and the correct Self parameter. TObject's Init constructor knows it doesn't need to allocate memory since there Self isn't nil and doesn't initialize the VMT of the instance since the VMT link parameter passed is TThatObject's VMT link, not his own.

But you could very well be right regarding the VMT offset passed, it would achieve the very same thing, and passing zero would indeed be simpler.

...

This doesn't give much information about the object apart from its size and the number of methods and where they are... What we'd need is something like from which class is another class derived from, its name, and so on...

So we should extend the VMT. Okay, why not ...

BTW, somebody knows a reasonable way how to implement multiple inheritance?

I strongly advises *agains't* multiple inheritance. It is the OOP 'goto' equivalent. Everything MI can do, you can do without MI if you design well. C++ is the bloated monster we know today in part because of that pseudo-feature. Neither Modula-3 or Oberon has multiple inheritance and both have been used in programming operating systems and huges projects.

...

Hmm... Is it possible to have a function automatically generated by the compiler before going to the optimizing stage? It would contain a table translating VMT pointers into strings of the classes name

No problem.

...

and would be optimized out of the program by the optimizer if unused, right?

True for a Program, false for a Unit. While the GPC compiler is *much* smarter than BP and would remove unused code and variables, the GNU linker is not able to remove dead code, it only does so if a whole Unit is unused.

Could this compiler generated function be generated in the program? Then it would be optimized out if unused? On the other hand, maybe we should do differently. In BP, there is a switch to have object symbols in for the object browser. It is separate from the debugging symbol switch. Maybe we could have a switch to have the object names and parent/childs informations included, which the ClassName() and others functions would consult. If the information isn't there, the ClassName() function would return "Unknown", an empty string or something similar... This information could be included in the VMT? This is more for you to decide... :-)

...

What I mean is (for example) a NewObject() function that would work just like New(), but instead of a typed pointer or an object type itself, it would take a VMT pointer as the first parameter. It would make the construction of an object from a stream as simple as calling "Get:=NewObject(TStreamRec.VMTLink, Load(@Self));" at the end of the TStream.Get method.

It should not be difficult to implement this using `GetMem' and an explicit assignment to `TypeOf'.

I think you are right, and anyway, thinking more about this, NewObject() would be very difficult to implement correctly. And whatever we do, we'll have to know the address of the Load constructor anyway (just like with the BP registration system). Unless it is virtual. I think *my* object library will have a virtual Load method (which won't be a constructor). Ok, can you give me an example of how to create an instance of a type specified by TypeOf? Would probably look like this:

function TStream.Get: PObject; var ObjID: word; VMTLink: pointer; LoadPtr: pointer; P: PObject; begin { here some code to read the ObjID and fetch the corresponding VMTLink. } GetMem(P, word(VMTLink^)); TypeOf(P):=VMTLink; { call the LoadPtr constructor, how do I do this correctly? } { With @Self as the 'normal' parameter of course... } end;

Hmm... One thing I think isn't very clean is the way TypeOf() works "in reverse"... It is *very* peculiar IMHO to set a value to a function! Maybe more something like SetTypeOf(P, VMTLink)? ;-) Attached to this message is the OBJECTS.PAS that goes with FPK-Pascal... Take a look at TObject and TStream.Get implementations...

...

BTW, how does New() work when it is passed an object type (say, PObject) as the first parameter?

The compiler picks up the (constant) size of the object, calls `GetMem', initializes the VMT field and finally calls the constructor. (In BP, the value for the VMT field is passed to the constructor which does the assignment, but I see no reason for that.)

So a constructor does *NOTHING* more than a normal procedure? Umm... What is the interest in a constructor then? :-)

Pierre Phaneuf

"The use of COBOL cripples the mind; its teaching should, therefore, be regarded as a criminal offense." - Edsger W. Dijkstra.

{****************************************************************************

This is a source file of FreeVision

parts copyright (c) 1992,96 by Florian Klaempfl

fnklaemp@cip.ft.uni-erlangen.de

parts copyright (c) 1996 by Frank ZAGO

zago@ecoledoc.ipc.fr

parts copyright (c) 1995 by MH Spiegel

This code is freeware

****************************************************************************}

{ History:

3/10/1996 Version 0.1

- first implementation

3/15/1996

- some suggestions of Frank Zago implemented

- tcollection is full implemented

3/17/1996

- interface for string lists implemented

- tstringlist und tstrlistmaker are implemented

}

{$E-}

{$define NOEXCEPTIONS}

{$define SSTRING}

unit objects;

interface

const

{ GO32 supports 128 MB data }

maxcollectionsize = (128*1024*1024-1) div sizeof(pointer);

coindexerror = -1;

cooverflow = -2;

vmtheadersize = 12;

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;

{ only for compatibality, we do this in an other way ... }

tstrindexrec = record

key,count,offset : longint;

end;

tstrindex = array[0..9999] of tstrindexrec;

pstrindex = ^tstrindex;

{ ... we use a tree, this needs more memory }

{ this fragments the heap, but there is enough space }

{ and it's very flexible }

pstrindexnode = ^tstrindexnode;

tstrindexnode = record

s : pstring;

key : longint;

left,right : pstrindexnode;

end;

pstringlist = ^tstringlist;

tstringlist = object(tobject)

root : pstrindexnode;

constructor load(var s : tstream);

constructor init(astrsize,aindexsize : longint);

destructor done;virtual;

function get(key : longint) : string;

procedure put(key : longint;str : pstring);

procedure put(key : longint;const s : string);

procedure store(var s : tstream);

end;

{ for backward compatibility }

pstrlistmaker = pstringlist;

tstrlistmaker = tstringlist;

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;

{ !!!!!!!

vmtlink : typeof(tcollection)

load : @tcollection.load;

store : @tcollection.store;

next : pointer;

}

);

rstringcollection : tstreamrec = (

objtype : 51;

{!!!!!!!}

);

rstringlist : tstreamrec = (

objtype : 52;

{!!!!!!!}

);

rstrlistmaker : tstreamrec = (

objtype : 52;

{!!!!!!!}

);

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 }

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;

if alimit<0 then

error(coindexerror,alimit);

{ in my opinion, this test is never need }

if alimit>maxcollectionsize then

alimit:=maxcollectionsize;

getmem(items,alimit*sizeof(pointer));

count:=0;

limit:=alimit;

delta:=adelta;

end;

constructor tcollection.load(var s : tstream);

var

i : longint;

begin

s.read(count,sizeof(count));

s.read(limit,sizeof(limit));

s.read(delta,sizeof(delta));

getmem(items,limit*sizeof(pointer));

for i:=0 to count-1 do

items^[i]:=getitem(s);

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

begin

{ delete the item (the memory the item occupies isn't freed) }

dec(count);

{ system.move tests for zero count }

move(items^[index+1],items^[index],

(count-index)*sizeof(pointer));

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

if (index>count) or (index<0) then

error(coindexerror,index)

else

begin

if count=limit then

setlimit(limit+delta);

{ verify that limit has changed }

if count=limit then

error(cooverflow,index)

else

begin

{ copy old items, count is tested by move }

move(items^[index],

items^[index+1],(count-index)*sizeof(pointer));

inc(count);

items^[index]:=item;

end;

end;

end;

procedure tcollection.atput(index : longint;item : pointer);

begin

if (index<0) or (index>=count) then

error(coindexerror,index)

else

{ replace the item in the collection,

but don't delete it from memory }

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 do_proc_call(proc : pointer;item : pointer) : boolean;

{ sorry, but this doesn't work without asm }

begin

asm

// push item

pushl 12(%ebp)

// load %ebp of tcollection.firstthat

movl (%ebp),%eax

// load %ebp of caller of firstthat or foreach

movl (%eax),%eax

// push this %ebp

pushl %eax

// load pointer to procedure

movl 8(%ebp),%eax

// do the call

call (%eax)

leave

ret $8

end;

end;

function tcollection.firstthat(test : pointer) : pointer;

var

i : longint;

begin

for i:=0 to count-1 do

begin

if do_proc_call(test,items^[i]) then

begin

firstthat:=items^[i];

exit;

end;

end;

firstthat:=nil;

end;

procedure tcollection.foreach(action : pointer);

var

i : longint;

begin

for i:=0 to count-1 do

do_proc_call(action,items^[i]);

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);

var

p : pobject;

begin

{ direct conversation crashes the compiler }

p:=pobject(item);

if assigned(item) then

dispose(p,done);

end;

function tcollection.getitem(var s : tstream) : pointer;

begin

getitem:=s.get;

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;

var

i : longint;

begin

for i:=count-1 downto 0 do

begin

if do_proc_call(test,items^[i]) then

begin

lastthat:=items^[i];

exit;

end;

end;

lastthat:=nil;

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);

var

p : pitemlist;

begin

{ Resize alimit }

if alimit<count then

alimit:=count;

if alimit>maxcollectionsize then

alimit:=maxcollectionsize;

if alimit<>limit then

begin

{ Create a new array }

getmem(p,alimit*sizeof(pointer));

{ Copie the datas }

move(items^,p^,count*sizeof(Pointer));

{ Delete the old array }

freemem(items,sizeof(pointer)*limit);

{ Initialise the new array }

items:=p;

limit:=alimit;

end;

end;

procedure tcollection.store(var s : tstream);

var

i : longint;

begin

s.write(count,sizeof(count));

s.write(limit,sizeof(limit));

s.write(delta,sizeof(delta));

for i:=0 to count-1 do

putitem(s,items^[i]);

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);

var

pos : longint;

b : boolean;

begin

b:=search(keyof(item),pos);

if not(b) or duplicates then

atinsert(pos,item);

end;

function tsortedcollection.keyof(item : pointer) : pointer;

begin

keyof:=item;

end;

function tsortedcollection.search(key : pointer;var index : longint) : boolean;

var

x,l,r : longint;

begin

l:=0;

x:=0;

r:=count-1;

if count>0 then

repeat

x:=(l+r) div 2;

if compare(key,keyof(items^[x]))<0 then

r:=x-1

else

l:=x+1;

until (compare(key,keyof(items^[x]))=0) or (l>r);

if compare(key,keyof(items^[x]))=0 then

begin

if duplicates then

while (x>0) and (compare(key,keyof(items^[x-1]))=0) do

dec(x);

index:=x;

search:=true;

end

else

begin

index:=l;

search:=false;

end;

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

{ !!!! do this better }

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;

{****************************************************************************

TSTRINGLIST

****************************************************************************}

constructor tstringlist.init(astrsize,aindexsize : longint);

begin

inherited init;

{ root is been set to zero by tobject.init! }

end;

constructor tstringlist.load(var s : tstream);

var

p : pstring;

count,i,k : longint;

begin

s.read(count,sizeof(longint));

for i:=1 to count do

begin

s.read(k,sizeof(longint));

p:=s.readstr;

put(k,p);

end;

end;

destructor tstringlist.done;

procedure delete(p : pstrindexnode);

begin

if assigned(p) then

begin

disposestr(p^.s);

delete(p^.left);

delete(p^.right);

end;

end;

begin

delete(root);

end;

function tstringlist.get(key : longint) : string;

var

s : pstring;

function search(p : pstrindexnode) : boolean;

begin

if assigned(p) then

begin

if p^.key=key then

begin

search:=true;

s:=p^.s;

end

else if key>p^.key then

search:=search(p^.right)

else

search:=search(p^.left);

end

else

search:=false;

end;

begin

if search(root) then

get:=s^

else

get:='';

end;

procedure tstringlist.put(key : longint;str : pstring);

function insert(var p : pstrindexnode) : boolean;

begin

if assigned(p) then

begin

if p^.key=key then

insert:=false

else if key>p^.key then

insert:=insert(p^.right)

else

insert:=insert(p^.left);

end

else

begin

insert:=true;

new(p);

p^.left:=nil;

p^.right:=nil;

p^.s:=str;

p^.key:=key;

end;

end;

begin

if not(insert(root)) then

disposestr(str);

end;

procedure tstringlist.put(key : longint;const s : string);

begin

put(key,newstr(s));

end;

procedure tstringlist.store(var s : tstream);

procedure write(p : pstrindexnode);

begin

if assigned(p) then

begin

s.write(p^.key,sizeof(longint));

s.writestr(p^.s);

write(p^.left);

write(p^.right);

end;

end;

begin

write(root);

end;

end.