home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l040 / 13.ddi / RTLOWL.ZIP / OMEMORY.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-28  |  1.8 KB  |  84 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Turbo Pascal for Windows Run-time Library       }
  5. {       ObjectWindows Unit                              }
  6. {                                                       }
  7. {       Copyright (c) 1991 Borland International        }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit OMemory;
  12.  
  13. interface
  14.  
  15. const
  16.   SafetyPoolSize: Word = 8192;
  17.  
  18. procedure InitMemory;
  19. procedure DoneMemory;
  20. function LowMemory: Boolean;
  21. procedure RestoreMemory;
  22. function MemAlloc(Size: Word): Pointer;
  23. function MemAllocSeg(Size: Word): Pointer;
  24.  
  25. implementation
  26.  
  27. uses WinProcs, WinTypes;
  28.  
  29. const
  30.   SafetyPool: Pointer = nil;
  31.   DisablePool: Boolean = False;
  32.  
  33. function LowMemory: Boolean;
  34. begin
  35.   LowMemory := SafetyPool = nil;
  36. end;
  37.  
  38. procedure RestoreMemory;
  39. begin
  40.   if LowMemory then
  41.     GetMem(SafetyPool, SafetyPoolSize);
  42. end;
  43.  
  44. function MemAlloc(Size: Word): Pointer;
  45. var
  46.   Tmp: Pointer;
  47. begin
  48.   DisablePool := True;
  49.   GetMem(Tmp, Size);
  50.   MemAlloc := Tmp;
  51.   DisablePool := False;
  52. end;
  53.  
  54. function MemAllocSeg(Size: Word): Pointer;
  55. begin
  56.   MemAllocSeg := GlobalLock(GlobalAlloc(gmem_Fixed, Size));
  57. end;
  58.  
  59. function HeapFunc(Size: Word): Integer; far;
  60. begin
  61.   if Size <> 0 then
  62.     if DisablePool then HeapFunc := 1
  63.     else if LowMemory then HeapFunc := 0
  64.     else
  65.     begin
  66.       FreeMem(SafetyPool, SafetyPoolSize);
  67.       SafetyPool := nil;
  68.       HeapFunc := 2;
  69.     end;
  70. end;
  71.  
  72. procedure InitMemory;
  73. begin
  74.   RestoreMemory;
  75.   HeapError := @HeapFunc;
  76. end;
  77.  
  78. procedure DoneMemory;
  79. begin
  80.   FreeMem(SafetyPool, SafetyPoolSize);
  81.   SafetyPool := nil;
  82. end;
  83.  
  84. end.