Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/OOF20.ZIP/DEMO.PAS

Pascal/Delphi Source File | 1987-09-19 | 5.9 KB | 219 lines

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<n+n then n := i shr 1 + 1;
    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.