Package Memory

Interface

Const
     Nil=Pointer(&HFFFF,&HFFFF)
Type
    Record BlockHead is
      Prec,Suiv as Word
      Size as Word
      FPrec,FSuiv as Word
    End
    BlockHeadPtr is ^BlockHead
Var
   FirstFreeBlock as Word

Def MemAlloc(Size as Word) as Pointer
Sub MemFree(P as Pointer)

Implementation

Const
     Nil16=&HF000

Def MemAlloc(Size as Word) as Pointer
   Block1,Block2 as ^BlockHead
   CurBlock,ParaSize as Word
Enter
\
  Calcul de la taille demand‚e en paragraphes, avec alignement sur 16 \
  ParaSize=(Size>>4)+(Size&&H0F<>0)
\
  Recherche dans la liste des blocs libres \
  CurBlock=FirstFreeBlock
  Always
    Block1=Pointer(CurBlock,0)
  Awhile
    CurBlock<>Nil16 And Block1^.Size<ParaSize
  Do
    CurBlock=Block1^.Suiv
  Wend
\
  Si pas de bloc assez gros, rendre Nil \
  If CurBlock=Nil16 Then Result=Nil
  Else
    If Block1^.Size<=ParaSize+1 Then
      ParaSize=Block1^.Size
    \ Virer Block1 de la liste des libres \
      BlockHeadPtr(Block1^.FPrec,0)^.FSuiv=Block1^.FSuiv
      BlockHeadPtr(Block1^.FSuiv,0)^.FPrec=Block1^.FPrec
    \ Traitement FirstFreeBlock \
      If CurBlock=FirstFreeBlock Then FirstFreeBlock=Block1^.FSuiv;
    Else
    \ Sinon, le d‚couper en 2 et rendre le r‚sultat \
    \ Remplissage Block2 (le morceau restant de l'ancien bloc libre) \
      Block2=Pointer(CurBlock+ParaSize+1,0)
      Block2^.Prec=CurBlock
      Block2^.Suiv=Block1^.Suiv
      BlockHeadPtr(Block1^.Suiv,0)^.Prec=High(Block2)
      Block2^.Size=Block1^.Size-ParaSize-1
    \ Remplacer Block1 par Block2 ds la liste des libres \
      BlockHeadPtr(Block1^.FPrec,0)^.FSuiv=High(Block2)
      BlockHeadPtr(Block1^.FSuiv,0)^.FPrec=High(Block2)
      Block2^.FPrec:=Block1^.FPrec
      Block2^.FSuiv:=Block1^.FSuiv
    \ Remplissage Block1 (le r‚sultat) \
      Block1^.Suiv=High(Block2)
      Block1^.Size=ParaSize
    \ Traitement FirstFreeBlock \
      If CurBlock=FirstFreeBlock Then FirstFreeBlock=High(Block2);
    End
  \ Set Block1 FPrec & FSuiv \
    Block1^.FPrec=Nil16
    Block1^.FSuiv=Nil16
  \ Set Result \
    Result=Pointer(High(Block1)+1,0)
  End
Leave

Sub MemFree(P as Pointer)
   TheBlock,PrecBlock,SuivBlock as ^BlockHead
Enter
\
  Quelques checks... \
  If P<>Nil And High(P)<>0 And Low(P)=0 Then
    TheBlock=BlockHeadPtr(High(P)-1,0)
  \
    Traitement des blocs adjacents en æ - bloc prec \
    If TheBlock^.Prec<>Nil16 Then
      PrecBlock=BlockHeadPtr(TheBlock^.Prec,0)
    \
      Si PrecBlock est un bloc libre, le fusionner avec TheBlock \
      If PrecBlock^.FPrec<>Nil16 Or
         PrecBlock^.FSuiv<>Nil16 Or
         High(PrecBlock)=FirstFreeBlock
      Then
      Begin
      \ Traitement FirstFreeBlock \
        If High(PrecBlock)=FirstFreeBlock Then FirstFreeBlock=PrecBlock^.FSuiv;
        PrecBlock^.Suiv=TheBlock^.Suiv
        BlockHeadPtr(TheBlock^.Suiv,0)^.Prec=High(PrecBlock)
        PrecBlock^.Size+=TheBlock^.Size+1
      \ Virer PrecBlock de la liste des libres \
        BlockHeadPtr(PrecBlock^.FPrec,0)^.FSuiv=PrecBlock^.FSuiv
        BlockHeadPtr(PrecBlock^.FSuiv,0)^.FPrec=PrecBlock^.FPrec
        TheBlock=PrecBlock
      End
    End
  \
    Traitement des blocs adjacents en æ - bloc suiv \
    If TheBlock^.Suiv<>Nil16 Then
      SuivBlock=BlockHeadPtr(TheBlock^.Suiv,0)
    \
      Si SuivBlock est un bloc libre, le fusionner avec TheBlock \
      If SuivBlock^.FPrec<>Nil16 Or
         SuivBlock^.FSuiv<>Nil16 Or
         High(SuivBlock)=FirstFreeBlock
      Then
      Begin
      \ Traitement FirstFreeBlock \
        If High(SuivBlock)=FirstFreeBlock Then FirstFreeBlock=SuivBlock^.FSuiv;
        TheBlock^.Suiv=SuivBlock^.Suiv
        BlockHeadPtr(SuivBlock^.Suiv,0)^.Prec=High(TheBlock)
        TheBlock^.Size+=SuivBlock^.Size+1
      \ Virer SuivBlock de la liste des libres \
        BlockHeadPtr(SuivBlock^.FPrec,0)^.FSuiv=SuivBlock^.FSuiv
        BlockHeadPtr(SuivBlock^.FSuiv,0)^.FPrec=SuivBlock^.FPrec
      End
    End
  \
    Rentrer TheBlock en tˆte de la liste des libres \
    TheBlock^.FPrec=Nil16
    TheBlock^.FSuiv=FirstFreeBlock
    FirstFreeBlock=High(TheBlock)
  End
Leave

Enter
\ Init FirstFreeBlock \
  FirstFreeBlock=Nil16
Leave