Topspeed_JPI/TS-V3/SRC/SHTHEAP.LST

Listing:

    1  (* Release 3.10 *)
    2  (*-------------------------------------------------------------------------*
    3  *                                                                          *
    4  *  SHTHEAP.MOD - Short heaps                                               *
    5  *                                                                          *
    6  *  COPYRIGHT (C) 1987..1992 Clarion Software Corporation.                  *
    7  *  All Rights Reserved                                                     *
    8  *                                                                          *
    9  *--------------------------------------------------------------------------*)
   10  
   11  (*# call(o_a_copy => on,
   12           o_a_size => on) *)
   13  (*%F _fdata *)
   14  (*# call(seg_name => null) *)
   15  (*# data(seg_name => null) *)
   16  (*%E *)
   17  (*# module(implementation=>off) *)
   18  (*# check(stack=>off,
   19            index=>off,
   20            range=>off,
   21            overflow=>off,
   22            nil_ptr=>off) *)
   23  
   24  IMPLEMENTATION MODULE ShtHeap ;
   25  
   26  IMPORT Lib, SYSTEM, CoreSig;
   27  
   28  TYPE   Offset = CARDINAL;
   29         Block  = RECORD
   30                    Siz: Size;
*****                         ^ undeclared identifier
   31                    Nxt: Pointer;
*****                         ^ undeclared identifier
   32                  END;
*****                  ^ not supported yet
   33  
   34  
   35    PROCEDURE Initialize ( H: Segment; Z: Size );
*****                              ^ undeclared identifier
*****                                          ^ undeclared identifier
   36    VAR B,F: POINTER H TO Block;
*****                     ^ 'FORWARD' expected
   37    BEGIN
   38      Z := (Z DIV Align) * Align;
   39      IF Z < 10 THEN
   40        Lib.RunTimeError(CoreSig._FatalErrorPos(), 9AH, 'ShtHeap.Initialize : Size Too Small');
   41      END;
   42      B := Pointer ( 0 );
   43      F := Pointer ( Align );
   44      B^.Siz := Z;
   45      B^.Nxt := F;
   46      F^.Siz := Z - Align;
   47      F^.Nxt := Nil;
   48    END Initialize;
   49  
   50  
   51    PROCEDURE Increase ( H: Segment; Z: Size );
   52    VAR B,L,I: POINTER H TO Block;
   53    BEGIN
   54      IF Debug THEN
   55        Test ( H );
   56      END;
   57      Z := (Z DIV Align) * Align;
   58      B := Pointer ( 0 );
   59      IF Z > MAX(Size) - B^.Siz THEN
   60        Lib.RunTimeError(CoreSig._FatalErrorPos(), 9BH, 'ShtHeap.Increase : Size Too Large');
   61      END;
   62      I := B;
   63      REPEAT
   64        L := I;
   65        I := I^.Nxt;
   66      UNTIL I = Nil;
   67      IF (L # B) AND (Offset ( L ) + L^.Siz = B^.Siz) THEN
   68        INC ( L^.Siz , Z );
   69      ELSE
   70        I := Pointer ( B^.Siz );
   71        L^.Nxt := I;
   72        I^.Siz := Z;
   73        I^.Nxt := Nil;
   74      END;
   75      INC ( B^.Siz , Z );
   76    END Increase;
   77  
   78  
   79    PROCEDURE Allocate ( H: Segment; VAR P: Pointer; Z: Size );
   80    VAR B,F,G,N: POINTER H TO Block;
   81    BEGIN
   82      IF Debug THEN
   83        Test ( H );
   84      END;
   85      Z := ( (Z+Align-1) DIV Align) * Align;
   86      IF Z = 0 THEN
   87        Lib.RunTimeError(CoreSig._FatalErrorPos(), 9CH, 'ShtHeap.Allocate : Size Too Small');
   88      END;
   89      B := Pointer ( 0 );
   90      G := B;
   91      LOOP
   92        F := G^.Nxt;
   93        IF F = Nil THEN
   94          IF Check THEN
   95              Lib.RunTimeError(CoreSig._FatalErrorPos(), 9DH, 'ShtHeap.Allocate : Out Of Memory');
   96          ELSE
   97              P := Nil;
   98              RETURN;
   99          END;
  100        ELSIF F^.Siz >= Z THEN
  101          EXIT;
  102        END;
  103        G := F;
  104      END;
  105      IF F^.Siz = Z THEN
  106        G^.Nxt := F^.Nxt;
  107      ELSE
  108        N := Pointer ( Offset ( F ) + Z );
  109        G^.Nxt := N;
  110        N^.Siz := F^.Siz - Z;
  111        N^.Nxt := F^.Nxt;
  112      END;
  113      IF Clear THEN
  114        Lib.WordFill ( ADR(F^) , Z DIV 2 , 0 );
  115      END;
  116      P := F;
  117    END Allocate;
  118  
  119  
  120    PROCEDURE Free ( H: Segment; VAR P: Pointer; Z: Size );
  121    VAR B,F,G,Q: POINTER H TO Block;
  122    BEGIN
  123      IF Debug THEN
  124        Test ( H );
  125      END;
  126      Z := ( (Z+Align-1) DIV Align) * Align;
  127      Q := P;
  128      P := Nil;
  129      IF Q = Nil THEN
  130          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9EH, 'ShtHeap.Free : Invalid Argument');
  131      END;
  132      B := Pointer ( 0 );
  133      G := B;
  134      LOOP
  135        F := G^.Nxt;
  136        IF (F = Nil) OR (Offset ( Q ) < Offset ( F )) THEN EXIT; END;
  137        G := F;
  138      END;
  139      IF Offset ( G ) + G^.Siz = Offset ( Q ) THEN
  140        INC ( G^.Siz , Z );
  141        Q := G;
  142      ELSE
  143        G^.Nxt := Q;
  144        Q^.Nxt := F;
  145        Q^.Siz := Z;
  146      END;
  147      IF Offset ( Q ) + Q^.Siz = Offset ( F ) THEN
  148        INC ( Q^.Siz , F^.Siz );
  149        Q^.Nxt := F^.Nxt;
  150      END;
  151    END Free;
  152  
  153  
  154    PROCEDURE Largest ( H: Segment ): Size;
  155    VAR P: POINTER H TO Block;
  156        Z: Size;
  157    BEGIN
  158      IF Debug THEN
  159        Test ( H );
  160      END;
  161      P := Pointer ( 0 );
  162      P := P^.Nxt;
  163      Z := 0;
  164      WHILE P # Nil DO
  165        IF Z < P^.Siz THEN
  166          Z := P^.Siz;
  167        END;
  168        P := P^.Nxt;
  169      END;
  170      RETURN Z;
  171    END Largest;
  172  
  173  
  174    PROCEDURE Total ( H: Segment ): Size;
  175    VAR P: POINTER H TO Block;
  176        Z: Size;
  177    BEGIN
  178      IF Debug THEN
  179        Test ( H );
  180      END;
  181      P := Pointer ( 0 );
  182      P := P^.Nxt;
  183      Z := 0;
  184      WHILE P # Nil DO
  185        INC ( Z , P^.Siz );
  186        P := P^.Nxt;
  187      END;
  188      RETURN Z;
  189    END Total;
  190  
  191  
  192    PROCEDURE Test ( H: Segment );
  193    VAR B,F,G: POINTER H TO Block;
  194    BEGIN
  195      B := Pointer ( 0 );
  196      IF B^.Siz MOD Align # 0 THEN
  197          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, 'ShtHeap.Test : Non-aligned heap size.');
  198      END;
  199      G := B;
  200      LOOP
  201        F := G^.Nxt;
  202        IF F = Nil THEN EXIT; END;
  203        IF    Offset ( F ) >= B^.Siz THEN
  204          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH, "ShtHeap.Test: Free block out of range" );
  205        ELSIF Offset ( F ) MOD Align # 0 THEN
  206          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH,  "ShtHeap.Test: Non-aligned free block" );
  207        ELSIF F^.Siz MOD Align # 0 THEN
  208          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH,  "ShtHeap.Test: Non-aligned free block size" );
  209        ELSIF Offset ( F ) < Offset ( G ) THEN
  210          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH,  "ShtHeap.Test: Unordered free list" );
  211        ELSIF (G # B) AND (Offset ( G ) + G^.Siz = Offset ( F )) THEN
  212          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH,  "ShtHeap.Test: Unjoined free list" );
  213        ELSIF (G # B) AND (Offset ( G ) + G^.Siz > Offset ( F )) THEN
  214          Lib.RunTimeError(CoreSig._FatalErrorPos(), 9FH,  "ShtHeap.Test: Overlapping free list" );
  215        END;
  216        G := F;
  217      END;
  218    END Test;
  219  
  220  
  221  BEGIN
  222    IF SIZE ( Block ) > Align THEN
  223      Lib.FatalError ( "ShtHeap: Alignment too small" );
  224    END;
  225    Clear := FALSE;
  226    Check := TRUE;
  227    Debug := FALSE;
  228  END ShtHeap.

    6 errors