        page  ,132
        title Alloc - memory arena manager

;********************************************************************** ;BN001;
;  B001  DCR 1329 - 2/16/91 TMB -  Add support for loading DOS device   ;BN001;
;                   drivers and TSRs into UMBs.                         ;BN001;
;********************************************************************** ;BN001;
; 11Jun91 - G.L.Fulk                                                    ;BN002;
; Add structure macros.                                                 ;BN002;
; Fixed bug with ExePack'ed programs.  The AllocMethod was being        ;BN002;
; corrupted on return from a call to $Alloc.                            ;BN002;
;********************************************************************** ;BN002;
; 11Jul91 - G.L.Fulk                                                    ;BN003;
; Change conditional jumps to short.                                    ;BN003;
;********************************************************************** ;BN003;
; 10Aug91 - G.L.Fulk                                                    ;BN004;
; $Dealloc allows the user to deallocate a block of memory owned by the ;BN004;
; system (owner=0008).  Because we handle the link between low 640K and ;BN004;
; UMB differently from DOS 5, poorly behaved apps (ie. WordPerfect)     ;BN004;
; attempt to deallocate the "Z" link that they do not own.  We will now ;BN004;
; not permit the user to deallocate system space.                       ;BN004;
;********************************************************************** ;BN004;
; 17Dec93 - ChangeTeam  Defect 76092                                    ;76092;
; Added code to $AllocOper to set LoadHigh flag if it was called from   ;76092;
; LOADHIGH command, and changed $Alloc to set HIGH_ONLY and DOSALLOC    ;76092;
; when LoadHigh flag is on.  This is to enable LOADHIGH command to      ;76092;
; function correctly with applications like Novell NETX, which          ;76092;
; intercepts the load request, preventing $Exec from setting HIGH_ONLY  ;76092;
; and DOSALLOC, resulting in low memory being used instead of high.     ;76092;
;********************************************************************** ;76092;
;
; Memory related system calls and low level routines for MSDOS 2.X.
; I/O specs are defined in DISPATCH.
;
;   $ALLOC
;   $SETBLOCK
;   $DEALLOC
;   $AllocOper
;   arena_free_process
;   arena_next
;   check_signature
;   Coalesce
;
;   Modification history:
;
;       Created: ARR 30 March 1983
;
;       danno   08-Nov-1988     Segments/macros/includes for MVDM
;

.xlist
include v86seg.inc
include arena.inc
.xcref
include error.inc
include basemaca.inc
include osmaca.inc
include oldmaca.inc
include demmac.inc
include dossymc.inc
include demumb.inc                      ;Support for UMBs
include struc30.inc
.cref
.list

.LALL

        CpuMode 386

;**************************************************************************
V86LoL  SEGMENT
        EXTRN   A20OFF_COUNT: byte
        EXTRN   DOS_FLAG: byte
        EXTRN   arena_head: word        ; seg address of start of arena
        EXTRN   UmbFlag: byte           ; UMB flag byte
        EXTRN   umb_head: word          ; UMB arena head cell
        EXTRN   start_arena: word       ; seg address of arena from which
                                        ; to start alloc scan
V86LoL  ENDS
;**************************************************************************
V86CONST SEGMENT
        EXTRN   AllocMethod: byte       ; how to alloc first(best)last
        EXTRN   fLoadHigh: byte         ; Loadhigh flag                 76092
V86CONST ENDS
;**************************************************************************
V86SDA  SEGMENT
        EXTRN   FirstArena: word        ; first free block found
        EXTRN   BestArena: word         ; best free block found
        EXTRN   LastArena: word         ; last free block found
        EXTRN   CurrentPDB: word        ; current process data block addr
        EXTRN   EXTERR_LOCUS: byte      ; Extended Error Locus
V86SDA  ENDS
;**************************************************************************
V86CODE SEGMENT
        assume  cs:V86GROUP

        EXTRN   ECritMem: near
        EXTRN   LCritMem: near
        EXTRN   get_user_stack: near    ;MsDisp.asm
        EXTRN   SYS_RET_ERR_AL: near    ;MsCode.asm
        EXTRN   SYS_RET_ERR: near       ;MsCode.asm
        EXTRN   SYS_RET_OK: near        ;MsCode.asm

SUBTTL memory allocation utility routines
PAGE

;-----------------------------------------------------------------------
;
; arena_free_process
; purpose:  free all blocks allocated to that PID
; input:    BX - PID of process
; output:   none
;
        align   4
public  arena_free_process
arena_free_process proc near
        assume  ds:nothing,es:nothing

        mov     ax,cs:[arena_head]
        .repeat

          mov     di,arena_signature

          ;entry: AX=address of block header
          ;       di=0=&arena_signature
          call    Check_Signature       ; ES <- AX, check for valid block
          ;exit:  ES=AX
          ;       CY=signature bad
          ;       NC=signature good

arena_free_process_loop:
          .leave  c                     ;leave if bad signature
          push    es
          pop     ds
          .if     <<ds:[arena_owner]> eq bx>    ;is block owned by pid?
            mov     ds:[arena_owner],DI ; yes... free him
          .endif

          .if     <<byte ptr ds:[di]> ne arena_signature_end>

            ;entry: DS=pointer to block head
            ;       DI=0
            call    arena_next          ; next item in ES/AX carry set if trash
            ;exit:  AX,ES=pointers to next head
            ;       CY=if trashed arena

            jmp     arena_free_process_loop
          .endif

          mov     ax, cs:[umb_head]     ; ax = umb_head
          .leave  <AX eq -1>            ; Q: is umb_head initialized
                                        ;    -1=no, not initialized
          mov     di, ds                ; di = last arena
        .until  <DI ae AX>              ;Q: is last arena above umb_head
        ret

arena_free_process endp

;-----------------------------------------------------------------------
;
; arena_next
; input:    DS - pointer to block head
;               (di) = 0
; output:   AX,ES - pointers to next head
;           carry set if trashed arena
;
        align   4
public  Arena_next
Arena_next proc near
        assume  ds:nothing,es:nothing

        mov     ax,ds                   ; AX <- current block
        add     ax,ds:[arena_size]      ; AX <- AX + current block length
        inc     ax                      ; remember that header!

;------ fall into check_signature and return
;;;;;;; CALL    check_signature         ; ES <- AX, carry set if error
;;;;;;; RET
Arena_next endp

;-----------------------------------------------------------------------
;
; check_signature
;
;       ENTRY   (AX) = address of block header
;               (di) = 0
;       EXIT     ES = AX
;               NC if signature good
;               CY if signature bad
;       USES    ES, Flags
;
;
        align   4
check_signature proc near
        assume  ds:nothing,es:nothing

        mov     es,ax                   ; ES <- AX
        .if     <<byte ptr es:[di]> ne arena_signature_normal> and
        .if     <<byte ptr es:[di]> ne arena_signature_end>
                                        ;IF next signature <> "M" & "Z"
          stc                           ;then set error
        .endif
                                        ;Either of the cmp/jumps above will
                                        ;clear the clear flag if jump is made.
        ret
check_signature endp
;-----------------------------------------------------------------------
;
; Coalesce - combine free blocks ahead with current block
;
;  Coalesce adds the block following the argument to the argument block,
;  iff it's free.  Coalesce is usually used to join free blocks, but
;  some callers (such as $setblock) use it to join a free block to it's
;  preceeding allocated block.
;
;             ENTRY   (ds) = pointer to the head of a free block
;                     (di) = 0
;             EXIT    NC if OK
;                       (ds) unchanged, this block updated
;                       (ax) = address of next block, IFF not at end
;                     CY if arena trashed
;             USES    (cx)
;
;        Output:   updated head of block, AX is next block
        align   4
        public  Coalesce
Coalesce proc   near
        assume  ds:nothing,es:nothing

        .while  <<byte ptr ds:[di]> ne arena_signature_end>
                                        ; IF current signature = "Z" then done

          ;entry: DS=pointer to block head
          ;       DI=0
          call    arena_next            ; ES,AX <- next block, Carry set if err
          ;exit:  AX,ES=pointers to next head
          ;       CY=if trashed arena

          .leave  c
          .leave  <<es:[arena_owner]> ne di>
                                        ; IF next block isnt free THEN return
          mov     cx,es:[arena_size]    ; CX <- next block size
          inc     cx                    ; CX <- CX + 1 (for header size)
          add     ds:[arena_size],CX    ; current size <- current size + CX
          mov     cl,es:[di]            ; move up signature
          mov     ds:[di],cl
        .endwhile

        ret
Coalesce endp

;-----------------------------------------------------------------------
SUBTTL $Alloc - allocate space in memory
PAGE                                                                                ;BN001;
;                                                                                   ;BN001;
;
;  $Alloc services the INT21 that allocates memory space to a program.
;  Alloc returns   a  pointer  to  a  free  block of
;  memory that has the requested  size  in  paragraphs.
;
;  If the allocation strategy is HIGH_FIRST or HIGH_ONLY memory is
;  scanned from umb_head if not from arena_head. If the strategy is
;  HIGH_FIRST the scan is continued from arena_head if a block of
;  appropriate size is not found in the UMBs. If the strategy is
;  HIGH_FIRST+HIGH_ONLY only the UMBs are scanned for memory.
;
;  In either case if bit 0 of UmbFlag is not initialized then the scan
;  starts from arena_head.
;
;  Assembler usage:
;      MOV     BX,size
;      MOV     AH,Alloc
;      INT     21h
;
;  BUGBUG - a lot can be done to improve performance.  We can set marks
;  so that we start searching the arena at it's first non-trivial free
;  block, we can peephole the code, etc.  (We can move some subr calls
;  inline, etc.)  I assume that this is called rarely and that the arena
;  doesn't have too many memory objects in it beyond the first free one.
;  verify that this is true; if so, this can stay as is
;
;       ENTRY   (bx) = requested size, in bytes
;               (DS) = (ES) = DOSGROUP
;       EXIT    NC if memory allocated
;                 (ax:0) = address of requested memory
;               CY if request failed
;                 (AX) = error_not_enough_memory
;                   (bx) = max size we could have allocated
;                 (ax) = error_arena_trashed
;       USES    All
;

        align   4
public $ALLOC
$ALLOC  proc    near
        assume  ds:nothing,es:nothing

        EnterCrit   critMem

;*********************************************************************
;               added for UMB support
;*********************************************************************

;------ default to load low, assume LOW_FIRST
        mov     ax,cs:[arena_head]
        mov     cs:[start_arena],ax

        .if     <<cs:[fLoadHigh]> eq TRUE>       ;if Loadhigh cmd,   ;76092
          or      cs:[AllocMethod],HIGH_ONLY     ;  set HIGH_ONLY    ;76092
          or      cs:[UmbFlag],DOSALLOC          ;  set DOSALLOC     ;76092
        .endif                                                       ;76092
        .if     <BIT <cs:[AllocMethod]> and HIGH_FIRST+HIGH_ONLY> and
        .if     <BIT <cs:[UmbFlag]> and UMBAVAIL>
                                        ;Is either bit on? and
                                        ;Are UMBs useable?
          .if     <BIT <cs:[UmbFlag]> and DOSALLOC> or
                                      ; Do we scan from UMB_HEAD even if not linked?
                                      ; start at UMB_HEAD anyway(OS/2)
          .if     <BIT <cs:[UmbFlag]> and LINKSTATE>
                                      ; Are UMBs already linked in?
                                      ; yes, scan from arena_head
            mov     ax,cs:[umb_head]  ; otherwise, start with umbs just in case
            .if     <AX ne -1>
              mov     cs:[start_arena], ax
            .endif
          .endif
        .endif

;------ init the options
        xor     ax,ax
        mov     di,ax
        mov     cs:[FirstArena],AX
        mov     cs:[BestArena],AX
        mov     cs:[LastArena],AX

        PUSH    AX                      ; alloc_max <- 0
start_scan:
        mov     ax,cs:[start_arena]     ; AX = beginning of arena
        CALL    Check_signature         ; ES <- AX, carry set if error
        JC      short alloc_err         ; IF error THEN GOTO err

alloc_scan:
        PUSH    ES
        POP     DS                      ; DS <- ES
        CMP     DS:[arena_owner],DI
        JZ      short alloc_free        ; IF current block is free THEN examine

alloc_next:

        ; Are UMBs linked & high_first? (if no, see if we reached last arena)
        .if     <BIT <cs:[UmbFlag]> and LINKSTATE> and
        .if     <BIT <cs:[AllocMethod]> and HIGH_FIRST>
          mov     ax,cs:[start_arena]
          .if     <ax eq <cs:[arena_head]>> ;did we start scan from arena_head?
            mov     ax,ds               ; ax = current block
            cmp     ax,cs:[umb_head]    ; Q: check against umb_head
            jmp     short alloc_chk_end
          .endif
        .endif

;------ see if we reached last arena (signature=="Z")
        CMP     BYTE PTR DS:[DI],arena_signature_end
alloc_chk_end:                          ; M000
                                        ; IF current block is last THEN GOTO end
        JZ      short alloc_end
        CALL    arena_next              ; AX, ES <- next block, Carry set if error
        JNC     short alloc_scan        ; IF no error THEN GOTO scan

alloc_err:
        POP     AX

alloc_trashed:
        LeaveCrit   critMem
        mov     al,error_arena_trashed
        jmp     Sys_ret_err_AL

alloc_end:
        CMP     cs:[FirstArena],0
        JNZ     alloc_do_split

        mov     ax,cs:[arena_head]
        cmp     ax,cs:[start_arena]     ; Q: started scanning from arena_head
        je      short alloc_fail        ; Y: not enough memory
                                        ; N:
                                        ; Q: is the alloc strat HIGH_ONLY
        test    cs:[AllocMethod],HIGH_ONLY
        jnz     short alloc_fail        ; Y: return size of largest UMB
        mov     cs:[start_arena],ax     ; N: start scanning from arena_head
        jmp     short start_scan

alloc_fail:
        call    get_user_stack
        pop     bx
        mov     [SI].user_BX,BX
        LeaveCrit   critMem
        mov     al,error_not_enough_memory
        jmp     Sys_ret_err_AL

alloc_free:
        CALL    coalesce                ; add following free block to current
        JC      short alloc_err         ; IF error THEN GOTO err
        MOV     CX,DS:[arena_size]

        POP     DX                      ; check for max found size
        .if     <CX a DX>
          mov     dx,cx
        .endif
        PUSH    DX
        CMP     BX,CX                   ; IF BX > size of current block THEN
        JA      short alloc_next        ;   GOTO next

        .if     <<cs:[FirstArena]> eq 0>
          mov     cs:[FirstArena],DS      ; save first one found
        .endif

        CMP     cs:[BestArena],0
        JZ      short alloc_make_best   ; initial best
        PUSH    ES
        mov     es,cs:[BestArena]
        cmp     es:[arena_size],CX      ; is size of best larger than found?
        POP     ES
        JBE     short alloc_last
alloc_make_best:
        mov     cs:[BestArena],ds       ; assign best
alloc_last:
        mov     cs:[LastArena],ds       ; assign last
        jmp     alloc_next

;
; split the block high
;
alloc_do_split_high:
        mov     ds,cs:[LastArena]
        mov     cx,ds:[arena_size]
        sub     cx,bx
        mov     dx,ds
        JE      short alloc_set_owner   ; sizes are equal, no split
        ADD     DX,CX                   ; point to next block
        MOV     ES,DX                   ; no decrement!
        DEC     CX
        XCHG    BX,CX                   ; bx has size of lower block
        JMP     short alloc_set_sizes   ; cx has upper (requested) size

;
; we have scanned memory and have found all appropriate blocks
; check for the type of allocation desired; first and best are identical
; last must be split high
;
alloc_do_split:
        mov     cl,cs:[AllocMethod]
        and     cl, HF_HO_MASK          ; mask off bit 7 and bit 6
        cmp     cl, BEST_FIT            ; Q; is the alloc strategy
                                        ;    best_fit
        JA      short alloc_do_split_high
        mov     ds,cs:[FirstArena]
        .if     AE
          mov     ds,cs:[BestArena]
        .endif
alloc_get_size:
        mov     cx,ds:[arena_size]
        SUB     CX,BX                   ; get room left over
        MOV     AX,DS
        MOV     DX,AX                   ; save for owner setting
        JE      short alloc_set_owner   ; IF BX = size THEN (don't split)
        ADD     AX,BX
        INC     AX                      ; remember the header
        MOV     ES,AX                   ; ES <- DS + BX (new header location)
        DEC     CX                      ; CX <- size of split block
alloc_set_sizes:
        mov     ds:[arena_size],BX      ; current size <- BX
        mov     es:[arena_size],CX      ; split size <- CX
        MOV     BL,arena_signature_normal
        XCHG    BL,DS:[DI]              ; current signature <- 4D
        MOV     ES:[DI],BL              ; new block sig <- old block sig
        MOV     ES:[arena_owner],DI

alloc_set_owner:
        MOV     DS,DX
        mov     ax,cs:[CurrentPDB]
        MOV     DS:[arena_owner],AX
        MOV     AX,DS
        INC     AX
        POP     BX
        LeaveCrit   critMem
        jmp     SYS_RET_OK

$alloc  endp

;-----------------------------------------------------------------------
SUBTTL $SETBLOCK - change size of an allocated block (if possible)
PAGE
;
;
;
;  Setblock changes the size of an allocated block.  First, we coalesce
;  any following free space onto this block; then we try to trim the
;  block down to the size requested.
;
;  Note that if the guy wants to grow the block but that growth fails,
;  we still go ahead and coalesce any trailing free blocks onto it.
;  Thus the maximum-size-possible value that we return has already
;  been allocated!  This is a bug, dare we fix it?  BUGBUG
;
;  NOTE - $SETBLOCK is in bed with $ALLOC and jumps into $ALLOC to
;          finish it's work.  For this reason we build the allocsf
;          structure on the frame, to make us compatible with $ALLOCs
;          code.
;
;   Assembler usage:
;           MOV     ES,block
;           MOV     BX,newsize
;           MOV     AH,setblock
;           INT     21h
;         if setblock fails for growing, BX will have the maximum
;         size possible
;
;       ENTRY   (es) = segment of old block
;               (bx) = newsize
;               (ah) = SETBLOCK
;
;       EXIT    NC if OK
;               CY if error
;   Error return:
;           AX = error_invalid_block
;              = error_arena_trashed
;              = error_not_enough_memory
;              = error_invalid_function
;           bx = maximum size possible, iff (ax) = error_not_enough_memory
;
        align   4
        public  $SETBLOCK
$SETBLOCK proc  near
        ASSUME  DS:NOTHING,ES:NOTHING
        EnterCrit   critMem
        MOV     DI,arena_signature
        MOV     AX,ES
        DEC     AX
        CALL    check_signature
        .if     c
setblock_bad:
          jmp     alloc_trashed
        .endif
        mov     ds,ax
        call    coalesce
        JC      short setblock_bad
        MOV     CX,DS:[arena_size]
        PUSH    CX
        CMP     BX,CX
        JBE     short alloc_get_size
        JMP     alloc_fail
$SETBLOCK endp

;-----------------------------------------------------------------------
SUBTTL $DEALLOC - free previously allocated piece of memory
PAGE
;
;       ENTRY   (es) = address of item
;
;       EXIT    NC of OK
;           Error return:
;               CY if error
;           AX = error_invalid_block
;              = error_arena_trashed
;
;   Assembler usage:
;           MOV     ES,block
;           MOV     AH,dealloc
;           INT     21h
;
;
        align   4
public  $DEALLOC
$DEALLOC proc   near
        ASSUME  DS:NOTHING,ES:NOTHING

        EnterCrit   critMem

;       DOS50                                                           ;BN004;
; Mace utilities MKEYRATE.COM version 1.0 copyright 1987 is an          ;BN004;
; execpacked program converted to a com file. Therefore if DOS is       ;BN004;
; loaded high and if this program is loaded below 64K it will blurt     ;BN004;
; out "packed file is corrupt".  This program does an int 21 ah=49h     ;BN004;
; before executing the buggy execpacked code.  This int21 call turns    ;BN004;
; a20 on and hence the problem.  In $dealloc alloc.asm A20OFF_COUNT is  ;BN004;
; set to 1 if bit 2 of DOS_FLAG was previously set by a call to exec    ;BN004;
; and if A20OFF_COUNT is 0.  In msdisp.asm, if A20OFF_COUNT is non zero ;BN004;
; then A20 will be turned OFF before returning to the user.  Bit 2 will ;BN004;
; be unconditionally cleared here.                                      ;BN004;
        .if     <<cs:[DOS_FLAG]> and EXECA20OFF> and ;was prev. call exec?
        .if     <<cs:[A20OFF_COUNT]> eq 0>           ;and is the count=0?
          mov     cs:[A20OFF_COUNT],1                ;then set the count:=1
        .endif

        MOV     DI,arena_signature
        MOV     AX,ES
        DEC     AX
        CALL    check_signature
        .if     nc                                                      ;BC004;
          .if     <<word ptr es:[arena_owner]> ne 8>                    ;BN004;
            mov     es:[arena_owner],di                                 ;BN004;
          .endif                                                        ;BN004;
          LeaveCrit   critMem
          jmp         SYS_RET_OK
        .endif                                                          ;BC004;
        LeaveCrit   critMem
        mov     al,error_invalid_block
        jmp     Sys_ret_err_AL
$DEALLOC endp

;-----------------------------------------------------------------------
SUBTTL $AllocOper - get/set allocation mechanism
PAGE
;
;   Assembler usage:
;           MOV     AH,AllocOper
;           MOV     BX,method
;           MOV     AL,func
;           INT     21h
;  ENTRY
;          (al) = 0
;            Get allocation Strategy in (ax)
;
;          (al) = 1, (bx) = method = zw0000xy
;            Set allocation strategy.
;             z  = 1  => HIGH_FIRST
;             w  = 1  => HIGH_ONLY
;             xy = 00 => FIRST_FIT
;                = 01 => BEST_FIT
;                = 10 => LAST_FIT
;
;          (al) = 2
;            Get UMB link state in (al)
;
;          (al) = 3
;            Set UMB link state
;             (bx) = 0 => Unlink UMBs
;             (bx) = 1 => Link UMBs
;
;
;  EXIT    'C' clear if OK
;
;           if (al) = 0
;            (ax) = existing allocmethod
;           if (al) = 1
;            Sets allocation strategy
;           if (al) = 2
;              (al) = 0 => UMBs not linked
;              (al) = 1 => UMBs linked in
;           if (al) = 3
;            Links/Unlinks the UMBs into DOS chain
;
;        Error return:
;              'C' set if error
;               AX = error_invalid_function
;
;
;
        align   4
public  $AllocOper
$AllocOper proc near
        ASSUME  DS:NOTHING,ES:NOTHING

        .select
        .when   <ZERO al>
          mov     al,cs:[AllocMethod]
          xor     ah,ah                 ; Return current AllocMethod
          jmp     SYS_RET_OK

        .when   <AL eq 1>
          push    bx
          ;mask off bit 7. Note bit 6, the
          ;HIGH_ONLY bit can't be set by a
          ;call to this. It's set by $exec
          ;if HIGH_FRIST is set.
          and     bl, HF_MASK
          cmp     bl,LAST_FIT           ;BX must be first/best/last
          pop     bx
          .if     be
            mov     cs:[AllocMethod],BL   ;establish new allocation method
            jmp     SYS_RET_OK
          .endif

        .when   <AL eq 2>
          ;return: (al) = 0 => UMBs not linked
          ;        (al) = 1 => UMBs linked in
          mov     al, cs:[UmbFlag]        ; return link state in al
          and     al, LINKSTATE           ; LINKSTATE, bit 0= 0 or 1
          jmp     SYS_RET_OK

        .when   <AL eq 3>
          mov     cx, cs:[umb_head]
          .if     <cx ne -1> and        ;UMBs have been initialized?
          .if     <BIT <cs:[UmbFlag]> and UMBAVAIL> and  ;UMBs available?
          .if     <BIT <cs:[UmbFlag]> nand NOLINKUMBS>   ;low arena built?
            cmp     bx, 1
            jb      short UnlinkUmbs
            jz      short LinkUmbs
          .endif

        .when   <AL eq 99h>             ;INT 21 5801 for Loadhigh cmd. ;76092
          mov     cs:[fLoadHigh],TRUE   ;  set loadhigh flag           ;76092
          push    bx                                                   ;76092
          ;mask off bit 7. Note bit 6, the                             ;76092
          ;HIGH_ONLY bit can't be set by a                             ;76092
          ;call to this. It's set by $alloc                            ;76092
          ;if HIGH_FIRST is set.                                       ;76092
          and     bl, HF_MASK                                          ;76092
          cmp     bl,LAST_FIT           ;BX must be first/best/last    ;76092
          pop     bx                                                   ;76092
          .if     be                                                   ;76092
            mov     cs:[AllocMethod],BL ;establish new alloc method    ;76092
            jmp     SYS_RET_OK                                         ;76092
          .endif                                                       ;76092

        .endselect

        mov     cs:[EXTERR_LOCUS],errLoc_mem ; Extended Error Locus
        mov     al,error_invalid_function
        jmp     Sys_ret_err_AL

AllocArenaError:
        mov     cs:[EXTERR_LOCUS],errLoc_mem ; M009: Extended Error Locus
        mov     al,error_arena_trashed
        jmp     Sys_ret_err_AL

UnlinkUmbs:
        .if     <BIT <cs:[UmbFlag]> and LINKSTATE>    ; Q: umbs unlinked?
          call    GetLastArena            ; get last low arena in DS
          jc      short AllocArenaError   ; arena trashed
                                          ; make it last
          mov     byte ptr ds:[0], arena_signature_end
          and     cs:[UmbFlag], NOT LINKSTATE; indicate unlink'd state
        .endif
        jmp     SYS_RET_OK

LinkUmbs:
        .if     <BIT <cs:[UmbFlag]> nand LINKSTATE>   ; Q: umbs linked?
          call    GetLastArena            ; get arena before umb_head
          jc      short AllocArenaError   ; arena trashed
                                          ; make it normal.  ds points to
                                          ; arena before umb_head
          mov     byte ptr ds:[0], arena_signature_normal
          or      cs:[UmbFlag], LINKSTATE    ; indicate link'd state in UmbFlag
        .endif
        jmp     SYS_RET_OK

$AllocOper endp
;-----------------------------------------------------------------------


;-----------------------------------------------------------------------
;
; Procedure Name : GetLastArena
;
; Inputs         : cx = umb_head
;
; Outputs        : If UMBs are linked
;                       ES = umb_head
;                       DS = arena before umb_head
;                  else
;                       DS = last arena
;                       ES = next arena. will be umb_head if NC.
;
;                  CY if error
;
; Uses           : DS, ES, DI, BX
;
;-----------------------------------------------------------------------

        align   4
public GetLastArena
GetLastArena proc near

        push    ax                      ; save ax
        mov     ax, cs:[arena_head]
        mov     es, ax                  ; es = arena_head
        xor     di, di

        .if     <<byte ptr es:[di]> ne arena_signature_end>
                                        ; Q: is this the last arena
                                        ; Y: return last arena in ES
          .repeat
            mov     ds, ax
            call    arena_next          ; ax, es -> next arena
            jc      short GLA_err

            test    cs:[UmbFlag], LINKSTATE ; Q: are UMBs linked
            jnz     short GLA_chkumb        ; Y: terminating condition is
                                            ;    umb_head
                                            ; N: terminating condition is Z
            cmp     byte ptr es:[di],arena_signature_end
                                        ; Q: is this the last arena
            jmp     short GLA_1
GLA_chkumb:
            cmp     ax, cx              ; Q: is this umb_head
GLA_1:
          .until  EQ                    ;get next arena

        .endif

        test    cs:[UmbFlag], LINKSTATE ; Q: are UMBs linked
        jnz     short GLA_ret           ; Y: we're done
                                        ; N: let us confirm that the
                                        ;    next arena is umb_head
        mov     ds, ax
        call    arena_next              ; ax, es -> next arena
        jc      short GLA_err
        cmp     ax, cx                  ; Q: is this umb_head
        jne     short GLA_err           ; N: error
                                        ;
GLA_ret:
        clc                             ; no error
        pop     ax
        ret

GLA_err:
        stc                             ; error
        pop     ax
        ret

GetLastArena endp


V86CODE    ENDS
    END
