//MLOAD.BCPL
//	9 May 1983

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

external [
// OS
	SetBlock; Zero; CreateDiskStream; Resets; Puts
	Gets; PositionPage; Closes; Endofs; ReadBlock; WriteBlock
	Allocate; Free; Noop; TruePredicate

// MIDAS
	MidasSwat; Initialized; TimeLoad; ElapsedTime

// MASM
	Wss; @WssCSS; ResetsCSS
	VUsc; GetField; PutField; ErrorProtect; DoubleNeg

// MDISP
	SetDisplay

// MIOC
	Wns; DataToStream

// MTXTBUF
	InputTextBuffer

// MSYM
	StreamFromTextName; SkipBlankToken; FindInTable; SearchBlocks
	@StringVec

// MSYMOV
	UpdateRcd; CleanUpBlocks

// MOVERLAY
	OverlayZone

// MCMD
	DisplayError; ErrorAbort; ConfirmAct; FormCmdMenu; WnsCSSD
	LoadDone; CmdCommentStream; SavedLoadText; ProgramStream; Confirmed

// MINIT0
	@MBlock; FixUpFP; ErrsFP

// Resident machine-dependent files
	GetMemData; PutMemData
	@MEMNAM; @MEMWID; @MEMCON; @MEMFORMS; @ScreenWidth

// Load overlay machine-dependent file
	PrepareLoad; RestoreAfterLoad; PutMDSymOnly; LoadCleanUp

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


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


manifest
[	MaxExtMemX = 16 ; NotDefined = -100
	ReadCnt = #4000	// Max word count read from .MB file
//Note that the sum of InVecSize and the sizes of the Load and Directory
//overlays must all fit in OverlayZone.
	InVecSize = ReadCnt+54
]

//lvProc points at LoadMB, LoadData, LoadSyms, DumpMB, or CompareMB
//**Ugly binding of vec's to statics here**
let InitLoad(lvProc,nil,nil) = valof
[	let DisplayState = SetDisplay(true)
	InVec = Allocate(OverlayZone,InVecSize+1)
	let CBufv = vec ValSize-1
	let XtoIMemXv = vec MaxExtMemX
	SetBlock(XtoIMemXv,NotDefined,MaxExtMemX)
	let XtoWdWidthv = vec MaxExtMemX
	CBuf,XtoIMemX,XtoWdWidth = CBufv,XtoIMemXv,XtoWdWidthv
	NWrong,NWords,NFixups,NExtFixUps,NAddresses,NDBlocks = 0,0,0,0,0,0
	let OKFlag = ErrorProtect(lvProc)
	Confirmed = false
	Free(OverlayZone,InVec)
	if DoingLoad do
	[ DoingLoad = false
	  ErrorProtect(lv RestoreAfterLoad)
	]
	if OKFlag & Initialized & LoadDone then FormCmdMenu()
	SetDisplay(DisplayState)
	ElapsedTime(lv TimeLoad)
	resultis OKFlag
]


and LoadSyms() = LoadX(UpdateRcd,0)
and LoadData() = LoadX(ChkUpdateRcd,1)
and LoadMB() = LoadX(UpdateRcd,2)
and LoadX(SymOp,LoadType) = valof
[	if InputTextBuffer!0 eq 0 then ErrorAbort("??file name??")
	if LoadDone do
	[ if not ConfirmAct(LoadType eq 0 ? "Merge symbols with ",
		"Overwrite ",SavedLoadText) then
	  resultis false
	]
	PrepareLoad(LoadType)
//Don't ordinarily need Midas.FixUps, but have to open it now because
//MemDef blocks have to be written before it is known whether or not
//there are any external fixups.
	MBOutStream = CreateDiskStream(FixUpFP)	//ksTypeReadWrite,wordItem
	if MBOutStream eq 0 then MidasSwat(NoFixups)
//Save text of files being loaded for possible dump
	MBlock(SavedLoadText,InputTextBuffer,ScreenWidth)
	let DataOp,FixUpOp,ExtFixUpOp,DefMemOp = nil,nil,nil,nil
	test LoadType eq 0
	ifso
	[ DataOp,FixUpOp = PutMDSymOnly,Noop
	  ExtFixUpOp,DefMemOp = Noop,DefMem
	]
	ifnot
	[ DataOp,FixUpOp = PutMemData,FixUp
	  ExtFixUpOp,DefMemOp = WriteExtFixUp,DumpMemDef
	]
	let OKFlag = ErrorProtect(lv ScanMBFiles,InputTextBuffer,DataOp,
			Noop,FixUpOp,SymOp,ExtFixUpOp,DefMemOp)
	if NExtFixUps ne 0 do
	[ if OKFlag ne 0 do
	  [ PutsMBO(0); PositionPage(MBOutStream,1)
	    OKFlag = ErrorProtect(lv GenMBIn,MBOutStream,
		BadFix,BadFix,BadFix,BadFix,ExtFixUp,DefMem)
	  ]
	]
	Closes(MBOutStream)
	test OKFlag eq 0
	ifso SavedLoadText!0 = 0
	ifnot
	[ if LoadType eq 0 then NWords = 0
	  ShowStats("Loaded ")
	  if Initialized do
	  [ Resets(ProgramStream); Wss(ProgramStream,"Loaded: ")
	    for I = 1 to SavedLoadText!0 do
		Puts(ProgramStream,SavedLoadText!I)
	    LoadDone = true
	  ]
	]
	CleanUpBlocks()		//Write dirty in-core blocks on symtab file
	LoadCleanUp()		//Build pointers into symtab file
	resultis OKFlag
]

and DumpMB() = valof
[	if SavedLoadText!0 eq 0 then
		ErrorAbort("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 resultis false
	MBOutStream = StreamFromTextName(TV,".MB",ksTypeWriteOnly,wordItem)
	PrepareLoad(false)
	let OKFlag = false
	OKFlag = ErrorProtect(lv ScanMBFiles,SavedLoadText,
		TruePredicate,DumpSetMem,Noop,DumpSymbol,Noop,DumpMemDef)
	PutsMBO(0)
	Closes(MBOutStream)
	if OKFlag ne 0 then ShowStats("Dumped ")
	resultis OKFlag
]


and CompareMB() = valof
[	let TV = InputTextBuffer!0 ne 0 ? InputTextBuffer,SavedLoadText
	if TV!0 eq 0 do ErrorAbort("Compare against ??file name??")
	if not ConfirmAct("Compare storage against ",TV) then
		resultis false
	MBOutStream = CreateDiskStream(ErrsFP,ksTypeWriteOnly,charItem)
	if MBOutStream eq 0 then MidasSwat(NoCompare)
	PrepareLoad(false)
	let OKFlag = ErrorProtect(lv ScanMBFiles,TV,
		CompareData,Noop,BadType,Noop,BadType,DefMem)
	if OKFlag do
	[ test NWrong eq 0
	  ifso WssCSS("No errors")
	  ifnot
	  [ WnsCSSD(NWrong); WssCSS(" errors on Midas.Compare")
	    PutsMBO($*N)
	    if NWrong > 50 do
	    [ Wss(MBOutStream,"..."); Wns(MBOutStream,NWrong-50,0,10)
	      Wss(MBOutStream," more errors not recorded...*N")
	    ]
	  ]
	]
	Closes(MBOutStream); resultis OKFlag
]


and ScanMBFiles(TV,Data,SetMem,FixUp,SymDef,ExtFixUp,MemDef) = valof
[	let PV,X,Z,S = vec 72,1,1,nil; PV!0 = 72
	while X le TV!0 do
	[ SkipBlankToken(TV,lv X)
	  let Size = (TV!0) - X + 1
	  for I = X to TV!0 do
	    if TV!I eq $, then
	    [ Size = I - X; break
	    ]
	  if X+Size > PV!0 then ErrorAbort("No .MB file list given")
	  PV!X = Size
	  MBlock(PV+X+1,TV+X,Size)
	  X = X+Size+1	//Skip comma in TV, Size in PV
	]
	let OKFlag = 0
	while Z < X do
	[ S = StreamFromTextName(PV+Z,".MB",ksTypeReadOnly,wordItem)
//DoingLoad is a flag for PutMemData/GetMemData which may cause variant
//operation of these procedures.  It also determines whether or not
//RestoreAfterLoad() is called.  Avoid setting the flag until here so
//that RestoreAfterLoad won't be called unless the hardware is touched.
	  DoingLoad = true
	  OKFlag = ErrorProtect(lv GenMBIn,S,
		Data,SetMem,FixUp,SymDef,ExtFixUp,MemDef)
	  Closes(S); if OKFlag eq 0 then break
	  Z = Z+PV!Z+1
	]
	resultis OKFlag
]

and PutsMBO(Char) be Puts(MBOutStream,Char)


and ShowStats(Str) be
[	if Initialized do
	[ WssCSS(Str)
	  WnsCSSD(NWords); WssCSS(" words, ")
	  WnsCSSD(NAddresses); WssCSS(" addresses, ")
	  WnsCSSD(NFixups); WssCSS(" fixups ")
	]
]


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


and BadFix(nil,nil,nil) be MidasSwat(BadFixupFile)


and WriteExtFixUp(Str,VMemX,Ptr) be
[	NExtFixUps = NExtFixUps+1
	PutsMBO(12+(VMemX lshift 8))
	PutsMBO(Ptr!0)
	PutsMBO(Ptr!1)
]


//Write data block for previous SetMem/dblock when new SetMem/dblock
//is seen or when EOF is seen.
and DumpSetMem(InExtX,BlockAddress,WordCount) be
[	if WordCount eq 0 then return
	PutsMBO(9+(InExtX lshift 8))
	PutsMBO(BlockAddress)
	PutsMBO(WordCount)
	let AVec = vec 1; AVec!0 = 0; AVec!1 = BlockAddress
	let MemX = XtoIMemX!InExtX
	for I = 1 to WordCount do
	[ unless GetMemData(MemX,CBuf,AVec) do
		ErrorAbort("GetMemData failed for ",MEMNAM!MemX)
	  WriteBlock(MBOutStream,CBuf,InWdWidth)
	  AVec!1 = AVec!1+1
	]
]


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


and FixUp(NewBits,VMemX,Ptr) be
[	let AVec = vec 1
	AVec!0, AVec!1 = 0, Ptr!0
	let Bit1,LastBit = (Ptr+1)>>lh,(Ptr+1)>>rh
	let MemX = CheckMemX(VMemX,"Fixup")
	if (LastBit ge MEMWID!MemX) % (((LastBit-Bit1) & 177760B) ne 0) do
		ErrorAbort("Ill. fixup")
	NFixups = NFixups+1
	if GetMemData(MemX,CBuf,AVec) do
	[ PutField(Bit1,LastBit-Bit1+1,CBuf,NewBits)
	  if PutMemData(MemX,CBuf,AVec) then return
	]
	ErrorAbort("Bad addr for fixup")
]


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


//LdData does not put addresses in the symbol table except those
//in memories marked with the "load-anyway" bit.  This aims mainly at
//the "Loader.mb" file, which is sometimes loaded with symbols for
//debugging, and sometimes not, to avoid poluting the symbol table.
and ChkUpdateRcd(Str,Body,BodySize,InExtX) be
[	if (MEMCON+(Body>>Symb.A.X))>>MRType.Retain ne 0 then
		UpdateRcd(Str,Body,BodySize)
]


and CompareData(MemX,DVec,AVec) = valof
[	unless GetMemData(MemX,CBuf,AVec) do resultis false
	if VUsc(DVec,CBuf,InWdWidth) ne 0 do
	[ NWrong = NWrong+1
	  if NWrong le 50 do
	  [ Wss(MBOutStream,MEMNAM!MemX)
	    Wns(MBOutStream,AVec!1,5,8)
	    Wss(MBOutStream," = ")
	    SearchBlocks(MBOutStream,MemX,AVec)
	    Wss(MBOutStream," was ")
	    DataToStream(MBOutStream,MEMFORMS!MemX,MEMWID!MemX,CBuf)
	    Wss(MBOutStream," should be ")
	    DataToStream(MBOutStream,MEMFORMS!MemX,MEMWID!MemX,DVec)
	    PutsMBO($*n)
	  ]
	]
	resultis true
]


and DumpMemDef(VMemX,BitWidth,Str) be
[	PutsMBO(11+(VMemX lshift 8))
	PutsMBO(BitWidth)
	WriteBlock(MBOutStream,Str,(Str>>lh rshift 1)+1)
	DefMem(VMemX,BitWidth,Str)
]


and DefMem(VMemX,BitWidth,Str) be
[	let SymbDef,SymbDefSize = vec size Symb/16,nil
	unless FindInTable(Str,SymbDef,lv SymbDefSize) &
		(SymbDef>>Symb.A.Type eq MemSymb) do
		ErrorAbort("Unknown mem name ",Str)
	let MemX = SymbDef>>Symb.M.X
	if MEMWID!MemX ne BitWidth then
		ErrorAbort("Mem width mismatch ",Str)
	XtoIMemX!VMemX = MemX
	XtoWdWidth!VMemX = (BitWidth+15) rshift 4
]

// In Vec stuff
and GenMBIn(Stream,Data,SetMem,FixUp,SymDef,ExtFixUp,MemDef) = valof
[ InVecLeft,InWdWidth,InDn = 0,0,0
  let VMemX,MemX,Body = nil,nil,vec size Symb.A/16
  let InExtX,BlockAddress,WordCount = nil,nil,0
  Body>>Symb.A.Type = AddrSymb
  let AVec0,AVec1 = 0,nil
  let AVec = lv AVec0	//Arrange to manipulate AVec!1 directly
  [ FillVec(Stream)
    switchon InWds>>rh into			// Dispatch on block type
    [
// Block types created by Micro
case 0:	NWords = NWords+WordCount		// terminating block
	SetMem(InExtX,BlockAddress,WordCount)
	resultis -1

case 1:	if InWdWidth le 0 then			// data word
		ErrorAbort("Data word before SetMem")
	InDn = InWdWidth+2
	if not Data(MemX,InWds+2,AVec) then
		ErrorAbort("Bad address for data word")
	AVec1 = AVec1 + 1; WordCount = WordCount+1
	loop	

case 2:	NWords = NWords+WordCount		// set current memory
	SetMem(InExtX,BlockAddress,WordCount)
	WordCount = 0
	InDn = 3
	InExtX = InWds!1
	BlockAddress = InWds!2
	AVec1 = BlockAddress
	MemX = CheckMemX(InExtX,"SetMem block")
	InWdWidth = XtoWdWidth!InExtX; loop

case 3:	InDn = 5				// fixup
	FixUp(InWds!4,InWds!1,InWds+2)
	loop

case 4:	InDn = ConvertMicroString(3)		// memory def
	MemDef(InWds!1,InWds!2,StringVec)
	loop

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

case 6:	InDn = ConvertMicroString(4)		// ext. fixup
	ExtFixUp(StringVec,InWds!1,InWds+2); loop

// New block types created by Dump
case 9:	NWords = NWords+WordCount		// data block
	SetMem(InExtX,BlockAddress,WordCount)
	NDBlocks = NDBlocks+1
	InExtX = InWds>>lh
	MemX = CheckMemX(InExtX,"Data block")
	BlockAddress = InWds!1
	AVec1 = BlockAddress
	WordCount = InWds!2
	InWdWidth = XtoWdWidth!InExtX
	InDn = 3
	for I = 1 to WordCount do
	[ FillVec(Stream)
	  if not Data(MemX,InWds,AVec) then
		ErrorAbort("Bad addr in data block")
	  AVec1 = AVec1 + 1
	  InDn = InWdWidth
	]
	loop

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

case 11: InDn = 3+((InWds!2)<<lh rshift 1)	// memory def (bcpl str)
	MemDef(InWds>>lh,InWds!1,InWds+2)
	loop

case 12: InDn = 4+((InWds!3)<<lh rshift 1)	// ext. fixup (bcpl str)
	ExtFixUp(InWds+3,InWds>>lh,InWds+1); loop

default: ErrorAbort("Bad blk type")
    ]
  ] repeat
]


//*This is only use of InVecLeft and InDn outside GenMBIn
and FillVec(Stream) be
[	InVecLeft = InVecLeft-InDn
	if InVecLeft < 0 then
		ErrorAbort("Incom block ending .MB file")
	InWds = InWds+InDn
	if InVecLeft < 53 then if not Endofs(Stream) do
	[ MBlock(InVec,InWds,InVecLeft)
	  InWds = InVec
	  InVecLeft = InVecLeft+ReadBlock(Stream,InVec+InVecLeft,ReadCnt)
	]
]


// 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 ]
	]
	test MaxLen eq 49
	ifso
	[ StringVec>>lh = MaxLen
	  ErrorAbort(StringVec," str too long in .MB file")
	]
	ifnot ErrorAbort(".MB file truncated inside string")
]


and CheckMemX(VMemX,Str) = valof
[	if (VMemX & 177760B) eq 0 do
	[ let MemX = XtoIMemX!VMemX
	  if MemX ne NotDefined then resultis MemX
	]
	ErrorAbort(Str," ill. MemX")
]