//MDload -- load the Micro binaries into memory
// last edited July 5, 1980  10:08 AM

	get "mddecl.d"
	get "streams.d"
	get "altofilesys.d"

external [	// defined here
	Load	// (sources, outs, tempzone, zone, loader(...))
	SkipMicroString	// (sp) -> p
	@Symbols; @SymLength
	fixTab
		// for MDload1
	AllocInbuf	// (zone, len)
	OpenSource	// (source) -> s
	LoadFile	// (strm, tempzone, dataproc, symproc, memproc, fixproc, xfixproc)
	dataIM0; dataIM1; dataIM2
	dataRM; dataIFUM; dataALUFM
	dataDISP; dataIMLOCK; dataIMMASK
	dataOther; dataSkip
	@mData
	@mWidths
	@mNames
	@mSymMax
]

external [
		// OS
	CreateDiskStream; Endofs; Closes
	ReadBlock
	MoveBlock; SetBlock; Usc; Zero
	Allocate; Free
	Noop
		// GetSetBits
	SetBits
		// MDmain
	@IP
	ScratchZone
	@DMachine
	@IM; @IMlocked; @NInstructions; @IMMASK
	@RM; @RMbits
	@IFUM; @IFUMbits; @NIFUM
	@ALUFM; @ALUFMbits
		// MDerr
	Err
	PutAddress
		// MDasm
	Get1Bit; Set1Bit
]


manifest
[	lLoadSpace = lKS+400b
]

//Memories expected by MicroD are as follows:
//	For D0:
//  1 IM 6 words (84 bits)
//  2 RM 1 word
//  - DISP 1 word
//  - IMLOCK 1 word (1 bit)
//  - VERSION 1 word
//  - IMMASK 2 words (20 bits)
//	For Dorado:
//  1 IM 5 or 6 words (80 or 96 bits)
//  2 RM 1 word
//  3 IFUM 2 words
//  4 ALUFM 1 word (8 bits)
//  - DISP 1 word
//  - IMLOCK 1 word (1 bit)
//  - RVREL 0 words
//  - VERSION 1 word
//  - IMMASK 2 words (20 bits)

static [
	@mData
	@mWidths
	@mNames
	@mSymMax
	fixTab = 0
	@inbuf; @lInbuf; @einbuf
	@Symbols
	@SymLength = 301b	// See hash algorithm in AddSym
	loadSpace
]


let AllocInbuf(zone, len) be
[	lInbuf = len
	inbuf = Allocate(zone, len)
	einbuf = inbuf+lInbuf
]

and Load(Sources, OutS, tempzone, zone, loader) be
[	NInstructions, NIFUM, IMMASK = 0, 0, 0
	loadSpace = Allocate(tempzone, lLoadSpace)
	let source = Sources
	while source ne 0 do
	 [ loader(source, OutS, tempzone, zone)
	   source = source>>Source.next
	 ]
	if DMachine eq 2 then	// shuffle bits for Dorado model 1
	 for i = 0 to NInstructions-1 do
	[ let ip = IP(i)
	  let w0, w1, w2 = ip>>IM.iw0, ip>>IM.iw1, ip>>IM.iw2
	  ip>>IM.iw0 = (w0 lshift 1) + (w1 rshift 15)
	  ip>>IM.iw1 = (w1 lshift 1) + (w2 rshift 15)
	  ip>>IM.iw2 = (w0 & 100000b) + (w2 & 77777b)
	]
	Free(tempzone, loadSpace, lLoadSpace)
]

and OpenSource(source) = valof
[	let S = CreateDiskStream(source>>Source.pFP, ksTypeReadOnly, wordItem, 0, 0, ScratchZone(loadSpace, lLoadSpace))
	if S eq 0 then Err(Fatal, "Can't open $S", source>>Source.pName)
	resultis S
]

and LoadFile(S, tempzone, zone, dataproc, symproc, memproc, fixproc, xfixproc) be
// Main code -- load one file
[ let MemX,Addr = -1,nil
  let dwords = nil
  let Ibase = NInstructions
  let BP = einbuf
  let end, endstop = einbuf, einbuf-maxMBblock
  let ddisp, adr, ip, idata = mData!0, nil, nil, nil	// to avoid making a block out of MBdata
  // begin main loop
  [ let more, blockdisp = nil, vec 8	// faster than switchon
    SetBlock(blockdisp, blockError, 8)
      blockdisp!MBend = blockEnd
      blockdisp!MBdata = blockData
      blockdisp!MBaddress = blockAddress
      blockdisp!MBfixup = blockFixup
      blockdisp!MBmemory = blockMemory
      blockdisp!MBsymbol = blockSymbol
      blockdisp!MBexternalfixup = blockExternalfixup
    more = labelMore	// for faster looping
labelMore:
    if BP gr endstop then
	[ if end eq einbuf then
	  [ MoveBlock(inbuf, BP, end-BP)
	    end = inbuf+end-BP
	    BP = inbuf
	    let nw = einbuf-end
	    nw = ReadBlock(S, end, nw)
	    end = end+nw
	    endstop = end-maxMBblock	// reset end test
	  ]
	  if BP ge end then
	    Err(Fatal, "Unexpected end of input file")
	]
    if (@BP & -8) ne 0 then goto blockError
    goto blockdisp!@BP

// Block types created by Micro
blockEnd:					// terminating block
	break

blockData:				// data word
	adr = Addr; Addr = Addr+1
	goto ddisp
dataOther:
	dataproc(BP, MemX, adr, dwords)
	// falls through
dataSkip:
	BP = BP+dwords
	goto more
dataIM0:	// D0 -- iw2 at end
	ip = IP(adr)
	idata = BP+1	// iw2 missing
	ip>>IM.iw2 = BP!7
	goto dataIMall
dataIM1:	// Dorado model 0 -- no iw2
	ip = IP(adr)
	idata = BP+1	// iw2 missing
	goto dataIMall
dataIM2:	// Dorado model 1 -- iw2 follows iw1
	ip = IP(adr)
	idata = BP+2
	ip>>IM.iw2 = idata!2
	// falls through
dataIMall: [	// common IM code
	ip>>IM.iw0, ip>>IM.iw1 = BP!2, BP!3
	ip!3, ip!4, ip!5 = idata!3, idata!4, idata!5
	// Adjust W1 and W2
	let w = ip>>IM.W1word
	ip>>IM.W1word = ((w&(IMsize-1)) eq WNull? adr+(1-WNull), Ibase)+w
	w = ip>>IM.W2word
	ip>>IM.W2word = ((w&(IMsize-1)) eq WNull? adr+(1-WNull), Ibase)+w
	if NInstructions ne adr then
	  Err(PassFatal, "$P....Imaginary addresses not consecutive ($O follows $O)", PutAddress, NInstructions, adr, NInstructions-1)
	NInstructions = adr+1
	if NInstructions gr NImax then IMfull()
	BP = BP+dwords
	goto more ]
dataRM: [	// RM
	let RP = RM+adr
	if (Get1Bit(RMbits, adr) ne 0) & (@RP ne BP!2) then
	  Err(NonFatal, "Attempt to load RM[$O] twice", adr)
	@RP = BP!2
	Set1Bit(RMbits, adr, 1)
	BP = BP+3
	goto more ]
dataIFUM: [	// IFUM
	let dp = BP+2
	let ifad = dp>>IFUM.IFAD
	if ifad ne WNull then dp>>IFUM.IFAD = ifad+Ibase	// relocate entry address
	if adr ge NIFUM then NIFUM = adr+1
	let ip = IFUM+adr*lIFUM
	test Get1Bit(IFUMbits, adr) ne 0
	 ifso Err(PassFatal, "Attempt to load IFUM[$O] twice", adr)
	 ifnot
	[ ip!0, ip!1 = BP!2, BP!3
	  Set1Bit(IFUMbits, adr, 1)
	]
	BP = BP+4
	goto more ]
dataALUFM: [	// ALUFM
	ALUFM!adr = BP!2
	Set1Bit(ALUFMbits, adr, 1)
	BP = BP+3
	goto more ]
dataDISP: [	// DISP -- not defined yet
	BP = BP+3
	goto more ]
dataIMLOCK: [	// IMLOCK
	Set1Bit(IMlocked, adr, BP!2 rshift 15)	// allow both set and reset
	BP = BP+3
	goto more ]
dataIMMASK: [	// IMMASK
	let m = Allocate(zone, lIMMASK)
	m>>IMMASK.next = IMMASK
	m>>IMMASK.addr = adr+Ibase	// address in IM, must be relocated
	m>>IMMASK.mask = BP!2
	m>>IMMASK.nseq = BP!3 rshift 12
	IMMASK = m
	BP = BP+4
	goto more ]
blockAddress: [			// set current memory and address
	MemX, Addr = BP!1, BP!2
	ddisp = mData!MemX
	dwords = 2+((mWidths!MemX+15) rshift 4)
	if MemX eq IMmemx then
	[ Addr = Addr+Ibase
	  if Addr gr NImax then IMfull()
	]
	BP = BP+3
	goto more ]

blockFixup: [			// fix up (forward ref)
	let addr, field, value = BP!2, BP!3, BP!4
	let fixp = selecton BP!1 into
	[
case IMmemx:	valof	// adjust bit #
	[	field = fixIMfield(field)
		if (field eq W1field) % (field eq W2field) then
		  value = value+Ibase
		resultis IP(addr+Ibase)
	]
case IFUMmemx:	valof	// check pass
	[	if field eq IFADfield then value = value+Ibase
		resultis IFUM+addr*lIFUM
	]
case ALUFMmemx:	ALUFM+addr
case RMmemx:	RM+addr
default:	valof
	[	fixproc(BP)
		goto noset
	]
	]
	// Actually do the fixup
	[ let firstbit = field<<lh
	  let nbits = field<<rh-firstbit+1
	  SetBits(fixp, firstbit, nbits, value)
	]
noset:
	BP = BP+5
	goto more ]

blockMemory: [			// memory def
	let mdp = BP
	BP = SkipMicroString(BP+3)
	memproc(mdp, BP, zone)
	goto more ]

blockSymbol: [					// symbol def
	let ap = BP
	BP = BP+3	// Open code SkipMicroString (see below)
	while (@BP)<<rh ne 0 do BP = BP+1
	if BP-ap ge 53 then Err(Fatal, "Symbol longer than 99 chars")
	BP = BP+1
	if ap!1 eq IMmemx then ap!2 = ap!2+Ibase
	symproc(ap, BP, zone)
	goto more ]

blockExternalfixup: [				// external fixup
	let ap = BP
	BP = SkipMicroString(BP+4)
	if ap!1 eq IMmemx then
	[ ap!2 = ap!2+Ibase
	  ap!3 = fixIMfield(ap!3)
	]
	xfixproc(ap, BP, zone)
	goto more ]

blockError: Err(Fatal, "Unknown block type $UO", @BP)

  ] repeat	// end main loop

]


and SkipMicroString(sp) = valof
[	let p = sp
	while (@p)<<rh ne 0 do p = p+1
	if p-sp ge 50 then Err(Fatal, "Symbol longer than 99 chars")
	resultis p+1
]


and fixIMfield(field) =
	((field ls 32*400b) % (DMachine eq 2)? field,	// iw0, iw1, or OK
	 field ls 80*400b? field+16*401b,	// not iw2
	 field-48*401b)	// iw2

and IMfull() be
	Err(Fatal, "More than $Ob microinstructions", NImax)