Category : Pascal Source Code
Archive   : OOF20.ZIP
Filename : DEMO.PAS

program Demo;
{ Version 2.0 87/09/19

Example of Object Oriented Programming in TURBO Pascal.

Author: Mike Babulic
3827 Charleswood Drive N.W.
Calgary, Alberta
CANADA
T2L 2C7

Compuserve Id.: 72307,314


This program demonstrates how to use OOF.INC to extend (or "Fudge")
Turbo Pascal to include Object Oriented Programming concets.
}



{------------------------- Debugging Tools ----------------------------------}

type str255 = string[255];

procedure WAIT;
var c : Char;
begin
writeln; writeln('Press any key ...');
repeat until keypressed;
gotoXY(1,whereY-1);
{ ClrScr;}
end;

procedure w(s:str255);
begin
writeln('DEBUG -- ',s);
wait;
end;

procedure stack(n:integer);
var s : array [-1..-1] of integer absolute n;
i : integer;
begin
i := 2-ofs(n);
write('SP = ',-i,' => ');
if i < 0 then i := 0;
if i for i := 1 to n do write(s[i],' /');
writeln;
end;


procedure PC(n:integer); {call to pc is 13 bytes}
var s : array [0..0] of integer absolute n;
i : integer;
begin
i := -1;
writeln('PC = ',s[i]+n);
end;


{----------------------------------------------------------------------------}


{$I OOF.INC} {Import Object Programming routines}


{---------------------- This Class counts by 1 ------------------------}



TYPE TOnesees = record

parent : TObject;

value : Integer;

end;

{MESSAGES}


procedure Assign(x:integer; var self); begin Message(0); end;


function Equals(var self):integer; begin Message(3); end;



procedure Up(var self); begin Message(6); end;

{METHODS}



procedure TOnesees_Assign(x:integer; var self:TOnesees); forward;


function TOnesees_Equals(var self:TOnesees):integer; forward;


procedure TOnesees_Up(var self:TOnesees); forward;

function TOnesees_GetParent(var self:Class):Class; forward; {CLASS METHOD}

{DISPATCHER}



procedure COnesees(message,no:integer);
begin
if (message>=ofs(assign)) and (message<=ofs(Up)) then
DoMethod(ofs(TOnesees_assign)+no)
else if message=ofs(GetParent) then
DoMethod(ofs(TOnesees_GetParent))
else
DoParent(ofs(cObject)); {Faster Compile}
{should never get here}
stack(10);
writeln(' eek! ',ofs(assign),', ',message);
halt
end;

{IMPLEMENTATION}



procedure TOnesees_Assign{x:integer; var self:TOnesees};
begin with self do begin

value := x;

end end;



function TOnesees_Equals{var self:TOnesees):integer};
begin with self do begin

TOnesees_Equals := value;

end end;



procedure TOnesees_Up{var self:TOnesees};
begin with self do begin

value := value + 1;

end end;

function TOnesees_GetParent{var self:Class):Class; (CLASS METHOD};
begin
TOnesees_GetParent := ofs(CObject);
end;



{---------------------- This Class counts by 2 ----------------------------}



TYPE TTwosees = TOnesees;

{METHODS} {ok, ok ... so I cheated a little, this bit is small enough!!!}


procedure TTwosees_Up(var self: TTwosees); {OVERRIDE METHOD so no message}

begin with self do begin
value := value + 2;

end end;

function TTwosees_GetParent(var self:Class):Class; {CLASS METHOD}
begin
TTwosees_GetParent := ofs(COnesees);
end;



{DISPATCHER}



procedure CTwosees(message,no:integer);

begin
if message=ofs(Up) then {OVERRIDE METHOD}
DoMethod(ofs(TTwosees_Up))
else if message=ofs(GetParent) then
DoMethod(ofs(TTwosees_GetParent))
else
DoParent(ofs(COnesees));
end;




{----------------------------------------------------------------------------}




VAR

a: TOnesees;
b: TTwosees;

begin

ClrScr;
writeln('----------------------- Initialization ------------------------');


writeln;
writeln('Notice that OOF uses the STACK and NOT THE HEAP to store objects.');
writeln(' This is unlike most object oriented programming systems. They');
writeln(' are almost always heap based.');
writeln;
writeln('Why is OOF stack based? Well, I''m not just being ornery ...');
writeln;
writeln(' 1) Garbage collection - this is trivial (and extremely fast)');
writeln(' with stack-based objects.');
writeln;
writeln(' 2) Safety - a programmer using Object Pascal must dispose of ');
writeln(' (and C++ programmes must free) objects when they are finished');
writeln(' with them. This creates a danger of DANGLING POINTERS.');
writeln;
writeln(' 3) Appropriate Model - the vast majority of objects are created by the');
writeln(' method that uses them. Why complicate things with a handle in');
writeln(' the stack AND an object in the heap?');
writeln;


SetClass(a,ofs(COnesees));

SetClass(b,ofs(CTwosees));

WAIT;
writeln('-- Count by 1 --------- ONEsees Class -------------------------');
writeln;

Assign(0,a);


Up(a); write(Equals(a),', ');

Up(a); write(Equals(a),', ');

Up(a); write(Equals(a));
writeln;

writeln;
writeln('GetParent(a)=ofs(CObject) is ',GetParent(a)=ofs(CObject));
writeln;

WAIT;
writeln('-- Count by 2 --------- TWOsees Class ------------------------');
writeln;



Assign(0,b);



Up(b); write(Equals(b),', ');

Up(b); write(Equals(b),', ');

Up(b); write(Equals(b),', ');
writeln;

writeln;
writeln('GetParent(b)=ofs(COnesees) is ',GetParent(b)=ofs(COnesees));

end.