// GHEAP.SR MALLOY ATTEMPT TO FIX BUGS

get "HEAP.DF";

// Incoming Procedures

external [
	errhlt;
	errck;
	ult;
	ugt;
	enphp;
	enphpd;
	move;
	adjustphpd;
	ckspecs // **
	];

// Incoming Statics

external [
	dcb;
	fdebug // **
	];

// Outgoing Procedures

external [
	hptoff;
	hpfree;
	hpalloc;
	hpcompact;
	hpinit;
	hpadjustphp;
	hppreparemove;
	inheap;
	ckhp; // **
	];

// Outgoing Statics

external [
	vpzone;
	vsncompact;
	hdebug // **
	]; 

// Local Statics

static [
	vpzone;
	vsncompact;
	hdebug // **
	];
// Local Structures

structure
	[
	blank	bit 15;
	odd	bit 1;
	];

// H P T O F F
let hptoff(php) be
[
(php >> HP.fp) >> HP.bp = php >> HP.bp;
(php >> HP.bp) >> HP.fp = php >> HP.fp;
vpzone >> ZONE.free = php >> HP.fp;
vpzone >> ZONE.cfree = (vpzone >> ZONE.cfree)-(php >> HP.siz);
] // End hptoff

// H P F R E E

and hpfree(p,newzone; numargs N) be
[
let tphp = p-((offset HP.use)/16);
if N gr 1 then vpzone = newzone;
vpzone >> ZONE.cfree = (vpzone >> ZONE.cfree)+(tphp >> HP.siz);
let hpfrlst = vpzone >> ZONE.free;
test tphp >> HP.fp eq prevfree ifso
	[
	let tpbkprev = tphp-rv(tphp-bsiz);
	tpbkprev >> HP.siz = tpbkprev >> HP.siz+(tphp >> HP.siz);
	tphp = tpbkprev;
	]
ifnot	[
	tphp >> HP.fp = hpfrlst >> HP.fp;
	tphp >> HP.bp = hpfrlst;
	(hpfrlst >> HP.fp) >> HP.bp = tphp;
	hpfrlst >> HP.fp = tphp;
	];

let nxphp = tphp+(tphp >> HP.siz);
if nxphp ne vpzone >> ZONE.max then test not ult(nxphp >> HP.fp,minlink) ifso
	[
	vpzone >> ZONE.cfree = vpzone >> ZONE.cfree+nxphp >> HP.siz;
	tphp >> HP.siz = tphp >> HP.siz+(nxphp >> HP.siz);
	hptoff(nxphp);
	]
ifnot	nxphp >> HP.fp = prevfree; // Used block, prev block free
rv(tphp-bsiz+tphp >> HP.siz) = tphp >> HP.siz;
] // end hpfree

// H P A L L O C

and hpalloc(siz,newzone; numargs N) = valof
[
let hpovd,hpfrlst = vpzone >> ZONE.ovh,vpzone >> ZONE.free;
let tphp = vpzone >> ZONE.free;
siz = siz+hpovd;
if siz << odd then siz = siz+1;

while tphp >> HP.siz ls siz do
	[
	tphp = tphp >> HP.fp;
	if (tphp eq 0) then errhlt("HWU"); // Used blk on free list
	if (tphp eq hpfrlst) then resultis 0;
	];

hptoff(tphp); // remove from the free list

test tphp >> HP.siz ge siz+hpovhf ifso
	[
	let tsiz = tphp >> HP.siz;
	tphp >> HP.siz = siz;
	let tphp2nd = tphp+siz;
	tphp2nd >> HP.siz = tsiz-siz;
	rv(tphp+tsiz-bsiz) = tsiz-siz;
	tphp2nd >> HP.fp = 0;
	hpfree(lv(tphp2nd >> HP.use));
	]
ifnot	[
	let nxphp = tphp+(tphp >> HP.siz);
	if nxphp ne vpzone >> ZONE.max & nxphp >> HP.fp eq prevfree
		then nxphp >> HP.fp = 0; // Turn off prevfree
	];
rv(tphp-bsiz+tphp >> HP.siz) = tphp >> HP.siz;
tphp >> HP.fp = 0; // Block now used.
resultis lv(tphp >> HP.use);
] // end hpalloc


// C K H P

and ckhp(newzone; numargs N) be
[
let unused,used = 0,0;
if N gr 1 then vpzone = newzone;
let minphp,maxphp = vpzone >> ZONE.min,vpzone >> ZONE.max;
let hpovd,dummy = vpzone >> ZONE.ovh,lv(vpzone >> ZONE.dummy);
let hpfrlst = vpzone >> ZONE.free;
let tphp = minphp;
let lastfree = false;
	[
	let tblksiz = tphp >> HP.siz;
	if tblksiz eq 0 then errck("HBZ");
	test (tphp >> HP.fp eq 0) % (tphp >> HP.fp eq prevfree) ifso
		[
		used = used+tblksiz;
		lastfree = false;
		]
	ifnot	[
		unused = unused+tblksiz;
		if lastfree then errck("HLF");
		lastfree = true;
		];
	tphp = tphp+tblksiz;
	if ugt(tphp,maxphp) then errck("HSL");
	] repeatuntil tphp eq maxphp;
if minphp+used+unused ne maxphp then errck("HSW");

let tpfree = dummy >> HP.fp;
let bhpfrlst,free = false,0;

while tpfree ne dummy do
	[ 
	if not ult(tpfree,maxphp)  then errck("HAF");
	if tpfree eq hpfrlst then
		test bhpfrlst ifso errck("HMF");
		ifnot bhpfrlst = true;
	if (tpfree >> HP.fp) >> HP.fp eq 0 then errck("HNF");
	free = free+(tpfree >> HP.siz);
	tpfree = tpfree >> HP.fp;
	] 
if free ne unused then errck("HSF");

if hpovd eq 4 then
	[
	tpfree = dummy >> HP.bp;
	bhpfrlst = false;
	free = 0;
	while tpfree ne dummy do
		[
		if not ult(tpfree,maxphp) then errck("HAB");
		if tpfree eq hpfrlst then
			test bhpfrlst ifso errck("HMB");
			ifnot bhpfrlst = true;
		free = free+(tpfree >> HP.siz);
		tpfree = tpfree >> HP.bp;
		] 
	if free ne unused then errck("HSB");

	if unused ne vpzone >> ZONE.cfree then errck("HSC");
	]; // end 4 word overhead checks
] // end ckhp

// H P C O M P A C T
and hpcompact(up,minphpnew,maxphpnew,newzone; numargs N) be
[
if hdebug then ckhp(); // **
if fdebug then ckspecs(); // **
let sum,curadr,endadr,tsiz = 0,nil,nil,0;
let newadr = nil;
if N eq 0 then up = false;
if N gr 3 then vpzone = newzone;
if N ls 2 then minphpnew = vpzone >> ZONE.min;
if N ls 3 then maxphpnew = vpzone >> ZONE.max;
if ult(vpzone >> ZONE.cfree,4) then return;
vsncompact = vsncompact+1;
if vpzone >> ZONE.ovh eq 2 & up then errhlt("HCU"); // Not allowed
test up ifnot
	[
	curadr = vpzone >> ZONE.min;
	while ult(curadr,vpzone >> ZONE.max) do
		[
		test curadr >> HP.fp eq 0 %
		     curadr >> HP.fp eq prevfree ifso
			[
			curadr >> HP.fp = minphpnew+sum;
			sum = sum+(curadr >> HP.siz);
			]
		ifnot curadr >> HP.fp = -1; // Mark as Free
		curadr = curadr+(curadr >> HP.siz);
		]
	]
ifso	[
	curadr = vpzone >> ZONE.max-(rv (vpzone >> ZONE.max-bsiz));
		[
		test curadr >> HP.fp eq 0 %
		     curadr >> HP.fp eq prevfree ifso
			[
			sum = sum+(curadr >> HP.siz);
			curadr >> HP.fp = maxphpnew-sum;
			]
		ifnot curadr >> HP.fp = -1; // Mark as Free
		if not ugt(curadr,vpzone >> ZONE.min) then break;
		curadr = curadr-rv(curadr-bsiz);
		] repeat;
	];
hpcomp1:

enphp(hpadjustphp);
enphpd(hppreparemove);
hpcomp2:

sum = 0;

test up ifnot
	[
	curadr = vpzone >> ZONE.min;
	while ult(curadr,vpzone >> ZONE.max) do
		[
		tsiz = curadr >> HP.siz;
		if curadr >> HP.fp ne -1 then
			[
			newadr = minphpnew+sum;
			move(curadr,newadr,tsiz);
			if ult(newadr >> HP.fp,minlink) then
				adjustphpd(newadr >> HP.fp,
				newadr);
			newadr >> HP.fp = 0; // Mark as used
			sum = sum+tsiz;
			]
		curadr = curadr+tsiz;
		];
	]
ifso	[
	curadr = vpzone >> ZONE.max-(rv (vpzone >> ZONE.max-bsiz));
		[
		tsiz = curadr >> HP.siz;
		if curadr >> HP.fp ne -1 then
			[
			sum = sum+tsiz;
			newadr = maxphpnew-sum;
			test not ult(curadr+tsiz-1,newadr) ifso
				[ for i = tsiz-1 to 0 by -1 do
					newadr ! i = curadr ! i;
				] 
			ifnot	move(curadr,newadr,tsiz);
			if ult(newadr >> HP.fp,minlink) then
				adjustphpd(newadr >> HP.fp,
				newadr);
			newadr >> HP.fp = 0;
			]
		if not ugt(curadr,vpzone >> ZONE.min) then break;
		curadr = curadr-rv(curadr-bsiz);
		] repeat;
	];

tsiz = maxphpnew-minphpnew-sum; // Total of unused storage
if up then (minphpnew+tsiz) >> HP.fp = prevfree;

test up ifnot hpinit(maxphpnew-tsiz,maxphpnew,vpzone >> ZONE.ovh)
ifso hpinit(minphpnew,minphpnew+tsiz,vpzone >> ZONE.ovh);

vpzone >> ZONE.min = minphpnew;
vpzone >> ZONE.max = maxphpnew;

if hdebug then ckhp(); // **
if fdebug then ckspecs(); // **
] // end hpcompact

// H P I N I T
// Hpinit sets the sizes for the big initial core block

and hpinit(min,max,ovh,newzone; numargs N) be
[
if N gr 3 then vpzone = newzone;
let dummy = lv(vpzone >> ZONE.dummy);
if min << odd then min = min+1;
if max << odd then max = max-1;

vpzone >> ZONE.free = dummy;
vpzone >> ZONE.min = min;
vpzone >> ZONE.max = max;
vpzone >> ZONE.ovh = ovh;
vpzone >> ZONE.cfree = max-min;

dummy >> HP.fp = min;
dummy >> HP.bp = min;
dummy >> HP.siz = hpovhf;
rv(dummy+hpovhf-bsiz) = hpovhf;

min >> HP.siz = max-min;
min >> HP.fp = dummy;
min >> HP.bp = dummy;
rv(max-1) = max-min;
] // end hpinit

// H P A D J U S T P H P
// SPE catalogue no.

and hpadjustphp(pphp) be
rv pphp = (((rv pphp)-(offset HP.use)/16) >> HP.fp)+((offset HP.use)/16);
// H P P R E P A R E M O V E
// catalogue no. 
and hppreparemove(id,php) be
	(php-(offset HP.use)/16) >> HP.fp = id;
// I N H E A P
//
and inheap(php) = valof
[ test not ult(php,vpzone >> ZONE.min) & not ugt(php,vpzone >> ZONE.max) ifso
	resultis true
ifnot	resultis false
]