Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/OOPTUT34.ZIP/OBCOMPAT.PAS

Pascal/Delphi Source File | 1993-06-14 | 6KB | 243 lines

{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,R-,S+,V+,X-}
{$M 16384,0,6000}
program object_compatability;

{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
{ Program to show dynamic objects and to illustrate the compatability    }
{ of descendant objects with ancestors. A simple database situation is   }
{ created with Surname and Forenames having a descendant, Address, which }
{ in turn has a descendant, Phone. As in the Borland program, LISTDEMO,  }
{ a Node record is created on the Heap and this points to the data item  }
{ and to the next Node record.                                           }
{ The program uses the Exec procedure to call DOS Debug to inspect the   }
{ data on the Heap.                                                      }
{                                                                        }
{ OBCOMPAT.PAS  ->  .EXE      R Shaw      2.11.92   and  22.11.92        }
{________________________________________________________________________}

uses Dos, Crt, Hexa;

type
   Str10 = string[10];
   Str15 = string[15];
   Str20 = string[20];
   Str30 = string[30];
   Str40 = string[40];

   PName = ^TName;
   TName = object
     Surname   : str20;
     Forenames : str40;
     Constructor Init(SName: str20; Fnames: str40);
     Destructor Done; virtual;
   end;

   PAddress = ^TAddress;
   TAddress = object(TName)
     Street   : str30;
     Town     : str20;
     County   : str20;
     PostCode : str10;
     Constructor Init(St: str30; T: str20; C: str20; Code: str10);
   end;

   PPhone = ^TPhone;
   TPhone = object(TAddress)
     Number   : string[15];
     Constructor Init(Num: str15);
   end;

   PNode = ^TNode;
   TNode = record
     Item: PName;
     Next: PNode;
   end;

   PList = ^TList;
   TList = object
     Nodes: PNode;
     constructor Init;
     destructor Done; virtual;
     procedure Add(Item: PName);
   end;

var
   HeapTop           : ^integer;
   SegHeap, OfsHeap  : word;
   SegHeapX,OfsHeapX : string;
   i                 : integer;
   ContactList       : TList;
   NamePtr           : PName;
   AddressPtr        : PAddress;
   PhonePtr          : PPhone;
   choice            : integer;
   Code              : Str10;
   Num               : Str15;
   SName,T,C         : Str20;
   FNames            : Str40;
   St                : Str30;
   reply             : char;

procedure InitData;
begin
   Code   := '';
   Num    := '';
   Sname  := '';
   Fnames := '';
   T      := '';
   C      := '';
   St     := '';
end;

Constructor TName.Init(SName: str20; Fnames: str40);
begin
   Surname := SName;
   Forenames := FNames;
end;

Constructor TAddress.Init(St: str30; T: str20; C: str20; Code: str10);
begin
   TName.Init(SName,FNames);
   Street   := St;
   Town     := T;
   County   := C;
   PostCode := Code;
end;

Constructor TPhone.Init(Num: str15);
begin
   TAddress.Init(St,T,C,Code);
   Number := Num;
end;

{--------------------------------------------------------}
{ TList's method implementations:                        }
{--------------------------------------------------------}

constructor TList.Init;
begin
  Nodes := nil;
end;

destructor TName.Done;
begin
end;

destructor TList.Done;
var
  N: PNode;
begin
  while Nodes <> nil do
  begin
    N := Nodes;
    Nodes := N^.Next;
    Dispose(N^.Item, Done);
    Dispose(N);
  end;
end;

procedure TList.Add(Item: PName);
var
  N: PNode;
begin
  New(N);
  N^.Item := Item;
  N^.Next := Nodes;
  Nodes := N;
end;


Function DebugPath : Pathstr;

var
  DPath : PathStr;

begin
  DPath := '';
  DPath := FSearch('DEBUG.EXE', GetEnv('PATH'));
  If DPath = '' then DPath := FSearch('DEBUG.COM', GetEnv('PATH'));
  If DPath = '' then
     begin
        writeln('DEBUG file not found. Please check your DOS system.');
        writeln;
        writeln('Press any key to continue: ');
        repeat until keypressed;
     end;
  DebugPath := DPath;
end;      {of Function DebugPath}


{Main}

begin
   ClrScr;
   Mark(HeapTop);
   SegHeap := Seg(HeapTop^);
   OfsHeap := Ofs(HeapTop^);
   SegHeapX := IntToHex(SegHeap);
   OfsHeapX := IntToHex(OfsHeap);
   For i := OfsHeap to (OfsHeap + 1000) do Mem[SegHeap:i] := 0;
   ContactList.Init;
   Repeat
   InitData;
   writeln;
   writeln('Please indicate type of entry by pressing the appropriate number key: ');
   writeln;
   writeln('   1  Names only');
   writeln('   2  Names and address');
   writeln('   3  Names and address and phone number');
   writeln;
   write('Please select now: ');
   repeat
     readln(choice);
   until choice in [1..3];
   writeln;
   write('Surname: ');
   readln(SName);
   write('Forenames: ');
   readln(FNames);
   writeln;
   if choice = 1 then
      begin
        NamePtr := New(PName,Init(SName,FNames));
        ContactList.Add(NamePtr);
      end;
   if (choice = 2) or (choice = 3) then
      begin
        write('Street: ');
        readln(St);
        write('Town: ');
        readln(T);
        write('County: ');
        readln(C);
        write('Code: ');
        readln(Code);
      end;
   if choice = 2 then
      begin
        AddressPtr := New(PAddress,Init(St,T,C,Code));
        ContactList.Add(AddressPtr);
      end;
   if choice = 3 then
      begin
        write('Phone Number: ');
        readln(Num);
        PhonePtr := New(PPhone,Init(Num));
        ContactList.Add(PhonePtr);
      end;
   writeln;
   write('Press C to continue or Q to quit: ');
   reply := readkey;
   until UpCase(reply) = 'Q';
   writeln;
   writeln('HeapTop address is ',SegHeapX,':',OfsHeapX);
   writeln;
   writeln('DOS Debug now entered from program by means of Exec procedure.');
   writeln('Please type D followed by a space and then the HeapOrg address, as above.');
   writeln('Then continue to type D until end of collection. Then type Q.');
   SwapVectors;
   Exec(DebugPath,'');
   If DosError <> 0 then writeln('Dos error # ',DosError);
   SwapVectors;
   ContactList.Done;
end.