home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Libraries / PNL Libraries / MyMemory.p < prev    next >
Encoding:
Text File  |  1995-10-22  |  3.5 KB  |  170 lines  |  [TEXT/CWIE]
  1. unit MyMemory;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types;
  7.  
  8.     function MNewPtr (var p: univ ptr; size: longint): OSErr;
  9.     function MNewHandle (var hhhh: univ handle; size: longint): OSErr;
  10.     function MSetPtrSize (var p: univ ptr; size: longint): OSerr;
  11.     function MSetHandleSize (var hhhh: univ handle; size: longint): OSerr;
  12.     procedure MDisposePtr (var p: univ ptr);
  13.     procedure MDisposeHandle (var hhhh: univ handle);
  14.     procedure MZero (p: univ ptr; size: longint);
  15.     procedure MFill (p: univ ptr; size: longint; val: integer);
  16.     procedure MFillLong (p: univ ptr; size: longint; val: longint);
  17. { ptr and size must be long alligned }
  18.     procedure LockHigh (hhhh: univ handle);
  19.     procedure HLockState (hhhh: handle; var state: SignedByte);
  20.     procedure HUnlockState (hhhh: handle; var state: SignedByte);
  21.     procedure TrashPtr (data: Ptr);
  22.     procedure TrashHandle (hhhh: handle);
  23.  
  24. implementation
  25.  
  26.     uses
  27.         Memory;
  28.  
  29. {$SETC debug_memory=0 }
  30.  
  31.     const
  32.         fill_byte = $E5; { odd, big, negative, easily recognizable }
  33.  
  34.     function CheckPtr (p: ptr): boolean;
  35.     begin
  36. {$IFC debug_memory }
  37.         if p = nil then begin
  38.             DebugStr('Memory Error!');
  39.         end;
  40. {$ENDC}
  41.         CheckPtr := p <> nil;
  42.     end;
  43.  
  44.     function MNewPtr (var p: univ ptr; size: longint): OSErr;
  45.         var
  46.             err: OSErr;
  47.     begin
  48.         p := NewPtr(size);
  49.         err := MemError;
  50. {$IFC debug_memory }
  51.         if (err = noErr) then begin
  52.             MFill(p, GetPtrSize(p), fill_byte);
  53.         end;
  54. {$ENDC}
  55.         MNewPtr := err;
  56.     end;
  57.  
  58.     function MNewHandle (var hhhh: univ handle; size: longint): OSErr;
  59.         var
  60.             err: OSErr;
  61.     begin
  62.         hhhh := NewHandle(size);
  63.         err := MemError;
  64. {$IFC debug_memory }
  65.         if (err = noErr) then begin
  66.             MFill(hhhh^, GetHandleSize(hhhh), fill_byte);
  67.         end;
  68. {$ENDC}
  69.         MNewHandle := err;
  70.     end;
  71.  
  72.     function MSetPtrSize (var p: univ ptr; size: longint): OSerr;
  73.     begin
  74.         SetPtrSize(p, size);
  75.         MSetPtrSize := MemError;
  76.     end;
  77.  
  78.     function MSetHandleSize (var hhhh: univ handle; size: longint): OSerr;
  79.     begin
  80.         SetHandleSize(hhhh, size);
  81.         MSetHandleSize := MemError;
  82.     end;
  83.  
  84.     procedure MDisposePtr (var p: univ ptr);
  85.     begin
  86.         if p <> nil then begin
  87. {$IFC debug_memory }
  88.             MFill(p, GetPtrSize(p), fill_byte);
  89. {$ENDC}
  90.             DisposePtr(p);
  91.             p := nil;
  92.         end;
  93.     end;
  94.  
  95.     procedure MDisposeHandle (var hhhh: univ handle);
  96.     begin
  97.         if hhhh <> nil then begin
  98. {$IFC debug_memory }
  99.             MFill(hhhh^, GetHandleSize(hhhh), fill_byte);
  100. {$ENDC}
  101.             DisposeHandle(hhhh);
  102.             hhhh := nil;
  103.         end;
  104.     end;
  105.  
  106.     procedure MZero (p: univ ptr; size: longint);
  107.     begin
  108.         MFill(p, size, 0);
  109.     end;
  110.     
  111.     procedure MFill (p: univ ptr; size: longint; val: integer);
  112.         var
  113.             i: longint;
  114.     begin
  115.         if CheckPtr(p) then begin
  116.             for i := longint(p) to longint(p) + size - 1 do begin
  117.                 ptr(i)^ := val;
  118.             end;
  119.         end;
  120.     end;
  121.  
  122.     procedure MFillLong (p: univ ptr; size: longint; val: longint);
  123.         type
  124.             longPtr = ^longint;
  125.         var
  126.             i: longint;
  127.     begin
  128.         if CheckPtr(p) then begin
  129.             i := longint(p);
  130.             while size > 3 do begin
  131.                 longPtr(i)^ := val;
  132.                 i := i + 4;
  133.                 size := size - 4;
  134.             end;
  135.         end;
  136.     end;
  137.  
  138.     procedure LockHigh (hhhh: univ handle);
  139.     begin
  140.         MoveHHi(hhhh);
  141.         HLock(hhhh);
  142.     end;
  143.  
  144.     procedure HLockState (hhhh: handle; var state: SignedByte);
  145.     begin
  146.         state := HGetState(hhhh);
  147.         HLock(hhhh);
  148.     end;
  149.  
  150.     procedure HUnlockState (hhhh: handle; var state: SignedByte);
  151.     begin
  152.         state := HGetState(hhhh);
  153.         HUnlock(hhhh);
  154.     end;
  155.  
  156.     procedure TrashPtr (data: Ptr);
  157.     begin
  158.         if (data <> nil) then begin
  159.             MFill(data, GetPtrSize(data), fill_byte);
  160.         end;
  161.     end;
  162.  
  163.     procedure TrashHandle (hhhh: handle);
  164.     begin
  165.         if (hhhh <> nil) & (hhhh^ <> nil) then begin
  166.             MFill(hhhh^, GetHandleSize(hhhh), fill_byte);
  167.         end;
  168.     end;
  169.  
  170. end.