// xcompact.sr		Compact display data on heap

get "DISPLAY.DF"
get "BRAVO1.DF"
get "ALTOFILESYS.D"
get "HEAP.DF"
get "DOC.DF"
get "VM.DF"
get "FONT.DF"

// Incoming procedures

external
	[
	hpcompact
	hpalloc
	ult
	errhlta
	freedl
	findlfpc
	mpDlDld
	mpDldDcbBm
	DlruOld
	errhlt
	hpfree
	ugt
	CallersFrame
	CwFddl
	]

// Incoming statics

external
	[
	inheap
	vpzone
	macww
	rgpctb
	mpfnsb
	vfont
	pbmfirstfree
	vwwlock
	rgul
	cnrgul
	vcompactlock
	mpfnof
	fontstd
	rgptcom
	rgpvcom
	rgptuser
	rgpvuser
	pxv
	mpfrfc
	rglook1
	rglook2
	parastat
	rgmpbifc
	rgmpbifb
	vfddfirst
	mpfunfd
	bpsrcqueue
	ozonel
// 	vfdd0
	vfddlFixed
	mpWwWwd
	SDldNew
	SDld
// 	vupdatemag
	fddlrutimer
	diskKd
	]

// Outgoing procedures

external
	[
	enphpd
	enphp
	compactdisplay
	hpalloca
	adjustphpd
	hpguarantee
	findhpspace
	WfdOldest
	]

// Outgoing statics

external
	[
	vup
	vproc
	vphp1
	vsbhptype
	]

// Local statics

static	[
	vup
	vproc
	vphp1
	vsbhptype
	]


// Local structures

structure WFD:
	[ fWw	byte
	  [ ifdd	byte ] =	[ ww	byte ]
	]
manifest
	[ wfdNil = -1
	]


// 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
]

// E N P H P D 
// catalogue no.
and enphpd(proc) be
[ vsbhptype = "BM"
let dld = SDld
for ww = 0 to macww-1 do
	[ let wwd = mpWwWwd ! ww
	dld = SDld+lDld*(wwd>>WWD.dlFirst)
	for dl = wwd>>WWD.dlFirst to wwd>>WWD.dlLast do
		[ if dld>>DLD.pbm ne 0 then
			proc(dl, dld>>DLD.pbm)
		dld = dld+lDld
		] 
	] 
] 

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

and enphp(proc) be
[
let pctb, rgcp = nil, nil
let ppcd = nil
vsbhptype = "LP"
// for i = 0 to maxlp-1 do
// 	[
// 	if rglp ! i eq 0 then loop
// 	proc(rglp+i)
// 	]
// proc(lv vlp)
vsbhptype = "PCTB"
for i = 0 to maxdoc-1 do
	[  pctb = rgpctb ! i
	if pctb eq -1 then loop
	proc(rgpctb+i)
	] 
vsbhptype = "SBFN or OF or MPBI(FC or FB)"
for i = 0 to maxfn-1 do
	[ if inheap(mpfnsb ! i) then proc(lv(mpfnsb ! i))
	if inheap(mpfnof ! i) then proc(mpfnof+i)
	if inheap(rgmpbifc ! i) then proc(lv(rgmpbifc ! i))
	if inheap(rgmpbifb ! i) then proc(rgmpbifb+i)
	] 
// for i = 0 to macbp-1 do
// 	if dnbp ! i ne 0 then proc(lv(dnbp ! i))
vsbhptype = "FONT"
let tfdd = vfddfirst
while tfdd ne 0 do
	[ if (tfdd>>FDD.font ne 0) & (tfdd ne vfddlFixed) then
		proc(lv (tfdd>>FDD.font))
	tfdd = tfdd>>FDD.fddnext
	] 
if inheap(vfont) then proc(lv vfont)
vsbhptype = "BMNEW"
for ww = 0 to macww-1 do
	[ let wwd = mpWwWwd ! ww
	let dldNew = SDldNew+lDld*(wwd>>WWD.dlFirst)
	for dl = wwd>>WWD.dlFirst to wwd>>WWD.dlLast do
		[ if dldNew>>DLD.pbm ne 0 then
//			proc(dl, dldNew>>DLD.pbm)
			proc(lv (dldNew>>DLD.pbm))
		dldNew = dldNew+lDld
		] 
	] 
vsbhptype = "TEMP"
if inheap(vphp1) then proc(lv vphp1)
if inheap(diskKd) then proc(lv diskKd)
] // end enphp

// F I N D H P S P A C E
//
and findhpspace() = valof
	[
	let chpspace = 0
	let tphp = nil
	for ww = 0 to macww-1 do
		unless ww eq vwwlock do
			[ let wwd = mpWwWwd ! ww
			for dl = (wwd>>WWD.dlFirst)+1 to wwd>>WWD.dlLast do
				[ let dld = mpDlDld(dl)
				if dld>>DLD.pbm ne 0 then
					[ tphp = dld>>DLD.pbm-((offset HP.use)/16)
					chpspace = chpspace+@tphp
					]
				] 
			] 
	let tfdd = vfddfirst
	while tfdd ne 0 do
		[ if (tfdd>>FDD.font ne 0) & (tfdd ne vfddlFixed) then
			[ tphp = tfdd>>FDD.font-((offset HP.use)/16)
			chpspace = chpspace+@tphp
			]
		tfdd = tfdd>>FDD.fddnext
		] 
	chpspace = chpspace+ozonel+vpzone>>ZONE.cfree
	resultis chpspace
	]
	
// A D J U S T P H P D 
// catalogue no. 
and adjustphpd(id, phpnew) be
[ let dld = mpDlDld(id)
phpnew = phpnew+(offset HP.use)/16
let dcb = mpDldDcbBm(dld)
dcb>>DCB.sa = phpnew
dld>>DLD.pbm = phpnew
] 

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

and hpalloca(siz) = valof
[
unless hpguarantee(siz) then errhlta(101)
let adr = hpalloc(siz)
if adr ne 0 then resultis adr
if vcompactlock then errhlta(102)
compactdisplay( )
adr = hpalloc(siz)
if adr eq 0 then errhlta(103)
resultis adr
]


// H P G U A R A N T E E
//
and hpguarantee(cwNeeded, newzone, fFree, FddProc; numargs carg) = valof
[
if carg gr 1 then vpzone = newzone
if carg ls 3 then fFree = true
if carg ls 4 then FddProc = 0
let fm = CallersFrame() + 4
cwNeeded = cwNeeded + vpzone>>ZONE.ovh + displaybuf
let cwAvail = vpzone>>ZONE.cfree
unless ult(cwAvail, cwNeeded) do
	resultis true

let dlru = -1
	[
	let wfd = WfdOldest(dlru)
	if wfd eq wfdNil then break
	test wfd<<WFD.fWw ifso
		[
		let ww = wfd<<WFD.ww
		let wwd = mpWwWwd ! ww
		for dl = wwd>>WWD.dlLast to wwd>>WWD.dlFirst+1 by -1 do
			[
			let dld = mpDlDld(dl)
			let tcw = (dld>>DLD.pbm - (offset HP.use/16))>>HP.siz
			test fFree ifso
				[
				wwd>>WWD.hpUsed = wwd>>WWD.hpUsed - tcw
				pbmfirstfree = 1
				freedl(dl, dld)
				if dld>>DLD.ul ge ulMaxNorm then
					cnrgul = cnrgul - 1
				wwd>>WWD.dlLast = dl - 1
				cwAvail = vpzone>>ZONE.cfree
				]
			ifnot	cwAvail = cwAvail + tcw
			unless ult(cwAvail, cwNeeded) do
				resultis true
			] 
		dlru = DlruOld(wwd>>WWD.lru, fddlrutimer)
		]
	ifnot
		[
		let fdd = vfddfirst;
		for tifdd = 0 to wfd<<WFD.ifdd-1 do
			[
			if fdd eq 0 then errhlt("fdd")
			fdd = fdd>>FDD.fddnext;
			]
		unless inheap(fdd>>FDD.font) do errhlta(20);

		if FddProc ne 0 then
			FddProc(fm, fdd)

		test fFree ifso
			[
			hpfree(fdd>>FDD.font);
			fdd>>FDD.font = 0;
// 			vupdatemag = true;
			cwAvail = vpzone>>ZONE.cfree
			]
		ifnot	cwAvail = cwAvail + CwFddl(fdd)
		unless ult(cwAvail, cwNeeded) do
			resultis true
		dlru = DlruOld(fdd>>FDD.lru, fddlrutimer)
		]
	] repeat

unless ult(cwAvail, cwNeeded - displaybuf) do
	resultis true
resultis false
]


// W F D   O L D E S T

and WfdOldest(dlruMac; numargs carg) = valof
[
if carg ls 1 then dlruMac = -1
let wfd = wfdNil
let dlruOldest = 0

for ww = 0 to macww-1 do
	[
	if ww eq vwwlock then loop
	let wwd = mpWwWwd ! ww
	if wwd>>WWD.dlLast le wwd>>WWD.dlFirst then loop
	let dlru = DlruOld(wwd>>WWD.lru, fddlrutimer)
	if ugt(dlru, dlruOldest) & ult(dlru, dlruMac) then
		[
		dlruOldest = dlru
		wfd<<WFD.ww = ww
		wfd<<WFD.fWw = true
		]
	] 

let ifdd = 0
let fdd = vfddfirst
while fdd ne 0 do
	[
	unless fdd>>FDD.font eq 0 % fdd eq vfddlFixed do
		[
		let dlru = DlruOld(fdd>>FDD.lru, fddlrutimer)
		if ugt(dlru, dlruOldest) & ult(dlru, dlruMac) then
			[
			dlruOldest = dlru
			wfd<<WFD.ifdd = ifdd
			wfd<<WFD.fWw = false
			]
		]
	fdd = fdd>>FDD.fddnext
	ifdd = ifdd + 1
	]

resultis wfd
]

(1411)