//MDload1 -- first pass loader for Micro binaries
// last edited July 5, 1980  8:35 AM

	get "mddecl.d"

external	// defined here
[	Load1	// (sources, outs, tempzone, zone)
]

external
[		// OS
	Closes
	Puts; WriteBlock
	Allocate; Free
	MoveBlock; SetBlock; Zero
	Noop
		// Template
	PutTemplate
		// MDmain
	@IP
	@DMachine
	@NInstructions
	@IM
	@RM
	@IFUM
		// MDinit
	Version
	Xternal
		// MDerr
	Err
	ErrHeaderProc
	PutBlanks
	PutAddress
	PutName
		// MDload
	AllocInbuf
	OpenSource
	DoFixups
	Load
	LoadFile
	dataIM0; dataIM1; dataIM2
	dataRM; dataIFUM; dataALUFM
	dataDISP; dataIMLOCK; dataIMMASK
	dataOther; dataSkip
	@mData
	@mWidths
	@mNames
	@mSymMax
	fixTab
	@Symbols; @SymLength
		// MDload0
	sourceNameWidth
]


structure V:	// VERSION parameter
[	machine byte
	version byte
]

structure S0:	// first word of symbol
[	blank bit 1
	char0 bit 7
	blank bit 1
	char1 bit 7
]


manifest
[	nHash = 26
]


static
[	maxMemX = 0
	verMemX = -1
	mCounts
	mSeen
	fixSyms
	nFix = 0
	@fixPtr = 0
	@outstrm; @outmemx = -1; @outaddr = -1
]


let Load1(sources, outs, tempzone, zone) be
[	Symbols = Allocate(zone, SymLength)
	mNames = Allocate(zone, nMemX)
	  mNames!IMmemx = "IM"
	  mNames!RMmemx = "RM"
	mWidths = Allocate(zone, nMemX)
	  SetBlock(mWidths, -1, nMemX)
	mData = Allocate(zone, nMemX)
	  SetBlock(mData, dataOther, nMemX)
	mCounts = Allocate(tempzone, nMemX)
	Zero(IM, IMsize*lIM)
	Zero(RM, RMsize)
	mSeen = Allocate(tempzone, nMemX)
	  SetBlock(mSeen, false, nMemX)
	mSymMax = Allocate(zone, nMemX)
	  SetBlock(mSymMax, -1, nMemX)
	AllocInbuf(tempzone, 2000b)
	fixSyms = Allocate(tempzone, nHash)
	Load(sources, outs, tempzone, zone, LoadFile1)
	if verMemX ge 0 then mData!verMemX = dataSkip
	Version = (Version ls 0? 0, Version<<V.version)
	Err(PassMessage, "*NTotal of $Ob instructions", NInstructions)
	for i = maxMemX+1 to nMemX-1 do
	[ if mCounts!i ne 0 then
	    Err(PassMessage, "$6UOb words in $S", mCounts!i, mNames!i)
	]
	fixPtr = 0
	ResolveSyms(Noop, WExt)	// count undefined refs
	fixTab = Allocate(zone, fixPtr+1)
	fixPtr = fixTab
	ResolveSyms(storefix, WExt)
	@fixPtr = -1
	if nFix ne 0 then
	[ test Xternal
	   ifso Err(PassMessage, "$D external symbols:", nFix)
	   ifnot Err(PassFatal, "$D undefined symbols:", nFix)
	  let sym = nil
	  for h = 0 to nHash-1 do
	  [ let p = fixSyms!h
	    while p ne 0 do
	    [ fixPtr = 0
	      MapSym(p, WExt, (Xternal? -1, WExt), Noop)
	      Err(PassMessage, "   $P -- $D reference(s)", PutName, p+1, fixPtr/2)
	      unless Xternal do	// print all references
	      [ let PrintRef(loc, sym) be
	        [ test (loc&140000b) eq 140000b
	           ifso Err(PassMessage, "      IFU: InsSet=$O, opcode=$O", (loc rshift 8)&3, loc&377b)
	           ifnot Err(PassMessage, "      $P", PutAddress, loc&(IMsize-1))
	        ]
	        MapSym(p, WExt, -1, PrintRef)
	      ]
	      p = @p
	    ]
	  ]
	]
	Err(PassMessage, "")
]

and LoadFile1(source, outs, tempzone, zone) be
[	static [ sourceName ]
	let s = OpenSource(source)
	sourceName = source>>Source.pName
	source>>Source.niFirst = NInstructions
	source>>Source.niLast = NImax	// in case of error
	outstrm = outs
	let load1EHP(s) be
	[ PutTemplate(s, "In $S:*N", sourceName)
	  ErrHeaderProc = 0
	]
	ErrHeaderProc = load1EHP
	LoadFile(s, tempzone, zone, data1, sym1, mem1, fix1, xfix1)
	ErrHeaderProc = 0
	Closes(s)
	source>>Source.niLast = NInstructions
	Err(PassMessage, "$S$P$6UOb instructions   written $S", sourceName, PutBlanks, sourceNameWidth-sourceName>>BS.length, NInstructions-source>>Source.niFirst, source>>Source.pDate)
]

and mem1(mdp, bp, zone) be
[	let memx, width = mdp!1, mdp!2
	if (memx le 0) % (memx ge nMemX) then
	  Err(Fatal, "Illegal memory #$UO", memx)
	mWidths!memx = width
	let sp = mdp+3
	let s = Allocate(zone, bp-sp)
	let n = 0
	until sp>>bytes^n eq 0 do
	[ s>>BS.char^(n+1) = sp>>bytes^n
	  n = n+1
	]
	s>>BS.length = n
	memname(memx, s)
	let imwidth = nil	// width of IM in output
	if memx eq IMmemx then	// decide which machine
	[ switchon width into
	  [ case 80:	// Dorado model 0
	    case 96:	// Dorado model 1
		DMachine, maxMemX = width/48, 4	// = 1 or 2
		imwidth = width-32	// = 48 or 64
		mWidths!IFUMmemx = 32
		mWidths!ALUFMmemx = 8
		memname(IFUMmemx, "IFUM")
		memname(ALUFMmemx, "ALUFM")
		mData!IFUMmemx = dataIFUM
		mData!ALUFMmemx = dataALUFM
		mData!IMmemx = (width eq 80? dataIM1, dataIM2)
		endcase
	    case 84:	// D0
		DMachine, maxMemX = 0, 2
		imwidth = 64
		mData!IMmemx = dataIM0
		endcase
	    default: maxMemX = 0	// illegal
	  ]
	  if (Version ge 0) & (DMachine ne Version<<V.machine) then
	    Err(Fatal, "IM width disagrees with /V or with VERSION from file")
	  mData!RMmemx = dataRM
	]
	test memx gr maxMemX ifso	// must be unknown or fake
	[ if StringEqual(s, "DISP") then
	  [ mData!memx = dataDISP; return ]
	  if StringEqual(s, "IMLOCK") then
	  [ mData!memx = dataIMLOCK; return ]
	  if StringEqual(s, "RVREL") then
	  [ mData!memx = dataSkip; return ]
	  if StringEqual(s, "VERSION") then
	  [ verMemX = memx; return ]
	  if StringEqual(s, "IMMASK") then
	  [ mData!memx = dataIMMASK; return ]
	]
	ifnot
	[ if memx le 0 then
	    Err(Fatal, "Definition for unknown memory #$O $S ($O bits)", memx, s, width)
	  unless width eq mWidths!memx do
	    Err(Fatal, "Memory #$O not valid $S", memx, mNames!memx)
	]
	if mSeen!memx return
	mSeen!memx = true
	// Copy memory def to output
	if memx eq IMmemx then mdp!2 = imwidth	// output IM has different width
	WriteBlock(outstrm, mdp, bp-mdp)
]

and memname(memx, s) be
[	let ns = mNames!memx
	if (ns ne 0) & not StringEqual(ns, s) then
	  Err(Fatal, "Memory #$O $S redefined as $S", memx, ns, s)
	mNames!memx = s
]

and data1(bp, memx, addr, dwds) be
// Data for unknown memory -- just copy unless undefined or VERSION
test memx eq verMemX
 ifso dataVer(addr, bp!2)
 ifnot
test mSeen!memx
 ifnot
	Err(Fatal, (memx eq 0? "Data word before address set", "Data for unknown memory $UO"), memx)
 ifso
[	if (memx ne outmemx) % (addr ne outaddr+1) then
	[ Puts(outstrm, MBaddress)
	  Puts(outstrm, memx)
	  Puts(outstrm, addr)
	]
	outmemx, outaddr = memx, addr
	WriteBlock(outstrm, bp, dwds)
	mCounts!memx = mCounts!memx+1
]

and dataVer(adr, v) be
[	if adr eq 0 then
	[ if ((Version ge 0) & (Version ne v)) %
	     ((DMachine ge 0) & (DMachine ne v<<V.machine)) then
	    Err(Fatal, "File says VERSION=$UO -- disagrees with /V or with IM width", v)
	  Version = v
	  DMachine = v<<V.machine
	]
]

and sym1(ap, bp, zone) be
// Save symbols for later output
[	let memx, addr = ap!1, ap!2
	unless mSeen!memx return	// skip DISP, IMLOCK, RVREL, VERSION
	let sp = ap+3
	let sval = AddSym(sp, 0, zone, 1)-1
	sval>>Sym.memx = memx
	sval>>Sym.addr = addr
	if sval>>Sym.addr ne addr then
	  Err(NonFatal, "$S symbol $P = $UO, >7777 not allowed", mNames!memx, PutName, sp, addr)
	if (memx ne IMmemx) & (addr gr mSymMax!memx) then
	  mSymMax!memx = addr
]

and fix1(bp) be
// Fixup for unknown memory -- just copy
	WriteBlock(outstrm, bp, 5)

and xfix1(ap, bp, zone) be
[	let memx, addr, field = ap!1, ap!2, ap!3
	let sp = ap+4
	let lvptr = fixSyms+(@sp rem nHash)
	let sym = AddSym(sp, lvptr, zone, 3)
	if sym!-1 ls 0 then	// new entry
	[ sym!-3, sym!-2, sym!-1 = WNull, WNull, WNull
	  nFix = nFix+1
	]
	test (memx eq IMmemx) & ((field eq W1field) % (field eq W2field))
	 ifso
	[ let ip = IP(addr)
	  test field eq W1field
	  ifso [ ip>>IM.W1 = sym!-1; sym!-1 = addr ]
	  ifnot [ ip>>IM.W2 = sym!-2; sym!-2 = addr ]
	]
	 ifnot
	test (memx eq IFUMmemx) & (field eq IFADfield)
	 ifso
	[ (IFUM+addr*lIFUM)>>IFUM.IFAD = sym!-3; sym!-3 = addr
	]
	 ifnot
	test memx eq IMmemx
	 ifso Err(PassFatal, "$P....External reference to $P", PutAddress, addr, PutName, sp)
	 ifnot Err(PassFatal, "$S $UO....External reference to $P", mNames!memx, addr, PutName, sp)
]


and StringEqual(s1, s2) = valof
[	let n1 = s1>>BS.length
	if s2>>BS.length ne n1 resultis false
	for i = 1 to n1 do
	   if s1>>BS.char^i ne s2>>BS.char^i resultis false
	resultis true
]


and ResolveSyms(proc, skipval) be
// Resolve external references
[	if nFix ne 0 then
	 for i = 0 to nHash-1 do
	[ let lvsym = fixSyms+i
	  while @lvsym ne 0 do
	  [ let sym, value = @lvsym, nil
	    let rsym = FindSym(sym+1)
	    test rsym ne 0
	     ifso
	    [ value = (rsym!-1)<<Sym.addr
	      nFix = nFix-1
	      @lvsym = @sym	// remove symbol from chain
	    ]
	     ifnot
	    [ value = WExt	// save ptr to symbol in fixTab
	      lvsym = sym
	    ]
	    MapSym(sym, value, skipval, proc)
	  ]
	]
endfix:
]

and MapSym(sym, value, skipval, proc) be
// Map a procedure over all undefined references from a symbol
[	let addr = sym!-1
	until addr eq WNull do
	[ if value eq WExt then [ proc(addr, sym); fixPtr = fixPtr+2 ]
	  let ip = IP(addr)
	  addr = ip>>IM.W1
	  if value ne skipval then ip>>IM.W1 = value
	]
	addr = sym!-2
	until addr eq WNull do
	[ if value eq WExt then [ proc(addr+100000b, sym); fixPtr = fixPtr+2 ]
	  let ip = IP(addr)
	  addr = ip>>IM.W2
	  if value ne skipval then ip>>IM.W2 = value
	]
	addr = sym!-3
	until addr eq WNull do
	[ if value eq WExt then [ proc(addr+140000b, sym); fixPtr = fixPtr+2 ]
	  let ip = IFUM+addr*lIFUM
	  addr = ip>>IFUM.IFAD
	  if value ne skipval then ip>>IFUM.IFAD = value
	]
]

and storefix(addr, sym) be
	@fixPtr, fixPtr!1 = addr, sym


and FindSym(sp) = valof
// Look up a symbol in Symbols, return 0 if missing.
// The symbol is already in internal format (end marked by bit 0).
[	let s0 = @sp
	let c0 = s0<<S0.char0
	let ptr = Symbols!
	  ((c0 ls 41b? 0, (c0-40b)*2) + (s0<<S0.char1 ge $N? 1, 0))
	until ptr eq 0 do
	[ if ptr!1 eq s0 then	// quick rejection check
	  [ let sym, tsym = ptr+1, sp
	    [ if @sym ls 0 resultis ptr
	      sym, tsym = sym+1, tsym+1
	    ] repeatwhile @sym eq @tsym
	  ]
	  ptr = @ptr
	]
	resultis 0
]

and AddSym(sp, lvptr, zone, extra) = valof
// Look up a symbol, insert it if missing.
// If lvptr=0, hash it into Symbols.
// Keep the chain in increasing alphabetical order.
[	let ep = sp
	until (@ep)<<rh eq 0 do
	[ @ep = @ep & 77577b
	  ep = ep+1
	]
	let s0 = @sp	// Pick up s0 before setting bit 0 in last word
	if (@ep eq 0) & (ep ne sp) then ep = ep-1
	@ep = @ep+100000b
	let c0 = s0<<S0.char0
	if lvptr eq 0 then lvptr = Symbols +
	  ((c0 ls 41b? 0, (c0-40b)*2) + (s0<<S0.char1 ge $N? 1, 0))
	until @lvptr eq 0 do
	[ if ((@lvptr)!1&77777b) ge s0 then	// quick rejection check
	  [ let sym, tsym = @lvptr+1, sp
	    while @sym eq @tsym do
	    [ if @sym ls 0 resultis @lvptr
	      sym, tsym = sym+1, tsym+1
	    ]
	    if (@sym&77777b) gr (@tsym&77777b) break	// insert here
	  ]
	  lvptr = @lvptr
	]
	if zone eq 0 resultis 0	// don't insert
	let nw = ep+1-sp
	let sym = Allocate(zone, nw+extra+1)+extra
	@sym = @lvptr
	@lvptr = sym
	MoveBlock(sym+1, sp, nw)
	if extra gr 0 then sym!-1 = -1	// mark as new
	resultis sym
]