Topspeed_JPI/TS-V3/SAVE/WSTORAGE.MOD

(* Release 3.10 *)
(*-------------------------------------------------------------------------*
*                                                                          *
*  WSTORAGE.MOD - Dynamic allocations under Windows                        *
*                                                                          *
*  COPYRIGHT (C) 1987..1992 Clarion Software Corporation.                  *
*  All Rights Reserved                                                     *
*                                                                          *
*--------------------------------------------------------------------------*)

(*%F _fdata *)
(*# call(seg_name => null) *)
(*%E *)
(*# data(seg_name => null) *)
(*# check(stack=>off,
          index=>off,
          range=>off,
          overflow=>off,
          nil_ptr=>off) *)
(*# module(implementation=>off) *)

IMPLEMENTATION MODULE Storage;

IMPORT SYSTEM, Lib, Windows, CoreSig;
(*%T _mthread *)
IMPORT Process;
(*%E *)

CONST
  EndMarker = 0FFFFH;
  Align = 4;


(* This is DOS ONLY *)

PROCEDURE FarMakeHeap( Source : CARDINAL;     (* base segment of heap *)
                        Size   : CARDINAL      (* size in paragraphs *)
                     ) : FarHeapRecPtr;
VAR
  storage,first,last : FarHeapRecPtr;
BEGIN
(*%T _mthread *)
  Process.Lock;
(*%E *)
  storage := [Source:0];
  first   := [Source+1:0];
  last    := [Source+Size-1:0];
  storage^.next := first;
  storage^.size := 0;
  first^.next := last;
  last^.next  := storage;
  first^.size := Size-2;
  last^.size  := EndMarker;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
  RETURN storage;
END FarMakeHeap;


PROCEDURE FarHeapAllocate(Source : FarHeapRecPtr;  (* source heap                *)
                          VAR A  : FarADDRESS; (* result                     *)
                          Size   : CARDINAL);      (* request size in paragraphs *)

VAR
  res,prev,split : FarHeapRecPtr;
BEGIN
  IF Source = MainHeap THEN
      FarAllocate(A,Size);
      RETURN;
  END;
(*%T _mthread *)
  Process.Lock;
(*%E *)
  IF Size=0 THEN INC(Size) END ;
  prev := Source;
  WHILE prev^.next^.size < Size DO
    prev := prev^.next;
  END;
  res := prev^.next;
  IF res^.size = EndMarker THEN (* heap run out of space *)
    SYSTEM.EI ;
    Lib.RunTimeError(CoreSig._FatalErrorPos(), 90H, 'FarHeapAllocate : Out Of Space');
  END;
  IF res^.size = Size THEN (* block correct size *)
    prev^.next := res^.next;
  ELSE (* split block, bottom half returned, top half linked to free chain *)
    split := [CARDINAL(Seg(res^))+Size:0];
    prev^.next := split;
    split^.next := res^.next;
    split^.size := res^.size - Size;
  END;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
  A := FarADR(res^);
END FarHeapAllocate;


PROCEDURE FarHeapAvail(Source: FarHeapRecPtr) : CARDINAL;
(* returns the largest block size available for allocation in paragraphs *)
VAR
  size : CARDINAL;
  p    : FarHeapRecPtr;
BEGIN
  IF Source = MainHeap THEN
      RETURN 1000H;
  END;
(*%T _mthread *)
  Process.Lock;
(*%E *)
  p  := Source^.next;
  size := 0;
  WHILE p^.size <> EndMarker DO
    IF p^.size>size THEN size := p^.size END;
    p := p^.next;
  END;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
  RETURN size;
END FarHeapAvail;


PROCEDURE FarHeapTotalAvail(Source: FarHeapRecPtr) : CARDINAL;
(* returns the total block size available for allocation in paragraphs *)
VAR
  size : CARDINAL;
  p    : FarHeapRecPtr;
BEGIN
  IF Source = MainHeap THEN
      RETURN 0FFFFH;
  END;
(*%T _mthread *)
  Process.Lock;
(*%E *)
  p  := Source^.next;
  size := 0;
  WHILE p^.size <> EndMarker DO
    INC(size,p^.size);
    p := p^.next;
  END;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
  RETURN size;
END FarHeapTotalAvail;



PROCEDURE FarHeapDeallocate(Source : FarHeapRecPtr;  (* source heap         *)
                            VAR A: FarADDRESS;
                            Size   : CARDINAL );     (* size of block
                                                        in paragraphs       *)
VAR
  target,prev,split : FarHeapRecPtr;
  tseg : CARDINAL;
BEGIN
  IF Source = MainHeap THEN
      FarDeallocate(A,Size);
      RETURN;
  END;
  IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 91H,  'FarHeapDeallocate : Invalid Argument');
  END;
(*%T _mthread *)
  Process.Lock;
(*%E *)
  IF Size=0 THEN INC(Size) END ;
  target := A;
  prev   := Source;
  tseg   := Seg(target^);
  WHILE CARDINAL(Seg(prev^.next^)) < tseg DO
    prev := prev^.next;
  END;
  IF CARDINAL(Seg(prev^))+prev^.size = tseg THEN (* amalgamate with prev *)
    prev^.size := prev^.size + Size;
    target := prev;
  ELSIF CARDINAL(Seg(prev^))+prev^.size > tseg THEN (* Heap corrupt *)
    SYSTEM.EI;
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 92H,  'FarHeapDeallocate : Heap Corrupt');
  ELSE
    (* link after prev *)
    target^.next := prev^.next;
    prev^.next := target;
    target^.size := Size;
  END;
  IF (target^.next^.size <> EndMarker)
     AND (CARDINAL(Seg(target^.next^)) = CARDINAL(Seg(target^))+target^.size) THEN
    (* amalgamate with next block *)
    target^.size := target^.size+target^.next^.size;
    target^.next := target^.next^.next;
  END;
  A := SYSTEM.FarNIL;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
END FarHeapDeallocate;


PROCEDURE FarHeapChangeAlloc(Source  : FarHeapRecPtr;  (* source heap       *)
                             A       : FarADDRESS; (* block to change   *)
                             OldSize,               (* old size of block *)
                             NewSize : CARDINAL)    (* new size of block *)
                                                    (* in paragraphs     *)
                             : BOOLEAN;             (* if sucessful      *)

(* This procedure attempts to change the size of an allocated block
   It returns TRUE if succeeded (only expansion can fail)
*)

VAR
  target,prev,
  split      : FarHeapRecPtr;
  tseg       : CARDINAL;
  result     : BOOLEAN;
  extendsize : CARDINAL;
  Res        : FarADDRESS;
BEGIN
  IF Source = MainHeap THEN
     RETURN FALSE;
  END;
  IF (CARDINAL(Seg(A^))=0)OR(CARDINAL(Ofs(A^))<>0) THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 93H,  'FarHeapChangeAlloc : Invalid Argument');
  END;
  IF OldSize = NewSize THEN RETURN TRUE END;
  IF OldSize > NewSize THEN
    target := [CARDINAL(Seg(A^))+NewSize:0];
    FarHeapDeallocate(Source,target,OldSize-NewSize);
    RETURN TRUE;
  END;
  extendsize := NewSize-OldSize;
(*%T _mthread *)
  Process.Lock;
(*%E *)
  target := A;
  prev := Source;
  tseg := Seg(target^);
  WHILE CARDINAL(Seg(prev^.next^)) < tseg DO
    prev := prev^.next;
  END;
  IF (prev^.next^.size <> EndMarker) AND
     (CARDINAL(Seg(prev^.next^)) = CARDINAL(Seg(target^))+OldSize) AND
     (extendsize <= prev^.next^.size) THEN
    IF (extendsize = prev^.next^.size) THEN
      prev^.next := prev^.next^.next
    ELSE
      split := [CARDINAL(Seg(target^))+NewSize:0];
      split^.next := prev^.next^.next;
      split^.size := prev^.next^.size - extendsize;
      prev^.next  := split;
    END;
    result := TRUE;
  ELSE
    result := FALSE;
  END;
(*%T _mthread *)
  Process.Unlock;
(*%E *)
  RETURN result;
END FarHeapChangeAlloc;



PROCEDURE FarHeapChangeSize(Source  : FarHeapRecPtr;         (* source heap       *)
                            VAR A   : FarADDRESS; (* block to change   *)
                            OldSize,                         (* old size of block *)
                            NewSize : CARDINAL );            (* new size of block
                                                                in paragraphs  *)

(*
   This procedure will change the size of an allocated block
   avoiding any copy of data if possible
   calls HeapChangeAlloc
*)

VAR
  na : FarADDRESS;
BEGIN
  IF Source = MainHeap THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 94H,  'FarHeapChangeSize : Out Of Memory');
      RETURN;
  END;
  IF NOT FarHeapChangeAlloc ( Source, A, OldSize, NewSize ) THEN
    FarHeapAllocate(Source,na,NewSize);
    Lib.FarWordMove(A, na, OldSize*8);
    FarHeapDeallocate(Source,A,OldSize);
    A := na;
  END;
END FarHeapChangeSize;


PROCEDURE NearMakeHeap(Source: NearADDRESS; Size: CARDINAL): NearHeapRecPtr;
         (* ========== *)
  VAR Storage, FirstFree: NearHeapRecPtr;
  BEGIN
    Size := (Size DIV Align) * Align;
    IF Size < 10 THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 95H,  'NearMakeHeap: Size Too Small');
    END;
    Storage := NearHeapRecPtr(Source);
    Storage^.next := NearHeapRecPtr(CARDINAL(Source)+Align);
    Storage^.size :=4;
    FirstFree := Storage^.next;
    FirstFree^.size := Size - Align;
    FirstFree^.next := SYSTEM.NearNIL;
    RETURN Storage;
END NearMakeHeap;

PROCEDURE NearHeapAllocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL);
         (* ======== *)
  VAR Base, Free, New: NearHeapRecPtr;
  BEGIN
    IF Size = 0 THEN INC(Size) END;
    Size := (( (Size+Align-1) DIV Align) * Align) + Align;
    IF Size = 0 THEN
        Size:=MAX(CARDINAL);
    END;
    Base := Source;
    LOOP
      Free := Base^.next;
      IF Free = SYSTEM.NearNIL THEN
        IF Check THEN
            Lib.RunTimeError(CoreSig._FatalErrorPos(), 96H,  'NearHeapAllocate: Out Of Memory');
        ELSE
            A := SYSTEM.NearNIL;
            RETURN;
        END;
      ELSIF Free^.size >= Size THEN
        EXIT;
      END;
      Base := Free;
    END;
    IF Free^.size = Size THEN
      Base^.next := Free^.next;
    ELSE
      New := NearHeapRecPtr(CARDINAL(Free)+Size);
      Base^.next := New;
      New^.size := Free^.size - Size;
      New^.next := Free^.next;
    END;
    IF ClearOnAllocate THEN
      Lib.WordFill ( ADDRESS(CARDINAL(Free)+Align) , (Size-Align) DIV 2 , 0 );
    END;
    A := NearADDRESS(CARDINAL(Free)+Align);
END NearHeapAllocate;

PROCEDURE Merge(PrevRec, LowRec, HighRec, Source: NearHeapRecPtr);

BEGIN
    IF (LowRec = SYSTEM.NearNIL) OR (HighRec = SYSTEM.NearNIL) THEN RETURN END;
    IF (LowRec = Source) THEN RETURN END;
    IF NearHeapRecPtr(CARDINAL(LowRec)+LowRec^.size) # HighRec THEN RETURN END;
    INC(LowRec^.size, HighRec^.size);
    LowRec^.next:=HighRec^.next;
    PrevRec^.next:=LowRec;
    RETURN;
END Merge;

PROCEDURE NearHeapDeallocate(Source: NearHeapRecPtr; VAR A: NearADDRESS; Size: CARDINAL );

VAR
    Curr, Base, Free: NearHeapRecPtr;

BEGIN
    Size := (( (Size+Align-1) DIV Align) * Align) + Align;
    Curr := NearHeapRecPtr(CARDINAL(A) - Align);
    A := SYSTEM.NearNIL;
    IF Curr = SYSTEM.NearNIL THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 97H,  'NearHeapDeallocate: Invalid Argument');
    END;
    Base:=Source;
    LOOP
      Free := Base^.next;
      IF (Free = SYSTEM.NearNIL) OR (CARDINAL(Curr) < CARDINAL(Free)) THEN EXIT; END;
      Base := Free;
    END;
    IF (CARDINAL(Base) + Base^.size = CARDINAL(Curr)) AND (Base # Source) THEN
      INC ( Base^.size , Size );
      Curr := Base;
    ELSE
      Base^.next := Curr;
      Curr^.next := Free;
      Curr^.size := Size;
    END;
    IF CARDINAL(Curr) + Curr^.size = CARDINAL(Free) THEN
      INC ( Curr^.size, Free^.size);
      Curr^.next := Free^.next;
    END;
END NearHeapDeallocate;

PROCEDURE NearHeapAvail(Source: NearHeapRecPtr): CARDINAL;

VAR
    Curr: NearHeapRecPtr;
    Size: CARDINAL;
BEGIN
    Curr := Source;
    Size := 0;
    WHILE Curr # SYSTEM.NearNIL DO
      IF Size < Curr^.size THEN
        Size := Curr^.size;
      END;
      Curr := Curr^.next;
    END;
    RETURN Size - Align;
END NearHeapAvail;


PROCEDURE NearHeapTotalAvail(Source: NearHeapRecPtr): CARDINAL;

VAR
    Curr: NearHeapRecPtr;
    Size: CARDINAL;
BEGIN
    Curr := Source^.next;
    Size := 0;
    WHILE Curr # SYSTEM.NearNIL DO
      INC ( Size , Curr^.size - Align);
      Curr := Curr^.next;
    END;
    RETURN Size;
END NearHeapTotalAvail;



PROCEDURE NearHeapChangeSize(Source: NearHeapRecPtr; VAR A: NearADDRESS;
                          OldSize, NewSize : CARDINAL);

VAR
    Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr;
    SplitSize: CARDINAL;
    OldA: NearADDRESS;
BEGIN
    NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align;
    OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align;
    IF OldSize = NewSize THEN RETURN END;
    Curr:=NearHeapRecPtr(CARDINAL(A)-Align);
    NextRec:=Source;
    PrevRec:=Source;
    LOOP
        IF NextRec = SYSTEM.NearNIL THEN EXIT END;
        IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END;
        PrevRec:=NextRec;
        NextRec:=NextRec^.next;
    END;
    IF OldSize > NewSize THEN
        SplitSize:=OldSize-NewSize;
        Curr^.size:=NewSize;
        NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize);
        NewRec^.size:=SplitSize;
        NewRec^.next:=PrevRec^.next;
        PrevRec^.next:=NewRec;
        Merge(PrevRec, NewRec, NextRec, Source);
        RETURN ;
    END;
    IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *)
        Curr^.size := OldSize;
        Merge(PrevRec, Curr, NextRec, Source);
        IF OldSize = NewSize THEN
            PrevRec^.next := Curr^.next;
            RETURN;
        ELSE
            NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize);
            NewRec^.size := Curr^.size-NewSize;
            NewRec^.next := Curr^.next;
            PrevRec^.next := NewRec;
            RETURN;
        END;
    END;
    OldA:=A;
    NearHeapDeallocate(Source, A, OldSize);
    NearHeapAllocate(Source, A, NewSize);
    Lib.WordMove(ADR(OldA), ADR(A), OldSize DIV 2);
    RETURN;
END NearHeapChangeSize;

PROCEDURE NearHeapChangeAlloc(Source: NearHeapRecPtr; A: NearADDRESS;
                          OldSize, NewSize : CARDINAL): BOOLEAN;

VAR
    Curr, NextRec, PrevRec, NewRec: NearHeapRecPtr;
    SplitSize: CARDINAL;
BEGIN
    NewSize := (( (NewSize+Align-1) DIV Align) * Align) + Align;
    OldSize := (( (OldSize+Align-1) DIV Align) * Align) + Align;
    IF OldSize = NewSize THEN RETURN TRUE END;
    Curr:=NearHeapRecPtr(CARDINAL(A)-Align);
    PrevRec:=Source;
    NextRec:=Source;
    LOOP
        IF NextRec = SYSTEM.NearNIL THEN EXIT END;
        IF CARDINAL(NextRec) > CARDINAL(Curr) THEN EXIT END;
        PrevRec:=NextRec;
        NextRec:=NextRec^.next;
    END;
    IF OldSize > NewSize THEN
        SplitSize:=OldSize-NewSize;
        Curr^.size:=NewSize;
        NewRec:=NearHeapRecPtr(CARDINAL(Curr)+NewSize);
        NewRec^.size:=SplitSize;
        NewRec^.next:=PrevRec^.next;
        PrevRec^.next:=NewRec;
        Merge(PrevRec, NewRec, NextRec, Source);
        RETURN TRUE;
    END;
    IF NearHeapRecPtr(CARDINAL(Curr)+OldSize) = NextRec THEN (* Next Block is free *)
        Curr^.size := OldSize;
        Merge(PrevRec, Curr, NextRec, Source);
        IF OldSize = NewSize THEN
            PrevRec^.next := Curr^.next;
        ELSE
            NewRec := NearHeapRecPtr(CARDINAL(Curr)+NewSize);
            NewRec^.size := OldSize-NewSize;
            NewRec^.next := Curr^.next;
            PrevRec^.next := NewRec;
        END;
        RETURN TRUE;
    ELSE
        RETURN FALSE;
    END;
END NearHeapChangeAlloc;


TYPE
  HANDLEPtr = POINTER TO Windows.HANDLE;


PROCEDURE NearDeallocate(VAR a: NearADDRESS; size: CARDINAL);

BEGIN
    IF ORD(Windows.LocalFree(Windows.HANDLE(a))) # 0 THEN END;
    a:= NearADDRESS(NIL);
END NearDeallocate;

PROCEDURE NearAllocate(VAR a: NearADDRESS; size: CARDINAL);

VAR
  mode: CARDINAL;
  h: Windows.HANDLE;
BEGIN
  IF size = 0 THEN size := 2 END;
  mode := Windows.LMEM_FIXED;
  IF ClearOnAllocate THEN
      mode := mode + Windows.LMEM_ZEROINIT;
  END;
  h := Windows.LocalAlloc(mode, size);
  IF ORD(h) = 0 THEN
      Lib.RunTimeError(CoreSig._FatalErrorPos(), 98H,  'NearAllocate: Out Of Memory');
  END;
  a := NearADDRESS(h);
END NearAllocate;

PROCEDURE NearAvailable(size: CARDINAL) : BOOLEAN;

BEGIN
  RETURN TRUE;
END NearAvailable;

PROCEDURE FarAllocate  (VAR a: FarADDRESS; size: CARDINAL);

BEGIN
  a := Windows.GlobalLock(Windows.GlobalAlloc(Windows.GMEM_MOVEABLE,LONGCARD(size)));
END FarAllocate;

PROCEDURE FarDeallocate(VAR a: FarADDRESS; size: CARDINAL);

VAR h : Windows.HANDLE;
BEGIN
  h := CARDINAL(Windows.GlobalHandle(Seg(a^)));
  Windows.GlobalUnlock(h);
  Windows.GlobalFree(h);
  a := FarNIL;
END FarDeallocate;

PROCEDURE FarAvailable(size: CARDINAL ): BOOLEAN;

BEGIN
  RETURN TRUE;
END FarAvailable;

PROCEDURE SegAllocate(Size: CARDINAL): CARDINAL;
VAR
  a : FarADDRESS;
BEGIN
  FarAllocate(a,Size);
  RETURN Seg(a^);
END SegAllocate;

PROCEDURE SegDeallocate(Sel: CARDINAL; Size: CARDINAL);
VAR a : FarADDRESS;
BEGIN
  a := [Sel:0];
  FarDeallocate(a,Size);
END SegDeallocate;



BEGIN
    MainHeap:=[0:0FFFFH];
END Storage.