// F O N T M A K E -- font load assembly 
//  errors 650-699
//
//

get "Spruce.d"

// outgoing procedures
external
	[
	FontMakeup
	]

// incoming procedures
external
	[
//SPRUCE
	SpruceError
	SpruceCondition
	FSGetX
	FSPut
	Min

// SpruceBand (buffer management routines)
	FlushBuffers

//WINDOW,FILES
	WindowGetPosition
	WindowSetPosition
	WindowReadBlock
	WindowWriteBlock	
	WindowRead
	WindowWrite
	WindowNextPage
	WindowCopy

//CURSOR
	CursorChar
	CursorDigit
//OS
	Zero
	MoveBlock

//SPRUCEML
	DoubleAdd; DoubleSub; DoubleCop; MulDiv
	OrbitCharSize

	SwapOnSpoolRequest
	]

// incoming statics
external
	[
	FontWindow; BandWindow; BandFree; BandAvail; emergencyStorage; xmFonts
	]
let FontMakeup(pDoc) be
[
	CursorChar($F)
	let nFontLoads=pDoc>>DocG.nFontLoads
	let ICCtotal=pDoc>>DocG.ICCtotal
	let fontIndex=FSGetX(ICCtotal)	//For building pointer table
	let pFonts=FSGetX(nFontLoads*(size FontG/16))
	pDoc>>DocG.Fonts=pFonts

	let fi=pDoc>>DocG.fontLoadList
while fi ne 0 do
    [FI
    SwapOnSpoolRequest() // ~~
    CursorDigit(fi>>FI.fontLoad)
    FlushBuffers(true)			// Get an initial buffers set up -- assumed clear to start
    let q=fi+(size FI/16)		//Pointer to ICC bit table
    let m=100000b
    let rec=WindowNextPage(BandWindow)
    Zero(fontIndex, ICCtotal)
    WindowWriteBlock(BandWindow, (table [ -1;0;0;0 ]), 4) 	//Dummy
    let charpos=4

    let p=pDoc>>DocG.fontList	//Go down ICC's, filling in
    while p ne 0 do
	[FN
	let CD=0
	let bc = p>>FN.bc
	let nc=p>>FN.ec-bc+1
	let relPosAdr=vec 2
	let tallest, widest = -p>>FN.tallest, p>>FN.widest-1

	for c=0 to nc-1 do
	[c
	if (@q & m) ne 0 then		//Char is needed
	    [ICCneed
	    if CD eq 0 then			//Need to read char posns
		[
		relPosAdr!0=0; relPosAdr!1=nc*(size CharWidth/16)
		DoubleAdd(relPosAdr, lv p>>FN.sa)
		CD=FSGetX(nc*2)
		WindowSetPosition(FontWindow, relPosAdr)
		WindowReadBlock(FontWindow, CD, nc*2)
		]
	    fontIndex!(c+p>>FN.ICCOffset)=charpos	//Relative pointer
	    let cp=CD+c+c
	    DoubleAdd(cp, relPosAdr)
	    WindowSetPosition(FontWindow, cp)
	    let nHeight=WindowRead(FontWindow)
	    let Widthm1=WindowRead(FontWindow)
	    compileif DebugSw then [
		if nHeight>0 % nHeight< tallest % Widthm1<0 % Widthm1>widest then
			SpruceCondition(650,ECFileTerminate,c+bc,p) ]
	    let siz=OrbitCharSize(-nHeight, Widthm1+1)-2
	    charpos = charpos+siz+2
	    if BandAvail+2 ge 0 % emergencyStorage eq 0 then FlushBuffers(true)
	    BandFree!0 = nHeight
	    BandFree!1 = Widthm1
	    BandFree = BandFree+2; BandAvail = BandAvail+2
	    while siz do
		[
		let this = nil
		    [
		    this = Min(siz, -BandAvail)
		    if this>0 break
		    FlushBuffers(true)
		    ] repeat
		BandAvail = BandAvail+this
		WindowReadBlock(FontWindow, BandFree, this)
		BandFree = BandFree+this
		siz = siz-this
		]
	    ]ICCneed
	m=m rshift 1
	if m eq 0 then
		[
		m=100000b
		q=q+1
		]
	]c
	if CD then FSPut(CD)
	p=p>>FN.next
	]FN
// Finished writing ICC's for this font load.  Check to see
// if all calculations worked out:
    if charpos ne fi>>FI.fontLength then SpruceError(690)
    FlushBuffers(false)
    if xmFonts then WindowNextPage(BandWindow)		//Align ICC table to next page
    WindowWriteBlock(BandWindow, fontIndex, ICCtotal)	//Index table
    let recEnd=WindowNextPage(BandWindow)

    let f=fi>>FI.fontLoad*(size FontG/16)+pFonts
    f>>FontG.nRecords=recEnd-rec
    f>>FontG.bandPos=rec
    f>>FontG.fontLength=charpos

    fi=fi>>FI.next
    ]FI

    FSPut(fontIndex)
]

// DCS, October 17, 1977  9:33 PM, use FN.tallest, widest for font validity check
// October 23, 1977  1:16 PM, buffer FontMakeup pass
// October 25, 1978  10:37 AM, use WindowCopy again in font makeup
// October 26, 1978  10:17 PM, use (better) large buffer again in font makeup
// November 3, 1978  11:11 PM, make better use of band buffer list at font time, allow very lg. chars.
// November 10, 1978  3:32 PM, better font name in error message
// April 7, 1979  4:23 PM, align ICC table to full disk page boundary for xmFonts version
//