// 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
 [
	next	word		//Pointer to next one.
	len	word		//Length of this one
	free	word		//Number of free words (at end)
	nchars	word		//Number of char representations here
	wavail	word		//Working temp
 ]

structure HTE :			//Hash table entry
 [
	ICC	word		//ICC this char (negated to "mark")
				// -1=empty; -2=deleted
	CoreAdr	word		//Pointer to char representation
	Age	word		//Used for LRU algorithm
	AgeList	word		//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)&#177774

	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&#170000) 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&#17)			//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&#17
   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&#17
	   ]

  	  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 &#77777	//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;
]
(1800)\18f1 56f0 40f1 53f0 189f1 74f0 10f1 64f0 8f1 62f0 12f1 67f0 8f1 50f0 8f1 33f0 8f1 65f0 8f1 33f0 13f1 11f0 2123b71B38b23B413b7B694b827B43b11B269b43B184b14B35b14B3306f1 16f0 19f1 79f0 153b7B967b31B415b4B13b7B5419b39B9b4B10b3B6b1B1068b3B10b7B25b3B79b6B620b8B31b7B122b7B218b3B8b7B201b23B33b2B30b3B159b3B225b7B171b7B1b3B32b3B340b8B19b42B67b4B247b7B17b7B790b370B332b7B3979b7B185b1B9b7B
//----------------------------------------------------------------------------
and GetFontSize(address) =  // helps with the code limitation
 ComputeFontSize(GetFontWord(address, 0), GetFontWord(address, 1))
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and ComputeFontSize(minusWidth, scansMinus1) = valof  // saves code
//----------------------------------------------------------------------------
[
// resultis ((-minusWidth) * (scansMinus1 + 1) + 15) / 16 + 2 evened up
let fontSize = vec 1; MulFull(-minusWidth, scansMinus1 + 1, fontSize);
DoubleAddV(fontSize, 15); if fontSize!0 ge #10 then PressError(1411);
DblShift(fontSize, 4); resultis fontSize!1 + 2 + 1 & -2;
]

//----------------------------------------------------------------------------
and GetFontWord(address, whichWord) =  // helps with the code limitation
 (UseXM? ((lv Read)(address+whichWord)), address!whichWord)
//----------------------------------------------------------------------------