scummvm-cursorfix/engines/glk/tads/tads2/memory_cache.cpp

/* ScummVM - Graphic Adventure Engine
 *
 * ScummVM is the legal property of its developers, whose names
 * are too numerous to list here. Please refer to the COPYRIGHT
 * file distributed with this source distribution.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *
 */

#include "glk/tads/tads2/memory_cache.h"
#include "glk/tads/tads2/memory_cache_heap.h"
#include "glk/tads/tads2/error.h"
#include "glk/tads/os_glk.h"

namespace Glk {
namespace TADS {
namespace TADS2 {

/* get an unused object cache entry, allocating a new page if needed */
static mcmodef *mcmoal(mcmcx1def *ctx, mcmon *objnum);

/* split a (previously free) block into two pieces */
static void mcmsplt(mcmcx1def *ctx, mcmon n, ushort siz);

/* unlink an object from a doubly-linked list */
static void mcmunl(mcmcx1def *ctx, mcmon n, mcmon *lst);

/* initialize a cache, return cache context */
/* find free block: find a block from the free pool to satisfy a request */
static mcmodef *mcmffb(mcmcx1def *ctx, ushort siz, mcmon *nump);

/* add page pagenum, initializing entries after firstunu to unused */
static void mcmadpg(mcmcx1def *ctx, uint pagenum, mcmon firstunu);

/* link an object into a doubly-linked list at the head of the list */
static void mcmlnkhd(mcmcx1def *ctx, mcmon *lst, mcmon n);

/* try to allocate a new chunk from the heap */
static uchar *mcmhalo(mcmcx1def *ctx);

/* relocate blocks in a heap */
static uchar *mcmreloc(mcmcx1def *ctx, uchar *start, uchar *end);

/* find next free heap block */
static uchar *mcmffh(mcmcx1def *ctx, uchar *p);

#ifdef NEVER
/* update entry to account for a block relocation */
static void mcmmove(mcmcx1def *ctx, mcmodef *obj, uchar *newaddr);
#else /* NEVER */
#define mcmmove(ctx, o, new) ((o)->mcmoptr = (new))
#endif /* NEVER */

/* consolidate two contiguous free blocks into a single block */
static void mcmconsol(mcmcx1def *ctx, uchar *p);

/* collect garbage in all heaps */
static void mcmgarb(mcmcx1def *ctx);

/* make some room by swapping or discarding objects */
static int mcmswap(mcmcx1def *ctx, ushort siz);

/* toss out an object; returns TRUE if successful */
static int mcmtoss(mcmcx1def *ctx, mcmon objnum);

/* next heap block, given a heap block (points to header) */
/* uchar *mcmhnxt(mcmcx1def *ctx, uchar *p) */

#define mcmnxh(ctx, p) \
 ((p) + osrndsz(sizeof(mcmon)) + mcmgobje(ctx, *(mcmon*)(p))->mcmosiz)

#ifdef DEBUG
# define MCMCLICTX(ctx) assert(*(((ulong *)ctx) - 1) == 0x02020202)
# define MCMGLBCTX(ctx) assert(*(((ulong *)ctx) - 1) == 0x01010101)
#else /* DEBUG */
# define MCMCLICTX(ctx)
# define MCMGLBCTX(ctx)
#endif /* DEBUG */

/* initialize a new client context */
mcmcxdef *mcmcini(mcmcx1def *globalctx, uint pages,
				  void (*loadfn)(void *, mclhd, uchar *, ushort),
				  void *loadctx,
				  void (*revertfn)(void *, mcmon), void *revertctx)
{
	mcmcxdef *ret;
	ushort    siz;

	siz = sizeof(mcmcxdef) + sizeof(mcmon *) * (pages - 1);
	IF_DEBUG(siz += sizeof(ulong));

	ret = (mcmcxdef *)mchalo(globalctx->mcmcxerr, siz, "mcm client context");
	IF_DEBUG((*(ulong *)ret = 0x02020202,
			  ret = (mcmcxdef *)((uchar *)ret + sizeof(ulong))));

	ret->mcmcxmsz = pages;
	ret->mcmcxgl = globalctx;
	ret->mcmcxldf = loadfn;
	ret->mcmcxldc = loadctx;
	ret->mcmcxrvf = revertfn;
	ret->mcmcxrvc = revertctx;
	ret->mcmcxflg = 0;
	memset(ret->mcmcxmtb, 0, (size_t)(pages * sizeof(mcmon *)));
	return(ret);
}

/* uninitialize a client context */
void mcmcterm(mcmcxdef *ctx)
{
	/* delete the context memory */
	mchfre(ctx);
}

/* initialize a new global context */
mcmcx1def *mcmini(ulong max, uint pages, ulong swapsize,
				  osfildef *swapfp, char *swapfilename, errcxdef *errctx)
{
	mcmcx1def *ctx;                /* newly-allocated cache manager context */
	uchar     *noreg chunk;/* 1st chunk of memory managed by this cache mgr */
	mcmodef   *obj;                      /* pointer to a cache object entry */
	ushort     siz;                /* size of current thing being allocated */
	ushort     rem;                             /* bytes remaining in chunk */
	int        err;

	NOREG((&chunk))

	/* make sure 'max' is big enough - must be at least one chunk */
	if (max < (ulong)MCMCHUNK) max = (ulong)MCMCHUNK;

	/* allocate space for control structures from low-level heap */
	rem = MCMCHUNK;

	IF_DEBUG(rem += sizeof(long));
	chunk = mchalo(errctx, rem, "mcmini");
	IF_DEBUG((*(ulong *)chunk = 0x01010101, chunk += sizeof(ulong),
		rem -= sizeof(ulong)));

	ctx = (mcmcx1def *)chunk;              /* put context at start of chunk */

	/* initialize swapper; clean up if it fails */
	ERRBEGIN(errctx)
		mcsini(&ctx->mcmcxswc, ctx, swapsize, swapfp, swapfilename, errctx);
	ERRCATCH(errctx, err)
		mcsclose(&ctx->mcmcxswc);
		mchfre(chunk);
		errsig(errctx, err);
	ERREND(errctx)

	chunk += sizeof(mcmcx1def);           /* rest of chunk is after context */
	rem -= sizeof(mcmcx1def);         /* remove from remaining size counter */

	/* allocate the page table (an array of pointers to pages) */
	ctx->mcmcxtab = (mcmodef **)chunk;            /* put at bottom of chunk */
	siz = pages * sizeof(mcmodef *);              /* calcuate size of table */

	memset(ctx->mcmcxtab, 0, (size_t)siz);            /* clear entire table */
	chunk += siz;                                  /* reflect size of table */
	rem -= siz;                       /* take it out of the remaining count */

	/* here we begin normal heap marking with object references */
	ctx->mcmcxhpch = (mcmhdef *)chunk;           /* set start of heap chain */
	chunk += sizeof(mcmhdef);
	rem -= sizeof(mcmhdef);
	ctx->mcmcxhpch->mcmhnxt = (mcmhdef *)nullptr;    /* no next heap in chain yet */

	/* allocate the first page */
	*(mcmon *)chunk = 0;               /* set object number header in chunk */
	chunk += osrndsz(sizeof(mcmon));
	rem -= osrndsz(sizeof(mcmon));

	ctx->mcmcxtab[0] = (mcmodef *)chunk;          /* put at bottom of chunk */
	memset(ctx->mcmcxtab[0], 0, (size_t)MCMPAGESIZE);
	chunk += MCMPAGESIZE;                           /* reflect size of page */
	rem -= MCMPAGESIZE;                     /* take it out of the remainder */

	/* set up the first page with an entry for itself */
	obj = mcmgobje(ctx, (mcmon)0);             /* point to first page entry */
	obj->mcmoflg = MCMOFPRES | MCMOFNODISC | MCMOFPAGE | MCMOFNOSWAP;
	obj->mcmoptr = (uchar *)ctx->mcmcxtab[0];
	obj->mcmosiz = MCMPAGESIZE;

	/* set up the rest of the context */
	ctx->mcmcxlru = ctx->mcmcxmru = MCMONINV;        /* no mru/lru list yet */
	ctx->mcmcxmax = max - (ulong)MCMCHUNK;
	ctx->mcmcxpage = 1;        /* next page slot to be allocated will be #1 */
	ctx->mcmcxpgmx = pages;          /* max number of pages we can allocate */
	ctx->mcmcxerr = errctx;
	ctx->mcmcxcsw = mcmcswf;

	/* set up the free list with the remainder of the chunk */
	ctx->mcmcxfre = 1;     /* we've allocated object 0; obj 1 is free space */
	obj = mcmgobje(ctx, ctx->mcmcxfre);       /* point to free object entry */
	obj->mcmonxt = obj->mcmoprv = MCMONINV;             /* end of free list */
	obj->mcmoflg = MCMOFFREE;                /* mark the free block as such */
	*(mcmon *)chunk = ctx->mcmcxfre;                /* set free list header */

	chunk += osrndsz(sizeof(mcmon));
	rem -= osrndsz(sizeof(mcmon));
	obj->mcmoptr = chunk;                                  /* rest of chunk */

	obj->mcmosiz = rem - osrndsz(sizeof(mcmon));          /* remaining size in chunk */

	/* set flag for end of chunk (invalid object header) */
	*((mcmon *)(chunk + rem - osrndsz(sizeof(mcmon)))) = MCMONINV;

	/* set up the unused entry list with the remaining headers in the page */
	mcmadpg(ctx, 0, 2);

	return(ctx);
}

/*
 *   Uninitialize the cache manager.  Frees the memory allocated for the
 *   cache, including the context structure itself.
 */
void mcmterm(mcmcx1def *ctx)
{
	mcmhdef *cur, *nxt;

	/*
	 *   Free each chunk in the cache block list, *except* the last one.  The
	 *   last one is special: it's actually the first chunk allocated, since
	 *   we build the list in reverse order, and the first chunk pointer
	 *   points into the middle of the actual allocation block, since we
	 *   sub-allocated the context structure itself and the page table out of
	 *   that memory.
	 */
	for (cur = ctx->mcmcxhpch ; cur != nullptr && cur->mcmhnxt != nullptr ; cur = nxt)
	{
		/* remember the next chunk, and delete this one */
		nxt = cur->mcmhnxt;
		mchfre(cur);
	}

	/*
	 *   As described above, the last chunk in the list is the first
	 *   allocated, and it points into the middle of the actual allocated
	 *   memory block.  Luckily, we do have a handy pointer to the start of
	 *   the memory block, namely the context pointer - it's the first thing
	 *   allocated out of the block, so it's the same as the block pointer.
	 *   Freeing the context frees this last/first chunk.
	 */
	mchfre(ctx);
}

/*
 *   Allocate a new object, returning a pointer to its memory.  The new
 *   object is locked upon return.  The object number for the new object
 *   is returned at *nump.
 */
static uchar *mcmalo1(mcmcx1def *ctx, ushort siz, mcmon *nump)
{
	mcmon    n;
	mcmodef *o;
	uchar   *chunk;

	MCMGLBCTX(ctx);

	/* round size to appropriate multiple */
	siz = osrndsz(siz);

	/* if it's bigger than the chunk size, we can't allocate it */
	if (siz > MCMCHUNK)
		errsig(ctx->mcmcxerr, ERR_BIGOBJ);

startover:
	/* look in the free block chain for a fit to the request */
	o = mcmffb(ctx, siz, &n);
	if (n != MCMONINV)
	{
		mcmsplt(ctx, n, siz);               /* split the block if necessary */
		mcmgobje(ctx, n)->mcmoflg = MCMOFNODISC | MCMOFLOCK | MCMOFPRES;
		mcmgobje(ctx, n)->mcmolcnt = 1;                /* one locker so far */
		*nump = n;
		return(o->mcmoptr);
	}

	/* nothing found; we must get space out of the heap if possible */
	chunk = mcmhalo(ctx);                            /* get space from heap */
	if (!chunk) goto error;           /* can't get any more space from heap */
	o = mcmoal(ctx, &n);               /* set up cache entry for free space */
	if (n == MCMONINV)
	{
		mcmhdef *chunk_hdr = ((mcmhdef *)chunk) - 1;
		ctx->mcmcxhpch = chunk_hdr->mcmhnxt;
		mchfre(chunk_hdr);
		goto error;         /* any error means we can't allocate the memory */
	}

	*(mcmon *)chunk = n;                               /* set object header */
	chunk += osrndsz(sizeof(mcmon));
	o->mcmoptr = chunk;
	o->mcmosiz = MCMCHUNK - osrndsz(sizeof(mcmon));
	o->mcmoflg = MCMOFFREE;
	mcmlnkhd(ctx, &ctx->mcmcxfre, n);
	goto startover;              /* try again, now that we have some memory */

error:
	*nump = MCMONINV;
	return((uchar *)nullptr);
}

static void mcmcliexp(mcmcxdef *cctx, mcmon clinum)
{
	/* add global number to client mapping table at client number */
	if (cctx->mcmcxmtb[clinum >> 8] == (mcmon *)nullptr)
	{
		mcmcx1def *ctx = cctx->mcmcxgl;
		int        i;
		mcmon     *p;

		/* this page is not allocated - allocate it */
		p = (mcmon *)mchalo(ctx->mcmcxerr, (256 * sizeof(mcmon)),
							"client mapping page");
		cctx->mcmcxmtb[clinum >> 8] = p;
		for (i = 0 ; i < 256 ; ++i) *p++ = MCMONINV;
	}
}

/* high-level allocate:  try, collect garbage, then try again */
uchar *mcmalo0(mcmcxdef *cctx, ushort siz, mcmon *nump,
			   mcmon clinum, int noclitrans)
{
	uchar     *ret;
	mcmcx1def *ctx = cctx->mcmcxgl;                       /* global context */
	mcmon      glb;                       /* global object number allocated */

	MCMCLICTX(cctx);
	MCMGLBCTX(ctx);

	/* try once */
	if ((ret = mcmalo1(ctx, siz, &glb)) != nullptr)
		goto done;

	/* collect some garbage */
	mcmgarb(ctx);

	/* try swapping until we get the memory or have nothing left to swap */
	for ( ;; )
	{
		/* try again */
		if ((ret = mcmalo1(ctx, siz, &glb)) != nullptr)
			goto done;

		/* nothing left to swap? */
		if (!mcmswap(ctx, siz))
			break;

		/* try yet again */
		if ((ret = mcmalo1(ctx, siz, &glb)) != nullptr)
			goto done;

		/* collect garbage once again */
		mcmgarb(ctx);
	}

	/* try again */
	if ((ret = mcmalo1(ctx, siz, &glb)) != nullptr)
		goto done;

	/* we have no other way of getting more memory, so signal an error */
	errsig(ctx->mcmcxerr, ERR_NOMEM1);
	NOTREACHEDV(uchar *);

done:
	if (noclitrans)
	{
		*nump = glb;
		return(ret);
	}

	/* we have an object - generate client number */
	if (clinum == MCMONINV)
	{
		/* find a free number */
		mcmon **p;
		uint    i;
		mcmon   j = 0;
		mcmon  *q;
		int     found = FALSE;
		int     unused = -1;

		for (i = 0, p = cctx->mcmcxmtb ; i < cctx->mcmcxmsz ; ++i, ++p)
		{
			if (*p)
			{
				for (j = 0, q = *p ; j < 256 ; ++j, ++q)
				{
					if (*q == MCMONINV)
					{
						found = TRUE;
						break;
					}
				}
			}
			else if (unused == -1)
				unused = i;            /* note an unused page mapping table */

			if (found) break;
		}

		if (found)
			clinum = (i << 8) + j;
		else if (unused != -1)
			clinum = (unused << 8);
		else
			errsig(ctx->mcmcxerr, ERR_CLIFULL);
	}

	/* expand client mapping table if necessary */
	mcmcliexp(cctx, clinum);

	/* make sure the entry isn't already in use */
	if (mcmc2g(cctx, clinum) != MCMONINV)
		errsig(ctx->mcmcxerr, ERR_CLIUSE);

	cctx->mcmcxmtb[clinum >> 8][clinum & 255] = glb;
	if (nump) *nump = clinum;
	return(ret);
}

/* reserve space for an object at a client object number */
void mcmrsrv(mcmcxdef *cctx, ushort siz, mcmon clinum, mclhd loadhd)
{
	mcmcx1def *ctx = cctx->mcmcxgl;                       /* global context */
	mcmon      glb;                       /* global object number allocated */
	mcmodef   *o;

	MCMCLICTX(cctx);
	MCMGLBCTX(ctx);

	o = mcmoal(ctx, &glb);                       /* get a new object header */
	if (!o) errsig(ctx->mcmcxerr, ERR_NOHDR);     /* can't get a new header */

	o->mcmoldh = loadhd;
	o->mcmoflg = 0;
	o->mcmosiz = siz;

	mcmcliexp(cctx, clinum);
	if (mcmc2g(cctx, clinum) != MCMONINV)
		errsig(ctx->mcmcxerr, ERR_CLIUSE);

	cctx->mcmcxmtb[clinum >> 8][clinum & 255] = glb;
}

/* resize an existing object */
uchar *mcmrealo(mcmcxdef *cctx, mcmon cliobj, ushort newsize)
{
	mcmcx1def *ctx = cctx->mcmcxgl;                       /* global context */
	mcmon      obj = mcmc2g(cctx, cliobj);
	mcmodef   *o = mcmgobje(ctx, obj);
	mcmon      nxt;
	mcmodef   *nxto;
	uchar     *p;
	int        local_lock;

	MCMCLICTX(cctx);
	MCMGLBCTX(ctx);

	newsize = osrndsz(newsize);

	/* make sure the object is locked, and note if we locked it */
	if ((local_lock = !(o->mcmoflg & MCMOFLOCK)) != 0)
		(void)mcmlck(cctx, cliobj);

	ERRBEGIN(ctx->mcmcxerr)

	if (newsize < o->mcmosiz)
		mcmsplt(ctx, obj, newsize);            /* smaller; just split block */
	else
	{
		/* see if there's a free block after this block */
		p = o->mcmoptr;
		nxt = *(mcmon *)(p + o->mcmosiz);
		nxto = (nxt == MCMONINV) ? (mcmodef *)nullptr : mcmgobje(ctx, nxt);

		if (nxto && ((nxto->mcmoflg & MCMOFFREE)
					 && nxto->mcmosiz >= newsize - o->mcmosiz))
		{
			/* sanity check - make sure heap and page table agree */
			assert(nxto->mcmoptr == p + o->mcmosiz + osrndsz(sizeof(mcmon)));
			/* annex the free block */
			o->mcmosiz += nxto->mcmosiz + osrndsz(sizeof(mcmon));
			/* move the free block to the unused list */
			mcmunl(ctx, nxt, &ctx->mcmcxfre);
			nxto->mcmonxt = ctx->mcmcxunu;
			ctx->mcmcxunu = nxt;
			nxto->mcmoflg = 0;

			/* split the newly grown block if necessary */
			mcmsplt(ctx, obj, newsize);
		}
		else
		{
			/* can't annex; allocate new memory and copy */

			if (o->mcmolcnt != 1)           /* if anyone else has a lock... */
				errsig(ctx->mcmcxerr, ERR_REALCK);      /* we can't move it */

			p = mcmalo0(cctx, newsize, &nxt, MCMONINV, TRUE);
			if (nxt == MCMONINV) errsig(ctx->mcmcxerr, ERR_NOMEM2);
			memcpy(p, o->mcmoptr, (size_t)o->mcmosiz);

			/* adjust the object entries */
			nxto = mcmgobje(ctx, nxt);          /* get pointer to new entry */
			newsize = nxto->mcmosiz;        /* get actual size of new block */
			nxto->mcmoptr = o->mcmoptr;   /* copy current block info to new */
			nxto->mcmosiz = o->mcmosiz;
			o->mcmoptr = p;        /* copy new block info to original entry */
			o->mcmosiz = newsize;

			/* now fix up the heap pointers, and free the temp object */
			*(mcmon *)(p - osrndsz(sizeof(mcmon))) = obj;
			*(mcmon *)(nxto->mcmoptr - osrndsz(sizeof(mcmon))) = nxt;
			mcmgunlck(ctx, nxt);
			mcmgfre(ctx, nxt);
		}
	}

	ERRCLEAN(ctx->mcmcxerr)
		/* release our lock, if we had to obtain one */
		if (local_lock) mcmunlck(cctx, cliobj);
	ERRENDCLN(ctx->mcmcxerr)

	/* return the address of the object */
	return(o->mcmoptr);
}

/*
 *   Free an object by GLOBAL number:  move object to free list.
 */
void mcmgfre(mcmcx1def *ctx, mcmon obj)
{
	mcmodef   *o = mcmgobje(ctx, obj);

	MCMGLBCTX(ctx);

	/* signal an error if the object is locked */
	if (o->mcmolcnt) errsig(ctx->mcmcxerr, ERR_LCKFRE);

	/* take out of LRU chain if it's in the chain */
	if (o->mcmoflg & MCMOFLRU) mcmunl(ctx, obj, &ctx->mcmcxlru);

	/* put it in the free list */
	mcmlnkhd(ctx, &ctx->mcmcxfre, obj);
	o->mcmoflg = MCMOFFREE;
}

/*
 *   load and lock an object that has been swapped out or discarded
 */
uchar *mcmload(mcmcxdef *cctx, mcmon cnum)
{
	mcmcx1def   *ctx = cctx->mcmcxgl;
	mcmodef     *o = mcmobje(cctx, cnum);
	mcmodef     *newdef;
	mcmon        newn;
	mcmon        num = mcmc2g(cctx, cnum);

	MCMCLICTX(cctx);
	MCMGLBCTX(ctx);

	/* we first need to obtain some memory for this object */
	(void)mcmalo0(cctx, o->mcmosiz, &newn, MCMONINV, TRUE);
	newdef = mcmgobje(ctx, newn);

	/* use memory block from our new object */
	o->mcmoptr = newdef->mcmoptr;
	o->mcmosiz = newdef->mcmosiz;

	/* load or swap the object in */
	ERRBEGIN(ctx->mcmcxerr)
		if (o->mcmoflg & (MCMOFNODISC | MCMOFDIRTY))
			mcsin(&ctx->mcmcxswc, o->mcmoswh, o->mcmoptr, o->mcmosiz);
		else if (cctx->mcmcxldf)
			(*cctx->mcmcxldf)(cctx->mcmcxldc, o->mcmoldh, o->mcmoptr,
							  o->mcmosiz);
		else
			errsig(ctx->mcmcxerr, ERR_NOLOAD);
	ERRCLEAN(ctx->mcmcxerr)
		mcmgunlck(ctx, newn);                          /* unlock the object */
		mcmgfre(ctx, newn);              /* don't need new memory after all */
	ERRENDCLN(ctx->mcmcxerr)

	/* unuse the new cache entry we obtained (we just wanted the memory) */
/* @@@ */
	*(mcmon *)(o->mcmoptr - osrndsz(sizeof(mcmon))) = num;      /* set obj# */
	newdef->mcmoflg = 0;                        /* mark new block as unused */
	newdef->mcmonxt = ctx->mcmcxunu;                /* link to unused chain */
	ctx->mcmcxunu = newn;

	/* set flags in the newly loaded object and return */
	o->mcmoflg |= MCMOFPRES | MCMOFLOCK; /* object is now present in memory */
	o->mcmoflg &= ~MCMOFDIRTY;         /* not written since last swapped in */
	o->mcmoflg |= MCMOFNODISC; /* don't discard once it's been to swap file */
	o->mcmolcnt = 1;                                   /* one locker so far */

	/* if the object is to be reverted upon loading, revert it now */
	if (o->mcmoflg & MCMOFREVRT)
	{
		(*cctx->mcmcxrvf)(cctx->mcmcxrvc, cnum);
		o->mcmoflg &= ~MCMOFREVRT;
	}

	return(o->mcmoptr);
}

/*
 *   Allocate a new object header.  This doesn't allocate an object, just
 *   the header for one.
 */
static mcmodef *mcmoal(mcmcx1def *ctx, mcmon *nump)
{
	mcmodef  *ret;
	uint      pagenum;

	MCMGLBCTX(ctx);

	/* look first in list of unused headers */
startover:
	if (ctx->mcmcxunu != MCMONINV)
	{
		/* we have something in the unused list; return it */
		*nump = ctx->mcmcxunu;
		ret = mcmgobje(ctx, *nump);
		ctx->mcmcxunu = ret->mcmonxt;
		ret->mcmoswh = MCSSEGINV;
		return(ret);
	}

	/*
	 *   No unused entries: we must create a new page.  To do so, we
	 *   simply allocate memory for a new page.  Allocate the memory
	 *   ourselves, to avoid deadlocking with the allocator (which can
	 *   try to get a new entry to satisfy our request for memory).
	 */
	if (ctx->mcmcxpage == ctx->mcmcxpgmx) goto error;      /* no more pages */
	pagenum = ctx->mcmcxpage++;                      /* get a new page slot */

	ctx->mcmcxtab[pagenum] =
		 (mcmodef *)mchalo(ctx->mcmcxerr, MCMPAGESIZE, "mcmoal");
	mcmadpg(ctx, pagenum, MCMONINV);
	goto startover;

error:
	*nump = MCMONINV;
	return((mcmodef *)nullptr);
}

/* find free block:  find a block from the free pool to satisfy allocation */
static mcmodef *mcmffb(mcmcx1def *ctx, ushort siz, mcmon *nump)
{
	mcmon    n;
	mcmodef *o;
	mcmon    minn;
	mcmodef *mino;
	ushort   min = 0;

	MCMGLBCTX(ctx);

	for (minn = MCMONINV, mino = nullptr, n = ctx->mcmcxfre ; n != MCMONINV ;
		 n = o->mcmonxt)
	{
		o = mcmgobje(ctx, n);
		if (o->mcmosiz == siz)
		{
			/* found exact match - use it immediately */
			minn = n;
			min = siz;
			mino = o;
			break;
		}
		else if (o->mcmosiz > siz)
		{
			/* found something at least as big; is it smallest yet? */
			if (minn == MCMONINV || o->mcmosiz < min)
			{
				/* yes, best fit so far, use it; but keep looking */
				minn = n;
				mino = o;
				min = o->mcmosiz;
			}
		}
	}

	/* if we found something, remove from the free list */
	if (minn != MCMONINV)
	{
		mcmunl(ctx, minn, &ctx->mcmcxfre);
		mino->mcmoflg &= ~MCMOFFREE;
		mino->mcmoswh = MCSSEGINV;
	}

	*nump = minn;
	return mino;
}

/*
 *   unlink an object header from one of the doubly-linked lists
 */
static void mcmunl(mcmcx1def *ctx, mcmon n, mcmon *lst)
{
	mcmodef *o = mcmgobje(ctx, n);
	mcmodef *nxt;
	mcmodef *prv;

	MCMGLBCTX(ctx);

	/* see if this is LRU chain - must deal with MRU pointer if so */
	if (lst == &ctx->mcmcxlru)
	{
		/* if it's at MRU, set MRU pointer to previous object in list */
		if (ctx->mcmcxmru == n)
		{
			ctx->mcmcxmru = o->mcmoprv;     /* set MRU to previous in chain */
			if (ctx->mcmcxmru != MCMONINV)           /* set nxt for new MRU */
				mcmgobje(ctx, ctx->mcmcxmru)->mcmonxt = MCMONINV;
			else
				ctx->mcmcxlru = MCMONINV;     /* nothing in list; clear LRU */
		}
		o->mcmoflg &= ~MCMOFLRU;
	}

	nxt = o->mcmonxt == MCMONINV ? (mcmodef *)nullptr : mcmgobje(ctx, o->mcmonxt);
	prv = o->mcmoprv == MCMONINV ? (mcmodef *)nullptr : mcmgobje(ctx, o->mcmoprv);

	/* set back link for next object, if there is a next object */
	if (nxt) nxt->mcmoprv = o->mcmoprv;

	/* set forward link for previous object, or head if no previous object */
	if (prv) prv->mcmonxt = o->mcmonxt;
	else *lst = o->mcmonxt;

	o->mcmonxt = o->mcmoprv = MCMONINV;
}

/* link an item to the head of a doubly-linked list */
static void mcmlnkhd(mcmcx1def *ctx, mcmon *lst, mcmon n)
{
	MCMGLBCTX(ctx);

	if (*lst != MCMONINV) mcmgobje(ctx, *lst)->mcmoprv = n;
	mcmgobje(ctx, n)->mcmonxt = *lst;      /* next is previous head of list */
	*lst = n;                               /* make object new head of list */
	mcmgobje(ctx, n)->mcmoprv = MCMONINV;     /* there is no previous entry */
}

/* add page pagenum, initializing entries after firstunu to unused */
static void mcmadpg(mcmcx1def *ctx, uint pagenum, mcmon firstunu)
{
	mcmon    unu;
	mcmodef *obj;
	mcmon    lastunu;

	MCMGLBCTX(ctx);

	unu = (firstunu == MCMONINV ? pagenum * MCMPAGECNT : firstunu);
	ctx->mcmcxunu = unu;
	lastunu = (pagenum * MCMPAGECNT) + MCMPAGECNT - 1;
	for (obj = mcmgobje(ctx, unu) ; unu < lastunu ; ++obj)
		obj->mcmonxt = ++unu;
	obj->mcmonxt = MCMONINV;
}

/*
 *   split a previously-free block into two chunks, adding the remainder
 *   back into the free list, if there's enough left over
 */
static void mcmsplt(mcmcx1def *ctx, mcmon n, ushort siz)
{
	mcmodef *o = mcmgobje(ctx, n);
	mcmon    newn;
	mcmodef *newp;

	MCMGLBCTX(ctx);

	if (o->mcmosiz < siz + MCMSPLIT) return;     /* don't split; we're done */

	newp = mcmoal(ctx, &newn);
	if (newn == MCMONINV) return;         /* ignore error - just skip split */

	/* set up the new entry, and link into free list */
	*(mcmon *)(o->mcmoptr + siz) = newn;
	newp->mcmoptr = o->mcmoptr + siz + osrndsz(sizeof(mcmon));
	newp->mcmosiz = o->mcmosiz - siz - osrndsz(sizeof(mcmon));
	newp->mcmoflg = MCMOFFREE;
	mcmlnkhd(ctx, &ctx->mcmcxfre, newn);

	o->mcmosiz = siz;       /* size of new object is now exactly as request */
}

/* allocate a new chunk from the heap if possible */
static uchar *mcmhalo(mcmcx1def *ctx)
{
	uchar  *chunk;
#define  size (MCMCHUNK + sizeof(mcmhdef) + 2*osrndsz(sizeof(mcmon)))

	MCMGLBCTX(ctx);

	if (ctx->mcmcxmax < MCMCHUNK) return((uchar *)nullptr);

	ERRBEGIN(ctx->mcmcxerr)
		chunk = mchalo(ctx->mcmcxerr, size, "mcmhalo");
	ERRCATCH_ERRCODE_UNUSED(ctx->mcmcxerr)
		ctx->mcmcxmax = 0;      /* remember we can't allocate anything more */
		return((uchar *)nullptr);                             /* return no memory */
	ERREND(ctx->mcmcxerr)

	ctx->mcmcxmax -= MCMCHUNK;

	/* link into heap chain */
	((mcmhdef *)chunk)->mcmhnxt = ctx->mcmcxhpch;
	ctx->mcmcxhpch = (mcmhdef *)chunk;
/*@@@@*/
	*(mcmon *)(chunk + osrndsz(sizeof(mcmhdef) + MCMCHUNK)) = MCMONINV;

	return(chunk + sizeof(mcmhdef));

#undef size
}

/* "use" an object - move to most-recent position in LRU chain */
void mcmuse(mcmcx1def *ctx, mcmon obj)
{
	mcmodef   *o = mcmgobje(ctx, obj);

	MCMGLBCTX(ctx);

	if (ctx->mcmcxmru == obj) return;         /* already MRU; nothing to do */

	/* remove from LRU chain if it's in it */
	if (o->mcmoflg & MCMOFLRU) mcmunl(ctx, obj, &ctx->mcmcxlru);

	/* set forward pointer of last block, if there is one */
	if (ctx->mcmcxmru != MCMONINV)
		mcmgobje(ctx, ctx->mcmcxmru)->mcmonxt = obj;

	o->mcmoprv = ctx->mcmcxmru;               /* point back to previous MRU */
	o->mcmonxt = MCMONINV;                /* nothing in list after this one */
	ctx->mcmcxmru = obj;                          /* point MRU to new block */

	/* if there's nothing in the chain at all, set LRU to this block, too */
	if (ctx->mcmcxlru == MCMONINV) ctx->mcmcxlru = obj;

	/* note that object is in LRU chain */
	o->mcmoflg |= MCMOFLRU;
}

/* find next free block in a heap, starting with pointer */
static uchar *mcmffh(mcmcx1def *ctx, uchar *p)
{
	mcmodef *o;

	MCMGLBCTX(ctx);

	while (*(mcmon *)p != MCMONINV)
	{
		o = mcmgobje(ctx, *(mcmon *)p);
		assert(o->mcmoptr == p + osrndsz(sizeof(mcmon)));
		if (o->mcmoflg & MCMOFFREE) return(p);
		p += osrndsz(sizeof(mcmon)) + o->mcmosiz;  /* move on to next chunk */
	}
	return((uchar *)nullptr);                      /* no more free blocks in heap */
}

#ifdef NEVER
static void mcmmove(mcmcx1def *ctx, mcmodef *o, uchar *newpage)
{
	mcmodef **page;

	MCMGLBCTX(ctx);

	/* see if we need to update page table (we do if moving a page) */
	if (o->mcmoflg & MCMOFPAGE)
	{
		for (page = ctx->mcmcxtab ; *page ; ++page)
		{
			if (*page == (mcmodef *)(o->mcmoptr))
			{
				*page = (mcmodef *)newpag;
				break;
			}
		}
		if (!*page) printf("\n*** internal error - relocating page\n");
	}
	o->mcmoptr = newpage;
}
#endif /* NEVER */

/* relocate blocks from p to (but not including) q */
static uchar *mcmreloc(mcmcx1def *ctx, uchar *p, uchar *q)
{
	mcmodef *o;
	ushort   dist;
	mcmon    objnum;

	MCMGLBCTX(ctx);

	objnum = *(mcmon *)p;      /* get number of free block being bubbled up */
	o = mcmgobje(ctx, objnum);                /* get pointer to free object */
	assert(o->mcmoptr == p + osrndsz(sizeof(mcmon)));
	dist = osrndsz(sizeof(mcmon)) + o->mcmosiz; /* compute distance to move */
	mcmmove(ctx, o, q - dist + osrndsz(sizeof(mcmon)));  /* move obj to top */

	memmove(p, p+dist, (size_t)(q - p - o->mcmosiz));        /* move memory */

	/* update cache entries for the blocks we moved */
	while (p != q - dist)
	{
		mcmmove(ctx, mcmgobje(ctx, *(mcmon *)p), p + osrndsz(sizeof(mcmon)));
		p = mcmnxh(ctx, p);
	}

	*(mcmon *)(q - dist) = objnum;                       /* set bubbled num */
	return(q - dist);               /* return new location of bubbled block */
}

/* consolidate the two (free) blocks starting at p into one block */
static void mcmconsol(mcmcx1def *ctx, uchar *p)
{
	uchar   *q;
	mcmodef *obj1, *obj2;

	MCMGLBCTX(ctx);

	q = mcmnxh(ctx, p);
	obj1 = mcmgobje(ctx, *(mcmon *)p);
	obj2 = mcmgobje(ctx, *(mcmon *)q);

	assert(obj1->mcmoptr == p + osrndsz(sizeof(mcmon)));
	assert(obj2->mcmoptr == q + osrndsz(sizeof(mcmon)));

	obj1->mcmosiz += osrndsz(sizeof(mcmon)) + obj2->mcmosiz;
	mcmunl(ctx, *(mcmon *)q, &ctx->mcmcxfre);

	/* add second object entry to unused list */
	obj2->mcmonxt = ctx->mcmcxunu;
	ctx->mcmcxunu = *(mcmon *)q;
	obj2->mcmoflg = 0;
}

/* attempt to compact all heaps by consolidating free space */
static void mcmgarb(mcmcx1def *ctx)
{
	mcmhdef *h;
	uchar   *p;
	uchar   *q;
	uchar   *nxt;
	ushort   flags;

	MCMGLBCTX(ctx);

	for (h = ctx->mcmcxhpch ; h ; h = h->mcmhnxt)
	{
		p = (uchar *)(h+1);                   /* get pointer to actual heap */
		p = mcmffh(ctx, p);                 /* get first free block in heap */
		if (!p) continue;             /* can't do anything - no free blocks */
		nxt = mcmnxh(ctx, p);              /* remember immediate next block */

		for (q=p ;; )
		{
			q = mcmnxh(ctx, q);                  /* find next chunk in heap */
			if (*(mcmon *)q == MCMONINV) break;      /* reached end of heap */
			assert(mcmgobje(ctx, *(mcmon *)q)->mcmoptr
				   == q + osrndsz(sizeof(mcmon)));
			flags = mcmgobje(ctx, *(mcmon *)q)->mcmoflg;       /* get flags */

			/* if the block is locked, p can't be relocated */
			if (flags & MCMOFLOCK)
			{
				p = mcmffh(ctx, q);         /* find next free block after p */
				q = p;
				if (p) continue;   /* try again; start with next free block */
				else break;         /* no more free blocks - done with heap */
			}

			/* if the block is free, we can relocate between p and q */
			if (flags & MCMOFFREE)
			{
				if (q != nxt) p = mcmreloc(ctx, p, q);          /* relocate */
				mcmconsol(ctx, p);           /* consolidate two free blocks */

				/* resume looking, starting with consolidated block */
				nxt = mcmnxh(ctx, p);
				q = p;
				continue;
			}
		}
	}
}

/* toss out a particular object */
static int mcmtoss(mcmcx1def *ctx, mcmon n)
{
	mcmodef *o = mcmgobje(ctx, n);
	mcmodef *newp;
	mcmon    newn;

	MCMGLBCTX(ctx);

	/* make a new block for the free space */
	newp = mcmoal(ctx, &newn);
	if (newn == MCMONINV)
		return(FALSE);           /* ignore the error, but can't toss it out */

	/* write object to swap file if not discardable */
	if (o->mcmoflg & (MCMOFNODISC | MCMOFDIRTY))
	{
		mcsseg old_swap_seg;

		/*
		 *   If this object was last loaded out of the load file, rather
		 *   than the swap file, don't attempt to find it in the swap file
		 *   -- so note by setting the old swap segment parameter to null.
		 */
		if (!(o->mcmoflg & MCMOFNODISC))
			old_swap_seg = o->mcmoswh;
		else
			old_swap_seg = MCSSEGINV;

		o->mcmoswh = mcsout(&ctx->mcmcxswc, (uint)n, o->mcmoptr, o->mcmosiz,
							old_swap_seg, o->mcmoflg & MCMOFDIRTY);
	}

	/* give the object's space to the newly created block */
	newp->mcmoptr = o->mcmoptr;
	newp->mcmosiz = o->mcmosiz;
	newp->mcmoflg = MCMOFFREE;
/*@@@*/
	*(mcmon *)(o->mcmoptr - osrndsz(sizeof(mcmon))) = newn;
	mcmlnkhd(ctx, &ctx->mcmcxfre, newn);

	o->mcmoflg &= ~MCMOFPRES;              /* object is no longer in memory */
	mcmunl(ctx, n, &ctx->mcmcxlru);                 /* remove from LRU list */
	return(TRUE);                             /* successful, so return TRUE */
}

/* swap or discard to make room for siz; return 0 if nothing swapped */
static int mcmswap(mcmcx1def *ctx, ushort siz)
{
	mcmon    n;
	mcmodef *o;
	mcmon    nxt;
	int      pass;                     /* pass 1: swap one piece big enough */
					  /* pass 2: swap enough pieces to add up to right size */
	ushort   tot;

	MCMGLBCTX(ctx);

	for (pass = 1, tot = 0 ; pass < 3 && tot < siz ; ++pass)
	{
		for (n = ctx->mcmcxlru ; n != MCMONINV && tot < siz ; n = nxt)
		{
			o = mcmgobje(ctx, n);
			nxt = o->mcmonxt;             /* get next now, as we may unlink */
			if (!(o->mcmoflg & (MCMOFLOCK | MCMOFNOSWAP | MCMOFPAGE))
				 && (pass == 2 || o->mcmosiz >= siz))
			{
				/* toss out, and add into size if successful */
				if (mcmtoss(ctx, n)) tot += o->mcmosiz;
			}
		}
	}

	/* if we managed to remove anything, return TRUE, otherwise FALSE */
	return(tot != 0);
}

/* compute size of cache */
ulong mcmcsiz(mcmcxdef *cctx)
{
	mcmcx1def *ctx = cctx->mcmcxgl;
	mcmhdef   *p;
	ulong      tot;

	MCMCLICTX(cctx);
	MCMGLBCTX(ctx);

	/* count number of heaps, adding in chunk size for each */
	for (tot = 0, p = ctx->mcmcxhpch ; p ; p = p->mcmhnxt)
		tot += MCMCHUNK;

	return(tot);
}

#ifdef MCM_NO_MACRO
/* routines that can be either macros or functions */

uchar *mcmlck(mcmcxdef *ctx, mcmon objnum)
{
	mcmodef *o = mcmobje(ctx, objnum);

	if ((o->mcmoflg & MCMOFFREE) != 0 || mcmc2g(ctx, objnum) == MCMONINV)
	{
		errsig(ctx->mcmcxgl->mcmcxerr, ERR_INVOBJ);
		return nullptr;
	}
	else if (o->mcmoflg & MCMOFPRES)
	{
		o->mcmoflg |= MCMOFLOCK;
		++(o->mcmolcnt);
		return(o->mcmoptr);
	}
	else
		return(mcmload(ctx, objnum));
}

void mcmunlck(mcmcxdef *ctx, mcmon obj)
{
	mcmodef *o = mcmobje(ctx, obj);

	if (o->mcmoflg & MCMOFLOCK)
	{
		if (!(--(o->mcmolcnt)))
		{
			o->mcmoflg &= ~MCMOFLOCK;
			mcmuse(ctx->mcmcxgl, mcmc2g(ctx, obj));
		}
	}
}

void mcmgunlck(mcmcx1def *ctx, mcmon obj)
{
	mcmodef *o = mcmgobje(ctx, obj);

	if (o->mcmoflg & MCMOFLOCK)
	{
		if (!(--(o->mcmolcnt)))
		{
			o->mcmoflg &= ~MCMOFLOCK;
			mcmuse(ctx, obj);
		}
	}
}

#endif /* MCM_NO_MACRO */

/*
 *   Change an object's swap file handle.  This routine will only be
 *   called for an object that is either present or swapped out (i.e., an
 *   object with a valid mcsseg number in its swap state).
 */
void mcmcswf(mcmcx1def *ctx, mcmon objn, mcsseg swapn, mcsseg oldswapn)
{
	mcmodef *o = mcmgobje(ctx, objn);

	MCMGLBCTX(ctx);

	/*
	 *   Reset the swap number only if the object is swapped out and its
	 *   swap file number matches the old one, or the object is currently
	 *   present (in which case the swap file number is irrelevant and can
	 *   be replaced).
	 */
	if (((o->mcmoflg & (MCMOFDIRTY | MCMOFNODISC)) && o->mcmoswh == oldswapn)
		|| (o->mcmoflg & MCMOFPRES))
		o->mcmoswh = swapn;
}


void mcmfre(mcmcxdef *ctx, mcmon obj)
{
	/* free the actual object */
	mcmgfre(ctx->mcmcxgl, mcmc2g(ctx, obj));

	/* unmap the client object number */
	mcmc2g(ctx, obj) = MCMONINV;
}

} // End of namespace TADS2
} // End of namespace TADS
} // End of namespace Glk