home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1991 / 06 / tricks / realloc2.pas < prev    next >
Pascal/Delphi Source File  |  1991-03-06  |  10KB  |  225 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    REALLOC2.PAS                        *)
  3. (*         Angepaßte Version für Turbo-Pascal 6.0         *)
  4. (*           (c) 1991 Gerd Cebulla & TOOLBOX              *)
  5. (* ------------------------------------------------------ *)
  6. {$X+}
  7.  
  8. UNIT ReAlloc2;
  9.  
  10. INTERFACE
  11.  
  12.   FUNCTION ChangeMem(P                : Pointer;
  13.                      OldSize, NewSize : WORD) : Pointer;
  14.  
  15. IMPLEMENTATION
  16.  
  17.   FUNCTION AbsAddr (P : Pointer) : LONGINT;
  18.   { Wandelt einen Zeiger im Format Segment:Offset in eine  }
  19.   { absolute Adresse im Bereich 0..$FFFFF um.              }
  20.   BEGIN
  21.     AbsAddr := LONGINT(Seg(P^)) SHL 4 + Ofs(P^);
  22.   END;
  23.  
  24.   FUNCTION NormPtr(Addr : LONGINT) : Pointer;
  25.   { Konvertiert eine absolute Adresse in einen             }
  26.   { "normalisierten" Zeiger, d.h., der Offsetanteil des    }
  27.   { Funktionsergebnisses liegt immer zwischen 0 und 15.    }
  28.   BEGIN
  29.     NormPtr := Ptr(Addr DIV 16, Addr MOD 16);
  30.   END;
  31.  
  32.   FUNCTION ChangeMem(P                : Pointer;
  33.                      OldSize, NewSize : WORD) : Pointer;
  34.   { Verändert die Größe des für die dynamische Variable P^ }
  35.   { reservierten Speicherbereichs. Bei erfolgreicher       }
  36.   { Ausführung zeigt das Funktionsergebnis auf die neue    }
  37.   { Adresse der dynamischen Variable, ansonsten  wird der  }
  38.   { Wert NIL zurückgeliefert.                              }
  39.   TYPE
  40.     FreePtr = ^FreeRec;
  41.     FreeRec = RECORD   {Aufbau eines Fragmentlisteneintrags}
  42.       Next : FreePtr;          {Zeiger auf nächsten Eintrag}
  43.       Size : Pointer;            {Größe des freien Bereichs}
  44.     END;
  45.     HeapFunc = FUNCTION (Size : WORD) : INTEGER;
  46.                     {wird als Typecast-Operator beim Aufruf}
  47.                             {der HeapError-Funktion benutzt}
  48.   VAR
  49.     NewP,                       {neue Adresse der dyn. Var.}
  50.     OldPEnd,                 {alte Endadresse der dyn. Var.}
  51.     NewPEnd : Pointer;       {neue Endadresse der dyn. Var.}
  52.     FPred,                {Zeiger auf Fragmentlisteneintrag}
  53.                  {für freien Speicherplatz unterhalb von P^}
  54.     FSucc   : FreePtr;                {dto. oberhalb von P^}
  55.     Frei    : LONGINT;           {verfügbarer Speicherplatz}
  56.     RetCode : INTEGER; {Rückgabewert der HeapError-Funktion}
  57.     Fehler  : BOOLEAN;  {True, wenn nicht genug freier Heap}
  58.   BEGIN
  59.     IF (OldSize = 0) AND (NewSize = 0) THEN
  60.       ChangeMem := NIL
  61.     ELSE IF OldSize = 0 THEN BEGIN
  62.       GetMem (P, NewSize);           {dyn. Var. neu anlegen}
  63.       ChangeMem := P;
  64.     END {else if OldSize = 0}
  65.     ELSE IF NewSize = 0 THEN BEGIN
  66.       FreeMem (P, OldSize);              {dyn. Var. löschen}
  67.       ChangeMem := NIL;
  68.     END {else if NewSize = 0}
  69.     ELSE BEGIN
  70.       {Speicher wird immer in Schritten von 8 Byte   }
  71.       {zugeteilt, daher OldSize und NewSize aufrunden}
  72.       OldSize := (OldSize + 7) AND NOT 7;
  73.       NewSize := (NewSize + 7) AND NOT 7;
  74.       P := NormPtr (AbsAddr (P));          {P normalisieren}
  75.       OldPEnd := NormPtr (AbsAddr (P) + OldSize);
  76.       REPEAT {until not Fehler}
  77.         Fehler := FALSE;
  78.         IF (LONGINT (P) < LONGINT (HeapOrg)) OR
  79.            (LONGINT (OldPEnd) > LONGINT (HeapPtr)) THEN
  80.               {zeigt P auf eine Adresse außerhalb des Heap?}
  81.           RunError (204);      {"invalid pointer operation"}
  82.         IF OldSize = NewSize THEN
  83.                                {Größe von P^ bleibt gleich?}
  84.           ChangeMem := P                       {dann fertig}
  85.         ELSE BEGIN
  86.           FPred := @FreeList;       {Zeiger auf Root-Record}
  87.           FSucc := FPred^.Next;   {1. Fragmentlisteneintrag}
  88.           WHILE LONGINT (FSucc) < LONGINT (P) DO BEGIN
  89.                                  {Fragmentliste durchsuchen}
  90.             FPred := FSucc;
  91.             FSucc := FPred^.Next;
  92.           END; {while}
  93.           IF NewSize < OldSize THEN BEGIN
  94.               {den für P^ reservierten Speicher verkleinern}
  95.             NewPEnd := NormPtr (AbsAddr (P) + NewSize);
  96.             IF HeapPtr = OldPEnd THEN
  97.               HeapPtr := NewPEnd
  98.             ELSE IF FSucc = OldPEnd THEN BEGIN
  99.               FreePtr (NewPEnd)^.Next := FSucc^.Next;
  100.               FreePtr (NewPEnd)^.Size := NormPtr
  101.                 (OldSize - NewSize + AbsAddr (FSucc^.Size));
  102.             END {else if FSucc = OldPEnd}
  103.             ELSE BEGIN
  104.               FreePtr (NewPEnd)^.Next := FSucc;
  105.               FreePtr (NewPEnd)^.Size := NormPtr
  106.                                         (OldSize - NewSize);
  107.             END; {else}
  108.             FPred^.Next := NewPEnd;
  109.             ChangeMem := P;
  110.           END {if NewSize < OldSize}
  111.           ELSE BEGIN
  112.             {freien Speicherplatz oberhalb von P^ berechnen}
  113.             IF HeapPtr = OldPEnd THEN
  114.               Frei := AbsAddr (HeapEnd) - AbsAddr (HeapPtr)
  115.             ELSE IF FSucc = OldPEnd THEN
  116.               Frei := AbsAddr (FSucc^.Size)
  117.             ELSE
  118.               Frei := 0;
  119.             Inc (Frei, OldSize);
  120.                 {den von P^ belegten Speicherplatz addieren}
  121.             IF Frei >= NewSize THEN BEGIN
  122.                               {genug Platz oberhalb von P^?}
  123.                     {dann entsprechend Speicher reservieren}
  124.               NewPEnd := NormPtr (AbsAddr (P) + NewSize);
  125.               IF HeapPtr = OldPEnd THEN BEGIN
  126.                 HeapPtr := NewPEnd;
  127.                 FPred^.Next := HeapPtr;
  128.                 IF HeapError <> NIL THEN
  129.                   HeapFunc (HeapError) (0);
  130.                      {neue Konvention bei Turbo-Pascal 6.0:}
  131.                      {Erhöhungen der Heap-Spitze müssen der}
  132.                         {HeapError-Funktion gemeldet werden}
  133.               END {if HeapPtr = OldPEnd}
  134.               ELSE IF Frei = NewSize THEN
  135.                 FPred^.Next := FSucc^.Next
  136.               ELSE BEGIN
  137.                 FPred^.Next := NewPEnd;
  138.                 FreePtr (NewPEnd)^.Next := FSucc^.Next;
  139.                 FreePtr (NewPEnd)^.Size :=
  140.                                    NormPtr (Frei - NewSize);
  141.               END; {else}
  142.               ChangeMem := P;
  143.             END {if Frei >= NewSize}
  144.             ELSE BEGIN
  145.                 {freien Speicher unterhalb von P^ ermitteln}
  146.               IF NormPtr (AbsAddr (FPred) +
  147.                           AbsAddr (FPred^.Size)) = P THEN
  148.                 Inc (Frei, AbsAddr (FPred^.Size));
  149.               IF Frei >= NewSize THEN BEGIN
  150.                              {genug Platz unterhalb von P^?}
  151.                             {dann P^ nach unten verschieben}
  152.                            {und Fragmentliste aktualisieren}
  153.                 NewP := FPred;
  154.                 NewPEnd := NormPtr (AbsAddr (NewP) +
  155.                                     NewSize);
  156.                 Move (P^, NewP^, OldSize);
  157.                 FPred := @FreeList;
  158.                 WHILE FPred^.Next <> NewP DO
  159.                   FPred := FPred^.Next;
  160.                 IF HeapPtr = OldPEnd THEN BEGIN
  161.                   HeapPtr := NewPEnd;
  162.                   FPred^.Next := HeapPtr;
  163.                   IF (LONGINT (NewPEnd) > LONGINT (OldPEnd))
  164.                      AND (HeapError <> NIL) THEN
  165.                     HeapFunc (HeapError) (0);
  166.                 END {if HeapPtr = OldPEnd}
  167.                 ELSE IF FSucc = OldPEnd THEN
  168.                   IF Frei = NewSize THEN
  169.                     FPred^.Next := FSucc^.Next
  170.                   ELSE BEGIN
  171.                     FreePtr (NewPEnd)^.Next := FSucc^.Next;
  172.                     FreePtr (NewPEnd)^.Size :=
  173.                                    NormPtr (Frei - NewSize);
  174.                     FPred^.Next := NewPEnd;
  175.                   END {else}
  176.                 ELSE IF NewPEnd = OldPEnd THEN
  177.                   FPred^.Next := FSucc
  178.                 ELSE BEGIN
  179.                   FreePtr (NewPEnd)^.Next := FSucc;
  180.                   FreePtr (NewPEnd)^.Size :=
  181.                                    NormPtr (Frei - NewSize);
  182.                   FPred^.Next := NewPEnd;
  183.                 END; {else}
  184.                 ChangeMem := NewP;
  185.               END {if Frei >= NewSize}
  186.               ELSE BEGIN        {weder ober- noch unterhalb}
  187.                                        {von P^ genug Platz?}
  188.                        {dann anderswo Speicher reservieren,}
  189.                             {P^ kopieren und ursprünglichen}
  190.                                  {Speicherbereich freigeben}
  191.                 GetMem (NewP, NewSize);
  192.                 IF NewP <> NIL THEN BEGIN
  193.                   Move (P^, NewP^, OldSize);
  194.                   FreeMem (P, OldSize);
  195.                   ChangeMem := NewP;
  196.                 END {if NewP <> nil}
  197.                 ELSE
  198.                   Fehler := TRUE;    {nicht genug Heap frei}
  199.               END; {else}
  200.             END; {else}
  201.           END; {else}
  202.         END; {else}
  203.         IF Fehler THEN BEGIN
  204.           IF HeapError = NIL THEN
  205.                    {keine Heapfehlerbehandlung installiert?}
  206.             RunError (203)           {"heap overflow error"}
  207.           ELSE BEGIN              {sonst benutzerdefinierte}
  208.                                 {Heapfehlerroutine aufrufen}
  209.             RetCode := HeapFunc (HeapError) (NewSize);
  210.             IF RetCode = 0 THEN
  211.               RunError (203)         {"heap overflow error"}
  212.             ELSE IF RetCode = 1 THEN BEGIN
  213.               Fehler := FALSE;
  214.               ChangeMem := NIL;
  215.             END; {else if RetCode = 1}
  216.           END; {else}
  217.         END; {if Fehler}
  218.       UNTIL NOT Fehler;
  219.     END; {else}
  220.   END; {ChangeMem}
  221.  
  222. END.
  223. (* ------------------------------------------------------ *)
  224. (*                    REALLOC2.PAS                        *)
  225.