
%if 0

lDOS memory handling
 by E. C. Masloch, 2018--2025

Usage of the works is permitted provided that this
instrument is retained with the works, so that any entity
that uses the works is notified of this instrument.

DISCLAIMER: THE WORKS ARE WITHOUT WARRANTY.

%endif

%if 0

Inside most functions, di is set to zero and used as index register to access
MCB fields (this allows the assembler to use byte offsets resulting in smaller
instructions). It's also used whenever a register with the value zero is handy,
for example, when ClearMCB wants to free the MCB by setting the owner word to
zero.

Most functions access the current working MCB with ds. CollectNextFreeMCB
accesses the secondary MCB (which is to be removed) with es.

--

The separate CheckMCBs function has been removed. To check the MCB chain, call
ReleaseOwnersMCBs with bx set to zero. The returned status indicates whether
the MCB chain is invalid. (This also resets the mcbName field of all already
free MCBs, but that shouldn't be an issue.)

--

As you may note, the functions are mostly ordered from those performing simple
or preparatory tasks to those more complex, calling the simpler ones. The last
functions are ModifyMCBRandom (which takes an address and resizes that MCB as
requested) and AllocateMCBRandom (which searches through the MCBs and decides
which one to reserve depending on the requested allocation strategy).

--

Note that the MS-DOS-compatible UMB link and memory allocation strategies
for allocation behave as follows:

UMB link? -->	Off			On
v Strategy area
00h		LMA only		LMA then UMA, as one area
40h		LMA only		UMA only, as one area
80h		LMA only		UMA as one area, then LMA as one area

In particular, "UMA then LMA" (80h) treats the two areas as distinct areas
for the search; if a UMA block is found that satisfies the search, it is
used, even if a better (best-fit) or later (last-fit) block would be found
in the LMA. (For first-fit, there is no difference.)

Our original implementation treated the "UMA then LMA" (80h) strategy area
as one area for the search, which for best-fit and last-fit differs.

--

The default now is to behave compatible to MS-DOS, that is, UMA then LMA
is handled as two areas, while LMA then UMA is handled as one area.
Setting the flag 2 in the high byte of the allocation strategy (stored
in alloc_strategy_ext) handles both cases in the original lDOS meaning,
that is, as one area. Setting the flag 4 instead handles both cases as
two areas. Flag 2 takes precedence if both are set. (This is handled in
AllocateMCBCompatible, which calls AllocateLargestMCBRandom for the two
area cases.)

--

When flag 1 of alloc_strategy_ext is set, the UMB link status (which
here includes whether the last LMCB has an M or a Z) is ignored and
the area flags of the allocation strategy are used exclusively.

%endif

%include "lmacros2.mac"
%include "lstruct.mac"


global GetMCBOwner, GetMCBFlags, GetRawMCBFlags, AllocateLargestMCBRandom
global AllocateMCBCompatible.flags_cx
global SplitMCB, ClearMCB


		; INP:	cx = user-requested flags
		; OUT:	cx = internally usable flags
		;	 (only one bit of bits 4..7 set, low nibble contains 0..2, high byte always clear)
		;	 word [ss:error_flags] updated
		; CHG:	-
		; STK:	4 word
		;
		; The user-requested flags are parsed to these internally used:
		; area:	10h LMA only
		;	20h LMA then UMA
		;	40h UMA only
		;	80h UMA then LMA
		;	(for the non-UMA build, all area flags are ignored and cleared)
		; mode:	00h First fit
		;	01h Best fit
		;	02h Last fit
%ifn _UMA
FixMCBFlags:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	test ch, ~(1 | 2 | 4)			; invalid flags set ?
	jz .validhigh
	and ch, (1 | 2 | 4)
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_InvalidAllocStrategy
%endif
.validhigh:
		; The problem arises that MS-DOS 5+ always supports
		; UMBs. Older versions allowed any value as strategy
		; using anything above 2 as "Last fit" too. Instead
		; of reproducing this behaviour, builds without UMA
		; fake that they actually support UMA but that there
		; was none installed. (After all, we use the DOS 5+
		; internal data layout.) Programs can check for this
		; fake support by calling 21.5802 and 21.5803. If UMA
		; is actually supported, 21.5802 always returns NC. If
		; UMA is not supported, it returns CY (ax = 0001h). If
		; UMA is supported, but not installed, 21.5803 still
		; returns CY (ax = 0001h).
	and cl, 0Fh				; clear area flags (we don't check these either)
	cmp cl, 3				; valid strategy ?
	jb .validstrategy			; yes -->
	xor cl, cl				; force first fit
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_InvalidAllocStrategy	; report invalid strategy
%endif
.validstrategy:
	retn
%else
FixMCBFlags:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	test ch, ~(1 | 2 | 4)			; invalid flags set ?
	jz .validhigh
	and ch, (1 | 2 | 4)
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_InvalidAllocStrategy
%endif
.validhigh:
	 push ax
	 push cx
	test cl, ~0Fh				; test whether any flag set
	jnz .gotflag
	or cl, 20h				; "LMA then UMA" (if UMA enabled)
.gotflag:
	mov ch, 80h
	stc
	call .test
	call .test
	call .test				; (after this call, 10h is the only flag left. it is set)

	xor ch, ch				; insure high byte zero
	push cx
	and cl, 0Fh				; clear flags
	cmp cl, 3				; valid strategy ?
					; (0 = first fit, 1 = best fit, 2 = last fit)
	pop cx
	jb .validstrategy			; yes -->
	and cl, ~0Fh				; force first fit
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_InvalidAllocStrategy	; invalid low nibble
%endif
.validstrategy:
	pop ax					; restore ch from stack into ah
	mov ch, ah				; restore ch
	pop ax					; restore ax from stack
	retn

.test:
	jnc .return				; previous call got flag
	test cl, ch				; current flag set ?
	jnz .match				; yes -->
	shr ch, 1				; shift down
	stc					; signal next calls to pass
.return:
	retn
.match:
	xor cl, ch				; clear flag itself
	test cl, ~0Fh				; any of the lower flags set ?
	jz .valid				; nope -->
	and cl, 0Fh				; clear lower flags
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_MultipleAllocAreas	; flag the error
%endif
.valid:
	xor cl, ch				; (NC) set flag again
	retn


		; Compare ax to first UMCB
		;
		; INP:	ax = MCB
		; OUT:	NZ if not first UMCB (or if there's no UMCB)
		;	ZR if first UMCB
		; CHG:	-
		; STK:	1 word
IsFirstUMCB?:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	cmp word [ss:first_umcb], byte -2
	ja .return			; (NZ if it jumps) -->
	cmp ax, word [ss:first_umcb]
.return:
	retn


GetRawMCBFlags:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	mov ch, byte [ss:alloc_strategy_ext]
	mov cl, byte [ss:AllocMethod]	; cx = flags
	retn


		; Get current MCB flags
		;
		; INP:	-
		; OUT:	cx = internally usable flags
		;	 (only one bit of bits 4..7 set, low nibble contains 0..2, high byte always clear)
		;	 error_flags updated
		; CHG:	-
		; STK:	3 word
GetMCBFlags:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	call GetRawMCBFlags
	call FixMCBFlags			; detect multiple area flags
%if _ERRORFLAGS
	test byte [ss:enable_uma], ~1
	jz .validlink
	or byte [ss:error_flags], EF_InvalidUMBLink	; invalid UMB link bits set
.validlink:
%endif
	test ch, 1				; use area flags and
						;  disregard UMB link ?
	jnz .return				; yes -->
	test byte [ss:enable_uma], 1		; UMA enabled ?
	jz .lmaonly				; no, force LMA only --> (no error flag)
	cmp word [ss:first_umcb], byte -1	; UMA available ?
	jne .return
%if _ERRORFLAGS
	or byte [ss:error_flags], EF_NoUMBsToLink	; UMB link enabled but none there
%endif
.lmaonly:					; change area to LMA only
	and cl, 0Fh
	or cl, 10h
.return:
	retn
%endif


		; Set MCB flags for linear access
		;  ("LMA only" if no UMA available, else "LMA then UMA")
		;
		; INP:	-
		; OUT:	ax = 0000h (to get first MCB on SNextMCB call)
		;	ss:sp-> flags (word 10h if no first UMCB, 20h else),
		;		loop detection counter (word initialised to 0),
		;		original si value
		;	ss:si-> flags (si = sp)
		;	NC, ZR
		; CHG:	-
		; STK:	5 word
SetLinearMCBFlags:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push bp
	mov bp, sp
	mov ax, 10h				; if no UMCB, set to 10h ("LMA only")
%if _UMA
	cmp word [ss:first_umcb], -1
	je .nonuma
	mov al, 20h				; else set to 20h ("LMA then UMA")
.nonuma:
%endif
	push ax					; flags word, at [bp - 2]
	push word [bp + 2]			; create return stack space, ip
	push word [bp]				; bp on stack
	xor ax, ax
	mov word [bp + 2], si			; save si value on stack
	mov word [bp], ax			; loop detection counter
	lea si, [bp - 2]			; ss:si-> flags
	pop bp					; bp = [bp - 6]
	retn					; ip = [bp - 4]


		; Get current MCB owner
		;
		; INP:	-
		; OUT:	dx = PSP address or owner override value
		; CHG:	-
		; STK:	2 word
GetMCBOwner:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	xchg dx, bx
%if 0
	mov bx, word [ss:current_driver]
	inc bx
	jz .usepsp				; was FFFFh, override inactive -->
	dec bx
	jnz .override				; was not 0000h, override active -->
%endif
.usepsp:
	call getpsp				; don't care which value returned
	test bx, bx
	jnz .return
	inc bx					; except, not zero !
.override:
.return:
	xchg dx, bx
	retn


		; Verify MCB
		;
		; INP:	ax = MCB
		; OUT:	ds = MCB
		;	di = 0
		;	NZ, CY if invalid MCB,
		;	 ax = error code 0007h (MCB chain corrupted)
		;	ZR, NC if valid MCB
		; CHG:	-
		; STK:	1 word
VerifyMCB:
 assume ds:nothing, es:nothing, ss:nothing
	xor di, di
	mov ds, ax				; set up working registers
 assume ds:nothing
	inc ax
	cmp ax, byte 2				; passed value FFFFh or 0000h ?
	jb .invalid				; (NZ, CY) yes -->
	dec ax
 assume ds:MCB
	cmp byte [di+mcbSignature], 'M'		; valid 'M' signature ?
	je .return				; yes --> (ZR, NC)
	cmp byte [di+mcbSignature], 'Z'		; valid 'Z' signature ?
	je .return				; yes --> (ZR, NC)
.invalid:
	stc
	mov ax, errorMCBDestroyed		; (CY, NZ) else invalid
.return:
	retn


		; INP:	ax = memory block's segment
		; OUT:	di = 0
		;	NC if valid MCB,
		;	 ds = ax = MCB address
		;	CY if invalid MCB,
		;	 ax = error code 0009h (Invalid MCB)
		; CHG:	ds
		; STK:	2 word
GetMCBFromBlock:
 assume ds:nothing, es:nothing, ss:nothing
	dec ax

		; Besides checking the signature, we don't do anything here.
		; We could walk the actual chain to insure that MCB is on it,
		; but that would prohibit freeing or resizing blocks in the
		; excluded UMA sub-chains. (As I verified once with my
		; horrible DEBUG preloading device driver hack, the usage of
		; independant sub-chains isn't prohibited by MS-DOS.)

		; Verify MCB, different error code
		;
		; INP:	ax = MCB
		; OUT:	ds = MCB
		;	di = 0
		;	NZ, CY if invalid MCB,
		;	 ax = error code 0009h (Invalid MCB)
		;	ZR, NC if valid MCB
		; CHG:	-
		; STK:	2 word
VerifySingleMCB:
 assume ds:nothing, es:nothing, ss:nothing
	call VerifyMCB
	jnc .return
	mov ax, errorMCBInvalid
.return:
	retn


		; Clear MCB owner and name, or name only
		;
		; INP:	ds = MCB
		;	di = 0
		; OUT:	-
		; CHG:	- (CF is preserved too)
		; STK:	1 word
		; STT:	ss need not equal DOSDATA
ClearMCB:
 assume ds:MCB, es:nothing, ss:nothing
	mov word [di+mcbOwner], di		; free up block
ClearMCBName:
 assume ds:MCB, es:nothing, ss:nothing
	mov word [di+mcbName+0], di
	mov word [di+mcbName+2], di
	mov word [di+mcbName+4], di
	mov word [di+mcbName+6], di		; clear the name field
	retn


		; Release MCB
		;
		; INP:	ax = memory block's segment
		; OUT:	CY if invalid MCB,
		;	 ax = error code
		;	NC if valid MCB, released,
		;	 ax = MCB
		; CHG:	ax
		;
		; DOS should not collect MCBs after freeing. This can
		; break software which directly modifies MCBs because
		; the software may think the MCB still exists there.
		; ecm 2026: Added option to collect MCBs after freeing.
ReleaseMCB:
 assume ds:nothing, es:nothing, ss:nothing
	push ds
	push di
	call GetMCBFromBlock			; get MCB from block address
	jc .ret					; invalid address or signature -->
 assume ds:MCB
	call ClearMCB				; free it
 assume ds:nothing

	rol byte [ss:config_collect_free_mcb], 1
	jnc .ret				; --> (NC)
	call SetLinearMCBFlags			; set order for accessing all MCBs
	mov ax, ds
.again:
	call CollectNextFreeMCB			; merge next with this one, if free
	jnc .again				; merged, check if next also free -->
	cmp ax, errorInsufficientMemory		; was error "Not enough memory" ?
	jne .collecterror
	mov ax, ds
	db __TEST_IMM8				; skip stc, NC
.collecterror:
	stc
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si

.ret:
 assume ds:nothing
	pop di
	pop ds
 assume ds:nothing
	retn


		; Get next MCB, insuring the chain doesn't loop
		;
		; INP:	word [ss:si] = area flags and allocation strategy
		;	word [ss:si + 2] = loop detection counter, init to 0
		;	ax = former MCB (0000h to get first)
		; OUT:	CY if MCB chain corrupted or loops,
		;	 ax = error code
		;	NC if MCB chain intact,
		;	 NZ if no next MCB,
		;	  ax = error code (0008h)
		;	 ZR if next MCB available,
		;	  ax = next MCB
		;	di = 0
		; CHG:	-
		; STK:	8 word
;	doscode_insure_low_byte_not_0CCh
SNextMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	xor di, di
	dec word [ss:si + 2]
	jnz @F
		; This doesn't branch if ZR, meaning if the 1_0000h iterations
		;  have run out (if counter was 1 prior to the dec).
	push ds
	mov ds, ax
	mov ax, errorMCBLoops
	jmp NextMCB.error

@@:
		; (fall through to NextMCB)


		; Get next MCB
		;
		; INP:	word [ss:si] = area flags and allocation strategy
		;	word [ss:si + 2] = loop detection counter
		;	ax = former MCB (0000h to get first)
		; OUT:	CY if MCB chain corrupted,
		;	 ax = error code
		;	NC if MCB chain intact,
		;	 NZ if no next MCB,
		;	  ax = error code 0008h (Not enough memory)
		;	 ZR if next MCB available,
		;	  ax = next MCB
		;	di = 0
		; CHG:	-
		; STK:	3 word
		;
		; An interesting effect of how this code handles the first UMCB
		; is that it doesn't care whether the previous MCB contains an
		; 'M' (normal MCB chain extended into UMA) or 'Z' (normal MCB
		; chain limited to LMA). Also, the parsed area flags allow to
		; ignore the actual requested UMB link: If it was zero, all
		; area flags are cleared and forced to 10h (LMA only) instead.
%ifn _UMA
NextMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push ds
	test ax, ax				; request for first ?
	jz .first				; yes -->

	call VerifyMCB				; check input MCB first
	jc .return
 assume ds:MCB
	inc ax
	add ax, word [di+mcbSize]		; get address of next (if any)
	cmp byte [di+mcbSignature], 'M'		; current in-chain ?
	je .verify				; yes, verify it -->
		; If this was NZ and didn't jump, then the mcbSignature
		;  contains the letter 'Z', which is above 'M'. Therefore,
		;  it is always true that it is NC at this point.
	mov ax, errorInsufficientMemory		; (NC, NZ)
	pop ds
 assume ds:nothing
	retn
.first:
	mov ax, word [ss:first_mcb]
.verify:
 assume ds:MCB
	call VerifyMCB				; NC, ZR if valid - CY if invalid
.return:
	pop ds
 assume ds:nothing
	retn
%else
		; The UMA build has to evaluate the (parsed) area flags
		; here to show the caller a continuous chain of MCBs.
		; This requires special handling in two cases: If the
		; caller's input was 0000h (to get the first MCB) or if
		; it was the MCB before the first UMCB. Area flags of
		; 80h and 40h want to start their search with the first
		; UMCB instead. Flags 20h want to proceed at the first
		; UMCB, all other flags want to stop there. The first
		; UMCB's handling ignores whether the preceeding MCB
		; contained 'M' or 'Z'.
NextMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push ds
	test ax, ax				; request for first ?
	jz .first				; yes -->

	call VerifyMCB				; check input MCB first
	jc .error
 assume ds:MCB
	mov word [ss:nextmcbinput], ax
	inc ax
	add ax, word [di+mcbSize]		; get address of next (whether current is 'M' or 'Z')

	call IsFirstUMCB?			; is the one behind this the first UMCB ?
	jne .notfirstumcb			; nope, check if last -->
	test byte [ss:si], ~2Fh			; "LMA then UMA" ?
		; x = D0h --> x & ~20h != 00h if area other than LMA-then-UMA,
		; x = 20h --> x & ~20h = 00h if area is LMA-then-UMA
	jz .verify				; yes, proceed here -->
		; After test, it is always NC here.
	jmp short .last				; (NC, NZ) else it's the last one (even if 'M') -->
.notfirstumcb:
	cmp byte [di+mcbSignature], 'M'		; current in-chain ?
	je .verify				; no -->
	cmp word [ss:first_umcb], byte -2	; any UMA ?
	ja .last				; (NC, NZ) no, really last -->
	test byte [ss:si], ~8Fh			; "UMA then LMA" ?
		; x = 70h --> x & ~80h != 00h if area other than UMA-then-LMA,
		; x = 80h --> x & ~80h = 00h if area is UMA-then-LMA
	jz .firstlma				; yes, start to search LMA instead -->
		; After test, it is always NC here.
.last:
	mov ax, errorInsufficientMemory		; (NC, NZ)
	pop ds
 assume ds:nothing
	retn
.first:
	mov word [ss:nextmcbinput], ax
	test byte [ss:si], (80h|40h)		; "UMA then LMA" or "UMA only" ?
	jz .firstlma				; no, start with LMA -->
	mov ax, word [ss:first_umcb]		; yes, start with UMA
	cmp ax, -1				; UMA valid ?
	jne .verify				; yes -->
.firstlma:
	mov ax, word [ss:first_mcb]		; start with LMA
.verify:
 assume ds:MCB
	call VerifyMCB				; NC, ZR if valid - CY if invalid
	jnc .return
.error:
 extern doscode_halt_query
 extern doscode_disp_msg_cs
 extern doscode_disp_al
 extern doscode_disp_al_hex
 extern doscode_disp_ax_hex
 extern doscode_disp_blank
 extern doscode_msg.mcb.1
 extern doscode_msg.mcb.2
 extern doscode_msg.mcb.3
 extern doscode_msg.mcb.4
 extern doscode_msg.mcb.first
 extern doscode_msg.empty
 extern doscode_msg.error_common
 extern doscode_msg.crlf
 extern nextmcbinput

	push si
	push ax
	mov si, doscode_msg.error_common	; access with cs
	call doscode_disp_msg_cs
	mov si, doscode_msg.mcb.1
	call doscode_disp_msg_cs
	call doscode_disp_al_hex
	mov si, doscode_msg.mcb.2
	call doscode_disp_msg_cs
	mov ax, word [ss:nextmcbinput]
	call DumpMCB
	mov si, doscode_msg.mcb.3
	call doscode_disp_msg_cs
	mov ax, ds
	call DumpMCB
	mov si, doscode_msg.empty
 extern flag_no_halt_mcb
	mov ax, flag_no_halt_mcb
	call doscode_halt_query
	pop ax
	pop si
	stc
.return:
	pop ds
 assume ds:nothing
	retn
%endif


DumpMCB:
	push ds
	push cx
	call doscode_disp_ax_hex
	mov si, doscode_msg.mcb.first
	test ax, ax
	jz .end
	mov ds, ax
	xor si, si
	call doscode_disp_blank
	lodsb			; sign
	call doscode_disp_al_hex
	call doscode_disp_blank
	call doscode_disp_blank
	mov cx, 2
@@:
	lodsw			; owner, size
	call doscode_disp_ax_hex
	call doscode_disp_blank
	loop @B
	call doscode_disp_blank
	mov cl, 3
@@:
	lodsb			; reserved
	call doscode_disp_al_hex
	call doscode_disp_blank
	loop @B
	call doscode_disp_blank
	mov cl, 8
@@:
	lodsb			; name
	call doscode_disp_al_hex
	call doscode_disp_blank
	loop @B

	mov cl, 8
	mov si, cx
	mov al, '"'
	call doscode_disp_al
@@:
	lodsb			; name
	inc ax			; 7Fh to 80h, 20h to 21h
	cmp al, 32		; 80h..FFh..20h ?
	jle @F			; yes, non-printable-ASCII, end -->
	dec ax			; restore
	call doscode_disp_al
	loop @B
@@:
	mov si, doscode_msg.mcb.4
.end:
	call doscode_disp_msg_cs
	pop cx
	pop ds
	retn


		; Release all memory of a specific owner
		;
		; INP:	bx = MCB owner of which blocks are to be freed
		; OUT:	CY if MCB chain corrupted or loops,
		;	 ax = error code
		;	NC if MCB chain valid
		; CHG:	ax
		; STK:	13 word
ReleaseOwnersMCBs:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push ds
	push di
	call SetLinearMCBFlags			; set order for accessing all MCBs
.loop:
 assume ds:nothing
	call SNextMCB				; ax = MCB
	jc .return
	jne .return
	mov ds, ax				; ds = MCB
 assume ds:MCB
	cmp word [di+mcbOwner], bx		; does block belong to owner ?
	jne .loop				; no -->
	call ClearMCB				; free up block
	jmp short .loop
.return:
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si
	pop di
	pop ds
 assume ds:nothing
	retn


		; Merge MCB with next one if possible
		;
		; INP:	ds = ax = MCB
		;	word [ss:si] = 20h/10h (linear MCB flag setting)
		;	word [ss:si + 2] = loop detection counter
		; OUT:	CY if invalid MCB,
		;	 ax = error code
		;	CY if no next MCB or next MCB is not free,
		;	 ax = errorInsufficientMemory
		;	NC if valid next MCB was free, merged
		;	di = 0
		; CHG:	-
		; STK:	10 word
CollectNextFreeMCB:
 assume ds:MCB, es:nothing, ss:DOSGROUP
	push es
	call SNextMCB
	jc .return
	jne .notenough				; at last block, can't expand -->
%if _UMA
	call IsFirstUMCB?			; next is first UMCB ?
	je .notenough				; yes, can't expand -->
%endif
		; SNextMCB can point to a non-contiguous MCB, eg when
		;  strategy = 0382h and this is called from the function
		;  AllocateMCBRandom and both the first LMCB and the last
		;  UMCB are free. (The last UMCB condition is not usually
		;  true. First LMCB may be free in COMPAT=HIDEDOSENTRY.)
		; To avoid collecting the non-contiguous MCB, add this
		;  check for contiguousness.
	push bx
	mov bx, ds
	add bx, word [di + mcbSize]
	inc bx					; => next *contiguous* MCB
	cmp ax, bx				; do these match ?
	pop bx					; (restore bx)
	jne .notenough				; no, can't expand -->
	mov es, ax				; address of next block
 assume es:MCB
	cmp word [es:di+mcbOwner], di		; is next block free ?
	jne .notenough				; no, can't expand -->

	mov al, byte [es:di+mcbSignature]	; get letter of next MCB
	mov byte [di+mcbSignature], al		; adjust letter of MCB if next was 'Z'
	mov ax, word [es:di+mcbSize]
	inc ax					; get size of next MCB (including the MCB)
	add word [di+mcbSize], ax		; expand MCB
 assume es:nothing
	mov ax, ds
	clc
.return:
	pop es
 assume es:nothing
	retn

.notenough:
 assume es:nothing
	stc
	mov ax, errorInsufficientMemory
	pop es
 assume es:nothing
	retn


		; Collect free MCBs
		;
		; INP:	-
		; OUT:	CY if MCB chain corrupted or loops,
		;	 ax = error code
		;	NC if valid
		; CHG:	ax
		; STK:	15 word
		;
		; Scans all MCBs and merges free ones together.
CollectFreeMCBs:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push ds
	push di
	call SetLinearMCBFlags			; set order for accessing all MCBs
.loop:
 assume ds:nothing
	call SNextMCB				; ax = next MCB
	jc .return				; chain corrupted -->
	jne .return				; no next -->
.check:
	mov ds, ax				; ds = MCB
 assume ds:MCB
	cmp word [di+mcbOwner], di		; is block free ?
	jne .loop				; no, try next -->
.again:
	call CollectNextFreeMCB			; merge next with this one, if free
	jnc .again				; merged, check if next also free -->
	cmp ax, errorInsufficientMemory		; was error "Not enough memory" ?
	stc
	jne .return				; no, real error -->
	mov ax, ds
	jmp short .loop				; try next block --> (SNextMCB reports if current was last)
.return:
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si
	pop di
	pop ds
 assume ds:nothing
	retn


		; Split one MCB into two smaller MCBs
		;
		; INP:	ds = ax = MCB
		;	di = 0
		;	cx = requested size of existing MCB
		;		(the MCB *MUST* be larger currently)
		;	dx = requested owner of new MCB
		; OUT:	dx = created new MCB (at ax+cx+1)
		;	NC if valid input
		;	CY if MCB size is smaller than or equal to cx,
		;	 ax = error code (errorMCBDestroyed)
		; CHG:	cx
		; STK:	5 word
		; STT:	ss need not equal DOSDATA
		;
		; Interestingly, this is the only code to create new MCBs.
		; Functions not calling this code simply re-use existing MCBs.
SplitMCB:
 assume ds:MCB, es:nothing, ss:nothing
	push ax
	 push cx				; save new size of MCB
	push ds
	inc cx					; include size of the MCB itself
	add ax, cx				; ax = where to create new MCB
	 push ax
	mov ax, word [di+mcbSize]		; current size of MCB
	sub ax, cx				; size of new MCB
	jc .internal_error
		; CY here means MCB's size currently <= INP:cx.
		; ax = 0 is valid, it means an MCB with size 0 is created.
		;  (The modified MCB is then shortened by 1 paragraph.)
	mov cl, byte [di+mcbSignature]
	 pop ds					; ds = new MCB
 assume ds:MCB
	call ClearMCBName			; clear name
	mov word [di+mcbReserved], di
	mov word [di+mcbReserved + 1], di	; clear reserved bytes
	mov byte [di+mcbSignature], cl		; move letter of MCB to new one
	mov word [di+mcbSize], ax
	mov word [di+mcbOwner], dx		; set size and owner
	mov dx, ds
	pop ds					; restore MCB's address
 assume ds:MCB
	 pop word [di+mcbSize]			; resize the existing MCB
	mov byte [di+mcbSignature], 'M'		; link it to new one (if it was 'Z')
	pop ax
	clc
	retn

.internal_error:
	pop ax
	pop ds
 assume ds:MCB
	pop ax
	pop ax
	xor dx, dx
	mov ax, errorMCBDestroyed
	stc
	retn


		; Modify MCB size
		;
		; INP:	ax = memory block's segment
		;	bx = requested number of paragraphs
		; OUT:	bx = new size of block
		;	CY if error,
		;	 ax = error code
		;	NC if successful,
		;	 ax = memory block's segment
		; CHG:	-
		; STK:	21 word
		;
		; Contraction involves splitting the block into two smaller
		; portions. Expansion requires that the block which follows
		; is empty. If it is, it is combined with the first block
		; to create a huge block, which can then be split.
		;
		; As MS-DOS does, we'll extend the block to the maximum
		; possible size if there's not enough free memory behind it
		; to fulfill the request. Also copying MS-DOS's behaviour
		; we'll set the owner of the resized MCB if it was resized
		; successfully (NC). This allows to allocate specific MCBs,
		; although I don't recommend to do so.
ModifyMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push dx
	call GetMCBOwner			; dx = owner
	call ModifyMCBRandom
	pop dx
	retn

		; Modify MCB size with random owner
		;
		; INP:	ax = memory block's segment
		;	bx = requested number of paragraphs
		;	dx = new owner
		; OUT:	bx = new size of block
		;	CY if error,
		;	 ax = error code
		;	NC if successful,
		;	 ax = memory block's segment
		; CHG:	-
		; STK:	19 word
ModifyMCBRandom:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	lframe near
	lenter
	lvar	word, alloc
	 push bx
	lvar	word, owner
	 push dx

	push dx
	push cx
	push di
	push ds
	mov dx, ax
	call SetLinearMCBFlags			; set order for accessing all MCBs
	mov ax, dx				; (restore ax without push and pop)
	xor bx, bx				; largest possible size of MCB, preset to zero
	call GetMCBFromBlock			; get MCB from block address, ax = ds = MCB
.compare_return_if_CY:
	jc .return				; invalid MCB -->
.compare:
 assume ds:MCB
	mov bx, word [di+mcbSize]		; remember current size if request fails
	mov cx, word [bp + ?alloc]		; cx = requested size
	cmp cx, bx				; what action is required ?
	jb .contract				; contraction -->
	je .success				; none, succeed -->
.expand:
	call CollectNextFreeMCB			; expansion, use next MCB if free
	; jc .return				; not free, or MCB chain corrupted -->
	jmp short .compare_return_if_CY		; compare new size, expand again or contract -->
.contract:
	xor dx, dx
	call SplitMCB				; free the unused high part of the MCB
	jmp short .compare_return_if_CY		; set ?size and return (MCB size now equals _alloc)
.success:
	inc ax					; point past MCB to actual allocation
	push word [bp + ?owner]
	pop word [di+mcbOwner]			; re-allocate MCB with requested owner

		; Testing on MS-DOS 7.10 revealed that the owner is only
		;  set by 21.4A when the resizing was successful. A partial
		;  resize (that cannot be fulfilled entirely due to not
		;  enough free space) doesn't set the owner.
.return:
 assume ds:nothing
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si
	pop ds
 assume ds:nothing
	pop di
	pop cx
	pop dx
	lleave
	lret


%ifn _UMA		; (Currently only used in non-UMA build.)
		; Allocate MCB
		;
		; INP:	bx = requested number of paragraphs
		; OUT:	CY if error,
		;	 ax = error code
		;	 bx = paragraph size of largest available block (zero if not error 0008h)
		;	NC if successful,
		;	 ax = segment address of allocation
		;	 bx = paragraph size of allocation
		; CHG:	-
		; STK:	23 word
AllocateMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push cx
%ifn _UMA
	mov ch, byte [ss:alloc_strategy_ext]
	mov cl, byte [ss:AllocMethod]	; cx = flags
%else
	call GetMCBFlags			; cx = fixed flags
%endif
	db __TEST_IMM8				; (skip push)
.flags_cx:
	push cx
	push dx
	call GetMCBOwner			; dx = owner
	call AllocateMCBRandom
	pop dx
	pop cx
	retn
%endif


		; Allocate MCB with random owner and flags
		;
		; INP:	bx = requested number of paragraphs
		;	cx = allocation strategy
		;	dx = owner
		; OUT:	CY if error,
		;	 ax = error code
		;	 bx = paragraph size of largest available block (zero unless error 0008h)
		;	NC if successful,
		;	 ax = segment address of allocation
		;	 bx = paragraph size of allocation
		; CHG:	-
		; STK:	20 word
AllocateMCBRandom:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	rol byte [ss:config_collect_all_mcbs], 1
	jnc @F
	call CollectFreeMCBs			; collect free blocks first
		; CHG:	ax
		; We could jump here if CY was returned, indicating
		;  a corrupted MCB chain. However, if it is relevantly
		;  corrupted, this error will also occur later on.
@@:
	lframe near
	lvar	word, loopcounter		; (immediately above ?flags)
	lvar	word, flags
	lvar	word, candidatefit		; candidate to allocate
	lenter
	lvar	word, alloc
	 push bx
	lvar	word, owner
	 push dx

	push cx
	push dx
	push si
	push di
	push ds
	lea si, [bp + ?flags]			; ss:si-> flags
	call FixMCBFlags			; fix flags to internally used ones
%if _UMA
	cmp word [ss:first_umcb], byte -1	; UMA available ?
	jne .umavalid
%endif
	and cl, 0Fh
	or cl, 10h				; force "LMA only" if no UMA available
.umavalid:
	mov word [ss:si], cx			; store fixed flags
	xor ax, ax				; 0000h to get first MCB
	mov word [ss:si + 2], ax		; initialise loop counter
	xor bx, bx
		; variable: size of largest block available
	mov cx, 0FFFFh
		; variable: best-fit excess size (excess size over requested)
		;  this is -1 if none found, 0 if found and first or last fit,
		;  else excess size (0 = exact fit) and best fit.
.loop:
 assume ds:nothing
	call SNextMCB
	jc .return				; chain corrupted -->
	jne .end				; end of chain, look for best or last fit -->
	mov ds, ax
 assume ds:MCB
	cmp word [di+mcbOwner], di		; free block ?
	jne .loop				; no, next -->

%if 0

ecm 2026: MS-DOS, FreeDOS, EDR-DOS all coalesce free blocks during
 the allocation loop, not in a separate loop before as lDOS did.
 Support their behaviour as an option (COMPAT=NOCOLLECTALLMCBS).
 In case it is selected (separate loop disabled), handle it here.

References:

MS-DOS v4.01: https://anonymous:github@hg.pushbx.org/ecm/msdos4/file/51ad27d225a8/src/DOS/ALLOC.ASM#l207

FreeDOS: https://github.com/FDOS/kernel/blob/417b6d0e2bd62a4de0c8e9f254b69d98ab59fe7a/kernel/memmgr.c#L143

EDR-DOS: https://anonymous:github@hg.pushbx.org/ecm/edrdos/file/6f38a5d95317/drdos/dosmem.nas#l345

Noticed in https://github.com/dmsc/emu2/issues/122

%endif

.again:
	call CollectNextFreeMCB			; merge next with this one, if free
	jnc .again				; merged, check if next also free -->
	cmp ax, errorInsufficientMemory		; was error "Not enough memory" ?
	stc
	jne .return				; no, real error -->
	mov ax, ds				; reset ax

	mov dx, word [di+mcbSize]		; get size

	cmp bx, dx				; larger than previous largest ?
	jae .notlarger				; no -->
	mov bx, dx				; store as new largest
.notlarger:

	sub dx, word [bp + ?alloc]		; large enough for request ?
	jb .loop				; no, next -->

	test byte [ss:si], 02h			; strategy last fit ?
	jnz .storecandidatezero			; yes, cx = 0 and store -->

	cmp cx, dx				; better than previous best ?
	jbe .notbetter				; no --> (important: prefer previous if same)

	test byte [ss:si], 03h			; strategy zero (first fit) ?
	jnz @F					; no, best fit -->
.storecandidatezero:	; treat last fit and first fit using cx = 0
	xor dx, dx				; treat as excess size 0
@@:
	mov cx, dx
	mov word [bp + ?candidatefit], ax	; store as new best
.notbetter:
	jmp short .loop

		; ax = error code 0008h (errorInsufficientMemory) here
.end:
 assume ds:nothing
	inc cx
	stc
	jz .return				; (CY) no fit (cx was still FFFFh) -->
	mov ax, word [bp + ?candidatefit]	; => MCB we want to allocate from
.alloc:
	mov ds, ax
 assume ds:MCB
	mov dx, word [bp + ?owner]
	mov word [di+mcbOwner], dx		; allocate it now
	call ClearMCBName			; clear the name
	mov cx, word [di+mcbSize]		; get size of block
	sub cx, word [bp + ?alloc]		; determine remaining block's size
	je .done				; (NC) no remaining block -->
	test byte [ss:si], 02h			; last fit ?
	jnz .lastfit				; yes, use upper part -->
	mov cx, word [bp + ?alloc]		; size of lower part (allocation)
	xor dx, dx				; free upper part
	call SplitMCB
	jc .return				; (else NC)
	jmp short .done
.lastfit:
	dec cx
	call SplitMCB				; (dx = owner upper part, cx = size lower part)
	jc .return				; (else NC)
	mov word [di+mcbOwner], di		; free lower part
	mov ax, dx
	mov ds, dx				; set ds = ax = allocation
 assume ds:MCB
.done:					; (NC)
 assume ds:nothing
	inc ax					; point past MCB
	mov bx, word [di+mcbSize]		; allocated size
.return:
	jnc .noerror				; no error --> (actual allocation size)
	cmp ax, errorInsufficientMemory		; "not enough memory" ?
	je .memerror				; bx set correctly --> (largest seen)
	xor bx, bx				; else report none free as largest
.memerror:
	stc					; set CY again
.noerror:
	pop ds
 assume ds:nothing
	pop di
	pop si
	pop dx
	pop cx
	lleave
	lret


		; Allocate largest MCB with random owner and flags
		;
		; INP:	ax = requested maximal number of paragraphs (FFFFh for largest)
		;	bx = requested minimal number of paragraphs
		;	cx = allocation strategy
		;	dx = owner
		; OUT:	CY if error,
		;	 ax = error code
		;	 bx = paragraph size of largest available block (zero unless error 0008h)
		;	NC if successful,
		;	 ax = segment address of allocation
		;	 bx = paragraph size of allocation
		; CHG:	-
		; STK:	29 word
		;
		; If the requested maximal size is smaller than the requested minimal size,
		; the minimal size is forced to the requested maximal size.
AllocateLargestMCBRandom:
 assume ds:nothing, es:nothing, ss:DOSGROUP
.:
	lframe near
	lenter
	lvar	word, min
	 push bx

%if _UMA
	cmp word [ss:first_umcb], byte -1	; UMA available ?
	je .single				; nope, all area flags turn to "LMA only" anyway -->
	test cl, 80h				; 80h "UMA then LMA" (top priority) ?
	jnz .dual				; yes, dual area -->
	test cl, 40h				; 40h "UMA only" (priority over 20h) ?
	jnz .single				; yes, single area -->
	test cl, 20h				; 20h "LMA then UMA" (priority over 10h)
	jnz .dual				; yes, dual area -->
.single:
%endif
	mov bx, ax				; maximal size
	call AllocateMCBRandom			; request with maximal size
	jnc .return				; if it succeeded -->
	cmp ax, errorInsufficientMemory		; "not enough memory" error ?
	stc
	jne .return				; if not this error, invalid MCBs -->
	cmp bx, word [bp + ?min]		; reported largest is large enough for request ?
	jb .return				; no, return the error as is --> (CY)
	call AllocateMCBRandom			; allocate the reported largest block, pass errors if any
.return:
%if _UMA
	lleave code
%else
	lleave
%endif
	lret

%if _UMA
		; Area flags involving two areas are split into two calls:
		; If the first area contains a block which is large enough,
		; it is preferred over a possibly larger block in the other
		; area and the other area won't be searched. The reported
		; largest block (if neither area contains one large enough)
		; is the larger one of these reported for both areas.
.dual:
	lvar	word, max
	 push ax
	lvar	word, flags
	 push cx

	push cx
	call FixMCBFlags			; check whether multiple flags are set
	and cl, 0Fh				; clear current flags
	or cl, 40h				; second try "UMA only"
	test byte [bp + ?flags], 80h		; requested "UMA then LMA" ?
	jz .dual_lmafirst			; no, must be "LMA then UMA" -->
%if _ERRORFLAGS
	test byte [bp + ?flags], 40h|20h|10h	; either set ? (multiple)
	jz .dual_validflags_umafirst
	or byte [ss:error_flags], EF_MultipleAllocAreas	; yes, flag
.dual_validflags_umafirst:
%endif
	and cl, 0Fh
	or cl, 10h				; second try "LMA only"
.dual_lmafirst:
	mov word [bp + ?flags], cx		; remember area for second try
	xor cl, 40h|10h				; set cx to the other one of the single areas

	call .					; try to allocate in first area
	jnc .dual_return			; (NC) success -->
	cmp ax, errorInsufficientMemory		; "not enough memory" error ?
	jne .dual_error				; no, invalid MCB -->
	mov cx, word [bp + ?flags]		; get other flags
	mov ax, word [bp + ?max]		; restore maximal value
	xchg bx, word [bp + ?min]		; restore minimal value, save largest available
	call .					; try to allocate in second area instead
	jnc .dual_return			; (NC) success -->
	cmp ax, errorInsufficientMemory		; "not enough memory" error ?
	jne .dual_error				; no, invalid MCB -->

	cmp bx, word [bp + ?min]		; second area contains larger free block ?
	jae .dual_error				; yes -->
	mov bx, word [bp + ?min]		; return largest free block of first area instead

.dual_error:
	stc
.dual_return:
	pop cx					; restore cx
	lleave
	lret
%endif


		; Allocate MCB, compatible to MS-DOS
		;
		; INP:	bx = requested number of paragraphs
		; OUT:	CY if error,
		;	 ax = error code
		;	 bx = paragraph size of largest available block (zero if not error 0008h)
		;	NC if successful,
		;	 ax = segment address of allocation
		;	 bx = paragraph size of allocation
		; CHG:	-
		;
		; Note:	This function implements the MS-DOS-compatible
		;	 handling where UMA-then-LMA is treated as two areas.
%if _UMA
AllocateMCBCompatible:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	push cx
	call GetMCBFlags			; cx = fixed flags
	db __TEST_IMM8				; (skip push)
.flags_cx:
	push cx
	push dx
	call GetMCBOwner			; dx = owner
	test ch, 2				; use lDOS meaning ? (one area)
	jnz .default				; yes -->
	test ch, 4				; use two areas ?
	jnz @F					; yes -->
	test cl, 80h				; is it UMA then LMA ?
	jnz @F					; yes, use two areas-->
.default:
	call AllocateMCBRandom			; else, simply use default
.end:
	pop dx
	pop cx
	retn

@@:
	mov ax, bx				; set up maximum size = size
	call AllocateLargestMCBRandom		; call two-area allocation
	jmp .end
%else
AllocateMCBCompatible: equ AllocateMCB
AllocateMCBCompatible.flags_cx: equ AllocateMCB.flags_cx
%endif


%if 0
		; INP:	dx = segment of which to get size
		; OUT:	NC if not overlapping,
		;	 bx = size of that segment until next MCB
		;	CY if overlapping (dx points to an MCB,
		;		or not inside any of the MCBs,
		;		or inside a free MCB),
		;	 bx = 0
		;	 ax = error code
		; CHG:	ax
GetSizeInMCB:
 assume ds:nothing, es:nothing, ss:DOSGROUP
	xor bx, bx
	push cx
	push ds
	push di
	call SetLinearMCBFlags			; set order for accessing all MCBs
.loop:
	call SNextMCB				; ax = next MCB
	jc .return				; chain corrupted -->
	jne .error				; no next -->
.check:
	mov ds, ax				; ds = MCB
 assume ds:MCB
	cmp dx, ax
	jbe .error
	mov cx, ax
	add cx, word [di+mcbSize]
	inc cx					; => next MCB
	cmp dx, cx				; is it equal-to-or-above the next MCB?
	jae .loop				; yes, next -->
	cmp word [di+mcbOwner], di		; is this block free ?
	je .error				; yes -->
	sub cx, dx				; (next MCB) - (block address)
	mov bx, cx				; size
	clc
	jmp .return

.error:
 assume ds:nothing
	xor bx, bx
	mov ax, errorMCBInvalid
	stc
.return:
 assume ds:nothing
	pop si					; discard flags word
	pop si					; discard loop counter word
	pop si
	pop di
	pop ds
 assume ds:nothing
	pop cx
	retn
%endif


usesection DOSBIODATA

 global config_collect_all_mcbs
config_collect_all_mcbs:	db -1
 global config_collect_free_mcb
config_collect_free_mcb:	db 0
