{*********************************************************}
{*                   VMM.IN2 1.00                        *}
{*********************************************************}

  constructor Dynarray.Init(MaxElements, ElementSize, Incr : Word);
    {-Called when a dynamic array is created}
  begin
   if (not Root.init) then
      Fail;
   if  (ElementSize = 0)
    or (Incr = 0)
    or (Incr > MaxElements)
    or (MaxElements = 0)
    or (LongInt(ElementSize)*Incr > MaxHeapAlloc)
    or (LongInt(MaxElements)*ElementSize > MaxHeapAlloc) then begin
       Done;
       InitStatus := epFatal+ecBadParam;
       Fail;
   end;

   daBase := nil;
   daElemSize := ElementSize;
   daArraySize:= 0;
   daInc := Incr;
   daMaxIndex := MaxElements-1;
   daValidElems := 0;
   daStatus := 0;
  end;

  destructor DynArray.Done;
    {-Free memory occupied by the array}
  begin
   Clear;
   Root.Done;
  end;

  function DynArray.GetStatus : Word;
    {-Return and reset array status}
  begin
   GetStatus := daStatus;
   daStatus := 0;
  end;

  function DynArray.PeekStatus : Word;
    {-Return array status}
  begin
   PeekStatus := daStatus;
  end;

  procedure DynArray.Error(Code : Word);
    {-Assign error code}
  begin
    daStatus := Code;
  end;

  procedure DynArray.SetElem(Index : Word; var Elem);
    {-Set an array element to a given value; Increase size if necessary}
  var
    P           : Pointer;
    NewSize     : Word;
    NeededElems : Word;
  begin
    if Index > daMaxIndex then begin
      Error(epFatal+ecBadParam);
      Exit;
    end;

    NeededElems := Succ(Index);
    if NeededElems > daArraySize div daElemSize then begin
    {The memory space allocated to the array must be increased}

      if (NeededElems mod daInc <> 0) or (Index = 0) then
        NeededElems := Succ(NeededElems div daInc) * daInc;
      if NeededElems > Succ(daMaxIndex) then
        NeededElems := Succ(daMaxIndex);     {No superfluous allocation}
      NewSize := NeededElems*daElemSize;
      if UserGetMem(P, NewSize) then begin
        FillChar(AddWordToPtr(P, daArraySize)^, NewSize-daArraySize, 0);
        Move(daBase^, P^, daArraySize);      {Data transfer}
        UserFreeMem(daBase, daArraySize);    {The bigger daIncr, the lesser}
        daArraySize := NewSize;              { the heap will be fragmented}
        daBase := P;
      end
      else begin
        Error(epFatal+ecOutOfMemory);
        Exit;
      end;
    end;

    if Succ(Index) > daValidElems then
      daValidElems := Succ(Index);

    {Now stores the element data into the array}
    Move(Elem, AddWordToPtr(daBase, daElemSize*Index)^, daElemSize);
  end;

  procedure DynArray.GetElem(Index : Word; var Elem);
    {-Return the indexth element}
  begin
    if Succ(LongInt(Index)) > daValidElems then
      Error(epFatal+ecBadParam)
    else
      Move(AddWordToPtr(daBase, daElemSize*Index)^, Elem, daElemSize);
  end;

  function DynArray.GetElemSize : Word;
    {-Return size of an element}
  begin
    GetElemSize := daElemSize;
  end;

  function DynArray.GetArraySize : Word;
    {-Return actual size of array}
  begin
    GetArraySize := daArraySize;
  end;

  function DynArray.GetMaxIndex : Word;
    {-Return maximum index allowed}
  begin
   GetMaxIndex := daMaxIndex;
  end;

  function DynArray.GetValidElems : Word;
    {-Return number of valid elements}
  begin
   GetValidElems := daValidElems;
  end;

  procedure DynArray.Shrink(ElemNb : Word);
    {-Shrink array size to ElemNb elements and discard exceeding elements}
  var
    P          : pointer;
    NewSize    : Word;
    SaveElemNb : Word;
  begin
    if ElemNb = 0 then begin
      Clear;
      Exit;
    end;
    if ElemNb >= daArraySize div daElemSize then
      Exit;
    SaveElemNb := ElemNb;
    if ElemNb mod daInc <> 0 then
      ElemNb := Succ(ElemNb div daInc) * daInc;
    NewSize := ElemNb*daElemSize;
    if NewSize < daArraySize then
    {Need to reallocate a smaller buffer}
      if UserGetMem(P, NewSize) then begin
        Move(daBase^, P^, NewSize);         {No need to fill with nulls since}
        UserFreeMem(daBase, daArraySize);   { it's a smaller block}
        daArraySize := NewSize;
        daBase := P;
      end
      else begin
        Error(epFatal+ecOutOfMemory);
        Exit;
      end;
    {No reallocation - just need to adjust daValidElems}
    if daValidElems > SaveElemNb then
      daValidElems := SaveElemNb;
  end;

  procedure DynArray.Clear;
    {-Reset array to minimum size and discard all elements}
  begin
   UserFreeMem(daBase, daArraySize);
   daArraySize := 0;
   daValidElems := 0;
   daStatus := 0;
  end;

  constructor DynArray.Load(var S : IdStream);
    {-Load a dynamic array from a stream}
  begin
   daBase := nil;
   if not Root.Init then
     Fail;
   {Read characteristics of dynamic array}
   S.ReadRange(daElemSize, daBase);
   if S.PeekStatus <> 0 then begin
     Done;
     Fail;
   end;
   {Allocates memory to store array data}
   if not UserGetMem(daBase, daArraySize) then begin
     Done;
     InitStatus := epFatal+ecOutOfMemory;
     Fail;
   end;
   {Now read array data}
   S.Read(daBase^, daArraySize);
   if S.PeekStatus <> 0 then begin
     Done;
     Fail;
   end;
  end;

  procedure DynArray.Store(var S : IdStream);
    {-Store a dynamic array in a stream}
  begin
   {Write characteristics of dynamic array}
   {Only daBase is not stored}
   S.WriteRange(daElemSize, daBase);
   {Write array data}
   S.Write(daBase^, daArraySize);
  end;

  procedure DynArrayStream(SPtr : IdStreamPtr);
    {-Register all types needed for streams containing DynArrays}
  begin
    SPtr^.RegisterType(otDynArray, veDynArray, TypeOf(DynArray),
                       @DynArray.Store, @DynArray.Load);
  end;

  {---------------------------------------------------------------------}

  procedure VmmStaticQueue.Remove(var Element);
    {-Remove first element found equal to Element from the queue}
  {
   This procedure is needed to maintain the LRU queue. The very nature of
   the LRU algorithm is to push into the queue a VMM handle each time it is
   dereferenced. So, if we make sure that this handle is deleted before
   pushing it into the queue, when we lock it or when we free it, we'll also
   be sure that the "Least Recently Used" handle will be the first one
   to be popped out from the queue.
   Since we are sure that the elements processed by a VmmStaticQueue are
   always handles (i.e. WORDs) the CompElem function is not really needed
   because we should only compare WORDs. Though, the CompElem function
   allows the VmmStaticQueue to be used for other purposes.
  }
  var
    Ptr   : Word;
    Found : Boolean;
  begin
    if sqTail > sqHead then begin
    {There is no wrap-around in the queue}
      Ptr := sqHead;
      Found := false;
      while not Found and (Ptr < sqTail) do begin
        Inc(Ptr, sqElSize);
        Found := CompElem(Element, sqBase^[Ptr], sqElSize);
      end;
      if Found then begin
      {Remove element}
        Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
        sqDec(sqTail);
      end;
    end
    else if not IsEmpty then begin
      {First search from Head to end of buffer}
      Ptr := sqHead;
      Found := false;
      while not Found and (Ptr < sqSize) do begin
        Inc(Ptr, sqElSize);
        Found := CompElem(Element, sqBase^[Ptr], sqElSize);
      end;
      if not Found then begin
      {Search from beginning of buffer to Tail}
        Ptr := 0;
        repeat
          Found := CompElem(Element, sqBase^[Ptr], sqElSize);
          Inc(Ptr, sqElSize);
        until Found or (Ptr >= sqTail);
        Dec(Ptr, sqElSize);
      end;
      if Found then begin
      {Remove element}
        if (Ptr > sqHead) then begin
        {A little bit trickier in that case - circular move}
          Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], (sqSize-Ptr-sqElSize));
          Move(sqBase^, sqBase^[sqSize-sqElSize], sqElSize);
          Move(sqBase^[sqElSize], sqBase^, sqTail);
        end
        else
          Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
        sqDec(sqTail);
      end;
    end;
    {If not found does nothing}
  end;

  function VmmStaticQueue.IsEmpty : Boolean;
    {-Return true if queue is empty}
  begin
    IsEmpty := sqHead = sqTail;
  end;

  {---------------------------------------------------------------------}

  constructor AbstractFreeList.Init(MaxElements, Incr : Word);
    {-Initialize a dynamic array of FreeRecords}
  begin
   if not DynArray.Init(MaxElements, SizeOf(FreeRecord), Incr) then
     Fail;
  end;

  function AbstractFreeList.GetFreeEntrySize(Index : Word) : LongInt;
    {-Return size of a free block}
  begin
    {This virtual method must be overridden by descendants}
    Abstract;
  end;

  function AbstractFreeList.SizeToEndPtr(OrgPtr : Pointer;
                                         BlkSize : LongInt) : Pointer;
    {-Given OrgPtr and block size, return new entry's EndPtr}
  begin
    {This virtual method must be overridden by descendants}
    Abstract;
  end;

  function AbstractFreeList.SizeToOrgPtr(EndPtr : Pointer;
                                         BlkSize : LongInt) : Pointer;
    {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  begin
    {This virtual method must be overridden by descendants}
    Abstract;
  end;

  function AbstractFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
    {-Return true if pointers can be merged to form a new freelist entry}
  begin
    {This virtual method must be overridden by descendants}
    Abstract;
  end;

  function AbstractFreeList.GetFreeEntry(BlkSize : Word) : Pointer;
    {-Search free list for a free block, return a pointer to it}
  var
    CurIndex   : Word;
    CurEntSize : LongInt;
    CurFreeRec : FreeRecord;
  begin
    if daValidElems = 0 then begin
      GetFreeEntry := nil;
      Exit;
    end
    else begin
      for CurIndex := 0 to Pred(daValidElems) do begin
      {Scan free list for a block that is big enough}
        GetElem(CurIndex, CurFreeRec);
        if GetStatus <> 0 then begin
          GetFreeEntry := nil;
          Exit;
        end;
        CurEntSize := GetFreeEntrySize(CurIndex);
        if CurEntSize > BlkSize then begin
          {bigger than needed - shrink size of block}
          GetFreeEntry := CurFreeRec.OrgPtr;
          CurFreeRec.OrgPtr := SizeToOrgPtr(CurFreeRec.EndPtr, CurEntSize-BlkSize);
          SetElem(CurIndex, CurFreeRec);
          if (GetStatus = 0) and Sort then;
          {Sort free list to make sure GetFreeEntry will always choose the}
          { smallest possible block - this will prevent fragmentation}
          Exit;
        end
        else if CurEntSize = BlkSize then begin  {Exact match}
          GetFreeEntry := CurFreeRec.OrgPtr;
          {Delete used entry}
          RemoveFreeEntry(CurIndex);
          if (GetStatus = 0) and Sort then;
          Exit;
        end;
      end;
      {We didn't find a free entry which size is >= BlkSize}
      GetFreeEntry := nil;
    end;
  end;

  function AbstractFreeList.AddFreeEntry(ThisOrgP : Pointer;
                                         BlkSize : LongInt) : LongInt;
    {-Insert a new free block in the FreeList or merge it with an }
    { existing one - return size of entry in FreeList}
  var
    SaveIndex   : Word;
    CurIndex    : Word;
    CurFreeRec  : FreeRecord;
    ThisEndP    : Pointer;
    FoundOne    : Boolean;
    FoundTwo    : Boolean;
    Found       : Boolean;
    Pass        : 1..2;
  label
    AddIt;
  begin
    ThisEndP := SizeToEndPtr(ThisOrgP, BlkSize);
    FoundOne := false;
    FoundTwo := false;
    if daValidElems = 0 then {Nothing to search for}
      Goto AddIt;

    for Pass := 1 to 2 do begin
    {All blocks combinations should be found in two passes}
      CurIndex := 0;
      Found := false;

      while (CurIndex <= Pred(daValidElems)) and not Found do begin
        {search for a free list entry to combine with}
        GetElem(CurIndex, CurFreeRec);
        {does the EndPtr of our entry match the start of the current one ?}
        if PtrIsEqual(ThisEndP, CurFreeRec.OrgPtr) then begin
          CurFreeRec.OrgPtr := ThisOrgP;
          Found := true;
          {Save index for freelist update if second match found}
          if Pass = 1 then begin
            ThisEndP := CurFreeRec.EndPtr; {save it for next loop}
            SaveIndex := CurIndex;
            FoundOne := true;
          end
          else
          {Second match found}
            FoundTwo := true;
        end
        {does the OrgPtr of our entry match the ind of the current one ?}
        else if PtrIsEqual(ThisOrgP, CurFreeRec.EndPtr) then begin
          CurFreeRec.EndPtr := ThisEndP;
          Found := true;
          if Pass = 1 then begin
            ThisOrgP := CurFreeRec.OrgPtr; {save it for next loop}
            SaveIndex := CurIndex;
            FoundOne := true;
          end
          else
            FoundTwo := true;
        end;
        {go to next entry in the freelist or...}
        if not Found then
          Inc(CurIndex)
        else begin
          {...update entry in freeList}
          SetElem(CurIndex, CurFreeRec);
          if GetStatus <> 0 then
            AddFreeEntry := 0
          else
            AddFreeEntry := GetFreeEntrySize(CurIndex);
        end;
      end;
    end;

AddIt:

    if FoundTwo then
    {We found two blocks to combine with ours - the first one has to be deleted}
      RemoveFreeEntry(SaveIndex)
    else if not FoundOne then begin
    {No block combination was possible - add new entry to freelist}
      CurFreeRec.OrgPtr := ThisOrgP;
      CurFreeRec.EndPtr := SizeToEndPtr(ThisOrgP, BlkSize);
      SetElem(daValidElems, CurFreeRec);
      AddFreeEntry := GetFreeEntrySize(Pred(daValidElems));
    end;

    if not ((GetStatus = 0) and Sort) then
      AddFreeEntry := 0;
    {Sort free list to make sure GetFreeEntry will always choose the}
    { smallest possible block - this will prevent fragmentation}
  end;

  procedure AbstractFreeList.RemoveFreeEntry(Index : Word);
    {-Remove entry from the list and shrink list size}
  var
    LastIndex : Word;
    F         : FreeRecord;
  begin
    if (daValidElems = 0) or (Index > daValidElems) then begin
      Error(epFatal+ecBadParam);
      Exit;
    end;
    LastIndex := Pred(daValidElems);
    {Move last entry...}
    GetElem(LastIndex, F);
    {...to the entry to be deleted}
    SetElem(Index, F);
    {and shrink freelist by one element}
    Shrink(LastIndex);
  end;

  function AbstractFreeList.MaxFree : Longint;
    {-Return size of largest free entry}
  begin
    {Since the free list is always sorted in block size order}
    { the largest block available is always the last one}
    if daValidElems > 0 then
      MaxFree := GetFreeEntrySize(Pred(daValidElems))
    else
      MaxFree := 0;
  end;

  procedure AbstractFreeList.QuickSort(L, R : Word);
    {-Actual sort procedure called by Sort}
  const
    StackToKeep = 512;
  var
    i, j, p : LongInt;
    Ei, Ej  : FreeRecord;
  begin
   if SPtr > StackToKeep then begin {Keep StackToKeep bytes free on stack}
    i := L;                         {Each recursion uses approximately 50 bytes}
    j := R;
    p := (i+j) div 2;
    repeat
     while GetFreeEntrySize(i) < GetFreeEntrySize(p) do
       Inc(i);
     while GetFreeEntrySize(p) < GetFreeEntrySize(j) do
       Dec(j);
     if i <= j then begin {Swap elements}
       GetElem(i, Ei);
       GetElem(j, Ej);
       SetElem(i, Ej);
       SetELem(j, Ei);
       Inc(i);
       Dec(j);
     end;
    until i > j;
    if L < j  then
      QuickSort(L, j); {Recursive call with new boundaries}
    IF i < R then
      QuickSort(i, R);
   end
   else
     Error(epNonFatal+ecOutOfMemory);
  end;

  function AbstractFreeList.Sort : boolean;
    {-Sort the free list in block size order}
  var
    Count : Word;
  const
    MaxCount = 3;
  begin
    Count := 0;
    if daValidElems > 1 then
      repeat
        QuickSort(0, Pred(daValidElems));
        Inc(Count);
      until (PeekStatus = 0) or (Count = MaxCount);
    Sort := GetStatus = 0;
    {
     Some explanations needed here. It's very important for the VMM that
     the freelist sort succeeds. If not, MaxFree will not return the right
     value and fragmentation will begin. The only reason for Sort to fail
     is that we could run out of stack space. In that case the array remains
     partially sorted. However, the number of recursions needed for a QuickSort
     depends heavily on the initial order of items in the array. So, a
     second (or a third) try on the partially sorted array may (will likely)
     succeed. Moreover, freelists are sorted very often. Hence, the required
     number of recursions will be very low.

     In most cases freelists will not be very big. So the SORT method will
     succeed anyway. Some experiments showed that even very big arrays
     can be sorted in 3 passes. In the very rare situations where 3 passes
     are not enough, you may want to increase MaxCount to allow more passes.
    }
  end;

  {---------------------------------------------------------------------}

  function VmmRamFreeList.GetFreeEntrySize(Index : Word) : LongInt;
    {-Return size of a free block}
  var
    F : FreeRecord;
  begin
    GetElem(Index, F);
    if GetStatus = 0 then
      with F do
        GetFreeEntrySize := PtrToLong(EndPtr) - PtrToLong(OrgPtr)
    else
      GetFreeEntrySize := 0;
  end;

  function VmmRamFreeList.SizeToEndPtr(OrgPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given OrgPtr and block size, return new entry's EndPtr}
  begin
    {Assume BlkSize validity}
    SizeToEndPtr :=AddLongToPtr(OrgPtr, BlkSize);
  end;

  function VmmRamFreeList.SizeToOrgPtr(EndPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given EndPtr and block size, return new entry's OrgPtr}
  begin
    {Assume BlkSize validity}
    SizeToOrgPtr := LongToPtr(PtrToLong(EndPtr) - BlkSize);
  end;

  function VmmRamFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
    {-Return true if pointers can be merged to form a new freelist entry}
  begin
    PtrIsEqual := PtrToLong(P1) = PtrToLong(P2);
  end;

  {---------------------------------------------------------------------}

  function VmmEmsFreeList.AddFreeEntry(ThisOrgP : Pointer;
                                       BlkSize : Word) : LongInt;
    {Override generic AddFreeEntry method because Ems need special handling}
    { This method will deallocate an Ems frame when it is empty}
  var
    F        : FreeRecord;
    Found    : Boolean;
    CurIndex : Word;
  begin
    {Use generic method and if entire Ems page frame is free, deallocate handle}
    if AbstractFreeList.AddFreeEntry(ThisOrgP, BlkSize) = MaxEmsBlock then begin
      {Because the freelist has been sorted in block order size the new}
      { entry is now necessarily the last one because it has the maximum}
      { size - So we only have to free the handle of the last entry and}
      { to remove it from the list}
      GetElem(Pred(daValidElems), F);
      if not DeAllocateEmsHandle(VmmPtrRec(F.OrgPtr).Seg) then
        Error(epNonFatal+ecCantFreeEms)
      else begin
        {Remove entry from freelist - we remove the last one, no need to sort}
        RemoveFreeEntry(Pred(daValidElems));
        if PeekStatus <> 0 then
          AddFreeEntry := 0;
      end;
    end;
  end;

  function VmmEmsFreeList.GetFreeEntrySize(Index : Word) : LongInt;
    {-Return size of a free block}
  var
    F : FreeRecord;
  begin
    GetElem(Index, F);
    if GetStatus = 0 then
      with F do
        GetFreeEntrySize := VmmPtrRec(EndPtr).Ofs - VmmPtrRec(OrgPtr).Ofs
    else
      GetFreeEntrySize := 0;
    {The segment part is assumed to be the same for EndPtr and OrgPtr}
    { It is the Ems handle - a free entry in EmsFreeList cannot be > 64k}
  end;

  function VmmEmsFreeList.SizeToEndPtr(OrgPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given OrgPtr and block size, return new entry's EndPtr}
  begin
    {Assume BlkSize validity - entries cannot be greater than 64k}
    Inc(VmmPtrRec(OrgPtr).Ofs, Word(BlkSize));
    SizeToEndPtr := OrgPtr;
    {The segment part is assumed to be the same for EndPtr and OrgPtr}
    { It is the Ems handle}
  end;

  function VmmEmsFreeList.SizeToOrgPtr(EndPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  begin
    {Assume BlkSize validity - entries cannot be greater than 64k}
    Dec(VmmPtrRec(EndPtr).Ofs, Word(BlkSize));
    SizeToOrgPtr :=EndPtr;
    {The segment part is assumed to be the same for EndPtr and OrgPtr}
    { It is the Ems handle}
  end;

  function VmmEmsFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
    {-Return true if pointers can be merged to form a new freelist entry}
  begin
    PtrIsEqual := P1 = P2; {Segment (handle) and offset must be the same}
  end;

  {---------------------------------------------------------------------}

  function VmmDskFreeList.GetFreeEntrySize(Index : Word) : LongInt;
    {-Return size of a free block}
  var
    F       : FreeRecord;
    Offsets : array [1..2] of LongInt absolute F;
  begin
    GetElem(Index, F);
    if GetStatus = 0 then
      GetFreeEntrySize := Offsets[2] - Offsets[1]
    else
      GetFreeEntrySize := 0;
  end;

  function VmmDskFreeList.SizeToEndPtr(OrgPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given OrgPtr and block size, return new entry's EndPtr}
  var
    BlockOrg : LongInt absolute OrgPtr;
  begin
    SizeToEndPtr := Pointer(BlockOrg + BlkSize);
  end;

  function VmmDskFreeList.SizeToOrgPtr(EndPtr : Pointer;
                                       BlkSize : LongInt) : Pointer;
    {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  var
    BlockEnd : LongInt absolute EndPtr;
  begin
    SizeToOrgPtr := Pointer(BlockEnd - BlkSize);
  end;

  function VmmDskFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
    {-Return true if pointers can be merged to form a new freelist entry}
  begin
    PtrIsEqual := P1 = P2; {LongInt(P1) = LongInt(P2)}
  end;