home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / PASTUT34 / HEAPLIST.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-03  |  4KB  |  152 lines
  1. {$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,R-,S+,V+,X-}
  2. {$M 4096,0,20000}
  3.  
  4. program HeapList;
  5.  
  6. {~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
  7. { The program demonstrates the creation of a single linked list of  }
  8. { records on the Heap, using pointers. The user is invited to enter }
  9. { the name, as a string[15], and price in pence, as an integer, for }
  10. { three items, which form the linked list.                          }
  11. {                                                                   }
  12. { HEAPLIST.PAS  ->  .EXE       R Shaw           2.12.92             }
  13. {___________________________________________________________________}
  14.  
  15. Uses  Crt, Dos, Graph, hex;
  16.  
  17. Type
  18.    PItem = ^ TItem;
  19.    TItem = record
  20.      Name     : string[15];
  21.      Price    : integer;
  22.      NextItem : PItem;
  23.    End;
  24.  
  25. Var
  26.    InName                        : string[15];
  27.    InPrice                       : integer;
  28.    FirstItem, LastItem, ThisItem : PItem;
  29.    i                             : integer;
  30.    HeapOrgSeg,HeapOrgOfs         : word;
  31.    HeapOrgSegX,HeapOrgOfsX       : string;
  32.    HeapPtrSeg,HeapPtrOfs         : word;
  33.    HeapPtrSegX,HeapPtrOfsX       : string;
  34.    HeapOrg                       : ^integer;
  35.  
  36. Procedure InitPointers;
  37. begin
  38.    FirstItem := Nil;
  39.    LastItem  := Nil;
  40. end;
  41.  
  42. Procedure ListAdd(AddName: string; AddPrice: integer);
  43. begin
  44.    New(ThisItem);
  45.    ThisItem^.Name := AddName;
  46.    ThisItem^.Price := AddPrice;
  47.    ThisItem^.NextItem := Nil;
  48.    If LastItem <> Nil then LastItem^.NextItem := ThisItem;
  49.    LastItem := ThisItem;
  50.    If FirstItem = Nil then FirstItem := LastItem;
  51. end;
  52.  
  53. Procedure ListDataIn;
  54. begin
  55.    Window(1,1,80,25);
  56.    writeln('Please enter the name [15 characters maximum], followed by ENTER, then price');
  57.    writeln('in pence [integer] followed by ENTER, when requested in table of 3 items below:');
  58.    writeln;
  59.    writeln('Item No.      Item name        Item Price');
  60.    writeln;
  61.    For i := 1 to 3 do
  62.    begin
  63.       GotoXY(4,5 + i);
  64.       write(i);
  65.       {$I-}
  66.       Repeat
  67.          GotoXY(15,5 + i);
  68.          ClrEol;
  69.          read(InName);
  70.       until IOResult = 0;
  71.       Repeat
  72.          GotoXY(32,5 + i);
  73.          ClrEol;
  74.          readln(InPrice);
  75.       until IOResult = 0;
  76.       {$I+}
  77.       ListAdd(InName,InPrice);
  78.    end;
  79. end;
  80.  
  81. Procedure HeapOrgCheck;
  82. begin
  83.  
  84.    Mark(HeapOrg);
  85.    HeapOrgSeg := seg(HeapOrg^);
  86.    HeapOrgOfs := ofs(HeapOrg^);
  87.    for i := HeapOrgOfs to (HeapOrgOfs + 1000) do Mem[HeapOrgSeg:i] := 0;
  88.    dec2hex(HeapOrgSeg,HeapOrgSegX);
  89.    dec2hex(HeapOrgOfs,HeapOrgOfsX);
  90. end;
  91.  
  92. Procedure HeapPtrCheck;
  93. begin
  94.    HeapPtrSeg := seg(HeapPtr^);
  95.    HeapPtrOfs := ofs(HeapPtr^);
  96.    dec2hex(HeapPtrSeg,HeapPtrSegX);
  97.    dec2hex(HeapPtrOfs,HeapPtrOfsX);
  98.    writeln;
  99.    Writeln('CHECK OF MEMORY FOR A SINGLE-LINKED LIST OF ITEMS.');
  100.    Writeln;
  101.    write('HeapOrg:    ',HeapOrgSegX,':',HeapOrgOfsX,'     ');
  102.    writeln('HeapPtr:    ',HeapPtrSegX,':',HeapPtrOfsX);
  103.    writeln;
  104. end;
  105.  
  106. Procedure MemoryCheck;
  107.  
  108. Function DebugPath : Pathstr;
  109.  
  110. var
  111.   DPath : PathStr;
  112.  
  113. begin
  114.   DPath := '';
  115.   DPath := FSearch('DEBUG.EXE', GetEnv('PATH'));
  116.   If DPath = '' then DPath := FSearch('DEBUG.COM', GetEnv('PATH'));
  117.   If DPath = '' then
  118.      begin
  119.         writeln('DEBUG file not found. Please check your DOS system.');
  120.         writeln;
  121.         writeln('Press any key to continue: ');
  122.         repeat until keypressed;
  123.      end;
  124.   DebugPath := DPath;
  125. end;      {of Function DebugPath}
  126.  
  127.  
  128. begin
  129.    writeln('Please wait for prompt (-) of DOS Debug, now being called by Exec procedure.');
  130.    writeln('Then type D followed by a space and then the HeapOrg address (above) and ENTER.');
  131.    writeln('Finally, after studying the contents of memory, type Q and press ENTER to quit.');
  132.    writeln;
  133.    SwapVectors;
  134.    Exec(DebugPath,'');
  135.    If DosError <> 0 then writeln('Dos error # ',DosError);
  136.    SwapVectors;
  137. end;
  138.  
  139.  
  140. {Main}
  141.  
  142. begin
  143.    ClrScr;
  144.    InitPointers;
  145.    HeapOrgCheck;
  146.    ListDataIn;
  147.    HeapPtrCheck;
  148.    MemoryCheck;
  149.    Release(HeapOrg);
  150. end.
  151.  
  152.