// pressFontD.sr
// press Font Directory Module
// last modified September 16, 1977  5:58 PM

get "BRAVO1.DF";
get "ALTOFILESYS.D";
get "Q.DF";
get "PRESS.DF";
get "format.DF";
get "FONT.DF";
get "st.DF";

// Incoming Procedures

external [
	errhlta
	move;
	PutChar
	PutWds;
	WritePressBufs;
	RealDA;
	];

// Incoming Statics

external [
	Dl
	mpfunfafe;
	mpfunfd
	Pd
	pgnFirst
	vfun
	vfa
	vpep
	macfsn;
	mpfsnfs;
	];

// Outgoing Procedures

external [
	pressFontDirectory
	sbToDl
	vsbToDl
	]

// local structure
structure Bytes: [
	char↑ 0,255 byte
	]

// P R E S S F O N T D I R E C T O R Y
//
let pressFontDirectory() = valof
[
PutWds(1,Pd)		// for Part Directory
let beginRec = 
	(lv vpep>>PRESS.acfaCur)>>CFA.fa.pageNumber-pgnFirst
PutWds(beginRec,Pd)
		// I haven't a clue!!
for ifsn = fsndef+1 to macfsn-1 do
	[ let fs = mpfsnfs ! ifsn
	let mpfefunfa = lv(fs >> FS.rvmpfefunfa);
	for ife = 0 to 15 do
		[ 
		let funfa = mpfefunfa ! ife;
		unless funfa eq funfanil do
			createFontEntry(ifsn,
				funfa << FUNFA.fun,
				funfa << FUNFA.fa, ife)
		] 
	]
PutWds(0,Dl)			// terminator 
WritePressBufs(Dl,vpep)

PutWds((lv vpep>>PRESS.acfaCur)>>
	 CFA.fa.pageNumber-pgnFirst-beginRec,Pd)
PutWds(-1,Pd)
resultis true
]

// S B T O D L
//
and sbToDl(sb,num) be
[		// sb is BCPL string address
		// num=2*field width in words
		// padded with trailing zeros
let c =  sb>>SB.cch
test c ls num ifso
	num = num-c-1

ifnot [
	c = num-1
	sb>>SB.cch = c
	num=0
	]

for i = 0 to c do
	PutChar(sb>>Bytes.char↑i,Dl)
for i=1 to num do
	PutChar(0,Dl)
]

// V S B T O D L
//
and vsbToDl(sb,num) be
[		// sb is long BCPL string address
		// num=2*field width in words
		// padded with trailing zeros
let c =  sb>>SL.cch
test c ls num ifso
	num = num-c-1

ifnot [
	c = num-1
	sb>>SL.cch = c
	num=0
	]

for i = 1 to c+1 do
	PutChar(sb>>Bytes.char↑i,Dl)
for i=1 to num do
	PutChar(0,Dl)
]

 
// C R E A T E F O N T E N T R Y
//
and createFontEntry(fsn,fun,fa,fntn) be
	[
	PutWds(16,Dl)		// entry length, words
	PutChar(fsn,Dl)		// font set number
	PutChar(fntn,Dl)		// font number in set
	PutChar(0,Dl)		// m, but I can't find it
	PutChar(127,Dl)		// n, ditto


	let fd = mpfunfd ! fun;
	let fdh = lv(fd >> FD.fdh)
	let ht = fdh>>FDH.height

	test fun ge maxfun ifso
		[ 
		let tsb = nil
		switchon fun into
			[ 
case maxfun:		tsb = "TIMESROMAN"
			ht = 10
			endcase

case maxfun+2:		tsb = "KEYHOLE"
			ht = 20
			endcase

default:			errhlta(180);
			] 
		sbToDl(tsb,20)
		] 
 
	ifnot		// Family name, 20 bytes
		sbToDl(lv(fdh >> FDH.rvsbname),20)

	PutChar(fa,Dl)		// face
	PutChar(0,Dl)		// source
	PutWds(ht,Dl)
	PutWds(0,Dl)		// portrait
	]