// GCOMPACT.SR	Compact display data on heap

get "DISPLAY.DF"
get "BRAVO.DF"
get "HEAP.DF"

// Incoming procedures

external
	[
	hpcompact
// **	enfs
	hpalloc
	ult
	errhlt
	freedl
	findlfpc;
// **	fsassign;
	enpspecs // **
	ugt
	hpfree // %%
	max // %%
	]

// Incoming statics

external
	[
	inheap
	vpzone
	macww
	rgdlfirst
	rgdllast
	rgpbm
	rgpctb
	dnlf
	vlf
	mpfnsb
	mpfunsb
	rgfont
	rgrgcc
	vrgcc
	fontstd // **
	vfont
	mpdldcb
	pbmfirstfree
	rghpused
	rgpbmnew;
// **	rgfs;
// **	rgfsnew;
// **	vfsesc;
// **	rgfsesc;
	vwwlock;
	rgul;
	cnrgul;
	vcompactlock;
	mpfnof;
// GYPSY ADDED: **
	rgsfile
	rgpara
	rgspec
	currentspec
	otherspec
	rgpage
	rgpagenum
	rgreadonly
	attoplevel // %%
	mww // %%
// END GYPSY ADDITIONS
	]

// Outgoing procedures

external
	[
	enphpd;
	enphp;
	compactdisplay
	hpalloca
	adjustphpd
	makeroominheap
	trycompact
	newsphp // %%
	freesphp // %%
	]

// Outgoing statics

external
	[
	vup
	vproc
	sphp // %%
	]

// Local statics

static
	[
	vup
	vproc
	csphp = 0 // %%
	sphp // %%
	]

// C O M P A C T D I S P L A Y
// SPE catalogue no.

let compactdisplay() be
[
let minphp,maxphp = nil,nil;
test vup ifso
	[
	minphp = vpzone >> ZONE.min+hpbuf;
	maxphp = vpzone >> ZONE.max+hpbuf;
	]
ifnot	[
	minphp = vpzone >> ZONE.min-hpbuf;
	maxphp = vpzone >> ZONE.max-hpbuf;
	];
hpcompact(vup,minphp,maxphp);
vup = not vup;
]

and trycompact() = valof
[
if ugt(vpzone >> ZONE.cfree,
	vpzone >> ZONE.free >> HP.fp >> HP.siz) then
		[
		let abandoned = gchp(vpzone) // %%
		compactdisplay()
		resultis abandoned? abandoned, -1 // %%
		]
resultis false
]

and gchp(zone) = valof // %%
	[
	if not attoplevel then resultis 0
	enphp(hpmarkused)
	let abandoned = 0
	let minphp,maxphp = zone >> ZONE.min,zone >> ZONE.max;
	let tphp = minphp;
	let abphp = 0
		[
		let tblksiz = tphp >> HP.siz;
		if tblksiz eq 0 then errhlt("HBZ");
		(lv tphp >> HP.siz)>>odd = 0
		let nxphp = tphp+tphp >> HP.siz;
		if (tphp >> HP.fp eq 0) % (tphp >> HP.fp eq prevfree)
			then if tblksiz<<odd eq 0 then
				[
				if abphp then hpfree(abphp)
				abandoned = abandoned+1;
				abphp = tphp+offset HP.use/16
				]
		tphp = nxphp;
		if ugt(tphp,maxphp) then errhlt("HSL");
		] repeatuntil tphp eq maxphp;
	if abphp then hpfree(abphp)
	resultis abandoned
	]

and hpmarkused(php) be // %%
	(lv (rv php - offset HP.use/16)>>HP.siz)>>odd = 1


// E N P H P D 
// catalogue no.
and enphpd(proc) be
[ for ww = 0 to macww-1 do
	for dl = rgdlfirst ! ww to rgdllast ! ww do
		if rgpbm ! dl ne 0 then
			proc(dl,rgpbm ! dl)
] 

// E N P H P
// catalogue no.

and enphp(proc) be
[
let lf,tp = nil,nil;
let pctb,rgcp = nil,nil;
let ppcd = nil;
for i = 0 to maxlf-1 do
	[
	if dnlf ! i eq 0 then loop;
	tp = lv(dnlf ! i);
	lf = rv tp;
	while lf do
		[
		proc(lv(lf >> LF.sl));
		proc(tp);
		pctb = rgpctb ! (lf >> LF.doc);
		rgcp = lv (pctb >> PCTB.rgcp);
		ppcd = rgcp+(pctb >> PCTB.maxpc)+1+((lf >> LF.pc) lshift 1);
		if (lf >> LF.pc ge pctb >> PCTB.macpc) %
			(lf >> LF.pc ls 0) %
			(not ppcd >> PCD.live) %
			(ppcd >> PCD.esc ne lf) then 
			lf >> LF.pc = findlfpc(lf >> LF.doc,lf);
		ppcd = rgcp+(pctb >> PCTB.maxpc)+1+((lf >> LF.pc) lshift 1);
		proc(lv (ppcd >> PCD.esc));
		tp = lv(lf >> LF.link);
		lf = lf >> LF.link;
		];
	];
for i = 0 to maxdoc-1 do
	[  pctb = rgpctb ! i;
	if pctb eq -1 then loop;
	proc(rgpctb+i);
	] 
proc(lv vlf);
for i = 0 to maxfn-1 do
	[ if inheap(mpfnsb ! i) then proc(lv(mpfnsb ! i));
	if inheap(mpfnof ! i) then proc(mpfnof+i);
	] 
// for i = 0 to macbp-1 do
// 	if dnbp ! i ne 0 then proc(lv(dnbp ! i));
// **enfs(proc);
for fun = 0 to maxfun-1 do
	[ 
	if inheap(mpfunsb ! fun) then
		proc(mpfunsb+fun);
	if inheap(rgfont ! fun) then
		proc(rgfont+fun);
	if inheap(rgrgcc ! fun) then
		proc(rgrgcc+fun);
	] 
if inheap(vrgcc) then proc(lv vrgcc);
if inheap(vfont) then proc(lv vfont);
if inheap(fontstd) then proc(lv fontstd); // **
for ww = 0 to macww-1 do
	for dl = rgdlfirst ! ww to rgdllast ! ww do
		if rgpbmnew ! dl ne 0 then
			proc(rgpbmnew+dl)

// ** GYPSY ADDITIONS:
if currentspec then proc(lv currentspec)
if otherspec then proc(lv otherspec)
for i = 1 to csphp do if sphp!i then proc(sphp!i) // %%
enpspecs(proc)
for i=0 to maxdoc-1 do if rgpctb ! i ne -1 then
	[
	if rgsfile ! i then proc(lv(rgsfile ! i))
	if rgpara ! i then proc(lv(rgpara ! i))
	if rgspec ! i then proc(lv(rgspec ! i))
	if rgpage ! i then proc(lv(rgpage ! i))
	if rgpagenum ! i then proc(lv(rgpagenum ! i))
	if rgreadonly ! i then proc(lv(rgreadonly ! i))
	]
// ** END GYPSY ADDITIONS:

] // end enphp


and newsphp(php) = valof // %%
	[
	for i = 1 to maxsphp do if not sphp!i then
		[
		sphp!i = php
		csphp = max(i, csphp)
		resultis i
		]
	errhlt("SPH")
	]

and freesphp(i) be sphp ! i = 0 // %%


// A D J U S T P H P D 
// catalogue no. 
and adjustphpd(id,phpnew) be
[ let dl = id;
phpnew = phpnew+(offset HP.use)/16;
(mpdldcb ! dl) >> DCB.sa = phpnew;
rgpbm ! dl = phpnew;
] 

// H P A L L O C A
// catalogue # SPE-

and hpalloca(siz) = valof // ** SUBROUTINIZED MAKEROOMINHEAP
[
let adr = hpalloc(siz);
if adr ne 0 then resultis adr;
makeroominheap(siz) // **
unless vcompactlock do compactdisplay( );
adr = hpalloc(siz);
if adr eq 0 then errhlt("HPE");
resultis adr;
]

// M A K E R O O M I N H E A P
// Gypsy added

and makeroominheap(siz) be // ** EXTRACTED FROM HPALLOCA
[
let hpovd = vpzone >> ZONE.ovh;
for ww = macww-1 to mww+1 by -1 do // %%
	unless vwwlock eq ww do
		for dl = rgdllast ! ww to rgdlfirst ! ww+1 by -1 do
			[ unless ult(vpzone >> ZONE.cfree,
				siz+hpovd) do return
			pbmfirstfree = 1;
			rghpused ! ww = rghpused ! ww -
				((rgpbm ! dl)-((offset HP.use)/16))
					>> HP.siz;
			freedl(dl);
// **			if rgfsesc ! ww then
// **				fsassign(rgfs+dl,0);
			if rgul ! dl ls 0 then cnrgul = cnrgul-1;
			rgdllast ! ww = dl-1;
			] 
errhlt("HPZ");
]