get "HEAP.DF";

// Incoming Procedures

external [
	errhlta;
	ult;
	ugt;
	enphp;
	enphpd;
	move;
	adjustphpd;
	];

// Incoming Statics

external [
	dcb;
	];

// Outgoing Procedures

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

// Outgoing Statics

external [
	vpzone;
	vsncompact;
	]; 

// Local Statics

static [
	vpzone;
	vsncompact;
	];
// 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 errhlta(110); // 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 errhlta(111);
// 	test (tphp >> HP.fp eq 0) % (tphp >> HP.fp eq prevfree) ifso
// 		[
// 		used = used+tblksiz;
// 		lastfree = false;
// 		]
// 	ifnot	[
// 		unused = unused+tblksiz;
// 		if lastfree then errhlta(112);
// 		lastfree = true;
// 		];
// 	unless (rv (tphp+tblksiz-bsiz)) eq tblksiz then errhlta(113);
// 	tphp = tphp+tblksiz;
// 	if ugt(tphp,maxphp) then errhlta(114);
// 	] repeatuntil tphp eq maxphp;
// if minphp+used+unused ne maxphp then errhlta(115);
// 
// let tpfree = dummy >> HP.fp;
// let bhpfrlst,free = false,0;
// 
// while tpfree ne dummy do
// 	[ 
// 	if not ult(tpfree,maxphp)  then errhlta(116);
// 	if tpfree eq hpfrlst then
// 		test bhpfrlst ifso errhlta(117);
// 		ifnot bhpfrlst = true;
// 	if (tpfree >> HP.fp) >> HP.fp eq 0 then errhlta(118);
// 	free = free+(tpfree >> HP.siz);
// 	tpfree = tpfree >> HP.fp;
// 	] 
// if free ne unused then errhlta(119);
// 
// if hpovd eq 4 then
// 	[
// 	tpfree = dummy >> HP.bp;
// 	bhpfrlst = false;
// 	free = 0;
// 	while tpfree ne dummy do
// 		[
// 		if not ult(tpfree,maxphp) then errhlta(120);
// 		if tpfree eq hpfrlst then
// 			test bhpfrlst ifso errhlta(121);
// 			ifnot bhpfrlst = true;
// 		free = free+(tpfree >> HP.siz);
// 		tpfree = tpfree >> HP.bp;
// 		] 
// 	if free ne unused then errhlta(122);
// 
// 	if unused ne vpzone >> ZONE.cfree then errhlta(123);
// 	]; // 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
[
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 errhlta(124); // 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;

if ult(tsiz,vpzone >> ZONE.ovh) then
	[ test up ifso
		minphpnew = minphpnew+tsiz
	ifnot	maxphpnew = maxphpnew-tsiz
	tsiz = 0;
	] 
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;

] // 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;
if ugt(min,max) then errhlta(125);
let tcfree = max-min;
if tcfree ne 0 & ult(tcfree,ovh) then errhlta(126);
vpzone >> ZONE.free = dummy;
vpzone >> ZONE.min = min;
vpzone >> ZONE.max = max;
vpzone >> ZONE.ovh = ovh;
vpzone >> ZONE.cfree = tcfree;

dummy >> HP.fp = (tcfree eq 0) ? dummy,min;
dummy >> HP.bp = (tcfree eq 0) ? dummy,min;
dummy >> HP.siz = hpovhf;
rv(dummy+hpovhf-bsiz) = hpovhf;

unless tcfree eq 0 then
	[ 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
]