home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / nicol / sti_aloc / stialloc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-08-19  |  8.6 KB  |  264 lines
  1. unit STIAlloc;
  2.  
  3. {$S-,R-,I-,V-,B-,D-}
  4.  
  5. interface
  6.  
  7. procedure STI_GetMem(var Point; NoBytes : LongInt);
  8. procedure STI_FreeMem(var Point; NoBytes : LongInt);
  9. function  STI_Ptr2Linear(Point : Pointer) : LongInt;
  10. function  STI_Linear2Ptr(Long : LongInt) : Pointer;
  11. function  STI_Difference(Point1, Point2 : Pointer) : LongInt;
  12. function  STI_Normalise(Point : Pointer) : Pointer;
  13.  
  14. implementation
  15.  
  16. Type
  17.   STI_Point = record                        {the structure of a pointer     }
  18.                 Offset,                     {the offset                     }
  19.                 Segment : Word;             {the segment                    }
  20.               end;
  21.  
  22.   FreeListRec = record
  23.                   BeginPtr : Pointer;       {pointer to the start of a block}
  24.                   EndPtr   : Pointer;       {pointer to the end of a block  }
  25.                 end;
  26.   FreeListRecPtr = ^FreeListRec;            {pointer to a free list entry   }
  27.  
  28. {---------------------------------------------------------------------------}
  29.  
  30. function STI_Normalise(Point : Pointer) : Pointer;
  31.  
  32. begin                                       {return a normalised pointer    }
  33.   inline(
  34.     $58/                                    {pop ax    ;pop offset into AX  }
  35.     $5A/                                    {pop dx    ;pop segment into DX }
  36.     $89/$C3/                                {mov bx,ax ;BX = Ofs(P^)        }
  37.     $B1/$04/                                {mov cl,4  ;CL = 4              }
  38.     $D3/$EB/                                {shr bx,cl ;BX = Ofs(P^) div 16 }
  39.     $01/$DA/                                {add dx,bx ;add BX to segment   }
  40.     $25/$0F/$00);                           {and ax,$F ;mask unwanted bits  }
  41. end;
  42.  
  43. {---------------------------------------------------------------------------}
  44.  
  45. function STI_Ptr2Linear(Point : Pointer) : LongInt;
  46.  
  47. begin                                       {convert a pointer to linear    }
  48.   with STI_Point(Point) do
  49.     STI_Ptr2Linear :=
  50.        (LongInt(Segment) shl 4)+LongInt(Offset);
  51. end;
  52.  
  53. {---------------------------------------------------------------------------}
  54.  
  55. function STI_Linear2Ptr(Long : LongInt) : Pointer;
  56.  
  57. begin                                       {convert Long to a pointer      }
  58.   STI_Linear2Ptr :=
  59.      Ptr(Word(Long shr 4), Word(Long and $0000000F));
  60. end;
  61.  
  62. {---------------------------------------------------------------------------}
  63.  
  64. function STI_Difference(Point1, Point2 : Pointer) : LongInt;
  65.  
  66. begin                                       {return difference in bytes     }
  67.   STI_Difference :=
  68.      Abs(STI_Ptr2Linear(Point1)-STI_Ptr2Linear(Point2));
  69. end;
  70.  
  71. {---------------------------------------------------------------------------}
  72.  
  73. procedure STI_GetMem(var Point; NoBytes : LongInt);
  74.  
  75. var
  76.   NewPoint   : Pointer absolute Point;
  77.   NewFreePtr : FreeListRecPtr;
  78.   Top        : Pointer;
  79.   ThisBlock  : LongInt;
  80.  
  81. begin
  82.   NewPoint    := NIL;                       {null the new pointer          }
  83.   NewFreePtr := FreePtr;                    {save the old free pointer     }
  84.   if STI_Point(NewFreePtr).Offset = 0 then  {check the segment boundary    }
  85.     Inc(STI_Point(NewFreePtr).Segment,$1000);
  86.  
  87.   {point to top of free memory ????}
  88.   if FreeMin = 0 then
  89.     Top := Ptr(STI_Point(FreePtr).Segment+$1000, 0)
  90.   else
  91.     Top := Ptr(STI_Point(FreePtr).Segment, -FreeMin);
  92.   if STI_Ptr2Linear(NewFreePtr) < STI_Ptr2Linear(Top) then
  93.     Top := NewFreePtr;
  94.  
  95.   {check block at HeapPtr^}
  96.   if STI_Difference(Top, HeapPtr) >= NoBytes then
  97.     begin
  98.       {use this block}
  99.       NewPoint := HeapPtr;
  100.  
  101.       {adjust HeapPtr}
  102.       HeapPtr := STI_Linear2Ptr(STI_Ptr2Linear(HeapPtr)+NoBytes);
  103.     end
  104.     else
  105.       while STI_Point(NewFreePtr).Offset <> 0 do
  106.         begin
  107.           {search the free list for a memory block that is big enough}
  108.           with NewFreePtr^ do
  109.             begin
  110.               {calculate the size of the block}
  111.               ThisBlock := STI_Difference(EndPtr, BeginPtr);
  112.  
  113.                if ThisBlock > NoBytes then
  114.                  begin
  115.                    {bigger than we need--shrink the size of the block}
  116.                    NewPoint := BeginPtr;
  117.                    BeginPtr := STI_Linear2Ptr(STI_Ptr2Linear(BeginPtr)+NoBytes);
  118.                    Exit;
  119.                  end
  120.                else
  121.                  if ThisBlock = NoBytes then
  122.                    begin
  123.                      {exact size--remove the record from the free list}
  124.                      NewPoint := BeginPtr;
  125.  
  126.                      {move the entry at the bottom of the free list up}
  127.                      NewFreePtr^ := FreeListRecPtr(FreePtr)^;
  128.  
  129.                      {adjust FreePtr}
  130.                      with STI_point(FreePtr) do
  131.                      Inc(Offset, SizeOf(FreeListRec));
  132.                      Exit;
  133.                    end;
  134.             end;
  135.  
  136.           {point to next record on free list}
  137.           Inc(STI_Point(NewFreePtr).Offset, SizeOf(FreeListRec));
  138.         end;
  139. end;
  140.  
  141. {---------------------------------------------------------------------------}
  142.  
  143. procedure STI_FreeMem(var Point; NoBytes : LongInt);
  144.  
  145. var
  146.   NewPoint : Pointer absolute Point;
  147.   EndP     : Pointer;
  148.   FP, SaveFP, NewFreePtr : FreeListRecPtr;
  149.   I : Word;
  150.   Found : Boolean;
  151.  
  152. begin
  153.     {exit if P is nil}
  154.     if (NewPoint = nil) then
  155.       Exit;
  156.  
  157.     {calculate pointer to end of block}
  158.     EndP := STI_Linear2Ptr(STI_Ptr2Linear(NewPoint)+NoBytes);
  159.  
  160.     {see if this is just below HeapPtr^}
  161.     if EndP = HeapPtr then
  162.       {just reset HeapPtr}
  163.       HeapPtr := NewPoint
  164.     else begin
  165.       {search for a free list entry to combine this block with}
  166.       Found := False;
  167.       FP := FreePtr;
  168.       while (STI_Point(FP).Offset <> 0) and not Found do begin
  169.         with FP^ do
  170.           {does the end of our block match the start of this one?}
  171.           if BeginPtr = EndP then begin
  172.             BeginPtr := NewPoint;
  173.             Found := True;
  174.           end
  175.           {does the start of our block match the end of this one?}
  176.           else if EndPtr = NewPoint then begin
  177.             EndPtr := EndP;
  178.             Found := True;
  179.           end;
  180.  
  181.         {point to next record on free list}
  182.         if not Found then
  183.           Inc(STI_Point(FP).Offset, SizeOf(FreeListRec));
  184.       end;
  185.  
  186.       if Found then begin
  187.         {save pointer into free list and get pointers to search for}
  188.         SaveFP := FP;
  189.         with FP^ do begin
  190.           NewPoint := BeginPtr;
  191.           EndP := EndPtr;
  192.         end;
  193.  
  194.         {see if we can combine this block with a second}
  195.         Found := False;
  196.         FP := FreePtr;
  197.         while (STI_Point(FP).Offset <> 0) and not Found do begin
  198.           with FP^ do
  199.             {does the end of our block match the start of this one?}
  200.             if BeginPtr = EndP then begin
  201.               BeginPtr := NewPoint;
  202.               Found := True;
  203.             end
  204.             {does the start of our block match the end of this one?}
  205.             else if EndPtr = NewPoint then begin
  206.               EndPtr := EndP;
  207.               Found := True;
  208.             end;
  209.  
  210.           {point to next record on free list}
  211.           if not Found then
  212.             Inc(STI_Point(FP).Offset, SizeOf(FreeListRec));
  213.         end;
  214.  
  215.         if Found then begin
  216.           {we combined two blocks--get rid of the 1st free list entry we found}
  217.  
  218.           {move the entry at the bottom of the free list up into its place}
  219.           SaveFP^ := FreeListRecPtr(FreePtr)^;
  220.  
  221.           {adjust FreePtr}
  222.           with STI_Point(FreePtr) do
  223.             Inc(Offset, SizeOf(FreeListRec));
  224.         end;
  225.       end
  226.       else begin
  227.         {can't combine with anything--add an entry to the free list}
  228.  
  229.         {calculate new FreePtr}
  230.         with STI_Point(FreePtr) do
  231.           NewFreePtr := Ptr(Segment, Offset-SizeOf(FreeListRec));
  232.  
  233.         {make sure the free list isn't full}
  234.         with STI_Point(NewFreePtr) do
  235.           if (STI_Ptr2Linear(NewFreePtr) < STI_Ptr2Linear(HeapPtr)) or (Offset = 0) then begin
  236.             {it's full--let real FreeMem generate a runtime error}
  237.             if NoBytes > 65521 then
  238.               I := 65521
  239.             else
  240.               I := NoBytes;
  241.             FreeMem(NewPoint, I);
  242.             Exit;
  243.           end;
  244.  
  245.         {fill in the new free list entry}
  246.         with NewFreePtr^ do begin
  247.           BeginPtr := NewPoint;
  248.           EndPtr := EndP;
  249.         end;
  250.  
  251.         {adjust FreePtr}
  252.         FreePtr := NewFreePtr;
  253.       end;
  254.  
  255.       {set P to nil}
  256.       NewPoint := nil;
  257.     end;
  258.   end;
  259.  
  260. {---------------------------------------------------------------------------}
  261.  
  262. begin
  263. end.
  264.