Topspeed_JPI/TS-V3/SRC/WSTORAGE.LST

Listing:

    1  (* Release 3.00 *)
    2  
    3  (* Copyright (C) 1987..1991 Jensen & Partners International *)
    4  
    5  (*%F _fdata *)
    6  (*# call(seg_name => null) *)
    7  (*%E *)
    8  (*# data(seg_name => null) *)
    9  (*# check(stack=>off,
   10            index=>off,
   11            range=>off,
   12            overflow=>off,
   13            nil_ptr=>off) *)
   14  (*# module(implementation=>off) *)
   15  
   16  IMPLEMENTATION MODULE Storage;
   17  
   18  IMPORT SYSTEM, Lib, Windows, CoreSig;
   19  (*%T _mthread *)
   20  IMPORT Process;
   21  (*%E *)
   22  
   23  CONST
   24    EndMarker = 0FFFFH;
   25    Align = 4;
   26  
   27  
   28  (* This is DOS ONLY *)
   29  
   30  PROCEDURE FarMakeHeap( Source : CARDINAL;     (* base segment of heap *)
   31                          Size   : CARDINAL      (* size in paragraphs *)
   32                       ) : FarHeapRecPtr;
*****                           ^ undeclared identifier
   33  VAR
   34    storage,first,last : FarHeapRecPtr;
*****                         ^ undeclared identifier
   35  BEGIN
   36  (*%T _mthread *)
   37    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
   38  (*%E *)
   39    storage := [Source:0];
*****    ^ not supported yet
*****                       ^ not supported yet
   40    first   := [Source+1:0];
*****    ^ not supported yet
*****                         ^ not supported yet
   41    last    := [Source+Size-1:0];
*****    ^ not supported yet
*****                              ^ not supported yet
   42    storage^.next := first;
*****    ^ not supported yet
*****             ^ not supported yet
*****                     ^ not supported yet
   43    storage^.size := 0;
*****    ^ not supported yet
*****             ^ not supported yet
   44    first^.next := last;
*****    ^ not supported yet
*****           ^ not supported yet
*****                   ^ not supported yet
   45    last^.next  := storage;
*****    ^ not supported yet
*****          ^ not supported yet
*****                   ^ not supported yet
   46    first^.size := Size-2;
*****    ^ not supported yet
*****           ^ not supported yet
   47    last^.size  := EndMarker;
*****    ^ not supported yet
*****          ^ not supported yet
   48  (*%T _mthread *)
   49    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
   50  (*%E *)
   51    RETURN storage;
*****           ^ not supported yet
   52  END FarMakeHeap;
*****      ^ not supported yet
   53  
   54  
   55  PROCEDURE FarHeapAllocate(Source : FarHeapRecPtr;  (* source heap                *)
*****                                     ^ undeclared identifier
   56                            VAR A  : FarADDRESS; (* result                     *)
*****                                     ^ undeclared identifier
   57                            Size   : CARDINAL);      (* request size in paragraphs *)
   58  
   59  VAR
   60    res,prev,split : FarHeapRecPtr;
*****                     ^ undeclared identifier
   61  BEGIN
   62    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
   63        Lib.RunTimeError(CoreSig._FatalErrorPos(), 90H, 'FarHeapAllocate : Out Of Space');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                        ^ not supported yet
   64        RETURN;
   65    END;
   66  (*%T _mthread *)
   67    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
   68  (*%E *)
   69    IF Size=0 THEN INC(Size) END ;
*****                   ^ undeclared identifier
*****                           ^ not supported yet
   70    prev := Source;
*****    ^ not supported yet
*****            ^ not supported yet
   71    WHILE prev^.next^.size < Size DO
*****          ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
   72      prev := prev^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                    ^ not supported yet
   73    END;
   74    res := prev^.next;
*****    ^ not supported yet
*****           ^ not supported yet
*****                 ^ not supported yet
   75    IF res^.size = EndMarker THEN (* heap run out of space *)
*****       ^ not supported yet
*****            ^ not supported yet
   76      SYSTEM.EI ;
*****      ^ not supported yet
*****             ^ not supported yet
   77      Lib.RunTimeError(CoreSig._FatalErrorPos(), 90H, 'FarHeapAllocate : Out Of Space');
*****      ^ not supported yet
*****          ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
*****                                              ^ not supported yet
*****                                                      ^ not supported yet
   78    END;
   79    IF res^.size = Size THEN (* block correct size *)
*****       ^ not supported yet
*****            ^ not supported yet
   80      prev^.next := res^.next;
*****      ^ not supported yet
*****            ^ not supported yet
*****                    ^ not supported yet
*****                         ^ not supported yet
   81    ELSE (* split block, bottom half returned, top half linked to free chain *)
   82      split := [CARDINAL(Seg(res^))+Size:0];
*****      ^ not supported yet
*****                         ^ undeclared identifier
*****                             ^ not supported yet
*****                                         ^ not supported yet
   83      prev^.next := split;
*****      ^ not supported yet
*****            ^ not supported yet
*****                    ^ not supported yet
   84      split^.next := res^.next;
*****      ^ not supported yet
*****             ^ not supported yet
*****                     ^ not supported yet
*****                          ^ not supported yet
   85      split^.size := res^.size - Size;
*****      ^ not supported yet
*****             ^ not supported yet
*****                     ^ not supported yet
*****                          ^ not supported yet
   86    END;
   87  (*%T _mthread *)
   88    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
   89  (*%E *)
   90    A := FarADR(res^);
*****    ^ not supported yet
*****         ^ undeclared identifier
*****                ^ not supported yet
   91  END FarHeapAllocate;
*****      ^ not supported yet
   92  
   93  
   94  PROCEDURE FarHeapAvail(Source: FarHeapRecPtr) : CARDINAL;
*****                                 ^ undeclared identifier
   95  (* returns the largest block size available for allocation in paragraphs *)
   96  VAR
   97    size : CARDINAL;
   98    p    : FarHeapRecPtr;
*****           ^ undeclared identifier
   99  BEGIN
  100    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
  101        RETURN 0;
  102    END;
  103  (*%T _mthread *)
  104    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
  105  (*%E *)
  106    p  := Source^.next;
*****    ^ not supported yet
*****          ^ not supported yet
*****                  ^ not supported yet
  107    size := 0;
  108    WHILE p^.size <> EndMarker DO
*****          ^ not supported yet
*****             ^ not supported yet
  109      IF p^.size>size THEN size := p^.size END;
*****         ^ not supported yet
*****            ^ not supported yet
*****                                   ^ not supported yet
*****                                      ^ not supported yet
  110      p := p^.next;
*****      ^ not supported yet
*****           ^ not supported yet
*****              ^ not supported yet
  111    END;
  112  (*%T _mthread *)
  113    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
  114  (*%E *)
  115    RETURN size;
  116  END FarHeapAvail;
*****      ^ not supported yet
  117  
  118  
  119  PROCEDURE FarHeapTotalAvail(Source: FarHeapRecPtr) : CARDINAL;
*****                                      ^ undeclared identifier
  120  (* returns the total block size available for allocation in paragraphs *)
  121  VAR
  122    size : CARDINAL;
  123    p    : FarHeapRecPtr;
*****           ^ undeclared identifier
  124  BEGIN
  125    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
  126        RETURN 0;
  127    END;
  128  (*%T _mthread *)
  129    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
  130  (*%E *)
  131    p  := Source^.next;
*****    ^ not supported yet
*****          ^ not supported yet
*****                  ^ not supported yet
  132    size := 0;
  133    WHILE p^.size <> EndMarker DO
*****          ^ not supported yet
*****             ^ not supported yet
  134      INC(size,p^.size);
*****      ^ undeclared identifier
*****               ^ not supported yet
*****                  ^ not supported yet
  135      p := p^.next;
*****      ^ not supported yet
*****           ^ not supported yet
*****              ^ not supported yet
  136    END;
  137  (*%T _mthread *)
  138    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
  139  (*%E *)
  140    RETURN size;
  141  END FarHeapTotalAvail;
*****      ^ not supported yet
  142  
  143  
  144  
  145  PROCEDURE FarHeapDeallocate(Source : FarHeapRecPtr;  (* source heap         *)
*****                                       ^ undeclared identifier
  146                              VAR A: FarADDRESS;
*****                                     ^ undeclared identifier
  147                              Size   : CARDINAL );     (* size of block
  148                                                          in paragraphs       *)
  149  VAR
  150    target,prev,split : FarHeapRecPtr;
*****                        ^ undeclared identifier
  151    tseg : CARDINAL;
  152  BEGIN
  153    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
  154        RETURN;
  155    END;
  156    IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN
*****                 ^ undeclared identifier
*****                     ^ not supported yet
*****                                        ^ undeclared identifier
*****                                            ^ not supported yet
  157        Lib.RunTimeError(CoreSig._FatalErrorPos(), 91H,  'FarHeapDeallocate : Invalid Argument');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  158    END;
  159  (*%T _mthread *)
  160    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
  161  (*%E *)
  162    IF Size=0 THEN INC(Size) END ;
*****                   ^ undeclared identifier
*****                           ^ not supported yet
  163    target := A;
*****    ^ not supported yet
*****              ^ not supported yet
  164    prev   := Source;
*****    ^ not supported yet
*****              ^ not supported yet
  165    tseg   := Seg(target^);
*****              ^ undeclared identifier
*****                  ^ not supported yet
  166    WHILE CARDINAL(Seg(prev^.next^)) < tseg DO
*****                   ^ undeclared identifier
*****                       ^ not supported yet
*****                             ^ not supported yet
  167      prev := prev^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                    ^ not supported yet
  168    END;
  169    IF CARDINAL(Seg(prev^))+prev^.size = tseg THEN (* amalgamate with prev *)
*****                ^ undeclared identifier
*****                    ^ not supported yet
*****                            ^ not supported yet
*****                                  ^ not supported yet
  170      prev^.size := prev^.size + Size;
*****      ^ not supported yet
*****            ^ not supported yet
*****                    ^ not supported yet
*****                          ^ not supported yet
  171      target := prev;
*****      ^ not supported yet
*****                ^ not supported yet
  172    ELSIF CARDINAL(Seg(prev^))+prev^.size > tseg THEN (* Heap corrupt *)
*****                   ^ undeclared identifier
*****                       ^ not supported yet
*****                               ^ not supported yet
*****                                     ^ not supported yet
  173      SYSTEM.EI;
*****      ^ not supported yet
*****             ^ not supported yet
  174        Lib.RunTimeError(CoreSig._FatalErrorPos(), 92H,  'FarHeapDeallocate : Heap Corrupt');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  175    ELSE
  176      (* link after prev *)
  177      target^.next := prev^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                            ^ not supported yet
  178      prev^.next := target;
*****      ^ not supported yet
*****            ^ not supported yet
*****                    ^ not supported yet
  179      target^.size := Size;
*****      ^ not supported yet
*****              ^ not supported yet
  180    END;
  181    IF (target^.next^.size <> EndMarker)
*****        ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
  182       AND (CARDINAL(Seg(target^.next^)) = CARDINAL(Seg(target^))+target^.size) THEN
*****                     ^ undeclared identifier
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                    ^ undeclared identifier
*****                                                        ^ not supported yet
*****                                                                  ^ not supported yet
*****                                                                          ^ not supported yet
  183      (* amalgamate with next block *)
  184      target^.size := target^.size+target^.next^.size;
*****      ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                              ^ not supported yet
*****                                   ^ not supported yet
*****                                           ^ not supported yet
*****                                                 ^ not supported yet
  185      target^.next := target^.next^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                              ^ not supported yet
*****                                    ^ not supported yet
  186    END;
  187    A := SYSTEM.FarNIL;
*****    ^ not supported yet
*****         ^ not supported yet
*****                ^ not supported yet
  188  (*%T _mthread *)
  189    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
  190  (*%E *)
  191  END FarHeapDeallocate;
*****      ^ not supported yet
  192  
  193  
  194  PROCEDURE FarHeapChangeAlloc(Source  : FarHeapRecPtr;  (* source heap       *)
*****                                         ^ undeclared identifier
  195                               A       : FarADDRESS; (* block to change   *)
*****                                         ^ undeclared identifier
  196                               OldSize,               (* old size of block *)
  197                               NewSize : CARDINAL)    (* new size of block *)
  198                                                      (* in paragraphs     *)
  199                               : BOOLEAN;             (* if sucessful      *)
  200  
  201  (* This procedure attempts to change the size of an allocated block
  202     It returns TRUE if succeeded (only expansion can fail)
  203  *)
  204  
  205  VAR
  206    target,prev,
  207    split      : FarHeapRecPtr;
*****                 ^ undeclared identifier
  208    tseg       : CARDINAL;
  209    result     : BOOLEAN;
  210    extendsize : CARDINAL;
  211    Res        : FarADDRESS;
*****                 ^ undeclared identifier
  212  BEGIN
  213    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
  214       RETURN FALSE;
  215    END;
  216    IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN
*****                 ^ undeclared identifier
*****                     ^ not supported yet
*****                                        ^ undeclared identifier
*****                                            ^ not supported yet
  217        Lib.RunTimeError(CoreSig._FatalErrorPos(), 93H,  'FarHeapChangeAlloc : Invalid Argument');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  218    END;
  219    IF OldSize = NewSize THEN RETURN TRUE END;
  220    IF OldSize > NewSize THEN
  221      target := [CARDINAL(Seg(A^))+NewSize:0];
*****      ^ not supported yet
*****                          ^ undeclared identifier
*****                              ^ not supported yet
*****                                           ^ not supported yet
  222      FarHeapDeallocate(Source,target,OldSize-NewSize);
*****      ^ not supported yet
*****                        ^ not supported yet
*****                               ^ not supported yet
*****                                                     ^ not supported yet
  223      RETURN TRUE;
  224    END;
  225    extendsize := NewSize-OldSize;
  226  (*%T _mthread *)
  227    Process.Lock;
*****    ^ not supported yet
*****            ^ not supported yet
  228  (*%E *)
  229    target := A;
*****    ^ not supported yet
*****              ^ not supported yet
  230    prev := Source;
*****    ^ not supported yet
*****            ^ not supported yet
  231    tseg := Seg(target^);
*****            ^ undeclared identifier
*****                ^ not supported yet
  232    WHILE CARDINAL(Seg(prev^.next^)) < tseg DO
*****                   ^ undeclared identifier
*****                       ^ not supported yet
*****                             ^ not supported yet
  233      prev := prev^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                    ^ not supported yet
  234    END;
  235    IF (prev^.next^.size <> EndMarker) AND
*****        ^ not supported yet
*****              ^ not supported yet
*****                    ^ not supported yet
  236       (CARDINAL(Seg(prev^.next^)) = CARDINAL(Seg(target^))+OldSize) AND
*****                 ^ undeclared identifier
*****                     ^ not supported yet
*****                           ^ not supported yet
*****                                              ^ undeclared identifier
*****                                                  ^ not supported yet
  237       (extendsize <= prev^.next^.size) THEN
*****                      ^ not supported yet
*****                            ^ not supported yet
*****                                  ^ not supported yet
  238      IF (extendsize = prev^.next^.size) THEN
*****                       ^ not supported yet
*****                             ^ not supported yet
*****                                   ^ not supported yet
  239        prev^.next := prev^.next^.next
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                            ^ not supported yet
*****                                  ^ not supported yet
  240      ELSE
  241        split := [CARDINAL(Seg(target^))+NewSize:0];
*****        ^ not supported yet
*****                           ^ undeclared identifier
*****                               ^ not supported yet
*****                                                 ^ not supported yet
  242        split^.next := prev^.next^.next;
*****        ^ not supported yet
*****               ^ not supported yet
*****                       ^ not supported yet
*****                             ^ not supported yet
*****                                   ^ not supported yet
  243        split^.size := prev^.next^.size - extendsize;
*****        ^ not supported yet
*****               ^ not supported yet
*****                       ^ not supported yet
*****                             ^ not supported yet
*****                                   ^ not supported yet
  244        prev^.next  := split;
*****        ^ not supported yet
*****              ^ not supported yet
*****                       ^ not supported yet
  245      END;
  246      result := TRUE;
  247    ELSE
  248      result := FALSE;
  249    END;
  250  (*%T _mthread *)
  251    Process.Unlock;
*****    ^ not supported yet
*****            ^ not supported yet
  252  (*%E *)
  253    RETURN result;
  254  END FarHeapChangeAlloc;
*****      ^ not supported yet
  255  
  256  
  257  
  258  PROCEDURE FarHeapChangeSize(Source  : FarHeapRecPtr;         (* source heap       *)
*****                                        ^ undeclared identifier
  259                              VAR A   : FarADDRESS; (* block to change   *)
*****                                        ^ undeclared identifier
  260                              OldSize,                         (* old size of block *)
  261                              NewSize : CARDINAL );            (* new size of block
  262                                                                  in paragraphs  *)
  263  
  264  (*
  265     This procedure will change the size of an allocated block
  266     avoiding any copy of data if possible
  267     calls HeapChangeAlloc
  268  *)
  269  
  270  VAR
  271    na : FarADDRESS;
*****         ^ undeclared identifier
  272  BEGIN
  273    IF Source = MainHeap THEN
*****       ^ not supported yet
*****                ^ undeclared identifier
  274        Lib.RunTimeError(CoreSig._FatalErrorPos(), 94H,  'FarHeapChangeSize : Out Of Memory');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  275        RETURN;
  276    END;
  277    IF NOT FarHeapChangeAlloc ( Source, A, OldSize, NewSize ) THEN
*****           ^ not supported yet
*****                                ^ not supported yet
*****                                        ^ not supported yet
*****                                                            ^ not supported yet
  278      FarHeapAllocate(Source,na,NewSize);
*****      ^ not supported yet
*****                      ^ not supported yet
*****                             ^ not supported yet
*****                                       ^ not supported yet
  279      Lib.FarWordMove(A, na, OldSize*8);
*****      ^ not supported yet
*****          ^ not supported yet
*****                      ^ not supported yet
*****                         ^ not supported yet
*****                                      ^ not supported yet
  280      FarHeapDeallocate(Source,A,OldSize);
*****      ^ not supported yet
*****                        ^ not supported yet
*****                               ^ not supported yet
*****                                        ^ not supported yet
  281      A := na;
*****      ^ not supported yet
*****           ^ not supported yet
  282    END;
  283  END FarHeapChangeSize;
*****      ^ not supported yet
  284  
  285  
  286  PROCEDURE NearMakeHeap(Source: NearADDRESS; Size: CARDINAL): NearHeapRecPtr;
*****                                 ^ undeclared identifier
*****                                                               ^ undeclared identifier
  287           (* ========== *)
  288    VAR Storage, FirstFree: NearHeapRecPtr;
*****                            ^ undeclared identifier
  289    BEGIN
  290      Size := (Size DIV Align) * Align;
  291      IF Size < 10 THEN
  292        Lib.RunTimeError(CoreSig._FatalErrorPos(), 95H,  'NearMakeHeap: Size Too Small');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  293      END;
  294      Storage := NearHeapRecPtr(Source);
*****      ^ not supported yet
*****                 ^ undeclared identifier
*****                                ^ not supported yet
  295      Storage^.next := NearHeapRecPtr(CARDINAL(Source)+Align);
*****      ^ not supported yet
*****               ^ not supported yet
*****                       ^ undeclared identifier
*****                                               ^ not supported yet
*****                                                            ^ not supported yet
  296      Storage^.size :=4;
*****      ^ not supported yet
*****               ^ not supported yet
  297      FirstFree := Storage^.next;
*****      ^ not supported yet
*****                   ^ not supported yet
*****                            ^ not supported yet
  298      FirstFree^.size := Size - Align;
*****      ^ not supported yet
*****                 ^ not supported yet
  299      FirstFree^.next := SYSTEM.NearNIL;
*****      ^ not supported yet
*****                 ^ not supported yet
*****                         ^ not supported yet
*****                                ^ not supported yet
  300      RETURN Storage;
*****             ^ not supported yet
  301  END NearMakeHeap;
*****      ^ not supported yet
  302  
  303  PROCEDURE NearHeapAllocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL);
*****                                     ^ undeclared identifier
*****                                                            ^ undeclared identifier
  304           (* ======== *)
  305    VAR Base, Free, New: NearHeapRecPtr;
*****                         ^ undeclared identifier
  306    BEGIN
  307      IF Size = 0 THEN INC(Size) END;
*****                       ^ undeclared identifier
*****                               ^ not supported yet
  308      Size := (( (Size+Align-1) DIV Align) * Align) + Align;
  309      IF Size = 0 THEN
  310          Size:=MAX(CARDINAL);
*****                ^ undeclared identifier
*****                            ^ not supported yet
  311      END;
  312      Base := Source;
*****      ^ not supported yet
*****              ^ not supported yet
  313      LOOP
  314        Free := Base^.next;
*****        ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
  315        IF Free = SYSTEM.NearNIL THEN
*****           ^ not supported yet
*****                  ^ not supported yet
*****                         ^ not supported yet
  316          IF Check THEN
*****             ^ undeclared identifier
  317              Lib.RunTimeError(CoreSig._FatalErrorPos(), 96H,  'NearHeapAllocate: Out Of Memory');
*****              ^ not supported yet
*****                  ^ not supported yet
*****                               ^ not supported yet
*****                                       ^ not supported yet
*****                                                      ^ not supported yet
*****                                                               ^ not supported yet
  318          ELSE
  319              A := SYSTEM.NearNIL;
*****              ^ not supported yet
*****                   ^ not supported yet
*****                          ^ not supported yet
  320              RETURN;
  321          END;
  322        ELSIF Free^.size >= Size THEN
*****              ^ not supported yet
*****                    ^ not supported yet
  323          EXIT;
  324        END;
  325        Base := Free;
*****        ^ not supported yet
*****                ^ not supported yet
  326      END;
  327      IF Free^.size = Size THEN
*****         ^ not supported yet
*****               ^ not supported yet
  328        Base^.next := Free^.next;
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                            ^ not supported yet
  329      ELSE
  330        New := NearHeapRecPtr(CARDINAL(Free)+Size);
*****        ^ not supported yet
*****               ^ undeclared identifier
*****                                       ^ not supported yet
*****                                                 ^ not supported yet
  331        Base^.next := New;
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
  332        New^.size := Free^.size - Size;
*****        ^ not supported yet
*****             ^ not supported yet
*****                     ^ not supported yet
*****                           ^ not supported yet
  333        New^.next := Free^.next;
*****        ^ not supported yet
*****             ^ not supported yet
*****                     ^ not supported yet
*****                           ^ not supported yet
  334      END;
  335      IF ClearOnAllocate THEN
*****         ^ undeclared identifier
  336        Lib.WordFill ( ADDRESS(CARDINAL(Free)+Align) , (Size-Align) DIV 2 , 0 );
*****        ^ not supported yet
*****            ^ not supported yet
*****                       ^ undeclared identifier
*****                                        ^ not supported yet
*****                                                   ^ not supported yet
*****                                                                              ^ not supported yet
  337      END;
  338      A := NearADDRESS(CARDINAL(Free)+Align);
*****      ^ not supported yet
*****           ^ undeclared identifier
*****                                ^ not supported yet
*****                                           ^ not supported yet
  339  END NearHeapAllocate;
*****      ^ not supported yet
  340  
  341  PROCEDURE Merge(PrevRec, LowRec, HighRec, Source: NearHeapRecPtr);
*****                                                    ^ undeclared identifier
  342  
  343  BEGIN
  344      IF (LowRec = SYSTEM.NearNIL) OR (HighRec = SYSTEM.NearNIL) THEN RETURN END;
*****          ^ not supported yet
*****                   ^ not supported yet
*****                          ^ not supported yet
*****                                       ^ not supported yet
*****                                                 ^ not supported yet
*****                                                        ^ not supported yet
  345      IF (LowRec = Source) THEN RETURN END;
*****          ^ not supported yet
*****                   ^ not supported yet
  346      IF NearHeapRecPtr(CARDINAL(LowRec)+LowRec^.size) # HighRec THEN RETURN END;
*****         ^ undeclared identifier
*****                                 ^ not supported yet
*****                                         ^ not supported yet
*****                                                 ^ not supported yet
*****                                                         ^ not supported yet
  347      INC(LowRec^.size, HighRec^.size);
*****      ^ undeclared identifier
*****          ^ not supported yet
*****                  ^ not supported yet
*****                        ^ not supported yet
*****                                 ^ not supported yet
  348      LowRec^.next:=HighRec^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                    ^ not supported yet
*****                             ^ not supported yet
  349      PrevRec^.next:=LowRec;
*****      ^ not supported yet
*****               ^ not supported yet
*****                     ^ not supported yet
  350      RETURN;
  351  END Merge;
*****      ^ not supported yet
  352  
  353  PROCEDURE NearHeapDeallocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL );
*****                                       ^ undeclared identifier
*****                                                              ^ undeclared identifier
  354  
  355  VAR
  356      Curr, Base, Free: NearHeapRecPtr;
*****                        ^ undeclared identifier
  357  
  358  BEGIN
  359      Size := (( (Size+Align-1) DIV Align) * Align) + Align;
  360      Curr := NearHeapRecPtr(CARDINAL(A) - Align);
*****      ^ not supported yet
*****              ^ undeclared identifier
*****                                      ^ not supported yet
*****                                                ^ not supported yet
  361      A := SYSTEM.NearNIL;
*****      ^ not supported yet
*****           ^ not supported yet
*****                  ^ not supported yet
  362      IF Curr = SYSTEM.NearNIL THEN
*****         ^ not supported yet
*****                ^ not supported yet
*****                       ^ not supported yet
  363        Lib.RunTimeError(CoreSig._FatalErrorPos(), 97H,  'NearHeapDeallocate: Invalid Argument');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  364      END;
  365      Base:=Source;
*****      ^ not supported yet
*****            ^ not supported yet
  366      LOOP
  367        Free := Base^.next;
*****        ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
  368        IF (Free = SYSTEM.NearNIL) OR (CARDINAL(Curr) < CARDINAL(Free)) THEN EXIT; END;
*****            ^ not supported yet
*****                   ^ not supported yet
*****                          ^ not supported yet
*****                                                ^ not supported yet
*****                                                                 ^ not supported yet
  369        Base := Free;
*****        ^ not supported yet
*****                ^ not supported yet
  370      END;
  371      IF (CARDINAL(Base) + Base^.size = CARDINAL(Curr)) AND (Base # Source) THEN
*****                   ^ not supported yet
*****                           ^ not supported yet
*****                                 ^ not supported yet
*****                                                 ^ not supported yet
*****                                                             ^ not supported yet
*****                                                                    ^ not supported yet
  372        INC ( Base^.size , Size );
*****        ^ undeclared identifier
*****              ^ not supported yet
*****                    ^ not supported yet
*****                                ^ not supported yet
  373        Curr := Base;
*****        ^ not supported yet
*****                ^ not supported yet
  374      ELSE
  375        Base^.next := Curr;
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
  376        Curr^.next := Free;
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
  377        Curr^.size := Size;
*****        ^ not supported yet
*****              ^ not supported yet
  378      END;
  379      IF CARDINAL(Curr) + Curr^.size = CARDINAL(Free) THEN
*****                  ^ not supported yet
*****                          ^ not supported yet
*****                                ^ not supported yet
*****                                                ^ not supported yet
  380        INC ( Curr^.size, Free^.size);
*****        ^ undeclared identifier
*****              ^ not supported yet
*****                    ^ not supported yet
*****                          ^ not supported yet
*****                                ^ not supported yet
  381        Curr^.next := Free^.next;
*****        ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
*****                            ^ not supported yet
  382      END;
  383  END NearHeapDeallocate;
*****      ^ not supported yet
  384  
  385  PROCEDURE NearHeapAvail(Source: NearHeapRecPtr): CARDINAL;
*****                                  ^ undeclared identifier
  386  
  387  VAR
  388      Curr: NearHeapRecPtr;
*****            ^ undeclared identifier
  389      Size: CARDINAL;
  390  BEGIN
  391      Curr := Source;
*****      ^ not supported yet
*****              ^ not supported yet
  392      Size := 0;
  393      WHILE Curr # SYSTEM.NearNIL DO
*****            ^ not supported yet
*****                   ^ not supported yet
*****                          ^ not supported yet
  394        IF Size < Curr^.size THEN
*****                  ^ not supported yet
*****                        ^ not supported yet
  395          Size := Curr^.size;
*****                  ^ not supported yet
*****                        ^ not supported yet
  396        END;
  397        Curr := Curr^.next;
*****        ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
  398      END;
  399      RETURN Size - Align;
  400  END NearHeapAvail;
*****      ^ not supported yet
  401  
  402  
  403  PROCEDURE NearHeapTotalAvail(Source: NearHeapRecPtr): CARDINAL;
*****                                       ^ undeclared identifier
  404  
  405  VAR
  406      Curr: NearHeapRecPtr;
*****            ^ undeclared identifier
  407      Size: CARDINAL;
  408  BEGIN
  409      Curr := Source^.next;
*****      ^ not supported yet
*****              ^ not supported yet
*****                      ^ not supported yet
  410      Size := 0;
  411      WHILE Curr # SYSTEM.NearNIL DO
*****            ^ not supported yet
*****                   ^ not supported yet
*****                          ^ not supported yet
  412        INC ( Size , Curr^.size - Align);
*****        ^ undeclared identifier
*****                     ^ not supported yet
*****                           ^ not supported yet
*****                                       ^ not supported yet
  413        Curr := Curr^.next;
*****        ^ not supported yet
*****                ^ not supported yet
*****                      ^ not supported yet
  414      END;
  415      RETURN Size;
  416  END NearHeapTotalAvail;
*****      ^ not supported yet
  417  
  418  
  419  
  420  PROCEDURE NearHeapChangeSize(Source: NearHeapRecPtr; VAR A: NearADDRESS;
*****                                       ^ undeclared identifier
*****                                                              ^ undeclared identifier
  421                            OldSize, NewSize : CARDINAL);
  422  
  423  VAR
  424      Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr;
*****                                      ^ undeclared identifier
  425      SplitSize: CARDINAL;
  426      OldA: NearADDRESS;
*****            ^ undeclared identifier
  427  BEGIN
  428      NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align;
  429      OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align;
  430      IF OldSize = NewSize THEN RETURN END;
  431      Curr:=NearHeapRecPtr(CARDINAL(A)-Align);
*****      ^ not supported yet
*****            ^ undeclared identifier
*****                                    ^ not supported yet
*****                                            ^ not supported yet
  432      NextRec:=Source;
*****      ^ not supported yet
*****               ^ not supported yet
  433      PrevRec:=Source;
*****      ^ not supported yet
*****               ^ not supported yet
  434      LOOP
  435          IF NextRec = SYSTEM.NearNIL THEN EXIT END;
*****             ^ not supported yet
*****                       ^ not supported yet
*****                              ^ not supported yet
  436          IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END;
*****                      ^ not supported yet
*****                                          ^ not supported yet
  437          PrevRec:=NextRec;
*****          ^ not supported yet
*****                   ^ not supported yet
  438          NextRec:=NextRec^.next;
*****          ^ not supported yet
*****                   ^ not supported yet
*****                            ^ not supported yet
  439      END;
  440      IF OldSize > NewSize THEN
  441          SplitSize:=OldSize-NewSize;
  442          Curr^.size:=NewSize;
*****          ^ not supported yet
*****                ^ not supported yet
  443          NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize);
*****          ^ not supported yet
*****                  ^ undeclared identifier
*****                                          ^ not supported yet
*****                                                       ^ not supported yet
  444          NewRec^.size:=SplitSize;
*****          ^ not supported yet
*****                  ^ not supported yet
  445          NewRec^.next:=PrevRec^.next;
*****          ^ not supported yet
*****                  ^ not supported yet
*****                        ^ not supported yet
*****                                 ^ not supported yet
  446          PrevRec^.next:=NewRec;
*****          ^ not supported yet
*****                   ^ not supported yet
*****                         ^ not supported yet
  447          Merge(PrevRec, NewRec, NextRec, Source);
*****          ^ not supported yet
*****                ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                          ^ not supported yet
  448          RETURN ;
  449      END;
  450      IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *)
*****         ^ undeclared identifier
*****                                 ^ not supported yet
*****                                              ^ not supported yet
*****                                                  ^ not supported yet
  451          Curr^.size := OldSize;
*****          ^ not supported yet
*****                ^ not supported yet
  452          Merge(PrevRec, Curr, NextRec, Source);
*****          ^ not supported yet
*****                ^ not supported yet
*****                         ^ not supported yet
*****                               ^ not supported yet
*****                                        ^ not supported yet
  453          IF OldSize = NewSize THEN
  454              PrevRec^.next := Curr^.next;
*****              ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
*****                                     ^ not supported yet
  455              RETURN;
  456          ELSE
  457              NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize);
*****              ^ not supported yet
*****                        ^ undeclared identifier
*****                                                ^ not supported yet
*****                                                             ^ not supported yet
  458              NewRec^.size := Curr^.size-NewSize;
*****              ^ not supported yet
*****                      ^ not supported yet
*****                              ^ not supported yet
*****                                    ^ not supported yet
  459              NewRec^.next := Curr^.next;
*****              ^ not supported yet
*****                      ^ not supported yet
*****                              ^ not supported yet
*****                                    ^ not supported yet
  460              PrevRec^.next := NewRec;
*****              ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
  461              RETURN;
  462          END;
  463      END;
  464      OldA:=A;
*****      ^ not supported yet
*****            ^ not supported yet
  465      NearHeapDeallocate(Source, A, OldSize);
*****      ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                           ^ not supported yet
  466      NearHeapAllocate(Source, A, NewSize);
*****      ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
*****                                         ^ not supported yet
  467      Lib.WordMove(ADR(OldA), ADR(A), OldSize DIV 2);
*****      ^ not supported yet
*****          ^ not supported yet
*****                   ^ undeclared identifier
*****                       ^ not supported yet
*****                              ^ undeclared identifier
*****                                  ^ not supported yet
*****                                                   ^ not supported yet
  468      RETURN;
  469  END NearHeapChangeSize;
*****      ^ not supported yet
  470  
  471  PROCEDURE NearHeapChangeAlloc(Source: NearHeapRecPtr; A: NearADDRESS;
*****                                        ^ undeclared identifier
*****                                                           ^ undeclared identifier
  472                            OldSize, NewSize : CARDINAL): BOOLEAN;
  473  
  474  VAR
  475      Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr;
*****                                      ^ undeclared identifier
  476      SplitSize: CARDINAL;
  477  BEGIN
  478      NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align;
  479      OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align;
  480      IF OldSize = NewSize THEN RETURN TRUE END;
  481      Curr:=NearHeapRecPtr(CARDINAL(A)-Align);
*****      ^ not supported yet
*****            ^ undeclared identifier
*****                                    ^ not supported yet
*****                                            ^ not supported yet
  482      PrevRec:=Source;
*****      ^ not supported yet
*****               ^ not supported yet
  483      NextRec:=Source;
*****      ^ not supported yet
*****               ^ not supported yet
  484      LOOP
  485          IF NextRec = SYSTEM.NearNIL THEN EXIT END;
*****             ^ not supported yet
*****                       ^ not supported yet
*****                              ^ not supported yet
  486          IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END;
*****                      ^ not supported yet
*****                                          ^ not supported yet
  487          PrevRec:=NextRec;
*****          ^ not supported yet
*****                   ^ not supported yet
  488          NextRec:=NextRec^.next;
*****          ^ not supported yet
*****                   ^ not supported yet
*****                            ^ not supported yet
  489      END;
  490      IF OldSize > NewSize THEN
  491          SplitSize:=OldSize-NewSize;
  492          Curr^.size:=NewSize;
*****          ^ not supported yet
*****                ^ not supported yet
  493          NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize);
*****          ^ not supported yet
*****                  ^ undeclared identifier
*****                                          ^ not supported yet
*****                                                       ^ not supported yet
  494          NewRec^.size:=SplitSize;
*****          ^ not supported yet
*****                  ^ not supported yet
  495          NewRec^.next:=PrevRec^.next;
*****          ^ not supported yet
*****                  ^ not supported yet
*****                        ^ not supported yet
*****                                 ^ not supported yet
  496          PrevRec^.next:=NewRec;
*****          ^ not supported yet
*****                   ^ not supported yet
*****                         ^ not supported yet
  497          Merge(PrevRec, NewRec, NextRec, Source);
*****          ^ not supported yet
*****                ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                          ^ not supported yet
  498          RETURN TRUE;
  499      END;
  500      IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *)
*****         ^ undeclared identifier
*****                                 ^ not supported yet
*****                                              ^ not supported yet
*****                                                  ^ not supported yet
  501          Curr^.size := OldSize;
*****          ^ not supported yet
*****                ^ not supported yet
  502          Merge(PrevRec, Curr, NextRec, Source);
*****          ^ not supported yet
*****                ^ not supported yet
*****                         ^ not supported yet
*****                               ^ not supported yet
*****                                        ^ not supported yet
  503          IF OldSize = NewSize THEN
  504              PrevRec^.next := Curr^.next;
*****              ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
*****                                     ^ not supported yet
  505          ELSE
  506              NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize);
*****              ^ not supported yet
*****                        ^ undeclared identifier
*****                                                ^ not supported yet
*****                                                             ^ not supported yet
  507              NewRec^.size := OldSize-NewSize;
*****              ^ not supported yet
*****                      ^ not supported yet
  508              NewRec^.next := Curr^.next;
*****              ^ not supported yet
*****                      ^ not supported yet
*****                              ^ not supported yet
*****                                    ^ not supported yet
  509              PrevRec^.next := NewRec;
*****              ^ not supported yet
*****                       ^ not supported yet
*****                               ^ not supported yet
  510          END;
  511          RETURN TRUE;
  512      ELSE
  513          RETURN FALSE;
  514      END;
  515  END NearHeapChangeAlloc;
*****      ^ not supported yet
  516  
  517  
  518  TYPE
  519    HANDLEPtr = POINTER TO Windows.HANDLE;
*****                                   ^ not supported yet
  520  
  521  
  522  PROCEDURE NearDeallocate(VAR a: NearADDRESS; size: CARDINAL);
*****                                  ^ undeclared identifier
  523  
  524  BEGIN
  525      IF ORD(Windows.LocalFree(Windows.HANDLE(a))) # 0 THEN END;
*****         ^ undeclared identifier
*****             ^ not supported yet
*****                     ^ not supported yet
*****                               ^ not supported yet
*****                                       ^ not supported yet
*****                                              ^ not supported yet
  526      a:= NearADDRESS(NIL);
*****      ^ not supported yet
*****          ^ undeclared identifier
*****                         ^ not supported yet
  527  END NearDeallocate;
*****      ^ not supported yet
  528  
  529  PROCEDURE NearAllocate(VAR a: NearADDRESS; size: CARDINAL);
*****                                ^ undeclared identifier
  530  
  531  VAR
  532    mode: CARDINAL;
  533    h: Windows.HANDLE;
*****               ^ not supported yet
  534  BEGIN
  535    IF size = 0 THEN size := 2 END;
  536    mode := Windows.LMEM_FIXED;
*****            ^ not supported yet
*****                    ^ not supported yet
  537    IF ClearOnAllocate THEN
*****       ^ undeclared identifier
  538        mode := mode + Windows.LMEM_ZEROINIT;
*****                       ^ not supported yet
*****                               ^ not supported yet
  539    END;
  540    h := Windows.LocalAlloc(mode, size);
*****    ^ not supported yet
*****         ^ not supported yet
*****                 ^ not supported yet
*****                                      ^ not supported yet
  541    IF ORD(h) = 0 THEN
*****       ^ undeclared identifier
*****           ^ not supported yet
  542        Lib.RunTimeError(CoreSig._FatalErrorPos(), 98H,  'NearAllocate: Out Of Memory');
*****        ^ not supported yet
*****            ^ not supported yet
*****                         ^ not supported yet
*****                                 ^ not supported yet
*****                                                ^ not supported yet
*****                                                         ^ not supported yet
  543    END;
  544    a := NearADDRESS(h);
*****    ^ not supported yet
*****         ^ undeclared identifier
*****                     ^ not supported yet
  545  END NearAllocate;
*****      ^ not supported yet
  546  
  547  PROCEDURE NearAvailable(size: CARDINAL) : BOOLEAN;
  548  
  549  BEGIN
  550    RETURN TRUE;
  551  END NearAvailable;
*****      ^ not supported yet
  552  
  553  PROCEDURE FarAllocate  (VAR a: FarADDRESS; size: CARDINAL);
*****                                 ^ undeclared identifier
  554  
  555  BEGIN
  556  
  557  END FarAllocate;
*****      ^ not supported yet
  558  
  559  PROCEDURE FarDeallocate(VAR a: FarADDRESS; size: CARDINAL);
*****                                 ^ undeclared identifier
  560  
  561  BEGIN
  562  
  563  END FarDeallocate;
*****      ^ not supported yet
  564  
  565  PROCEDURE FarAvailable(size: CARDINAL ): BOOLEAN;
  566  
  567  BEGIN
  568    RETURN TRUE;
  569  END FarAvailable;
*****      ^ not supported yet
  570  
  571  PROCEDURE SegAllocate(Size: CARDINAL): CARDINAL;
  572  
  573  BEGIN
  574    RETURN 0;
  575  END SegAllocate;
*****      ^ not supported yet
  576  
  577  PROCEDURE SegDeallocate(Sel: CARDINAL; Size: CARDINAL);
  578  
  579  BEGIN
  580  END SegDeallocate;
*****      ^ not supported yet
  581  
  582  
  583  
  584  BEGIN
  585      MainHeap:=[0FFFFH:0FFFFH];
*****      ^ undeclared identifier
*****                        ^ not supported yet
  586  END Storage.
*****      ^ not supported yet

  752 errors