[_CD8_]<press>PressSources.dm!2>ScanChars.bcpl

// ScanChars.bcpl

// last modified by Ramshaw, December 4, 1981 2:23 PM
// now use syncInfinity instead of 9999
// last modified by Ramshaw, April 6, 1981 12:14 PM
// - ScanCharInit, check to see if chips really exist for bank one before using it
// - ScanChar, take only as many bits as necessary for high bits
// of position from BEChar.ICC - 10/20
// - factor out GetFontSize, ComputeFontSize, and GetFontWord - 10/2
// - ScanCharLO, if UseXM & CoreAdr ugr -(iccMax + 1), swap in icc - 10/1
// - ScanCharFault, if SpaceAvail ls needed swap out leftovers - 10/1
// - ScanCharInit, if UseXM save iccMax addresses to swap out leftovers - 9/30
// - ScanChar, nobuffer, if UseXM try for XMSize/4 - 9/30
// - ScanChar, call ScanCharFault - 9/30
// - ScanCharFault, add Joe’s double precision needed computation - 9/26
// - ScanChar, keep high bits of bit position in BEChar.ICC - 8/7/80

// errors 1400
//
//Scan conversion pass on characters.
//WITH XM FONT STORAGE
//
//ScanCharInit()
//Called at beginning of scan conversion pass to initialize
//hash table, etc.
//ScanCharClose()
//Called at end of scan conversion pass to release core.
//ScanCharColor(c)
//Called whenever color is changed
//ScanChar(v)
//Called when a character has been extracted from a BAND list.
//v => table that contains a BEChar structure for char.
//Returns number of left-over words to record.
//ScanCharLO(v)
//Similar to ScanChar, but character has been extracted from a
//LeftOver list.
//

get "PressInternals.df"
get "PressParams.df"

// outgoing procedures
external
[
ScanCharInit
ScanCharClose
ScanCharColor
ScanChar
ScanCharLO
]

// outgoing statics
//external
//[
//]
//static
//[
//]

// incoming procedures
external
[
//PRESS
PressError
FSGetX
FSGet
FSPut
DblShift

//PRESSML
DoubleAdd;DoubleAddV;MulFull;DivFull
MulDiv
Ugt

//OS
MoveBlock
SetBlock
Zero

//WINDOWS
WindowInit
WindowClose
WindowGetPosition
WindowSetPosition
WindowRead
WindowWrite
WindowReadBlock
WindowDirty

//MEER
MeterBlock
]

// incoming statics
external
[
BESizes
DPzero

ScratchFile
GodFile

ScanBuf//Buffer for bits
ScanBitWc//Word count for scan line
mpSBuf//Addresses of scanline buffers
ScanS//Scan line of first in buffer
ScanColorTable//Color table pointer
ScanMax
ScanMin
currentScanColor

Left1RB//Leftover windows
Left2RB// "

UseMicroCode
FMCycles//Count of font memory cycles needed

Report
Debug
SoftScan
Transparent
]

external [ iccMax; longLines; ] // found in PreChars

// internal statics
static
[
CharHashTab//Hash table
CharBufList//List of character storage buffers
AgeList//List of HTE’s by age
CharScratchW//Window on scratch file
CharGodW//Window on dictionary file
CDPos//Position of icc table

relocBufBot//Two statics to help relocator
relocBufTop// last address +1

hashTablePopulation //number of characters in hash table
//incremented by ScanCharFault
//reset by CompactHash
ExtraFontSpace = 0
UseXM
XMSize = #177000
Read=#70006
Write=#70007
MoveBlockXM=#70010 // replace these with BitBlt someday
MoveBlockToXM=#70011
]

// File-wide structure and manifest declarations.

structure CB ://Character buffer header
[
nextword//Pointer to next one.
lenword//Length of this one
freeword//Number of free words (at end)
ncharsword//Number of char representations here
wavailword//Working temp
]

structure HTE ://Hash table entry
[
ICCword//ICC this char (negated to "mark")
// -1=empty; -2=deleted
CoreAdrword//Pointer to char representation
Ageword//Used for LRU algorithm
AgeListword//Linked list by age (oldest first)
]

manifest [
HTESize=size HTE/16//Size of hash table entry
HashShift=4//Shift amount for hash function
HashMask=(nCharsHash*HTESize-1)𫙮

hashTableSaturationLevel = (nCharsHash*8)/10
BankRegs=#177740
]

// Procedures

//----------------------------------------------------------------------------
let ScanCharInit() be
//----------------------------------------------------------------------------
[ compileif HTESize ne 4 then [ foo=0 ]//Masks set for this
CharHashTab=FSGetX(nCharsHash*HTESize)
SetBlock(CharHashTab,-1,nCharsHash*HTESize)

let version=(table [ #61014;#1403])()
UseXM=(version𩠐) eq #30000
if UseXM then
[
//try storing zero in location 1000
BankRegs!0=1//set emulator task XMAR appropriately
(lv Write)(1000,0)
if (lv Read)(1000) ne 0 then UseXM=false
]
if UseXM then
[
//try storing -1 in location 1000
(lv Write)(1000,-1)
if (lv Read)(1000) ne -1 then UseXM=false
]
if not UseXM then
//KLUDGE!! get rid of strategically placed XMAR instructions
[ //WriteRAM(high,addr,low)=
// [ sta 3,1,2;lda 3,3,2;WRTRAM;lda 3,1,2;jmp 1,3]
let WriteRAM=table [ #55001;#35003;#61012;#35001;#1401]
let ReadRAM=table [ #61011;#1401]
WriteRAM(ReadRAM(nil,#2023),#23,ReadRAM(nil,#23) xor #60000)
WriteRAM(ReadRAM(nil,#2024),#24,ReadRAM(nil,#24) xor #60000)
BankRegs!0=0//don’t use nonexistent chips
]
//Get core buffer space for characters.
CharBufList=0
let cnt=-20//No more than 20 buffers
let CoreNeeded=FontStoreSize+ExtraFontSpace//Amount to claim.
while CoreNeeded ne 0 do
[
cnt=cnt+1
let p=CoreNeeded+256
let a=nil
[
p=p-256
if p ls 0 % cnt eq 0 then PressError(1400)
if UseXM then [ p=size CB/16;CoreNeeded=p]
a=FSGet(p)
] repeatuntil a ne 0
CoreNeeded=CoreNeeded-p
a>>CB.next=CharBufList
if UseXM & Ugt(XMSize, -(iccMax + 1)) then XMSize = -(iccMax + 1);
a>>CB.len=UseXM?(XMSize),(p-(size CB/16))
a>>CB.free=UseXM?(XMSize),(p-(size CB/16))
a>>CB.nchars=0
CharBufList=a
]

//Scratch file has 3 buffers so one can always be in the vicinity of
// the CDPos table, and two others can be used to read character
// encodings.
CharScratchW=WindowInit(ScratchFile,3)
CharGodW=WindowInit(GodFile,1)
CDPos=FSGetX(2)
WindowSetPosition(CharScratchW,table [ 0;4] )
WindowReadBlock(CharScratchW,CDPos,2)//Pointer to icc table
AgeList=0
hashTablePopulation=0
]

//----------------------------------------------------------------------------
and ScanCharClose() be
//----------------------------------------------------------------------------
[ FSPut(CharHashTab)
while CharBufList do
[
let t=CharBufList>>CB.next
FSPut(CharBufList)
CharBufList=t
]
WindowClose(CharScratchW)
WindowClose(CharGodW)
FSPut(CDPos)
]

// Use microcode if color=black and told to use microcode
//----------------------------------------------------------------------------
and ScanCharColor(c) be
//----------------------------------------------------------------------------
[
@ScanPutChar=NoTrap
if c eq 0 & UseMicroCode ne 0 then @ScanPutChar = ScanPutCharTrap
]

//ScanChar(v) --and-- ScanCharLO(v)
//These routines are called from the extractor of BE’s from bands and
//leftover tables.
// **** These functions to be in microcode eventually ****

//ScanChar(v)
//Called when a character has been extracted from a BAND list.
//v => table that contains a BEChar structure for char.
//Returns number of left-over words to record.
//Calls ScanCharFault to get the character in core if necessary.
//----------------------------------------------------------------------------
and ScanChar(v) = valof
//----------------------------------------------------------------------------
[
if (not SoftScan & currentScanColor eq 0) & (not longLines) then
resultis 0; // ORbit does it all
if Transparent & (currentScanColor eq 255) then resultis 0; // nothing

let icc = v>>BEChar.ICC; // Get Char code.
if longLines then icc = icc & longLines;
if icc eq 0 then resultis 0; // dummy entry
let adr = ScanCharHash(icc); if adr eq -1 then resultis 0;
let ohw = GetFontWord(adr, 0); let ons = GetFontWord(adr, 1);
if (ohw eq 0) % (ons ls 0) then resultis 0; // Nothing to show; no leftover
let si = v>>BEChar.Sr; // Offset
let Bit = v>>BEChar.Bit; // address on scan line
if longLines then
[
let reverseTable = table [ 0;8;4;12;2;10;6;14;1;9;5;13;3;11;7;15; ]
Bit = Bit +
reverseTable!((v>>BEChar.ICC & not longLines) rshift 11) lshift 12;
]
v>>BELOChar.Bit = Bit;
v>>BELOChar.orbitW = ohw;
v>>BELOChar.orbitS = ons;
v>>BELOChar.bitOffset = 0;
v>>BELOChar.CoreAdr = adr + 2; // And install address

if Bit ls ScanMin then ScanMin = Bit
if (Bit - ohw) gr ScanMax then ScanMax = Bit - ohw
resultis ScanPutChar(si, v)//Go write the char.
]

//----------------------------------------------------------------------------
and ScanCharHash(icc) = valof
//----------------------------------------------------------------------------
[
let h = (icc xor (icc lshift HashShift)) & HashMask; // Hash it.
[
let c = CharHashTab!h;
compileif offset HTE.ICC ne 0 then [ foo=0 ]
if c eq icc then break; // Found it.
if c eq -1 then // an "empty", call ScanCharFaultICC to process fault.
resultis (ScanCharFaultICC(icc)? ScanCharHash(icc), -1); //Redo character
h = (h + HTESize) & HashMask; // Linear rehash
] repeat
(CharHashTab + h)>>HTE.Age = -1; // Say we referenced it
resultis (CharHashTab + h)>>HTE.CoreAdr;
]

//----------------------------------------------------------------------------
and ScanCharLO(v) = valof
//----------------------------------------------------------------------------
[
if UseXM & Ugt(v>>BELOChar.CoreAdr, -(iccMax + 1)) then
[
let iccAddress = ScanCharHash(-v>>BELOChar.CoreAdr);
if iccAddress eq -1 then PressError(1409);
v>>BELOChar.CoreAdr = CoreAddress(iccAddress, v);
unless v>>BELOChar.CoreAdr then PressError(1412);
]
let bitAddress = v>>BELOChar.Bit;
let fb = -(#170000 + v>>BELOChar.orbitW); // bits per scan
if bitAddress ls ScanMin then ScanMin = bitAddress;
if (bitAddress + fb) gr ScanMax then ScanMax = bitAddress + fb;
resultis ScanPutChar(0, v); // No offset
]

//ScanPutChar(Soff,v)
// V => BELOChar structure for character. Soff is number of scan lines
// at beginning of band to pass up. Returns 0 if no left-over, otherwise
// the number of words to put in the leftover list (size BELOChar/16)
// **** This function also in microcode ****

//----------------------------------------------------------------------------
and ScanPutChar(Soff, v) = valof
//----------------------------------------------------------------------------
[
let Bit=v>>BELOChar.Bit

let Badr=mpSBuf!Soff+(Bit rshift 4)//First band address
let ShiftCnt=(Bit)//Amount to shift a word
let nS=v>>BELOChar.orbitS+1//Number of scan lines remaining
let Fadr=v>>BELOChar.CoreAdr//Font address
let Fb=-(#170000+v>>BELOChar.orbitW)//Number of bits per scanline
let FracPart=Fb
let masks=
table [#177777;#177776;#177774
#177770;#177760;#177740
#177700;#177600;#177400
#177000;#176000;#174000
#170000;#160000;#140000
#100000;#177777
]
let lastMask=masks!(16-FracPart)
let Fw=(Fb+15)/16//number of output words per scanline
let inputShiftAmt=v>>BELOChar.bitOffset
let Cycle=table [ #60000;#1401]
let rightMask1=-1 rshift ShiftCnt
let leftMask1=not rightMask1

//color calculations
let s=ScanS+Soff
let cycleLen=ScanColorTable!0
let cyclePerBlock=ScanColorTable!1
let linesPerBlock=ScanColorTable!2
let blockNum=s/linesPerBlock
let lineNum=s rem linesPerBlock
let wordOffset=Bit rshift 4
let colorLine=ScanColorTable+3+lineNum*cycleLen
let lineIndex=(blockNum*cyclePerBlock+wordOffset) rem cycleLen
let color=colorLine!lineIndex

[
let leftMask=masks!inputShiftAmt
let rightMask=not leftMask
let nextW=Cycle(GetFontWord(Fadr, 0),inputShiftAmt)
let WLEFT=0

for j=1 to Fw do
[ let thisW=nextW&leftMask
nextW=Cycle(GetFontWord(Fadr, j),inputShiftAmt)
thisW=thisW+(rightMask&nextW)
if j eq Fw then//update shiftAmt, mask w
[ thisW=thisW&lastMask
inputShiftAmt=inputShiftAmt+Fb
Fadr=Fadr+inputShiftAmt/16
inputShiftAmt=inputShiftAmt
]

if thisW then //Play only if non-zero
[ thisW=Cycle(thisW,16-ShiftCnt)
WLEFT=(thisW&rightMask1)%WLEFT
]
if WLEFT then
[ compileif DebugSw then
[let ScanBufLast=ScanBuf-(ScanBuf!-1)-2
if Ugt(ScanBuf,Badr) % Ugt(Badr+1,ScanBufLast) then
PressError(1401)
]
Badr!0=(Badr!0 & (not WLEFT))% (WLEFT & color)
]
WLEFT=thisW&leftMask1
Badr=Badr+1
lineIndex=lineIndex+1;if lineIndex eq cycleLen then lineIndex=0
color=colorLine!lineIndex
] //end of for j=1 to Fw

Badr!0=(Badr!0 & (not WLEFT))% (WLEFT & color)
Badr=Badr+ScanBitWc-Fw//Bump to new scan line

compileif MeterSw then
[
let inc=vec 1
inc!0=0; inc!1=Fw
DoubleAdd(FMCycles, inc)
]

nS=nS-1
if nS eq 0 then resultis 0//No more to do on this char
Soff=Soff+1
if Soff eq BANDWidth then break//Must leave leftovers

//and color update for new scan line
lineNum=lineNum+1
if lineNum eq linesPerBlock then [ lineNum=0;blockNum=blockNum+1]
colorLine=ScanColorTable+3+lineNum*cycleLen
lineIndex=(blockNum*cyclePerBlock+wordOffset) rem cycleLen
color=colorLine!lineIndex
] repeat

v>>BELOChar.CoreAdr=Fadr//New font address
v>>BELOChar.orbitS=nS-1//New # scan lines remaining
v>>BELOChar.bitOffset=inputShiftAmt

resultis size BELOChar/16
]

//ScanCharFault(v)
// Called when hashing on (BAND) character v yields no luck. Read in
// character, relocating addresses saved in left over lists if necessary,
// and update hash table. Caller should then try to hash again.
// Returns true if able to page in char; false if should not try again.

//----------------------------------------------------------------------------
and ScanCharFault(v) = valof
//----------------------------------------------------------------------------
[
compileif ReportSw then
[ Report>>REP.nCharFaults = Report>>REP.nCharFaults + 1; ]

let icc=v>>BEChar.ICC; // Get character code.
if longLines then icc = icc & longLines;

compileif MeterSw then
[
let vs = vec size FAULTStat / 16;
vs>>FAULTStat.ICC = icc;
MeterBlock(METERFault, vs, size FAULTStat / 16);
]

resultis ScanCharFaultICC(icc);
]

//----------------------------------------------------------------------------
and ScanCharFaultICC(icc) = valof
//----------------------------------------------------------------------------
[
//Update AgeList by going down it and removing from the list all
// those chars that have been referenced since last time (Age ne 0),
// and appending these on the end. Now AgeList is a list of HTE’s in
// order of: (1) chars that have seen little recent use (not including empty
// or deleted HTE’s), and (2) chars that have seen recent use.

let nat=0//New age list tail
let AgeLast=nil
let prev=(lv AgeList)-(offset HTE.AgeList/16)
[
let p=prev>>HTE.AgeList
if p eq 0 then break//Done.
test p>>HTE.Age then
[
let n=p>>HTE.AgeList//Next entry
prev>>HTE.AgeList=n//Take this one off
p>>HTE.AgeList=nat
if nat eq 0 then AgeLast=p//New last one
nat=p
p>>HTE.Age=0//Till next time.
]
or prev=p
] repeat
prev>>HTE.AgeList=nat//Paste (possibly null) list on end
if nat eq 0 then AgeLast=prev

//Position appropriate file for reading the character.
let t=vec 1
t!0=0; t!1=icc*2
DoubleAdd(t,CDPos)//File pos for pointer
WindowSetPosition(CharScratchW,t)
WindowReadBlock(CharScratchW,t,2)
let win=CharScratchW
if t>>FPOS.File eq FPOSGod then win=CharGodW
if t>>FPOS.File eq FPOSDNE then PressError(1402)
WindowSetPosition(win,t)

//Read FHEADp word to decide how many words needed for char.

let ohw=WindowRead(win)
let ons=WindowRead(win)
let needed = ComputeFontSize(ohw, ons);

//Now go through buffers, looking for available space. If found,
// break, leaving address of spot and buffer set up.

let b=CharBufList
while b do
[
b>>CB.wavail=0//Getting set for below
//if b>>CB.free ge needed then break
if Ugt(b>>CB.free+1,needed) then break//Found one!
b=b>>CB.next
]

//If no space found, go through left over lists and mark in hash table the
// chars pointed to by them, by making ICC entries in hash table negative.

let markLeftOvers = true;
let needHashSpace=hashTablePopulation gr hashTableSaturationLevel
if (b eq 0)%needHashSpace then
[nobuffer//More work!!!

LeftOverMarkNeeded(Left1RB, markLeftOvers);
LeftOverMarkNeeded(Left2RB, markLeftOvers)

//Now remove HTE’s from head of AgeList that have not been marked as
// essential to left-over lists, and reclaim space, keeping relocation table.
// The amount of space reclaimed is ScanSpaceReclaim/10 times the amount
// needed. This makes subsequent calls faster, but may toss out some
// characters that have been recently used.

let spaceAvail=0
let sizeToTryFor=MulDiv(needed, ScanSpaceReclaim, 10)
if UseXM then sizeToTryFor = XMSize rshift 2;
let p=AgeList
let releaseCount=needHashSpace?(nCharsHash/10),0

while p do
[
if p>>HTE.ICC ge 0 then
[//Can remove this one.
let adr = p>>HTE.CoreAdr
let siz = GetFontSize(adr)
let bTry=CharBufList//Look through buffers
while bTry do
[
if UseXM%(Ugt(adr,bTry)&Ugt(bTry+bTry>>CB.len+size CB/16,adr)) then
[
siz=bTry>>CB.wavail+siz
bTry>>CB.wavail=siz//Assume we can use this one.
break
]
bTry=bTry>>CB.next
]
if bTry eq 0 then PressError(1403)//Didn’t find the character
releaseCount=releaseCount-1
if siz gr spaceAvail then
[
spaceAvail=siz
b=bTry
if (siz ge sizeToTryFor)&(releaseCount ls 0) then break
]
]
p=p>>HTE.AgeList
]
let Lastp=p//We looked this far.

let Reloc=0//No relocation.

if spaceAvail ge needed then
[Reclaim

//b has buffer to work on.
let btop=b>>CB.len+(UseXM?0,(b+size CB/16))
relocBufBot=UseXM?0,b; relocBufTop=btop

// Build relocation list (Reloc)
// Each entry identifies a "hole" that is being opened up:
// HTE.CoreAdr = first address of hole
// HTE.Age = last address of hole +1
let prev=(lv AgeList)-(offset HTE.AgeList/16)

[
p=prev>>HTE.AgeList
if p eq 0 then break//Only happens if not enough core
let adr=p>>HTE.CoreAdr
//normally, an address is always strictly greater than relocBufBot,
//due to size CB words of leader. This is not true for XM fontstore,
//so we need UGe, simulated by Ugt(adr+1,relocBufBot)
let a1=adr+(UseXM?1,0)
test (p>>HTE.ICC ge 0)&Ugt(a1,relocBufBot)&Ugt(relocBufTop,adr) then
[
p>>HTE.ICC=-2//Deleted entry
prev>>HTE.AgeList=p>>HTE.AgeList//Take off AgeList
if p eq AgeLast then AgeLast=prev
let hsiz = GetFontSize(adr);
b>>CB.free=b>>CB.free+hsiz
let lastPlus1=adr+hsiz

//Now sort the hole [adr, lastPlus1) into the Reloc list:
Sort1:let prevR=(lv Reloc)-(offset HTE.AgeList/16)
[
let r=prevR>>HTE.AgeList
let rAdr=r>>HTE.CoreAdr
if r eq 0 % Ugt(rAdr, lastPlus1) then
[
prevR>>HTE.AgeList=p
p>>HTE.Age=lastPlus1
p>>HTE.AgeList=r
break
]
if rAdr eq lastPlus1 then [ r>>HTE.CoreAdr=adr; break ]
if r>>HTE.Age eq adr then [ r>>HTE.Age=lastPlus1; break ]
prevR=r
] repeat
if p eq Lastp then break
] or prev=p
] repeat

//Now relocate the LeftOver lists.
if markLeftOvers then
[ LeftOverRelocate(Left1RB,Reloc); LeftOverRelocate(Left2RB,Reloc) ]

RelocM:
//Now move core around in this buffer.
let rel=Reloc
let offs=0
let curBot=UseXM?0,(b+size CB/16)
[
let Move=UseXM?(lv MoveBlockXM),MoveBlock
let adr=rel>>HTE.CoreAdr
if rel eq 0 then adr=btop
if offs then Move(curBot+offs, curBot, adr-curBot)
if rel eq 0 then break
curBot=rel>>HTE.Age
offs=offs-(curBot-adr)
rel=rel>>HTE.AgeList
] repeat

]Reclaim

//Now "unmark" any relevant HTE’s and relocate them.

p=AgeList
while p do
[
p>>HTE.CoreAdr=Relocate(p>>HTE.CoreAdr, Reloc)
p>>HTE.ICC=p>>HTE.ICC 𒿑//Turn off sign bit
p=p>>HTE.AgeList
]

if spaceAvail ls needed then test UseXM & markLeftOvers
ifso [ markLeftOvers = false; loop; ]
ifnot [ PressError(1404); resultis false; ] //No point in displaying char

break;
]nobuffer repeat // repeat allows us to loop to swap out leftovers

//Compute hash, find free spot in hash table.
let h=(icc xor (icc lshift HashShift))&HashMask
let cnt=-nCharsHash
[
let c=CharHashTab!h//Entry
if c ls 0 then break//Found a good spot
cnt=cnt+1
if cnt eq 0 then [ PressError(1405); resultis false ]
h=(h+HTESize)&HashMask
] repeat

//We have finally found a buffer (b) in which to put the new character.
// Read in character.
let p=nil
test UseXM then
[ p=b>>CB.len-b>>CB.free
(lv Write)(p,ohw)
(lv Write)(p+1,ons)
let bank0=vec 256
let bank1=p+2
let toRead=needed-2
while toRead gr 256 do
[ WindowReadBlock(win,bank0,256)
(lv MoveBlockToXM)(bank1,bank0,256)
bank1=bank1+256
toRead=toRead-256
]
WindowReadBlock(win,bank0,toRead)
(lv MoveBlockToXM)(bank1,bank0,toRead)
]
or
[ p=b+(size CB/16)+b>>CB.len-b>>CB.free//Pointer to new spot
p!0=ohw//Put in header word
p!1=ons
WindowReadBlock(win,p+2,needed-2) //Read rest of character
]
b>>CB.free=b>>CB.free-needed

//Put this HTE on the end of the AgeList
let q=CharHashTab+h//Pointer to HTE for us.
q>>HTE.ICC=icc
q>>HTE.CoreAdr=p//This is where we put it
q>>HTE.Age=0
q>>HTE.AgeList=0//Put this at the end of the
AgeLast>>HTE.AgeList=q// age list.
hashTablePopulation=hashTablePopulation+1

//Now compact the hash table.
CompactHash()
resultis true
]

//Need to compact hash table because otherwise, there get to be a
// lot of "deleted" entries, and the table gets slow and also
// may eventually cause the hash routine to loop indefinitely.

and CompactHash() be
[
let moves=nil
[
moves=0
let op=(lv AgeList)-(offset HTE.AgeList/16)
[
let p=op>>HTE.AgeList
if p eq 0 then break
// Process HTE entry pointed to by p. Use its ICC to re-hash it.
// If, as you go down the hash chain, you find a deleted spot,
// move this entry to there.
let icc=p>>HTE.ICC
let h=(icc xor (icc lshift HashShift))&HashMask
[
if CharHashTab+h eq p then break//Found it
if CharHashTab!h ls 0 then
[
MoveBlock(CharHashTab+h, p, (size HTE/16))
p!0=-2//Deleted
p=CharHashTab+h
op>>HTE.AgeList=p
moves=moves+1
break
]
h=(h+HTESize)&HashMask
] repeat
op=p
] repeat
] repeatuntil moves eq 0

// Now go through table marking each empty or deleted entry as empty
let delCount=0
let p=CharHashTab
for i=0 to nCharsHash-1 do
[
if @p ls 0 then
[
@p=-1//Empty
delCount=delCount+1
]
p=p+(size HTE/16)
]
hashTablePopulation=nCharsHash-delCount
if delCount eq 0 then [ PressError(1405) ]
]

and Relocate(thisadr, Reloc) = valof
[
if Ugt(relocBufBot,thisadr) % Ugt(thisadr,relocBufTop) then resultis thisadr
let offs=0
[
let adr=Reloc>>HTE.CoreAdr
if Reloc eq 0 % Ugt(adr, thisadr) then
[
compileif DebugSw then
[
if Ugt(relocBufBot, thisadr+offs) % Ugt(thisadr+offs, relocBufTop)
then PressError(1407)
]
resultis thisadr+offs
]
offs=offs-(Reloc>>HTE.Age-adr)
Reloc=Reloc>>HTE.AgeList
] repeat
]

//LeftOverMarkNeeded(leftoverwindow)
// Go through the leftover list.
// If mark is true then mark the entries in the hash table for characters that
// are referred to in the left over list.
// If mark is false then "swap out" the characters.

//----------------------------------------------------------------------------
and LeftOverMarkNeeded(Left, mark) be ForLeftOver(Left, MarkNeededLO, mark);
//----------------------------------------------------------------------------

//LeftOverRelocate(leftoverwindow,reloctable,numrelocations)
// Go through the leftover list and do any relocations that may be
// necessary (see above for format of relocation table).

//----------------------------------------------------------------------------
and LeftOverRelocate(Left,Reloc) be ForLeftOver(Left,RelocateLO,Reloc)
//----------------------------------------------------------------------------

//"Map" function for leftover entries.

//----------------------------------------------------------------------------
and ForLeftOver(win,fun,a1) be
//----------------------------------------------------------------------------
[
let opos=vec 1
WindowGetPosition(win,opos)//Remember current position
test win>>RB.Reading then //check for already at end
[ if win>>RB.Sync eq syncInfinity then return //yup, at end
]
or
[//Writing, so must dummy up an end
WindowWrite(win,BEEndH)
WindowSetPosition(win,DPzero) //Start at beginning
]
let v=vec 100

[
v!0=WindowRead(win)
test v!0 ls 0 then
[//Character....
WindowReadBlock(win,v+1,size BELOChar/16-1)
fun(win,v,a1)//Call function
]
or
[
if v!0 eq BEEndH then break//End
WindowReadBlock(win,v+1,BESizes!(v!0)-1)
]
] repeat//For entire left over list

WindowSetPosition(win,opos)//Restore position
]

//----------------------------------------------------------------------------
and MarkNeededLO(win, v, mark) be
//----------------------------------------------------------------------------
[
let fontAddress = v>>BELOChar.CoreAdr; // Current font address
if UseXM & Ugt(fontAddress, -(iccMax + 1)) then return; // Swapped out?
let p = AgeList; while p ne 0 do // Look in hash table for it
[
let hteAddress = p>>HTE.CoreAdr;
let nextAddress = hteAddress + GetFontSize(hteAddress);
if Ugt(fontAddress, hteAddress) & Ugt(nextAddress, fontAddress) then
[ // This is it.
test mark
ifso p>>HTE.ICC = p>>HTE.ICC % #100000; // Turn on a bit
ifnot test fontAddress eq CoreAddress(p>>HTE.CoreAdr, v)
ifso ChangeCoreAddress(win, -p>>HTE.ICC);
ifnot PressError(1410);
break
]
p = p>>HTE.AgeList;
]
if p eq 0 then PressError(1406);
]

//----------------------------------------------------------------------------
and RelocateLO(win, v, Reloc) be
ChangeCoreAddress(win, Relocate(v>>BELOChar.CoreAdr, Reloc))
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and ChangeCoreAddress(win, newWord) be
//----------------------------------------------------------------------------
// Change the BELOChar.CoreAdr word in the buffer. Note that this code
// depends on the word being the last in the BELOChar structure.
// The "compileif" tries to make sure that this is true.
[
compileif offset BELOChar.CoreAdr ne size BELOChar -16 then [ foo=0 ]
(win>>W.Base)!(win>>W.Offset-1) = newWord;
WindowDirty(win)//...
]

//----------------------------------------------------------------------------
and CoreAddress(iccAddress, v) = valof // v is a BELOChar
//----------------------------------------------------------------------------
// uses the height and width of the whole character and how many leftover
// scans there are to compute the word pointer into the character
// N.B. UseXM must be true.
// called by ScanCharLO and SwapOutLO
// returns 0 if v>>BELOChar.bitOffset is inconsistent
[
let width = -(lv Read)(iccAddress);
let scansMinus1 = (lv Read)(iccAddress + 1);
let scansDone = scansMinus1 - v>>BELOChar.orbitS;
let bitsDone = vec 1; MulFull(width, scansDone, bitsDone);
if (bitsDone!1 & #17) ne v>>BELOChar.bitOffset then resultis 0;
DblShift(bitsDone, 4); resultis iccAddress + 2 + bitsDone!1;
]