//MLOAD.BCPL

get "mdecl.d"
get "streams.d"

external [
// OS
	OpenFile; Resets; Gets; Puts; PositionPage; Closes; Endofs; Wns; Wss
	ReadBlock; WriteBlock; MoveBlock; SetBlock; Zero; CallSwat
	Allocate; Free; Noop; TruePredicate

// MIDAS
	GetField; PutField; Initialized; HaveHardware

// MASM
	ErrorProtect

// MDISP
	SetDisplay

// MMENU
	FormMenu

// MMPRGN
	DoubleNeg

// MIOC
	MDatatoStream

// MPARSE
	ParseTextList

// MTV
	StreamFromTextName

// MTXTBUF
	InputTextBuffer

// MSYM
	FindInTable; UpdateRcd; @StringVec; SearchBlocks

// MOVERLAY
	OverlayZone

// MCMD
	DisplayError; ConfirmAct; QuickOpenFile; FormCmdmenuText; CmdMDFS
	LoadDone; CmdCommentStream; SavedLoadText; ProgramStream; WssCSS

// MINIT0
	FixUpFP; ErrsFP

// Hardware interface
	GetMemData; PutMemData; ProcOnTest; RestoreAfterLoad
	@MEMNAM; @MEMWID

// Defined here
	InitLoad; LoadMB; LoadSyms; LoadData; DumpMB; CompareMB
]


static[
// local statics
	@MBOutStream; @CBuf; @XtoIMemX; @XtoWdWidth
	@InVecLeft; @InWdWidth; @InWds; @InDn; @InVec
	NWrong; @NAddresses; @NFixups; NExtFixUps; @NWords; @NDBlocks
      ]


manifest [ ReadCnt = 5400B	// Max word count read from .MB file
	InVecSize = ReadCnt+54; MaxExtMemX = 12 ; NotDefined = -100
]

//lvProc points at LoadMB, LoadData, LoadSyms, DumpMB, or CompareMB
let InitLoad(lvProc) = valof
[	if (Initialized & HaveHardware) then if not ProcOnTest() do
	[ DisplayError("Power is off","Continue-loading")
	  Resets(CmdCommentStream)
	]
	CBuf = Allocate(OverlayZone,6)
	InVec = Allocate(OverlayZone,InVecSize+1)
	XtoIMemX = Allocate(OverlayZone, MaxExtMemX+1)
	XtoWdWidth = Allocate(OverlayZone, MaxExtMemX+1)
	SetBlock(XtoIMemX,NotDefined,MaxExtMemX)
	NWrong,NWords,NFixups,NExtFixUps,NAddresses,NDBlocks = 0,0,0,0,0,0
	(rv lvProc)(); if Initialized then RestoreAfterLoad()
	if LoadDone then FormMenu(CmdMDFS,FormCmdmenuText)
	Free(OverlayZone,CBuf); Free(OverlayZone,InVec)
	Free(OverlayZone,XtoIMemX); Free(OverlayZone,XtoWdWidth)
	resultis -1
]


and LoadSyms() be
[	if LoadDone do
	[ if not ConfirmAct("Merge symbols from ",InputTextBuffer)
		then return
	]
	let AbortFlag = false
	MoveBlock(SavedLoadText,InputTextBuffer,73)
	test ErrorProtect(lv ScanMBFiles,InputTextBuffer,
		TruePredicate,Noop,Noop,UpdateRcd,Noop) eq 0
	ifso SavedLoadText!0 = 0
	ifnot [ LoadDone,NWords = Initialized,0; ShowStats("Loaded ",true) ]
]


and LoadData() be LoadX(Noop)
and LoadMB() be LoadX(UpdateRcd)
and LoadX(SymOp) be
[	if LoadDone do
	[ if not ConfirmAct("Overwrite ",SavedLoadText) then return ]
	let OKFlag = nil
//Save text of files being loaded for possible MBDump()
	MoveBlock(SavedLoadText,InputTextBuffer,73)
	[ OKFlag = ErrorProtect(lv ScanMBFiles,InputTextBuffer,
		PutMemData,Noop,FixUp,SymOp,WriteExtFixUp)
	  unless NExtFixUps eq 0 do
	  [ unless OKFlag eq 0 do
	    [ Puts(MBOutStream,0); PositionPage(MBOutStream,1)
	      OKFlag = ErrorProtect(lv GenMBIn,MBOutStream,
		BadFix,BadFix,BadFix,BadFix,ExtFixUp)
	    ]
	    Closes(MBOutStream)
	  ]
	]
	test OKFlag eq 0
	ifso SavedLoadText!0 = 0
	ifnot [ LoadDone = Initialized; ShowStats("Loaded ",true) ]
]


and DumpMB() be
[	if SavedLoadText!0 eq 0 then
		DisplayError("No previous LOAD file list to control dump")
	if not LoadDone then WssCSS("[**Image clobbered**] ")
	let TV = InputTextBuffer!0 eq 0 ? SavedLoadText,InputTextBuffer
	if not ConfirmAct("Dump on ",TV) then return
	MBOutStream = StreamFromTextName(QuickOpenFile,TV,".MB",
		ksTypeWriteOnly,wordItem)
	let OKFlag = false
	[ OKFlag = ErrorProtect(lv ScanMBFiles,SavedLoadText,
		TruePredicate,DumpSetMem,Noop,DumpSymbol,Noop)
	  Puts(MBOutStream,0)
	]
	Closes(MBOutStream)
	if OKFlag ne 0 then ShowStats("Dumped ",false)
]

and CompareMB() be
[	let TV = InputTextBuffer!0 ne 0 ? InputTextBuffer,
		(SavedLoadText!0 eq 0 ? 0,SavedLoadText)
	if TV eq 0 do
	[ WssCSS("Compare against ??file Name??"); return ]
	if not ConfirmAct("Compare storage against ",TV) then return
	MBOutStream = OpenFile("Midas.Errors",ksTypeWriteOnly,charItem,
		verLatestCreate,ErrsFP,0,OverlayZone)
	if MBOutStream eq 0 then DisplayError("Can't open Midas.Errors")
	if ErrorProtect(lv ScanMBFiles,TV,
		CompareData,Noop,BadType,Noop,BadType) do
	[ test NWrong eq 0
	  ifso WssCSS("No errors")
	  ifnot
	  [ Wns(CmdCommentStream,NWrong,0,10)
	    WssCSS(" errors on Midas.Errors")
	    Puts(MBOutStream,15B)
	    if NWrong > 50 do
	    [ Wss(MBOutStream,"..."); Wns(MBOutStream,NWrong-50,0,10)
	      Wss(MBOutStream," more errors not recorded...*N")
	    ]
	  ]
	]
	Closes(MBOutStream)
]


and ScanMBFiles(TextVec,Data,SetMem,FixUp,SymDef,ExtFixUp) = valof
[	let PV,X,Y,Z,S = vec 72,1,1,1,nil; PV!0 = 72
	unless ParseTextList(TextVec,lv X,PV,lv Y) then
		DisplayError("No .MB file list given")
	let DisplayOff = SetDisplay(true)
	let OKFlag = 0
	while Z < Y do
	[ S = ErrorProtect(lv StreamFromTextName,QuickOpenFile,PV+Z,".MB",
		ksTypeReadOnly,wordItem)
	  if S eq 0 then [ OKFlag = 0; break ]
	  OKFlag = ErrorProtect(lv GenMBIn,S,
		Data,SetMem,FixUp,SymDef,ExtFixUp)
	  Closes(S); if OKFlag eq 0 then break
	  Z = Z+PV!Z+1
	]
	SetDisplay(DisplayOff); resultis OKFlag
]


and ShowStats(Str,ldPred) be
[	if ldPred do
	[ Resets(ProgramStream); Wss(ProgramStream,"Loaded: ")
	  for I = 1 to SavedLoadText!0 do
		Puts(ProgramStream,SavedLoadText!I)
	]
	if not Initialized then return
	WssCSS(Str)
	Wns(CmdCommentStream,NWords,0,10); WssCSS(" words, ")
	Wns(CmdCommentStream,NAddresses,0,10); WssCSS(" addresses, ")
	Wns(CmdCommentStream,NFixups,0,10); WssCSS(" fixups")
]


and BadType() be
[	DisplayError("Fixups on .MB file--can't compare until dumped")
]


and BadFix() be
[	DisplayError("Block type not external fixup on Midas.FixUps")
]


and WriteExtFixUp() be
[	if NExtFixUps eq 0 do
	[ MBOutStream = OpenFile("Midas.Fixups",ksTypeReadWrite,wordItem,
		verLatestCreate,FixUpFP,0,OverlayZone)
	  if MBOutStream eq 0 then
		DisplayError("Unable to open Midas.Fixups")
	]
	NExtFixUps = NExtFixUps+1
	WriteBlock(MBOutStream,InWds,InDn)
]


and DumpSetMem(MemX,BlockAddress,WordCount) be
[	if WordCount eq 0 then return
	Puts(MBOutStream,9+(MemX lshift 8))
	Puts(MBOutStream,BlockAddress)
	Puts(MBOutStream,WordCount)
	let AddrVec = vec 1; AddrVec!0 = 0; AddrVec!1 = BlockAddress
	for I = 1 to WordCount do
	[ GetMemData(MemX,AddrVec,CBuf)
	  for I = 0 to InWdWidth-1 do Puts(MBOutStream,CBuf!I)
	  AddrVec!1 = AddrVec!1+1
	]
]


and ExtFixUp() 
be
[	let SymbDef,SymbDefSize = vec size Symb/16,nil
	unless FindInTable(StringVec,SymbDef,lv SymbDefSize)
	  & SymbDef>>Symb.A.Type eq AddrSymb do
	[ DisplayError(" is undefined external","use 0",StringVec)
	  SymbDef>>Symb.A.A2 = 0; Resets(CmdCommentStream)
	]
	FixUp(SymbDef>>Symb.A.A2)
]


and FixUp(NewBits) be
[	let AVec,Bit1 = vec 1,(InWds!3)<<lh
	AVec!0, AVec!1 = 0, InWds!2
	let Buf = vec 6
	let IMemX = XtoIMemX!(InWds!1)
	GetMemData(IMemX,AVec,Buf)
	PutField(Bit1,(InWds!3)<<rh-Bit1+1,Buf,NewBits)
	PutMemData(IMemX,AVec,Buf)
	NFixups = NFixups+1
]


and DumpSymbol(Str,Body,Size) be
[	Puts(MBOutStream,10+(Body>>Symb.A.X lshift 8))
	Puts(MBOutStream,Body>>Symb.A.A2)
	let N = Str>>lh rshift 1
	for I = 0 to N do Puts(MBOutStream,Str!I)
]


and CompareData(MemX,AddrVec,DataVec) be
[	GetMemData(MemX,AddrVec,CBuf)
	for I = 0 to InWdWidth-1 do
	[ if DataVec!I ne CBuf!I do
	  [ NWrong = NWrong+1
	    if NWrong > 50 then return
	    Puts(MBOutStream,15B); Puts(MBOutStream,12B)
	    Wss(MBOutStream,MEMNAM!MemX)
	    Wns(MBOutStream,AddrVec!1,5,8)
	    Wss(MBOutStream," = ")
	    SearchBlocks(MBOutStream,MemX,AddrVec)
	    Wss(MBOutStream," was ")
	    MDatatoStream(MBOutStream,MemX,CBuf)
	    Wss(MBOutStream," should be ")
	    MDatatoStream(MBOutStream,MemX,DataVec); return
	  ]
	]
]


//InWds!0 = XMemX
//InWds!1 = memory width
//X holds name
and DefMem(X) be
[	let SymbDef,SymbDefSize = vec size Symb/16,nil
	let XMemX,BitWidth = InWds!1,InWds!2
	unless FindInTable(X,SymbDef,lv SymbDefSize) logand
		SymbDef>>Symb.A.Type eq MemSymb
	  do DisplayError("Unknown memory name")
	if SymbDef>>Symb.M.BitWidth ne BitWidth
	  then DisplayError("Mem width does not match")
	XtoIMemX!XMemX = SymbDef>>Symb.M.X
	XtoWdWidth!XMemX = (BitWidth+15) rshift 4
]

// In Vec stuff

and GenMBIn(Stream,Data,SetMem,FixUp,SymDef,ExtFixUp) = valof
[ if Stream eq 0 then CallSwat("Stream arg is 0 to GenMBIn")
  InVecLeft,InWdWidth = 0,0
  let MemX,AddrVec,Body = nil,vec 2,vec size Symb.A/16
  let InExtX,BlockAddress,WordCount = nil,nil,0
  Zero(AddrVec,2); Body>>Symb.A.Type = AddrSymb
  while true do
  [ if InVecLeft < 53 then if not Endofs(Stream) do
    [ MoveBlock(InVec,InWds,InVecLeft)
      InWds = InVec
      InVecLeft = InVecLeft+ReadBlock(Stream,InVec+InVecLeft,ReadCnt)
    ]
    switchon InWds>>rh into			// Dispatch on block type
    [
// Block types created by Micro
case 0:	NWords = NWords+WordCount		// terminating block
	SetMem(MemX,BlockAddress,WordCount)
	resultis -1

case 1:	if InWdWidth le 0 then
		DisplayError("Data word before setting memory in .MB")
	InDn = InWdWidth+2			// data word
	if not Data(MemX,AddrVec,InWds+2) then
		DisplayError("Bad address for data word")
	AddrVec!1 = AddrVec!1 + 1
	WordCount = WordCount+1
	endcase	

case 2:	InDn = 3				// set current memory
	NWords = NWords+WordCount
	SetMem(MemX,BlockAddress,WordCount)
	InExtX = InWds!1; BlockAddress = InWds!2
	AddrVec!1 = BlockAddress
	MemX = XtoIMemX!InExtX
	if MemX eq NotDefined % InExtX < 0 % InExtX > MaxExtMemX
		then DisplayError("Illegal memory index in .MB")
	InWdWidth = XtoWdWidth!InExtX
	WordCount = 0; endcase

case 3:	InDn = 5; FixUp(InWds!4)		// fix up (forward ref)
	endcase

case 4:	InDn = ConvertMicroString(3)		// memory def
	DefMem(StringVec)
	endcase

case 5:	InDn = ConvertMicroString(3)		// symbol def
	Body>>Symb.A.X = XtoIMemX!(InWds!1)
	Body>>Symb.A.A2 = InWds!2
	SymDef(StringVec,Body,size Symb.A/16)
	NAddresses = NAddresses+1
	endcase

case 6:	InDn = ConvertMicroString(4)		// external fixup
	ExtFixUp(); endcase

// New block types created by Dump
case 9:	SetMem(MemX,BlockAddress,WordCount)	// data block
	NWords = NWords+WordCount
	NDBlocks = NDBlocks+1
	MemX = InWds>>lh; BlockAddress = InWds!1
	AddrVec!1 = BlockAddress
	WordCount = InWds!2
	InWdWidth = (MEMWID!MemX + 15) rshift 4
	InVecLeft = InVecLeft-3; InWds = InWds+3
	for I = 1 to WordCount do
	[ if InVecLeft < 53 then if not Endofs(Stream) do
	  [ MoveBlock(InVec,InWds,InVecLeft)
	    InWds = InVec
	    InVecLeft = InVecLeft+ReadBlock(Stream,InVec+InVecLeft,ReadCnt)
	  ]
	  if not Data(MemX,AddrVec,InWds) then
		DisplayError("Bad address or MemX in data block")
	  AddrVec!1 = AddrVec!1 + 1
	  InVecLeft = InVecLeft-InWdWidth
	  if InVecLeft < 0 then
		DisplayError("Incomplete block terminating .MB file")
	  InWds = InWds+InWdWidth
	]
	loop

case 10: InDn = 3+((InWds!2)<<lh rshift 1)	// symbol def (bcpl string)
	Body>>Symb.A.X = InWds>>lh
	Body>>Symb.A.A2 = InWds!1
	SymDef(InWds+2,Body,size Symb.A/16)
	NAddresses = NAddresses+1
	endcase

default: DisplayError("Unknown block type")
    ]
    InVecLeft = InVecLeft-InDn
    if InVecLeft < 0 then
	DisplayError("Incomplete block terminating .MB file")
    InWds = InWds+InDn
  ]
]


// Arg is the number of words preceding the Micro text string
and ConvertMicroString(N) = valof
[	let MaxLen = InVecLeft-N
	if MaxLen > 49 then MaxLen = 49
	let W,R,L = nil,nil,0
	for I = 0 to MaxLen do
	[ W = InWds!(N+I); R = W<<lh; StringVec!I = L+R
	  if R eq 0 do [ StringVec>>lh = I+I; resultis N+I+1 ]
	  L = W lshift 8
	  if L eq 0 do [ StringVec>>lh = I+I+1; resultis N+I+1 ]
	]
	DisplayError("Bad block read from .MB file")
]