home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / dtx9101 / xheap / xheap.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1991-09-13  |  22.0 KB  |  637 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      XHEAP.PAS                         *)
  3. (*  Diese Unit ermöglicht es großen Programmen, die einen *)
  4. (*  sehr gierigen Speicherbedarf haben, einen privaten,   *)
  5. (*  erweiterten Heap zu benutzen. Dieser Heap wird vom    *)
  6. (*  EMS genommem; steht dieses nicht zur Verfügung oder   *)
  7. (*  reicht es immer noch nicht aus, so wird auch die      *)
  8. (*  Platte als Heap verwendet. Das Programm arbeitet in   *)
  9. (*  jedem Fall nur mit den dynamischen Daten (Zeigern).   *)
  10. (*     (c) 1991 Dipl.Ing. O. Grossklaus & DMV-Verlag      *)
  11. (* ------------------------------------------------------ *)
  12. {$F+,I-}
  13. UNIT XHeap;
  14.  
  15. INTERFACE
  16.  
  17. USES
  18.   Dos;
  19.  
  20. CONST
  21.   AbsMaxEMSBlocks  : BYTE = 8;     { abs. Max. an 64K-Blk (EMS)    }
  22.   AbsMaxFileBlocks : BYTE = 8;     { abs. Max. an 64K-Blk (HDD)    }
  23.  
  24.   SwapBufferSize   = 65500;        { nur relevant, wenn kein EMS,  }
  25.                                    { also alles im HEAP(std.65500) }
  26.   MaxLLEntrys      =  1000;        { Anzahl der LochListenEinträge }
  27.   NormSize         = TRUE;         { normalisiere die Größe        }
  28.   BestFit          = TRUE;
  29.   UseNHeapForSBuf  = TRUE;         { normalen Heap mitbenutzen     }
  30.  
  31. TYPE
  32.   BlockType     = (EMSType, HDType);      { Typ des 64K-Blocks     }
  33.   XtendedPtr    = RECORD                  { EMS-Pointer-Typ        }
  34.                     P       : POINTER;    { anpassen mit TypeCast  }
  35.                     BlockNr : WORD;       { BlockNr. des Speichers }
  36.                   END;
  37.   SwapBufferPtr = ^SwpBuffer;         { Block zum Arbeiten auf HDD }
  38.  
  39.   SwpBuffer     = ARRAY [1..SwapBufferSize] of BYTE;
  40.  
  41.   LLEntry       = RECORD                  { Lochlisteneintrag      }
  42.                     Offset : WORD;
  43.                     Size   : WORD;
  44.                   END;
  45.   LLPtr         = ^LochLst;               { Lochliste              }
  46.   LochLst       = ARRAY [1..MaxLLEntrys] of LLEntry;
  47.   DescTypePtr   = ^DescType;              { Block-Identifier       }
  48.   DescType      = RECORD
  49.                     BlockNr : WORD;       { EMS/HDD-Block          }
  50.  
  51.   (* ---------------------------------------------------- *)
  52.   (* Zur Geschwindigkeitssteigerung kann das folgende     *)
  53.   (* Flag aktiviert werden. Es muß aber bei Benutzung der *)
  54.   (* Speicherblöcke "von Hand" gesetzt werden, damit      *)
  55.   (* dieser Block gespeichert wird.                       *)
  56.   (* ---------------------------------------------------- *)
  57. {.$DEFINE SpeedUp}
  58.  
  59. {$IFDEF SpeedUp}
  60.                     Modified : BOOLEAN;   { wurde es geändert ?    }
  61. {$ENDIF}
  62.  
  63.                     Typ      : BlockType; { Blocktyp: EMS oder HDD }
  64.                     BlkUsed  : LONGINT;   { # Benutzungen          }
  65.                     AnzPtr   : WORD;      { # Zeiger auf den Block }
  66.                   END;
  67.  
  68. VAR
  69.   MMUse        : BOOLEAN;          { extended MemoryManagement Use }
  70.   CurrentBlock : WORD;             { aktueller EMS/HDD-Block       }
  71.   Descriptor   : DescTypePtr;      { Block-Beschreibung            }
  72.   LochListe    : LLPtr;            { Lochliste eines Blocks        }
  73.   EMSError     : WORD;      { EMS-Fehler nach EMS-Aufruf?          }
  74.   EMSBlocks    : WORD;      { Wieviele EMSBlks sind gerade benutzt }
  75.   FileBlocks   : WORD;      { dto. für Datei-Blöcke                }
  76.  
  77.  
  78.   FUNCTION MemAvailX(Size : WORD) : BOOLEAN;
  79.     (* Testroutine, ob überhaupt noch Speicher vorhanden *)
  80.  
  81.   PROCEDURE GetMemX(VAR P; Size : WORD);
  82.     (* Speicheranforderungsroutine *)
  83.  
  84.   PROCEDURE FreeMemX(VAR P; Size : WORD);
  85.     (* Speicherfreigaberoutine *)
  86.  
  87.   PROCEDURE BlendeBlockEin(Nr : WORD);
  88.     (* Einblenderoutine eines bestimmten Blocks *)
  89.  
  90. (* ------------------------------------------------------ *)
  91.   
  92. IMPLEMENTATION
  93.  
  94. VAR
  95.   EMSInt            : POINTER ABSOLUTE 0:$19C;  { Interrupt für EMS }
  96.   Regs              : Registers;
  97.  
  98.   ExitSave          : POINTER; { Exit-Routine zum Aufräumen EMS/HDD }
  99.  
  100.   SwapFile          : FILE OF SwpBuffer;  { Datei für Auslagerungen }
  101.  
  102.   SwapBufferPresent : BOOLEAN;       { gibt's zum Swappen Speicher? }
  103.   SwapBuffer        : SwapBufferPtr; { Zeiger auf einen 64K-Block   }
  104.   EMSAvail          : BOOLEAN;       { Ist EMS da?                  }
  105.   EMSHandle         : WORD;          { verwendeter EMSHandle        }
  106.  
  107.                                      { LochListen-Update-Routinen   }
  108.   ClearMemory : ARRAY[0..3] OF
  109.                   PROCEDURE(Pt : XtendedPtr; Size : WORD);
  110.  
  111.  
  112.   PROCEDURE EMSCall;
  113.     (* Aufruf des EMS-Treibers *)
  114.   BEGIN
  115.     Intr($67, Regs);
  116.     EMSError := Regs.AH;
  117.   END;
  118.  
  119.   FUNCTION EMSAvailable : BOOLEAN;
  120.     (* Feststellen, ob es überhaupt EMS gibt *)
  121.   BEGIN
  122.     EMSAvailable := FALSE;
  123.     IF EMSInt <> NIL THEN BEGIN
  124.       IF BYTE(EMSInt^) <> $CF THEN BEGIN                  { IRET }
  125.                                 { Ist EMS überhaupt installiert? }
  126.         Regs.AH := $40;
  127.         EMSCall;
  128.         IF EMSError = 0 THEN BEGIN
  129.           Regs.AH := $42;       { hole Anzahl freier 16K Blöcke  }
  130.           EMSCall;
  131.           EMSAvailable := (EMSError = 0) AND (Regs.BX >= 4);
  132.         END;
  133.       END;
  134.     END;
  135.   END;
  136.  
  137.   PROCEDURE GetWorkBufferEMS;
  138.     (* Arbeitsbuffer im EMS festlegen *)
  139.   VAR
  140.     i : BYTE;
  141.   BEGIN
  142.     Regs.AH := $43;                { reserviere Blöcke           }
  143.     Regs.BX := 4;                  { einen 64K Block reservieren }
  144.     EMSCall;                       { reserviere die 16K Blöcke   }
  145.     EMSHandle := Regs.DX;          { Handle zurück               }
  146.     FOR i := 0 to 3 DO BEGIN       { EMSBlock 0 einblenden       }
  147.       Regs.AX := $4400 + i;
  148.       Regs.BX := i;
  149.       Regs.DX := EMSHandle;
  150.       EMSCall;
  151.     END;
  152.   END;
  153.  
  154.   FUNCTION GetPageFrameSeg : WORD;
  155.     (* Anfangsadresse des Arbeitsbuffers erfragen *)
  156.   BEGIN
  157.     GetPageFrameSeg := 0;
  158.     IF EMSAvail THEN BEGIN
  159.       Regs.AH := $41;
  160.       EMSCall;
  161.       IF EMSError = 0 THEN
  162.         GetPageFrameSeg := Regs.BX;
  163.     END;
  164.   END;
  165.  
  166.   PROCEDURE InitAll;
  167.     (* Alle Variablen und Strukturen initialisieren *)
  168.   BEGIN
  169.     MMUse             := TRUE;   { Benutze diese Verwaltung            }
  170.     EMSBlocks         := 0;      { Keine Blocks bis jetzt              }
  171.     FileBlocks        := 0;      { dto.                                }
  172.     EMSHandle         := 0;      { Handlenummer für EMS                }
  173.     EMSError          := 0;      { EMS-Fehler                          }
  174.     SwapBuffer        := NIL;    { kein Swapbuffer präsent             }
  175.     SwapBufferPresent := FALSE;  { ... }
  176.     Descriptor        := NIL;    { keine Swapbuffer-Beschreibung aktiv }
  177.     LochListe         := NIL;                { keine Lochliste aktiv   }
  178.     CurrentBlock      := $FFFF;              { kein aktiver Block      }
  179.     EMSAvail          := EMSAvailable;       { schau mal nach ...      }
  180.     IF EMSAvail THEN BEGIN
  181.                                       { GetWorkBuffer im EMS PageFrame }
  182.       GetWorkBufferEMS;
  183.       SwapBuffer := Ptr(GetPageFrameSeg, 0);
  184.     END ELSE BEGIN
  185.                                       { GetWorkBuffer im normalen HEAP }
  186.       IF (MaxAvail>=SwapBufferSize) AND UseNHeapForSBuf THEN
  187.         GetMem(SwapBuffer, SwapBufferSize)
  188.       ELSE
  189.         MMUse := FALSE;       { keine Möglichkeit, die Verw. zu nutzen }
  190.     END;
  191.     IF MMUse THEN BEGIN
  192.                          { Festlegung der Blockdescriptoren und der LL }
  193.       Descriptor        := DescTypePtr(SwapBuffer);
  194.       LochListe         := Ptr(Seg(Descriptor^), SizeOf(DescType));
  195.       SwapBufferPresent := TRUE;
  196.       FillChar(SwapBuffer^, SwapBufferSize, #0);     { Blank putzen    }
  197.       Assign(SwapFile, 'SWAP.!!!');                  { SwapFile öffnen }
  198.       Rewrite(SwapFile);
  199.       IF IOResult <> 0 THEN;
  200.     END;
  201.   END;
  202.  
  203.   PROCEDURE SaveCurrentFileBlock;
  204.     (* Den aktuellen 64K-Block auf Datei sichern (wenn nötig) *)
  205.   BEGIN
  206.     IF (FileBlocks <> 0)
  207. {$IFDEF SpeedUp}
  208.         AND Descriptor^.Modified
  209. {$ENDIF}
  210.                                   THEN BEGIN
  211.       Seek(SwapFile, Descriptor^.BlockNr-EMSBlocks-1);
  212.       IF IOResult <> 0 THEN;
  213. {$IFDEF SpeedUp}
  214.       Descriptor^.Modified := FALSE;
  215. {$ENDIF}
  216.       Write(SwapFile, SwapBuffer^);
  217.       IF IOResult <> 0 THEN;
  218.     END;
  219.   END;
  220.  
  221.   PROCEDURE PositionFile(Place : WORD);
  222.     (* Dateizeiger auf den durch PLACE angegebenen Block setzen *)
  223.   BEGIN
  224.     IF Place <= FileSize(SwapFile) THEN
  225.       Seek(SwapFile, Place);
  226.     IF IOResult <> 0 THEN;
  227.   END;
  228.  
  229.   PROCEDURE BlendeBlockEin(Nr : WORD);
  230.     (* aktuellen Block speichern und NR-Block einblenden *)
  231.   VAR
  232.     i : BYTE;
  233.   BEGIN
  234.     IF CurrentBlock <> Nr THEN BEGIN
  235.                                 { ist der Blk schon eingeblendet? }
  236.       IF (Nr <= EMSBlocks) AND EMSAvail THEN      { Block aus EMS }
  237.         FOR i := 0 to 3 DO BEGIN
  238.           Regs.AX := $4400 + i;     { Block (16K) 0..3 einblenden }
  239.           Regs.BX := Nr * 4 + i;
  240.           Regs.DX := EMSHandle;
  241.           EMSCall;
  242.         END ELSE BEGIN                            { Block von HDD }
  243.           IF EMSAvail THEN            { FileWorkBuffer einblenden }
  244.             BlendeBlockEin(0);
  245.           SaveCurrentFileBlock;       { aktuellen Block speichern }
  246.           IF Nr > 0 THEN
  247.             PositionFile(Pred(Nr - EMSBlocks));
  248.           IF FilePos(SwapFile) <> FileSize(SwapFile) THEN
  249.             IF Descriptor^.BlockNr <> (Nr - EMSBlocks) THEN
  250.               Read(SwapFile, SwapBuffer^);             { einlesen }
  251.           IF IOResult <> 0 THEN;
  252.         END;
  253.       CurrentBlock := Nr;                   { Currentblock setzen }
  254.     END;
  255.   END;
  256.  
  257.   PROCEDURE InitCurrentBlock(Nr : WORD);
  258.     (* neuen Block initialisieren *)
  259.   BEGIN
  260.     FillChar(SwapBuffer^, SwapBufferSize, #0);     { Blank putzen }
  261.     WITH Descriptor^ DO BEGIN
  262.       BlockNr := Nr;                         { BlockNummer setzen }
  263. {$IFDEF SpeedUp}
  264.       Modified := TRUE;
  265. {$ENDIF}
  266.       IF Nr > EMSBlocks THEN
  267.         Typ := HDType                           { Typ setzen }
  268.       ELSE
  269.         Typ := EMSType;
  270.     END;
  271.     WITH LochListe^[1] DO BEGIN       { Lochliste initialisieren }
  272.       Offset := SizeOf(DescType) + SizeOf(LochLst);
  273.       Size := SwapBufferSize - Offset;
  274.     END;
  275.     IF Nr > EMSBlocks THEN
  276.       CurrentBlock := Nr;
  277.     Descriptor^.BlkUsed := 0;
  278.     Descriptor^.AnzPtr  := 0;
  279.   END;
  280.  
  281.   PROCEDURE NormalizeSize(VAR Size : WORD);
  282.     (* Größe anpassen auf das nächste acht-fache *)
  283.   BEGIN
  284.     IF NormSize THEN
  285.       Size := 8 + (8 * (Pred(Size) DIV 8));
  286.   END;
  287.  
  288.   FUNCTION MemAvailX;
  289.     (* Testen, ob in irgendeinem Block noch die angeforderte *)
  290.     (* Menge an Speicher vorhanden ist                       *)
  291.   VAR
  292.     BlockCount : WORD;
  293.  
  294.     FUNCTION CheckLLEntrys : BOOLEAN;
  295.       (* Lochlisten-Check auf genügend großen Eintrag *)
  296.     VAR
  297.       LLCount : WORD;
  298.     BEGIN
  299.       CheckLLEntrys := TRUE;
  300.       LLCount := 1;
  301.       WHILE (LochListe^[LLCount].Size > 0) AND
  302.             (LLCount <= MaxLLEntrys) DO BEGIN
  303.         IF LochListe^[LLCount].Size >= Size THEN
  304.           Exit;
  305.         Inc(LLCount);
  306.       END;
  307.       CheckLLEntrys := FALSE;
  308.     END;
  309.  
  310.   BEGIN
  311.     NormalizeSize(Size);
  312.     IF (Size = 0) OR
  313.        (Size > (SwapBufferSize -
  314.               SizeOf(DescType) -
  315.               SizeOf(LochLst))) THEN BEGIN       { ungültig, also }
  316.       MemAvailX := FALSE;                        { raus hier!     }
  317.       Exit;
  318.     END;
  319.     MemAvailX := TRUE;
  320.                 { erst mal EMS testen, weil es am schnellsten ist }
  321.     IF EMSAvail THEN BEGIN
  322.                 { Ist im CurrentBlock (EMS) noch Platz ?...       }
  323.       IF (EMSBlocks > 0) and(CurrentBlock <= EMSBlocks) THEN
  324.         IF CheckLLEntrys THEN Exit;               { es gibt Platz }
  325.  
  326.            { ...Nein! ist in irgendeinem Block (EMS) was frei ?...}
  327.       BlockCount := 1;
  328.       WHILE BlockCount <= EMSBlocks DO BEGIN
  329.         BlendeBlockEin(BlockCount);      { alle EMS-Blöcke testen }
  330.         IF CheckLLEntrys THEN Exit;      { es gibt Platz          }
  331.  
  332.         INC(BlockCount);
  333.       END;
  334.  
  335.                       {... Nein! ist überhaupt noch EMS frei ?... }
  336.       Regs.AH := $42;             { hole Anzahl freier 16K Blöcke }
  337.       EMSCall;
  338.       IF EMSBlocks >= AbsMaxEMSBlocks THEN       { "Schallgrenze" }
  339.         Regs.BX := 0;
  340.       IF (Regs.BX >= 4) THEN BEGIN
  341.                                { es gibt noch über 64K freies EMS }
  342.         Regs.AH := $51;
  343.         Regs.BX := (EMSBlocks * 4) + 8;         { neuen 64K Block }
  344.         Regs.DX := EMSHandle;
  345.         EMSCall;
  346.         IF (Regs.BX = (EMSBlocks * 4) + 8) AND
  347.            (EMSError = 0) THEN BEGIN
  348.           INC(EMSBlocks);              { reservieren hat geklappt }
  349.           BlendeBlockEin(EMSBlocks);   { mache den Blk aktuell    }
  350.           InitCurrentBlock(EMSBlocks); { Initialisiere Blk        }
  351.           Exit;                        { Ergebnis: Speicher da!   }
  352.         END;
  353.       END;
  354.     END;
  355.  
  356.         { EMSWorkBuffer einblenden, und alle Plattenblöcke testen }
  357.     IF EMSAvail THEN BEGIN
  358.       BlendeBlockEin(0);
  359.       CurrentBlock := Descriptor^.BlockNr;
  360.     END;
  361.  
  362.        { ...Nein! ist auf dem aktuellen Plattenblock was frei?... }
  363.     IF FileBlocks <> 0 THEN BEGIN
  364.       IF CheckLLEntrys THEN
  365.         Exit;               { es gibt ein real existierendes Loch }
  366.  
  367.        { ...Nein! ist auf irgendeinem HDD-Block was frei ?...     }
  368.       BlockCount := 1;
  369.       WHILE BlockCount <= FileBlocks DO BEGIN
  370.                                         { alle Blöcke durchtesten }
  371.         BlendeBlockEin(EMSBlocks + BlockCount);
  372.         IF CheckLLEntrys THEN
  373.           Exit;                    { ein Block mit Platz gefunden }
  374.         INC(BlockCount);
  375.       END;
  376.     END;
  377.             { ...Nein! ist überhaupt auf der Platte was frei ?... }
  378.     IF FileBlocks <> 0 THEN
  379.       SaveCurrentFileBlock;           { evtl. alten Block sichern }
  380.  
  381.     IF FileBlocks < AbsMaxFileBlocks THEN BEGIN
  382.                                  { nächsten Plattenblock erzeugen }
  383.       InitCurrentBlock(EMSBlocks + Succ(FileBlocks));
  384.       Seek(SwapFile, FileSize(SwapFile));
  385. {$IFDEF SpeedUp}
  386.       Descriptor^.Modified := FALSE;
  387. {$ENDIF}
  388.       Write(SwapFile, SwapBuffer^);
  389.       IF IOResult = 0 THEN BEGIN
  390.                       { es gibt auf der Platte einen freien Block }
  391.         INC(FileBlocks);
  392.         Exit;
  393.       END ELSE
  394.                   { Vorletzten Block einblenden, wenn Platte voll }
  395.         BlendeBlockEin(Pred(CurrentBlock));
  396.     END;
  397.          { ...Nein! also: DEFINITIV KEIN SPEICHER! }
  398.     IF (CurrentBlock = 0) AND
  399.        ((EMSBlocks + FileBlocks) > 0) THEN
  400.       BlendeBlockEin(1);
  401.     MemAvailX := FALSE;
  402.   END;
  403.  
  404.   PROCEDURE ClearLLEntry(LC : WORD);
  405.     (* Lochlisteneintrag entfernen *)
  406.   BEGIN
  407.     Move(LochListe^[Succ(LC)], LochListe^[LC],
  408.         (MaxLLEntrys-LC)*SizeOf(LLEntry));
  409.     LochListe^[MaxLLEntrys].Size := 0;
  410.     LochListe^[MaxLLEntrys].Offset := 0;
  411.   END;
  412.  
  413.   PROCEDURE SortLL;
  414.     (* Sortieren der Lochliste nach Größe führt dazu, daß immer *)
  415.     (* das am besten passende Loch genommen wird                *)
  416.   VAR
  417.      LLCount : WORD;
  418.      Tmp     : LLEntry;
  419.      i       : WORD;
  420.   BEGIN                                        { Bubble-Sort }
  421.     LLCount := 2;
  422.     WHILE (LLCount <= MaxLLEntrys) AND
  423.           (LochListe^[LLCount].Size > 0) DO BEGIN
  424.       IF LochListe^[LLCount].Size <
  425.          LochListe^[Pred(LLCount)].Size THEN BEGIN
  426.         i := LLCount;
  427.         WHILE (I > 1) AND                    { Swap-Eintrag }
  428.             (LochListe^[I].Size <
  429.              LochListe^[Pred(I)].Size) DO BEGIN
  430.           Tmp := LochListe^[Pred(I)];
  431.           LochListe^[Pred(I)] := LochListe^[I];
  432.           LochListe^[I] := Tmp;
  433.           DEC(i);
  434.         END;
  435.       END;
  436.       INC(LLCount);
  437.     END;
  438.   END;
  439.  
  440.   PROCEDURE GetMemX;
  441.     (* Speicher anfordern.Diese Routine DARF nur nach MemAvailX *)
  442.     (* aufgerufen werden, damit der richtige Block eingeblendet *)
  443.     (* ist.                                                     *)
  444.   VAR
  445.     Pt      : XtendedPtr ABSOLUTE P;    { TypeCasting des Zeigers }
  446.     LLCount : WORD;
  447.   BEGIN
  448.     NormalizeSize(Size);
  449.     Pt.P := NIL;
  450.     Pt.BlockNr := 0;
  451.     IF Size = 0 THEN Exit;
  452.              { Block ist eingeblendet und hat Speicher !!! }
  453.     LLCount := 1;
  454.     WHILE (LochListe^[LLCount].Size < Size) AND
  455.           (LLCount <= MaxLLEntrys) DO
  456.       Inc(LLCount);
  457.     IF LLCount > MaxLLEntrys THEN
  458.       RunError(203);             { falsche XHEAP-Anforderung }
  459.     Pt.P := Ptr(Seg(SwapBuffer^), LochListe^[LLCount].Offset);
  460.     Pt.BlockNr := CurrentBlock;
  461.     IF CurrentBlock = 0 THEN
  462.       inline($cc);
  463.                                 { Locheintrag aktualisieren }
  464.     Dec(LochListe^[LLCount].Size, Size);
  465.     Inc(LochListe^[LLCount].Offset, Size);
  466.     IF LochListe^[LLCount].Size = 0 THEN
  467.       ClearLLEntry(LLCount);    { Leeren Locheintrag löschen }
  468. {$IFDEF SpeedUp}
  469.     Descriptor^.Modified := TRUE;
  470. {$ENDIF}
  471.     inc(Descriptor^.AnzPtr);
  472.     inc(Descriptor^.BlkUsed);
  473.     IF BestFit THEN SortLL;
  474.   END;
  475.  
  476.   FUNCTION ExistLochOver(Pt : XtendedPtr; Size : WORD) : BYTE;
  477.     (* Gibt es über dem freizugebenden Loch ein weiteres,   *)
  478.     (* das zu einem großen Loch zusammengefaßt werden kann? *)
  479.   VAR
  480.     LLCount : WORD;
  481.   BEGIN
  482.     ExistLochOver := 0;
  483.     LLCount := 1;
  484.     WHILE (LochListe^[LLCount].Size > 0) AND
  485.           (LLCount <= MaxLLEntrys) DO BEGIN
  486.       IF Ofs(Pt.P^) + Size = LochListe^[LLCount].Offset THEN BEGIN
  487.         ExistLochOver := 2;      { Index für PROCEDURE-ARRAY }
  488.         Exit;
  489.       END;
  490.       Inc(LLCount);
  491.     END;
  492.     IF LLCount > MaxLLEntrys THEN         { Fehlerbehandlung }
  493.       RunError(204);
  494.   END;
  495.  
  496.   FUNCTION ExistLochUnder(Pt : XtendedPtr) : BYTE;
  497.     (* dto. aber unterhalb ein Loch frei *)
  498.   VAR
  499.     LLCount : WORD;
  500.   BEGIN
  501.     ExistLochUnder := 0;
  502.     LLCount := 1;
  503.     WHILE (LochListe^[LLCount].Size > 0) AND
  504.           (LLCount <= MaxLLEntrys) DO BEGIN
  505.       WITH LochListe^[LLCount] DO
  506.         IF Offset + Size = Ofs(Pt.P^) THEN BEGIN
  507.           ExistLochUnder := 1;   { Index für PROCEDURE-ARRAY }
  508.           Exit;
  509.         END;
  510.       Inc(LLCount);
  511.     END;
  512.     IF LLCount > MaxLLEntrys THEN         { Fehlerbehandlung }
  513.       RunError(204);
  514.   END;
  515.  
  516.   PROCEDURE Clear0(Pt : XtendedPtr; Size : WORD);
  517.     (* einfache Speicherfreigabe *)
  518.   VAR
  519.     LLCount : WORD;
  520.   BEGIN
  521.     LLCount := 1;    { suche den nächsten freien Locheintrag }
  522.     WHILE (LochListe^[LLCount].Size <> 0) AND
  523.           (LLCount <= MaxLLEntrys) DO
  524.       Inc(LLCount);
  525.     IF LLCount > MaxLLEntrys THEN
  526.       RunError(204);
  527.                                { markiere Speicher als FREI }
  528.     LochListe^[LLCount].Offset := Ofs(Pt.P^);
  529.     LochListe^[LLCount].Size := Size;
  530.   END;
  531.  
  532.   PROCEDURE Clear1(Pt : XtendedPtr; Size : WORD);
  533.     (* aktuelle Freigabe mit Loch darunter *)
  534.   VAR
  535.     LLCount : WORD;
  536.   BEGIN
  537.     LLCount := 1;          { suche den passenden Locheintrag }
  538.     WHILE (LochListe^[LLCount].Offset +
  539.            LochListe^[LLCount].Size <> Ofs(Pt.P^)) AND
  540.            (LLCount <= MaxLLEntrys) DO
  541.       Inc(LLCount);
  542.     IF LLCount > MaxLLEntrys THEN
  543.       RunError(204);
  544.     Inc(LochListe^[LLCount].Size, Size);{ Eintrag vergrößern }
  545.   END;
  546.  
  547.   PROCEDURE Clear2(Pt : XtendedPtr; Size : WORD);
  548.     (* Freigabe mit Loch darüber *)
  549.   VAR
  550.     LLCount : WORD;
  551.   BEGIN
  552.     LLCount := 1;              { finde passenden Locheintrag }
  553.     WHILE (Ofs(Pt.P^)+Size <> LochListe^[LLCount].Offset) AND
  554.           (LLCount <= MaxLLEntrys) DO
  555.       Inc(LLCount);
  556.     IF LLCount > MaxLLEntrys THEN
  557.       RunError(204);
  558.     Dec(LochListe^[LLCount].Offset, Size);{ Eintrag anpassen }
  559.     Inc(LochListe^[LLCount].Size, Size);
  560.   END;
  561.  
  562.   PROCEDURE Clear3(Pt : XtendedPtr; Size : WORD);
  563.     (* Freigabe mit Loch darüber UND darunter *)
  564.   VAR
  565.     LochUnder,
  566.     LochOver : WORD;
  567.   BEGIN
  568.     LochUnder := 1;                    { finde Loch darunter }
  569.     WHILE (LochListe^[LochUnder].Offset +
  570.            LochListe^[LochUnder].Size <> Ofs(Pt.P^)) AND
  571.            (LochUnder <= MaxLLEntrys) DO
  572.       Inc(LochUnder);
  573.     LochOver := 1;                      { finde Loch darüber }
  574.     WHILE (Ofs(Pt.P^)+Size <> LochListe^[LochOver].Offset) AND
  575.           (LochOver <= MaxLLEntrys) DO
  576.       Inc(LochOver);
  577.                               { aktualisiere die Lochliste }
  578.     LochListe^[LochUnder].Size := LochListe^[LochUnder].Size +
  579.                                   LochListe^[LochOver].Size +
  580.                                   Size;
  581.     ClearLLEntry(LochOver);     { Leeren Locheintrag löschen }
  582.   END;
  583.  
  584.   PROCEDURE FreeMemX;
  585.     (* Freigabe des angeforderten Speichers *)
  586.   VAR
  587.     Pt : XtendedPtr ABSOLUTE P;    { TypeCasting des Zeigers }
  588.   BEGIN
  589.     NormalizeSize(Size);
  590.     IF Size = 0 THEN Exit;
  591.     BlendeBlockEin(Pt.BlockNr);           { Block einblenden }
  592.     IF Pt.P = NIL THEN                    { Fehlerbehandlung }
  593.       RunError(204);
  594.                               { trickiger PROCEDURE-Aufruf }
  595.     ClearMemory[ExistLochUnder(Pt) +
  596.                 ExistLochOver(Pt,Size)](Pt, Size);
  597.     Pt.P := NIL;
  598.     Pt.BlockNr := 0;
  599. {$IFDEF SpeedUp}
  600.     Descriptor^.Modified := TRUE;
  601. {$ENDIF}
  602.     dec(Descriptor^.AnzPtr);
  603.     IF BestFit THEN SortLL;
  604.   END;
  605.  
  606.   PROCEDURE ExitEMS;
  607.   BEGIN
  608.     IF EMSAvail THEN BEGIN                 { gebe EMS wieder frei }
  609.       Regs.AH := $45;
  610.       Regs.DX := EMSHandle;
  611.       EMSCall;
  612.     END ELSE                              { gebe HEAP wieder frei }
  613.       IF SwapBuffer <> NIL THEN
  614.         FreeMem(SwapBuffer, SwapBufferSize);
  615.     Close(SwapFile);                 { lösche die Swap-Datei }
  616.     IF IOResult <> 0 THEN;
  617.     Erase(SwapFile);
  618.     IF IOResult <> 0 THEN;
  619.     ExitProc := ExitSave;
  620.   END;
  621.  
  622.  
  623. BEGIN
  624.  
  625.   (* Initialisierungsteil *)
  626.  
  627.   ExitSave       := ExitProc;
  628.   ExitProc       := @ExitEMS;
  629.   InitAll;                      { Variablen initialisieren }
  630.   ClearMemory[0] := Clear0;     { PROCEDURE-Zeiger setzen  }
  631.   ClearMemory[1] := Clear1;
  632.   ClearMemory[2] := Clear2;
  633.   ClearMemory[3] := Clear3;
  634. END.
  635. (* ------------------------------------------------------ *)
  636. (*                  Ende von XHEAP.PAS                    *)
  637.