home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / cebit_91 / tricks / realloc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-01-13  |  9.6 KB  |  241 lines
  1. (* ------------------------------------------------------ *)
  2. (*                      REALLOC.PAS                       *)
  3. (*         Mehr Dynamik für Turbo-Pascal 4.0/5.0/5.5      *)
  4. (*            (c) 1991 Gerd Cebulla & TOOLBOX             *)
  5. (* ------------------------------------------------------ *)
  6. UNIT ReAlloc;
  7.  
  8. INTERFACE
  9.  
  10.   FUNCTION ChangeMem(P                : Pointer;
  11.                      OldSize, NewSize : WORD) : Pointer;
  12.  
  13. IMPLEMENTATION
  14.  
  15. TYPE
  16.   FreeRec = RECORD
  17.               { Format eines Eintrags in der Fragmentliste }
  18.  
  19.               FreeStart,
  20.                 { Zeiger auf Anfang des freien Bereichs    }
  21.               FreeEnd   : Pointer;
  22.                 { Zeiger auf erstes Byte oberhalb          }
  23.                 { des freien Bereichs                      }
  24.             END;
  25.   FreeList = ARRAY [0..8190] OF FreeRec;
  26.  
  27.  
  28.   FUNCTION AbsAddr(P : Pointer) : LongInt;
  29.   { Wandelt einen Zeiger im Format Segment:Offset in eine  }
  30.   { absolute Adresse im Bereich 0..$FFFFF um.              }
  31.   BEGIN
  32.     AbsAddr := LongInt(Seg(P^)) SHL 4 + Ofs(P^);
  33.   END;
  34.  
  35.   FUNCTION NormPtr(Addr : LongInt) : Pointer;
  36.   { Konvertiert absolute Adresse in einen "normalisierten" }
  37.   { Zeiger, d.h., der Offsetanteil des Funktions-          }
  38.   { ergebnisses liegt immer zwischen 0 und 15.             }
  39.   BEGIN
  40.     NormPtr := Ptr(Addr DIV 16, Addr MOD 16);
  41.   END;
  42.  
  43.   PROCEDURE AddToFreeList(Start, Ende : Pointer);
  44.   { Fügt einen neuen Eintrag in die Fragmentliste ein.     }
  45.   { "Start" zeigt auf den Anfang des freien Bereichs,      }
  46.   { "Ende" auf das erste Byte oberhalb.                    }
  47.   VAR
  48.     FP : ^FreeRec;
  49.   BEGIN
  50.     FP := Ptr(Seg(FreePtr^), Ofs(FreePtr^)-SizeOf(FreeRec));
  51.     IF (Ofs(FP^) = 0) OR
  52.        (AbsAddr(FP) < AbsAddr(HeapPtr)) THEN
  53.                                      { Fragmentliste voll? }
  54.       RunError(204);         { "invalid pointer operation" }
  55.     FP^.FreeStart := Start;              { Werte eintragen }
  56.     FP^.FreeEnd   := Ende;
  57.     FreePtr       := FP;           { FreePtr aktualisieren }
  58.   END;
  59.  
  60.   PROCEDURE DeleteFromFreeList(DelP : Pointer);
  61.   { Löscht den Eintrag, auf den DelP zeigt, aus der        }
  62.   { Fragmentliste.                                         }
  63.   VAR
  64.     FP : ^FreeList;
  65.   BEGIN
  66.     IF DelP <> FreePtr THEN BEGIN
  67.       FP := FreePtr;
  68.       Move(FP^[0], FP^[1], AbsAddr(DelP)-AbsAddr(FreePtr));
  69.           { Anfang der Fragmentliste nach oben verschieben }
  70.     END;
  71.     FreePtr := Ptr(Seg(FreePtr^),
  72.            Ofs(FreePtr^) + SizeOf(FreeRec));
  73.                    { FreePtr aktualisieren }
  74.   END;
  75.  
  76.   FUNCTION ChangeMem(P                : Pointer;
  77.              OldSize, NewSize : WORD) : Pointer;
  78.   { Verändert die Größe des für die dynamische Variable P^ }
  79.   { reservierten Speicherbereichs. Bei erfolgreicher       }
  80.   { Ausführung zeigt das Funktionsergebnis auf die neue    }
  81.   { Adresse der dynamischen Variable, ansonsten wird der   }
  82.   { Wert NIL zurückgeliefert.                              }
  83.   VAR
  84.     NewP,                     { neue Adresse der dyn. Var. }
  85.     OldPEnd,               { alte Endadresse der dyn. Var. }
  86.     NewPEnd : Pointer;     { neue Endadresse der dyn. Var. }
  87.     FP      : ^FreeList;        { Zeiger auf Fragmentliste }
  88.     FPred,              { Zeiger auf Fragmentlisteneintrag }
  89.                { für freien Speicherplatz unterhalb von P^ }
  90.     FSucc   : ^FreeRec;             { dto. oberhalb von P^ }
  91.     Frei    : LongInt;         { verfügbarer Speicherplatz }
  92.     FIndex,           { Index eines Fragmentlisteneintrags }
  93.     FAnzahl,           { Anzahl der Fragmentlisteneinträge }
  94.     FLen    : WORD;      { Länge der Fragmentliste in Byte }
  95.     RetCode : INTEGER;   { Rückgabewert HeapError-Funktion }
  96.     Fehler  : BOOLEAN;{ True, wenn nicht genug freier Heap }
  97.   BEGIN
  98.     IF (OldSize = 0) AND (NewSize = 0) THEN
  99.       ChangeMem := NIL
  100.     ELSE IF OldSize = 0 THEN BEGIN
  101.       GetMem(P, NewSize);          { dyn. Var. neu anlegen }
  102.       ChangeMem := P;
  103.     END ELSE IF NewSize = 0 THEN BEGIN
  104.       FreeMem(P, OldSize);             { dyn. Var. löschen }
  105.       ChangeMem := NIL;
  106.     END ELSE BEGIN
  107.       P := NormPtr(AbsAddr(P));          { P normalisieren }
  108.       OldPEnd := NormPtr(AbsAddr(P) + OldSize);
  109.       REPEAT
  110.         Fehler := FALSE;
  111.         IF (LongInt(P) < LongInt(HeapOrg)) OR
  112.            (LongInt(OldPEnd) > LongInt(HeapPtr)) THEN
  113.             { zeigt P auf eine Adresse außerhalb des Heap? }
  114.           RunError(204);     { "invalid pointer operation" }
  115.         IF OldSize = NewSize THEN
  116.                              { Größe von P^ bleibt gleich? }
  117.           ChangeMem := P                     { dann fertig }
  118.         ELSE BEGIN
  119.           IF Ofs(FreePtr^) = 0 THEN
  120.             FAnzahl := 0
  121.           ELSE
  122.             FAnzahl := ($10000 - Ofs(FreePtr^)) DIV
  123.                        SizeOf(FreeRec);
  124.           FIndex := 0;
  125.           FPred  := NIL;
  126.           FSucc  := NIL;
  127.           FP := FreePtr;      { FP zeigt auf Fragmentliste }
  128.           WHILE (FIndex < FAnzahl) AND
  129.                 ((FPred = NIL) OR (FSucc = NIL)) DO BEGIN
  130.                                { Fragmentliste durchsuchen }
  131.             IF FP^[FIndex].FreeStart = OldPEnd THEN
  132.               FSucc := @FP^[FIndex]
  133.                          { freier Speicher oberhalb von P^ }
  134.             ELSE IF FP^[FIndex].FreeEnd = P THEN
  135.               FPred := @FP^[FIndex];
  136.                         { freier Speicher unterhalb von P^ }
  137.             Inc(FIndex);
  138.           END;
  139.           IF NewSize < OldSize THEN BEGIN
  140.             { den für P^ reservierten Speicher verkleinern }
  141.             NewPEnd := NormPtr(AbsAddr(P) + NewSize);
  142.             IF HeapPtr = OldPEnd THEN
  143.               HeapPtr := NewPEnd
  144.             ELSE IF FSucc <> NIL THEN
  145.               FSucc^.FreeStart := NewPEnd
  146.             ELSE
  147.               AddToFreeList(NewPEnd, OldPEnd);
  148.             ChangeMem := P;
  149.           END ELSE BEGIN
  150.           { freien Speicherplatz oberhalb von P^ berechnen }
  151.             IF HeapPtr = OldPEnd THEN BEGIN
  152.               FLen := FAnzahl * SizeOf(FreeRec);
  153.               IF FreeMin > FLen THEN
  154.                 FLen := FreeMin;
  155.               Frei := LongInt(Seg(FreePtr^) + $1000) SHL 4 -
  156.                         FLen - AbsAddr(HeapPtr);
  157.             END ELSE IF FSucc = NIL THEN
  158.               Frei := 0
  159.             ELSE
  160.               Frei := AbsAddr(FSucc^.FreeEnd) -
  161.                       AbsAddr(FSucc^.FreeStart);
  162.             Inc(Frei, OldSize);
  163.               { den von P^ belegten Speicherplatz addieren }
  164.             IF Frei >= NewSize THEN BEGIN
  165.                   { genug Platz oberhalb von P^ ?          }
  166.                   { dann entsprechend Speicher reservieren }
  167.               NewPEnd := NormPtr(AbsAddr(P) + NewSize);
  168.               IF HeapPtr = OldPEnd THEN
  169.                 HeapPtr := NewPEnd
  170.               ELSE IF Frei = NewSize THEN
  171.                 DeleteFromFreeList(FSucc)
  172.               ELSE
  173.                 FSucc^.FreeStart := NewPEnd;
  174.               ChangeMem := P;
  175.             END ELSE BEGIN
  176.               { freien Speicher unterhalb von P^ ermitteln }
  177.               IF FPred <> NIL THEN
  178.                 Inc(Frei, AbsAddr(FPred^.FreeEnd) -
  179.                           AbsAddr(FPred^.FreeStart));
  180.               IF Frei >= NewSize THEN BEGIN
  181.                          { genug Platz unterhalb von P^ ?  }
  182.                          { dann P^ nach unten verschieben  }
  183.                          { und Fragmentliste aktualisieren }
  184.                 NewP := FPred^.FreeStart;
  185.                 NewPEnd := NormPtr(AbsAddr(NewP) + NewSize);
  186.                 Move(P^, NewP^, OldSize);
  187.                 DeleteFromFreeList(FPred);
  188.                 IF HeapPtr = OldPEnd THEN
  189.                   HeapPtr := NewPEnd
  190.                 ELSE IF FSucc <> NIL THEN
  191.                   IF Frei = NewSize THEN
  192.                     DeleteFromFreeList(FSucc)
  193.                   ELSE
  194.                     FSucc^.FreeStart := NewPEnd
  195.                 ELSE IF NewPEnd <> OldPEnd THEN
  196.                   AddToFreeList(NewPEnd, OldPEnd);
  197.                 ChangeMem := NewP;
  198.               END ELSE BEGIN
  199.                      { weder ober- noch unterhalb          }
  200.                      { von P^ genug Platz ?                }
  201.                      { dann anderswo Speicher reservieren, }
  202.                      { P^ kopieren und ursprünglichen      }
  203.                      { Speicherbereich freigeben           }
  204.                 GetMem(NewP, NewSize);
  205.                 IF NewP <> NIL THEN BEGIN
  206.                   Move(P^, NewP^, OldSize);
  207.                   FreeMem(P, OldSize);
  208.                   ChangeMem := NewP;
  209.                 END ELSE
  210.                   Fehler := TRUE;  { nicht genug Heap frei }
  211.               END;
  212.             END;
  213.           END;
  214.         END;
  215.         IF Fehler THEN BEGIN
  216.           IF HeapError = NIL THEN
  217.                  { keine Heapfehlerbehandlung installiert? }
  218.             RunError(203)          { "heap overflow error" }
  219.           ELSE BEGIN            { sonst benutzerdefinierte }
  220.                               { Heapfehlerroutine aufrufen }
  221.             INLINE (
  222.               $FF/$B6/NewSize/     { push NewSize[bp]      }
  223.               $FF/$1E/HeapError/   { call far [HeapError]  }
  224.               $89/$86/RetCode      { mov  RetCode[bp],ax   }
  225.             );
  226.             IF RetCode = 0 THEN
  227.               RunError(203)        { "heap overflow error" }
  228.             ELSE IF RetCode = 1 THEN BEGIN
  229.               Fehler := FALSE;
  230.               ChangeMem := NIL;
  231.             END;
  232.           END;
  233.         END;
  234.       UNTIL NOT Fehler;
  235.     END;
  236.   END;
  237.  
  238. END.
  239. (* ------------------------------------------------------ *)
  240. (*                   Ende von REALLOC.PAS                 *)
  241.