// D0PackMB -- Pack a D0 .MB file for use with LRJ
// last edited January 27, 1982  5:10 PM, van Melle
// last edited August 6, 1980  9:46 AM

// Command line format is:
//	D0PackMB xxx.MB xxx.BR [startlabel/startaddress] (xxx.MB startlabel/startaddress)* [symbol]

	get "streams.d"

external
[		// O.S.
	Closes
	Endofs
	MoveBlock
	Noop
	OpenFile
	SetBlock
	Wo; Ws; WriteBlock
	Zero
	fpComCm
		// GP
	SetupReadParam
	ReadParam
		// ReadMB
	ReadMB
		// WriteBR
	StartBRfile
	StartBRnames; BRname
	StartBRlabels; BRlabel
	StartBRcode; BRcode
	EndBRblock
	EndBRfile
]


structure BS: [ length byte; char↑1,255 byte ]

static
[	imx = -1
	imap
	imv
	ni
	sa
	sav
]


let D0PackMB() be
[	let com = OpenFile(0, ksTypeReadOnly, charItem, 0, fpComCm)
	let nv, swv = vec 100, vec 100
	SetupReadParam(nv, swv, com, swv)
	let inst = ReadParam("IW", ".MB file (input): ", nv, swv)
	let outst = ReadParam("OW", ".BR file (output): ", nv, swv)
	let svv = vec 100
	sav = svv
	let imp = vec 10000b	// Imaginary to real address map
	imap = imp
	let imvec = vec 30000b	// Holds resulting IM data, 3 words per instruction
	imv = imvec
	let name, nextname = vec 128, vec 128
	let outcome = nil
	let totalni = 0

// at this point, we have inst open on (first) mb file, outst on br file
// Command line is startlabel [ next.mb startlabel ]* [symbol]

	StartBRfile(outst)
	StartBRcode()
	BRcode(0)	// Bldr zeros the first word!
			// But LRJ wants an extra word on the front anyway
	MoveBlock(name, "RamImage", 5)

   [    test Endofs(com)
	   ifso sa = 0
	  ifnot [ ReadParam($P, 0, svv, swv)
		  sa = readSA(svv)
		]
	ni = 0			// instruction counter
	SetBlock(imp, -1, 10000b)	// clear (-1) the virtual to real map

	outcome = ReadMB(inst, 20, pmemproc, (sa eq -1? psymproc, Noop))

	BRcode(imv, ni*3)	// dump out instructions
	let w0, w1, w2 = 7777b lshift 4, 0, sa
	BRcode(lv w0, 3)	// final entry has addr=7777, starting address
	Closes(inst)
	if outcome
	   then break		// error occurred
	Wo(ni); Ws("b instructions*N")
	if Endofs (com)		// more command line?
	   then break		// no, done
	ReadParam($P, 0, nextname, swv)
	test Endofs(com)	// more than one thing on com line?
	   ifso [ 		// no, nextname is a label for br file
		  if nextname!0
		     then MoveBlock(name, nextname, (nextname>>BS.length+1)/2)
		  break
		]
	  ifnot [ inst = OpenFile(nextname, ksTypeReadOnly, wordItem, 0)
		  if inst eq 0
		     then [ Ws ("Error: can't open ")
			    Ws (nextname)
			    Ws ("*N")
			    break
			  ]
		  totalni = totalni+ni
		]
   ] repeat			// do all mb files

	EndBRblock()
	Closes(com)
				// now write label section of br file
	StartBRnames()
	BRname(#140, 0, name)	// entry label xxx points at leading zero word
	let len = name>>BS.length+1
	for i = 0 to 4 do
	  name>>BS.char↑(len+i) = table[ $L; $a; $s; $t; 0]!i
	name>>BS.length = len+3
	BRname(#140, 0, name)	// entry label xxxLast points at 7777 entry
	EndBRblock()

	StartBRlabels()
	BRlabel(1, 0)		// initialize the initial label
	BRlabel(2, 1+totalni*3)	// initialize the Last label
	EndBRblock()
	EndBRfile()
	Closes(outst)

	if sa eq -1
	 then [ Ws("Error: starting address not found*N") ]
	if outcome
	   then [ Ws("Error: "); Ws(outcome); Ws("*N") ]
]

and readSA(sav) = valof
// Read starting address from string, return value if numeric or -1 if not
[	if sav>>BS.length eq 0 resultis -1	// null string
	let sa = 0
	for i = 1 to sav>>BS.length do
	[ let c = sav>>BS.char↑i
	  test (c ge $0) & (c le $7)
	   ifso sa = sa*10b+c-$0
	   ifnot resultis -1
	]
	resultis sa
]


and pmemproc(memx, width, name) = valof
[	test (name!0 eq 1000b+$I) & (name!1 eq $M*400b)
	 ifso [ imx = memx; resultis pimproc ]
	 ifnot resultis Noop
]

and pimproc(addr, data) be
[	let ima = data!3
	let p = imv+ni*3
	p!0, p!1, p!2 = (ima lshift 4) + (data!2 rshift 12), data!0, data!1
	imap!addr = ima
	ni = ni+1
]

and psymproc(memx, value, name) be
// Look up a symbolic starting address
if (sa eq -1) & (memx eq imx) then	// might have found it already
[	if name>>BS.length ne sav>>BS.length return
	for i = 1 to name>>BS.length do
	[ let c1 = name>>BS.char↑i
	  let c2 = sav>>BS.char↑i
	  if (c1 & not 40b) ne (c2 & not 40b) return	// case shift
	]
	sa = imap!value
	Ws(name); Ws(" ="); Wo(sa); Ws("*N")
]