Pascal Memory Code Library

Unit Memory;

{$IFNDEF OS2}
{$O+,F+,X+,I-,S-,Q-}

Interface

Const
  MaxHeapSize: Word = 655360 Div 16;    { 640K }
  LowMemSize: Word = 4096 Div 16;       {   4K }
  MaxBufMem: Word = 65536 Div 16;       {  64K }

Procedure InitMemory;
Procedure DoneMemory;
Procedure InitDosMem;
Procedure DoneDosMem;
Function LowMemory: Boolean;
Function MemAlloc (Size: Word): Pointer;
Function MemAllocSeg (Size: Word): Pointer;
Procedure NewCache (Var P: Pointer; Size: Word);
Procedure DisposeCache (P: Pointer);
Procedure NewBuffer (Var P: Pointer; Size: Word);
Procedure DisposeBuffer (P: Pointer);
Function GetBufferSize (P: Pointer): Word;
Function SetBufferSize (P: Pointer; Size: Word): Boolean;
Procedure GetBufMem (Var P: Pointer; Size: Word);
Procedure FreeBufMem (P: Pointer);
Procedure SetMemTop (MemTop: Pointer);

Implementation

Type
  PtrRec = Record
             Ofs, Seg: Word;
           End;

Type
  PCache = ^TCache;
  TCache = Record
             Size: Word;
             Master: ^Pointer;
             Data: Record End;
           End;

Type
  PBuffer = ^TBuffer;
  TBuffer = Record
              Size: Word;
              Master: ^Word;
            End;

Const
  CachePtr: Pointer = Nil;
  HeapResult: Integer = 0;
  BufHeapPtr: Word = 0;
  BufHeapEnd: Word = 0;

Function HeapNotify (Size: Word): Integer; Far; Assembler;
Asm
  CMP   Size, 0
  JNE   @@3
  @@1:  MOV     AX, CachePtr. Word [2]
  CMP   AX, HeapPtr. Word [2]
  JA    @@3
  JB    @@2
  MOV   AX, CachePtr. Word [0]
  CMP   AX, HeapPtr. Word [0]
  JAE   @@3
  @@2:  XOr     AX, AX
  PUSH  AX
  PUSH  AX
  Call  DisposeCache
  JMP   @@1
  @@3:  MOV     AX, HeapResult
End;

Procedure FreeCacheMem;
Begin
  While CachePtr <> HeapEnd Do DisposeCache (CachePtr);
End;

Procedure InitMemory;
Var
  HeapSize: Word;
Begin
  HeapError := @HeapNotify;
  If BufHeapPtr = 0 Then
  Begin
    HeapSize := PtrRec (HeapEnd).Seg - PtrRec (HeapOrg).Seg;
    If HeapSize > MaxHeapSize Then HeapSize := MaxHeapSize;
    BufHeapEnd := PtrRec (HeapEnd).Seg;
    PtrRec (HeapEnd).Seg := PtrRec (HeapOrg).Seg + HeapSize;
    BufHeapPtr := PtrRec (HeapEnd).Seg;
  End;
  CachePtr := HeapEnd;
End;

Procedure DoneMemory;
Begin
  FreeCacheMem;
End;

Procedure InitDosMem;
Begin
  SetMemTop (Ptr (BufHeapEnd, 0) );
End;

Procedure DoneDosMem;
Var
  MemTop: Pointer;
Begin
  MemTop := Ptr (BufHeapPtr, 0);
  If BufHeapPtr = PtrRec (HeapEnd).Seg Then
  Begin
    FreeCacheMem;
    MemTop := HeapPtr;
  End;
  SetMemTop (MemTop);
End;

Function LowMemory: Boolean; Assembler;
Asm
  MOV   AX, HeapEnd. Word [2]
  SUB   AX, HeapPtr. Word [2]
  SUB   AX, LowMemSize
  SBB   AX, AX
  NEG   AX
End;

Function MemAlloc (Size: Word): Pointer;
Var
  P: Pointer;
Begin
  HeapResult := 1;
  GetMem (P, Size);
  HeapResult := 0;
  If (P <> Nil) And LowMemory Then
  Begin
    FreeMem (P, Size);
    P := Nil;
  End;
  MemAlloc := P;
End;

Function MemAllocSeg (Size: Word): Pointer;
Var
  P, T: Pointer;
Begin
  Size := (Size + 7) And $FFF8;
  P := MemAlloc (Size + 8);
  If P <> Nil Then
  Begin
    If PtrRec (P).Ofs = 0 Then
    Begin
      PtrRec (T).Ofs := Size And 15;
      PtrRec (T).Seg := PtrRec (P).Seg + Size ShR 4;
    End Else
    Begin
      T := P;
      PtrRec (P).Ofs := 0;
      Inc (PtrRec (P).Seg);
    End;
    FreeMem (T, 8);
  End;
  MemAllocSeg := P;
End;

Procedure NewCache (Var P: Pointer; Size: Word); Assembler;
Asm
  LES   DI, P
  MOV   AX, Size
  ADD   AX, (Type TCache) + 15
  MOV   CL, 4
  ShR   AX, CL
  MOV   DX, CachePtr. Word [2]
  SUB   DX, AX
  JC    @@1
  CMP   DX, HeapPtr. Word [2]
  JBE   @@1
  MOV     CX, HeapEnd. Word [2]
  SUB   CX, DX
  CMP   CX, MaxBufMem
  JA    @@1
  MOV   CachePtr. Word [2], DX
  PUSH  DS
  MOV   DS, DX
  XOr   SI, SI
  MOV   DS: [SI].TCache. Size, AX
  MOV   DS: [SI].TCache. Master. Word [0], DI
  MOV   DS: [SI].TCache. Master. Word [2], ES
  POP   DS
  MOV   AX, Offset TCache. Data
  JMP   @@2
  @@1:  XOr     AX, AX
  CWD
  @@2:  CLD
  STOSW
  XCHG  AX, DX
  STOSW
End;

Procedure DisposeCache (P: Pointer); Assembler;
Asm
  MOV   AX, CachePtr. Word [2]
  XOr   BX, BX
  XOr   CX, CX
  MOV   DX, P. Word [2]
  @@1:  MOV     ES, AX
  CMP   AX, DX
  JE    @@2
  ADD   AX, ES: [BX].TCache. Size
  CMP   AX, HeapEnd. Word [2]
  JE    @@2
  PUSH  ES
  Inc   CX
  JMP   @@1
  @@2:  PUSH    ES
  LES   DI, ES: [BX].TCache. Master
  XOr   AX, AX
  CLD
  STOSW
  STOSW
  POP   ES
  MOV   AX, ES: [BX].TCache. Size
  JCXZ  @@4
  @@3:  POP     DX
  PUSH  DS
  PUSH  CX
  MOV   DS, DX
  ADD   DX, AX
  MOV   ES, DX
  MOV   SI, DS: [BX].TCache. Size
  MOV   CL, 3
  ShL   SI, CL
  MOV   CX, SI
  ShL   SI, 1
  Dec   SI
  Dec   SI
  MOV   DI, SI
  STD
  REP   MOVSW
  LDS   SI, ES: [BX].TCache. Master
  MOV   DS: [SI].Word [2], ES
  POP   CX
  POP   DS
  LOOP  @@3
  @@4:  ADD     CachePtr. Word [2], AX
End;

Procedure MoveSeg (Source, Dest, Size: Word); Near; Assembler;
Asm
  PUSH  DS
  MOV   AX, Source
  MOV   DX, Dest
  MOV   BX, Size
  CMP   AX, DX
  JB    @@3
  CLD
  @@1:  MOV     CX, 0FFFH
  CMP   CX, BX
  JB    @@2
  MOV   CX, BX
  @@2:  MOV     DS, AX
  MOV   ES, DX
  ADD   AX, CX
  ADD   DX, CX
  SUB   BX, CX
  ShL   CX, 1
  ShL   CX, 1
  ShL   CX, 1
  XOr   SI, SI
  XOr   DI, DI
  REP   MOVSW
  Or    BX, BX
  JNE   @@1
  JMP   @@6
  @@3:  ADD     AX, BX
  ADD   DX, BX
  STD
  @@4:  MOV     CX, 0FFFH
  CMP   CX, BX
  JB    @@5
  MOV   CX, BX
  @@5:    SUB   AX, CX
  SUB   DX, CX
  SUB   BX, CX
  MOV   DS, AX
  MOV   ES, DX
  ShL   CX, 1
  ShL   CX, 1
  ShL   CX, 1
  MOV   SI, CX
  Dec   SI
  ShL   SI, 1
  MOV   DI, SI
  REP   MOVSW
  Or    BX, BX
  JNE   @@4
  @@6:  POP     DS
End;

Function GetBufSize (P: PBuffer): Word;
Begin
  GetBufSize := (P^. Size + 15) ShR 4 + 1;
End;

Procedure SetBufSize (P: PBuffer; NewSize: Word);
Var
  CurSize: Word;
Begin
  CurSize := GetBufSize (P);
  MoveSeg (PtrRec (P).Seg + CurSize, PtrRec (P).Seg + NewSize,
  BufHeapPtr - PtrRec (P).Seg - CurSize);
  Inc (BufHeapPtr, NewSize - CurSize);
  Inc (PtrRec (P).Seg, NewSize);
  While PtrRec (P).Seg < BufHeapPtr Do
  Begin
    Inc (P^. Master^, NewSize - CurSize);
    Inc (PtrRec (P).Seg, (P^. Size + 15) ShR 4 + 1);
  End;
End;

Procedure NewBuffer (Var P: Pointer; Size: Word);
Var
  BufSize: Word;
  Buffer: PBuffer;
Begin
  BufSize := (Size + 15) ShR 4 + 1;
  If BufHeapPtr + BufSize > BufHeapEnd Then P := Nil Else
  Begin
    Buffer := Ptr (BufHeapPtr, 0);
    Buffer^. Size := Size;
    Buffer^. Master := @PtrRec (P).Seg;
    P := Ptr (BufHeapPtr + 1, 0);
    Inc (BufHeapPtr, BufSize);
  End;
End;

Procedure DisposeBuffer (P: Pointer);
Begin
  Dec (PtrRec (P).Seg);
  SetBufSize (P, 0);
End;

Function GetBufferSize (P: Pointer): Word;
Begin
  Dec (PtrRec (P).Seg);
  GetBufferSize := PBuffer (P)^. Size;
End;

Function SetBufferSize (P: Pointer; Size: Word): Boolean;
Var
  NewSize: Word;
Begin
  Dec (PtrRec (P).Seg);
  NewSize := (Size + 15) ShR 4 + 1;
  SetBufferSize := False;
  If BufHeapPtr + NewSize - GetBufSize (P) <= BufHeapEnd Then
  Begin
    SetBufSize (P, NewSize);
    PBuffer (P)^. Size := Size;
    SetBufferSize := True;
  End;
End;

Procedure GetBufMem (Var P: Pointer; Size: Word);
Begin
  NewCache (P, Size);
End;

Procedure FreeBufMem (P: Pointer);
Begin
  DisposeCache (P);
End;

Procedure SetMemTop (MemTop: Pointer); Assembler;
Asm
  MOV   BX, MemTop. Word [0]
  ADD   BX, 15
  MOV   CL, 4
  ShR   BX, CL
  ADD   BX, MemTop. Word [2]
  MOV   AX, PrefixSeg
  SUB   BX, AX
  MOV   ES, AX
  MOV   AH, 4AH
  Int   21H
End;

{$ELSE}

{$X+,I-,S-,Q-}

interface

uses Use32;

const
  LowMemSize: Word = 4096 div 16;       {   4K }

procedure InitMemory;
procedure DoneMemory;
procedure InitDosMem;
procedure DoneDosMem;
function LowMemory: Boolean;
function MemAlloc(Size: Word): Pointer;
procedure NewCache(var P: Pointer; Size: Word);
procedure DisposeCache(P: Pointer);
procedure NewBuffer(var P: Pointer; Size: Word);
procedure DisposeBuffer(P: Pointer);
function GetBufferSize(P: Pointer): Word;
function SetBufferSize(P: Pointer; Size: Word): Boolean;

{ The following procedure is not implemented

function MemAllocSeg(Size: Word): Pointer;

}

implementation

type
  PtrRec = record
    Ofs: Longint;
  end;

type
  PCache = ^TCache;
  TCache = record
    Next: PCache;
    Master: ^Pointer;
    Size: Word;
    Data: record end;
  end;

  PBuffer = ^TBuffer;
  TBuffer = record
    Next: PBuffer;
    Size: Word;
    Data: record end;
  end;

const
  CacheList: PCache = nil;
  SafetyPool: Pointer = nil;
  BufferList: PBuffer = nil;
  SafetyPoolSize: Word = 0;
  DisablePool: Boolean = False;

function FreeCache: Boolean;
begin
  FreeCache := False;
  if CacheList <> nil then
  begin
    DisposeCache(CacheList^.Next^.Master^);
    FreeCache := True;
  end;
end;

function FreeSafetyPool: Boolean;
begin
  FreeSafetyPool := False;
  if SafetyPool <> nil then
  begin
    FreeMem(SafetyPool, SafetyPoolSize);
    SafetyPool := nil;
    FreeSafetyPool := True;
  end;
end;

function HeapNotify(Size: Word): Integer;
begin
  if FreeCache then HeapNotify := 2 else
    if DisablePool then HeapNotify := 1 else
      if FreeSafetyPool then HeapNotify := 2 else HeapNotify := 0;
end;

procedure InitMemory;
begin
  HeapError := @HeapNotify;
  SafetyPoolSize := LowMemSize * 16;
  LowMemory;
end;

procedure DoneMemory;
begin
  while FreeCache do;
  FreeSafetyPool;
end;

procedure InitDosMem;
begin
end;

procedure DoneDosMem;
begin
end;

function LowMemory: Boolean;
begin
  LowMemory := False;
  if SafetyPool = nil then
  begin
    SafetyPool := MemAlloc(SafetyPoolSize);
    if SafetyPool = nil then LowMemory := True;
  end;
end;

function MemAlloc(Size: Word): Pointer;
var
  P: Pointer;
begin
  DisablePool := True;
  GetMem(P, Size);
  DisablePool := False;
  MemAlloc := P;
end;

procedure NewCache(var P: Pointer; Size: Word);
var
  Cache: PCache;
begin
  Inc(Size, SizeOf(TCache));
  if MaxAvail >= Size then GetMem(Cache,Size) else Cache := nil;
  if Cache <> nil then
  begin
    if CacheList = nil then Cache^.Next := Cache else
    begin
      Cache^.Next := CacheList^.Next;
      CacheList^.Next := Cache;
    end;
    CacheList := Cache;
    Cache^.Master := @P;
    Cache^.Size := Size;
    Inc(PtrRec(Cache).Ofs, SizeOf(TCache));
  end;
  P := Cache;
end;

procedure DisposeCache(P: Pointer);
var
  Cache, C: PCache;
begin
  PtrRec(Cache).Ofs := PtrRec(P).Ofs - SizeOf(TCache);
  C := CacheList;
  while (C^.Next <> Cache) and (C^.Next <> CacheList) do C := C^.Next;
  if C^.Next = Cache then
  begin
    if C = Cache then CacheList := nil else
    begin
      if CacheList = Cache then CacheList := C;
      C^.Next := Cache^.Next;
    end;
    Cache^.Master^ := nil;
    FreeMem(Cache,Cache^.Size);
  end;
end;

procedure NewBuffer(var P: Pointer; Size: Word);
var
  Buffer: PBuffer;
begin
  Inc(Size, SizeOf(TBuffer));
  Buffer := MemAlloc(Size);
  if Buffer <> nil then
  begin
    Buffer^.Next := BufferList;
    Buffer^.Size := Size;
    BufferList := Buffer;
    Inc(PtrRec(Buffer).Ofs, SizeOf(TBuffer));
  end;
  P := Buffer;
end;

procedure DisposeBuffer(P: Pointer);
var
  Buffer,PrevBuf: PBuffer;
begin
  if P <> nil then
  begin
    Dec(PtrRec(P).Ofs, SizeOf(TBuffer));
    Buffer := BufferList;
    PrevBuf := nil;
    while (Buffer <> nil) and (P <> Buffer) do
    begin
      PrevBuf := Buffer;
      Buffer := Buffer^.Next;
    end;
    if Buffer <> nil then
    begin
      if PrevBuf = nil then BufferList := Buffer^.Next else PrevBuf^.Next := Buffer^.Next;
      FreeMem(Buffer,Buffer^.Size);
    end;
  end;
end;

function GetBufferSize(P: Pointer): Word;
begin
  if P = nil then GetBufferSize := 0
else
  begin
    Dec(PtrRec(P).Ofs,SizeOf(TBuffer));
    GetBufferSize := PBuffer(P)^.Size;
  end;
end;

function SetBufferSize(P: Pointer; Size: Word): Boolean;
begin
  SetBufferSize := False;
end;

{$ENDIF}

End.