// xcompact.srCompact 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:
[ fWwbyte
[ ifddbyte ] =[ wwbyte ]
]
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
]
ifnotcwAvail = 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
]
ifnotcwAvail = 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
]