home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / OOF20.ZIP / DEMO.PAS next >
Encoding:
Pascal/Delphi Source File  |  1987-09-19  |  5.9 KB  |  219 lines

  1. program Demo;
  2. {                          Version 2.0                        87/09/19
  3.  
  4.   Example of Object Oriented Programming in TURBO Pascal.
  5.  
  6.   Author:   Mike Babulic
  7.             3827 Charleswood Drive N.W.
  8.             Calgary, Alberta
  9.             CANADA
  10.             T2L 2C7
  11.  
  12.             Compuserve Id.:  72307,314
  13.  
  14.  
  15. This program demonstrates how to use OOF.INC to extend (or "Fudge")
  16. Turbo Pascal to include Object Oriented Programming concets.
  17.  }
  18.  
  19.  
  20.  
  21. {------------------------- Debugging Tools ----------------------------------}
  22.  
  23. type str255 = string[255];
  24.  
  25. procedure WAIT;
  26.   var c : Char;
  27.   begin
  28.     writeln; writeln('Press any key ...');
  29.     repeat until keypressed;
  30.     gotoXY(1,whereY-1);
  31. {    ClrScr;}
  32.   end;
  33.  
  34. procedure w(s:str255);
  35.   begin
  36.     writeln('DEBUG -- ',s);
  37.     wait;
  38.   end;
  39.  
  40. procedure stack(n:integer);
  41.   var s : array [-1..-1] of integer absolute n;
  42.       i : integer;
  43.   begin
  44.     i := 2-ofs(n);
  45.     write('SP = ',-i,' => ');
  46.     if i < 0 then i := 0;
  47.     if i<n+n then n := i shr 1 + 1;
  48.     for i := 1 to n do write(s[i],' /');
  49.     writeln;
  50.   end;
  51.  
  52.  
  53. procedure PC(n:integer); {call to pc is 13 bytes}
  54.   var s : array [0..0] of integer absolute n;
  55.       i : integer;
  56.   begin
  57.      i := -1;
  58.      writeln('PC = ',s[i]+n);
  59.   end;
  60.  
  61.  
  62. {----------------------------------------------------------------------------}
  63.  
  64.  
  65. {$I OOF.INC}      {Import Object Programming routines}
  66.  
  67.  
  68. {---------------------- This Class counts by 1 ------------------------}
  69.  
  70.  
  71.  
  72. TYPE    TOnesees = record
  73.  
  74.           parent    : TObject;
  75.  
  76.           value     : Integer;
  77.  
  78.           end;
  79.  
  80. {MESSAGES}
  81.  
  82.  
  83.     procedure Assign(x:integer; var self);      begin Message(0); end;
  84.  
  85.  
  86.     function Equals(var self):integer;          begin Message(3); end;
  87.  
  88.  
  89.  
  90.     procedure Up(var self);                     begin Message(6); end;
  91.  
  92. {METHODS}
  93.  
  94.  
  95.  
  96.     procedure TOnesees_Assign(x:integer; var self:TOnesees);  forward;
  97.  
  98.  
  99.     function TOnesees_Equals(var self:TOnesees):integer;  forward;
  100.  
  101.  
  102.     procedure TOnesees_Up(var self:TOnesees);  forward;
  103.  
  104.     function TOnesees_GetParent(var self:Class):Class;  forward; {CLASS METHOD}
  105.  
  106. {DISPATCHER}
  107.  
  108.  
  109.  
  110.     procedure COnesees(message,no:integer);
  111.       begin
  112.         if (message>=ofs(assign)) and (message<=ofs(Up)) then
  113.           DoMethod(ofs(TOnesees_assign)+no)
  114.         else if message=ofs(GetParent) then
  115.           DoMethod(ofs(TOnesees_GetParent))
  116.         else
  117.           DoParent(ofs(cObject)); {Faster Compile}
  118.         {should never get here}
  119.           stack(10);
  120.           writeln(' eek! ',ofs(assign),', ',message);
  121.           halt
  122.       end;
  123.  
  124. {IMPLEMENTATION}
  125.  
  126.  
  127.  
  128.     procedure TOnesees_Assign{x:integer; var self:TOnesees};
  129.       begin with self do begin
  130.  
  131.         value := x;
  132.  
  133.       end  end;
  134.  
  135.  
  136.  
  137.     function TOnesees_Equals{var self:TOnesees):integer};
  138.       begin with self do begin
  139.  
  140.         TOnesees_Equals := value;
  141.  
  142.       end  end;
  143.  
  144.  
  145.  
  146.     procedure TOnesees_Up{var self:TOnesees};
  147.       begin with self do begin
  148.  
  149.         value := value + 1;
  150.  
  151.       end  end;
  152.  
  153.     function TOnesees_GetParent{var self:Class):Class;  (CLASS METHOD};
  154.       begin
  155.         TOnesees_GetParent := ofs(CObject);
  156.       end;
  157.  
  158.  
  159.  
  160. {---------------------- This Class counts by 2 ----------------------------}
  161.  
  162.  
  163.  
  164. TYPE    TTwosees = TOnesees;
  165.  
  166. {METHODS}  {ok, ok ... so I cheated a little, this bit is small enough!!!}
  167.  
  168.  
  169.     procedure TTwosees_Up(var self: TTwosees);  {OVERRIDE METHOD so no message}
  170.  
  171.       begin with self do begin
  172.         value := value + 2;
  173.  
  174.       end  end;
  175.  
  176.     function TTwosees_GetParent(var self:Class):Class; {CLASS METHOD}
  177.       begin
  178.         TTwosees_GetParent := ofs(COnesees);
  179.       end;
  180.  
  181.  
  182.  
  183. {DISPATCHER}
  184.  
  185.  
  186.  
  187.     procedure CTwosees(message,no:integer);
  188.  
  189.       begin
  190.         if message=ofs(Up) then  {OVERRIDE METHOD}
  191.           DoMethod(ofs(TTwosees_Up))
  192.         else if message=ofs(GetParent) then
  193.           DoMethod(ofs(TTwosees_GetParent))
  194.         else
  195.           DoParent(ofs(COnesees));
  196.       end;
  197.  
  198.  
  199.  
  200.  
  201. {----------------------------------------------------------------------------}
  202.  
  203.  
  204.  
  205.  
  206. VAR
  207.  
  208.     a: TOnesees;
  209.     b: TTwosees;
  210.  
  211. begin
  212.  
  213.   ClrScr;
  214.   writeln('----------------------- Initialization ------------------------');
  215.  
  216.  
  217.   writeln;
  218.   writeln('Notice that OOF uses the STACK and NOT THE HEAP to store objects.');
  219.   writeln('  This is unlike most object oriented programming systems. They');
  220.   writeln('  are almost always heap based.');
  221.   writeln;
  222.   writeln('Why is OOF stack based? Well, I''m not just being ornery ...');
  223.   writeln;
  224.   writeln('      1) Garbage collection - this is trivial (and extremely fast)');
  225.   writeln('              with stack-based objects.');
  226.   writeln;
  227.   writeln('      2) Safety - a programmer using Object Pascal must dispose of ');
  228.   writeln('              (and C++ programmes must free) objects when they are finished');
  229.   writeln('              with them. This creates a danger of DANGLING POINTERS.');
  230.   writeln;
  231.   writeln('      3) Appropriate Model - the vast majority of objects are created by the');
  232.   writeln('              method that uses them. Why complicate things with a handle in');
  233.   writeln('              the stack AND an object in the heap?');
  234.   writeln;
  235.  
  236.  
  237.   SetClass(a,ofs(COnesees));
  238.  
  239.   SetClass(b,ofs(CTwosees));
  240.  
  241.   WAIT;
  242.   writeln('-- Count by 1 --------- ONEsees Class -------------------------');
  243.   writeln;
  244.  
  245.   Assign(0,a);
  246.  
  247.  
  248.   Up(a); write(Equals(a),', ');
  249.  
  250.   Up(a); write(Equals(a),', ');
  251.  
  252.   Up(a); write(Equals(a));
  253.   writeln;
  254.  
  255.   writeln;
  256.   writeln('GetParent(a)=ofs(CObject) is ',GetParent(a)=ofs(CObject));
  257.   writeln;
  258.  
  259.   WAIT;
  260.   writeln('-- Count by 2 --------- TWOsees Class ------------------------');
  261.   writeln;
  262.  
  263.  
  264.  
  265.   Assign(0,b);
  266.  
  267.  
  268.  
  269.   Up(b); write(Equals(b),', ');
  270.  
  271.   Up(b); write(Equals(b),', ');
  272.  
  273.   Up(b); write(Equals(b),', ');
  274.   writeln;
  275.  
  276.   writeln;
  277.   writeln('GetParent(b)=ofs(COnesees) is ',GetParent(b)=ofs(COnesees));
  278.  
  279. end.