home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / listings / v_01_03 / 1n03014a < prev    next >
Text File  |  1990-06-14  |  2KB  |  76 lines
  1.  
  2. Listing 7
  3.  
  4. function hexstr(w : word) : string;
  5. function ptrstr(p : pointer) : string;
  6.  
  7. function absaddr(p : pointer) : longint;
  8.         type
  9.                 pc = ^char;
  10.         begin
  11.         absaddr := seg(pc(p)^) * longint(16) + ofs(pc(p)^);
  12.         end;
  13.  
  14. const
  15.         FREELIST_MAX = 8191;
  16.  
  17. type
  18.         FreeRec =
  19.                 record
  20.                 OrgPtr, EndPtr : pointer;
  21.                 end;
  22.         FreeList = array [1 .. FREELIST_MAX] of FreeRec;
  23.         FreeListP = ^FreeList;
  24.  
  25. procedure in_heap(p : pointer);
  26.         var
  27.                 ec : byte;
  28.                 freecount, i : word;
  29.                 fp : FreeListP;
  30.                 ea_p, ea_org, ea_end : longint;
  31.         begin
  32.         ec := 0;
  33.         ea_p := absaddr(p);
  34.         if (ea_p < absaddr(HeapOrg))
  35.         or (ea_p >= absaddr(FreePtr)) then
  36.                 ec := 211
  37.         else
  38.                 begin
  39.                 fp := FreePtr;
  40.                 freecount := (FREELIST_MAX + 1 - ofs(fp^) div 8)
  41.                         mod (FREELIST_MAX + 1);
  42.                 i := 1;
  43.                 while (i <= freecount) and (ec = 0) do
  44.                         begin
  45.                         ea_org := absaddr(fp^[i].OrgPtr);
  46.                         ea_end := absaddr(fp^[i].EndPtr);
  47.                         if (ea_org <= ea_p) and (ea_p < ea_end) then
  48.                                 ec := 211;
  49.                         i := i + 1;
  50.                         end;
  51.                 end;
  52.         if ec <> 0 then
  53.                 runerror(ec);
  54.         end;
  55.  
  56. var
  57.         p1, p2, p3 : ^longint;
  58. begin
  59. new(p1);
  60. {$ifdef DEBUG} in_heap(p1); {$endif}
  61. p1^ := 1;
  62. p2 := p1;
  63. {$ifdef DEBUG} in_heap(p2); {$endif}
  64. p2^ := 2;
  65. new(p3);
  66. {$ifdef DEBUG} in_heap(p3); {$endif}
  67. p3^ := 3;
  68. dispose(p2);
  69. {$ifdef DEBUG} in_heap(p1); {$endif}
  70. p1^ := 1;
  71. writeln('p1 = ', ptrstr(p1), ', p1^ = ', p1^);
  72. writeln('p2 = ', ptrstr(p2), ', p2^ = ', p2^);
  73. writeln('p3 = ', ptrstr(p3), ', p3^ = ', p3^);
  74. end.
  75.  
  76.