// MDmain.bcpl -- main program for MicroD
// last edited February 2, 1981  3:15 PM

	get "mddecl.d"
	get "streams.d"
	get "altofilesys.d"
	get "sysdefs.d"
	get "bcplfiles.d"

external [	// defined here
	@IP
		// statics
	@DMachine
	@OutputS; @MBS; @ErrDspS
	@TempZone; @Zone
	// Memories
	@IM; @SaveW2; @IMlocked; @NInstructions; @IMMASK
	@RM; @RMbits
	@IFUM; @IFUMbits; @NIFUM
	@ALUFM; @ALUFMbits
	// for Err
	End
	AbortCode; NErrors; NWarnings; errMax
	SourceFiles
	// for MDmisc
	OverlayCFA; lvOverlayLoc; lOverlaySz
]

external [
		// OS
	Allocate
	Closes; CounterJunta; CreateDiskStream
	Free
	MoveBlock
	Noop
	Puts
	ReadBlock; ReadCalendar
	SetBlock; SetFilePos; ShowDisplayStream
	TruncateDiskStream
	Usc
	WriteBlock; Ws; Wss
	Zero
	dsp
	OsFinishSafeAdr
		// EasyJunta
	EasyJunta
		// Template
	PutTemplate
		// GetSetBits
	GetBits
		// BcplRuntime and LoadRam
	InitBcplRuntime
	LoadRam
	RamImage
		// PrintMB
	PrintMB
		// MDmisc
	NextOverlay
	// for initialization
	GetLow; PutLow
	GetStorage; PutStorage
	RealPutTS
	// Statics
	PutTS
	@Storage; @EndStorage
	MinSpace
	RealMin
		// MDerr
	Err
	Show
		// MDinit
	Init
	// Statics (flags & parameters)
	DebugFlag
	DebugFirstLoc
	DebugLastLoc
	ListingLevel
	ListAbs
	MapChart
	MapIM
	MapRM
	MapOccupied
	ListSymbols
	TraceStorage
	ScratchSource
	DeleteScratch
		// MDload/0/1
	Load; Load0; Load1
	OpenSource
	@Symbols; @SymLength
		// MDprescan
	PreScan
		// MDscan
	Scan
		// MDlink
	Link
		// MDalist
	BuildALists
		// MDassign
	Assign
	WritePlaceStats
		// MDcheck
	Check
		// MDfixup
	FixupJCN
		// MDDump
	Dump
	LinkSyms
	DumpSyms
		// MDlist
	OpenListFile
	ListIM
	ListIMAbs
	ListIMUsed
	ListOccupied
	ListIMap
	ListChart
	ListRM
	ListNonIM
	ListOtherSyms
]

manifest [
	lvCodeTop = #335
	StackSize = 3400b
	lSysZone = lDS+10	// only needed for display stream structure
	lErrStr = 120	// for errors before OutputS is opened
]

static [
	DMachine = -1
	AbortCode = -1; NErrors = 0; NWarnings = 0; errMax = 50
	@OutputS; @MBS; @ErrDspS; @ScratchS
	@TempZone; @Zone
	Format
	StartTime
	TotalTime
	saveDsp
	dpasses
	SourceFiles
	@ErrStr; @ErrPos = 0
		//
	OverlayCFA
	lvOverlayLoc
	lOverlaySz = lKS+400b
		//
	IM; SaveW2; IMlocked; NInstructions; IMMASK
	RM; RMbits
	IFUM; IFUMbits; NIFUM
	ALUFM; ALUFMbits
]

let MicroD(blv, nil, cfa) be
[	StartTime = seconds()
	saveDsp = dsp
	let save = vec (lCFA+lBLV)
	MoveBlock(save, cfa, lCFA)
	MoveBlock(save+lCFA, blv, lBLV)
	EasyJunta(levStreams, microd1, save, lCFA+lBLV, lSysZone)
]

and microd1(save) be	// called after Junta
[	OverlayCFA = save
	lvOverlayLoc = lv (OverlayCFA+lCFA)>>BLV.overlayAddress↑0

// Initialize storage
	Storage = EasyJunta
	EndStorage = (lv save)-StackSize
	@lvCodeTop = EndStorage
	let zone = vec 2
	zone!0 = GetStorage
	zone!1 = PutStorage
	Zone = zone
	let lowzone = vec 2
	lowzone!0 = GetLow
	lowzone!1 = PutLow
	TempZone = lowzone
	PutTS = Noop
	OpenListFile = 0	// for optional loading of final overlay
// Code for each phase gets returned to storage after execution

	ErrStr = Allocate(zone, (lErrStr+2)/2)
	let eds = vec lST
	ErrDspS = eds
	ErrDspS>>ST.puts = ErrPuts

	let IP(i) = IM+i*lIM
	compileif lIM ne 6 then [ lIMne6 = 0 ]	// cause error
	IP = table[	// replace by assembly code
	  #105120	// MOVZL 0 1
	  #123120	// ADDZL 1 0
	  0	// LDA 1 IM
	  #123000	// ADD 1 0
	  #1401	// JMP 1 3
	 ]
	IP!2 = #24000 + lv IM

	SourceFiles = Init()
	if TraceStorage then PutTS = RealPutTS
	if LoadRam(RamImage) eq 0 then InitBcplRuntime()
	if ListingLevel eq listPrintMB then	// just list the input files
	[ EndPass(Init)
	  static [ pinst = 0 ]
	  let listmb(source, out, nil, pzone) be
	  [ let s = OpenSource(source)
	    pinst = PrintMB(s, out, pzone, pinst)
	    Closes(s)
	  ]
	  Load(SourceFiles, OutputS, lowzone, zone, listmb)
	  End()
	]
	EndPass(PrintMB, false)
	dpasses = DebugFlag

	Load0(SourceFiles, MBS, lowzone, zone)
	EndPass(Load0, false)

	IM = Allocate(zone, IMsize*lIM)
	IMlocked = Allocate(zone, IMsize/16)
	  Zero(IMlocked, IMsize/16)
	allocmem(lowzone)
	IFUM = Allocate(lowzone, IFUMsize*lIFUM)
	for i = 0 to IFUMsize-1 do
	  (IFUM+i*lIFUM)>>IFUM.IFAD = WNull
	Load1(SourceFiles, MBS, lowzone, zone)
	let format1 = ";;;!@GP;rcjf;bgk2;"
	Format = format1
	ScratchS = CreateDiskStream(ScratchSource>>Source.pFP, ksTypeReadWrite, wordItem, 0, 0, zone)
	WriteBlock(ScratchS, IM, NInstructions*lIM)
	sxfer(WriteBlock)
	EndPass(Load, true)

	NextOverlay()
	if NIFUM ne 0 then	// reload IFUM for Scan
	[ SetFilePos(ScratchS, 0, NInstructions*(lIM*2))	// *2 because byte position
	  IFUM = Allocate(lowzone, NIFUM*lIFUM)
	  ReadBlock(ScratchS, IFUM, NIFUM*lIFUM)
	]

	Scan()	// Mark IFU entries, check common errors
	EndPass(Scan, false)
	Link(zone)		//Setup branch linkages
	Format = "sa--;;;IWGP;rcjf;mgk-;"
	EndPass(Link, true)

	BuildALists(zone)	//Form allocation lists
	EndPass(BuildALists, true)

	NextOverlay()

	Assign(lowzone)
	if TraceStorage then WritePlaceStats(OutputS)
	test AbortCode ge 0
	 ifso	// Still want storage map
	[ let code = AbortCode
	  AbortCode = -1
	  EndPass(Assign, true)
	  NextOverlay()
	  ListIMUsed(OutputS, true)
	  doList(MapIM, lv ListIMap)
	  AbortCode = code
	  End()
	]
	 ifnot
	  EndPass(Assign, true)

	Err(PassMessage, "Reloading binaries...")
	SetFilePos(ScratchS, 0, 0)
	reloadIM(ScratchS, lowzone)
	allocmem(zone)
	IFUM = Allocate(zone, NIFUM*lIFUM)	// Only allocate amount needed
	sxfer(ReadBlock)
	if DeleteScratch then
	[ SetFilePos(ScratchS, 0, 0)
	  TruncateDiskStream(ScratchS)
	]
	Closes(ScratchS)
	Format = format1
	EndPass(0, true)

	NextOverlay()

	Check()
	EndPass(Check, false)

	FixupJCN()
	Dump(MBS, lowzone)
	DumpSyms(MBS, Symbols, SymLength, lowzone)
	Puts(MBS, MBend)
	CloseMBS()

	LinkSyms(Symbols, SymLength, zone)
	ListIM(OutputS, SourceFiles)
	ListIMUsed(OutputS, false)
	ListNonIM(OutputS, ListingLevel)
	if ListSymbols then
	[ if ListingLevel ls 0 then ListRM(OutputS)
	  ListOtherSyms(OutputS)
	]

	EndPass(Dump, true)

	doList(ListAbs, lv ListIMAbs)
	doList(MapIM, lv ListIMap)
	doList(MapOccupied, lv ListOccupied)
	doList(MapChart, lv ListChart)
	doList(MapRM, lv ListRM)

	End()
]

and doList(Source, lvProc) be
if Source ne 0 then
[	if OpenListFile eq 0 then NextOverlay()	// don't load overlay until needed
	let s = OpenListFile(Source, TempZone)
	(@lvProc)(s, SourceFiles)
	Closes(s)
]

and allocmem(z) be
[	RM = Allocate(z, RMsize)
	RMbits = Allocate(z, RMsize/16)
	IFUMbits = Allocate(z, IFUMsize/16)
	ALUFM = Allocate(z, ALUFMsize)
	ALUFMbits = Allocate(z, ALUFMsize/16)
	Zero(RMbits, RMsize/16)
	Zero(IFUMbits, IFUMsize/16)
	Zero(ALUFMbits, ALUFMsize/16)
]

and reloadIM(S, z) be
[	let savew0 = Allocate(z, NInstructions)
	for i = 0 to NInstructions-1 do savew0!i = IP(i)>>IM.W0word & W0mask
	ReadBlock(S, IM, NInstructions*lIM)
	for i = 0 to NInstructions-1 do
	[ let ip = IP(i)
	  ip>>IM.W0word = (ip>>IM.W0word & not W0mask) + savew0!i
	]
	Free(z, savew0, NInstructions)
]

and sxfer(proc) be
[	if DMachine ne 0 then
	[ proc(ScratchS, IFUM, NIFUM*lIFUM)
	  proc(ScratchS, IFUMbits, IFUMsize/16)
	  proc(ScratchS, ALUFM, ALUFMsize)
	  proc(ScratchS, ALUFMbits, ALUFMsize/16)
	]
	proc(ScratchS, RM, RMsize)
	proc(ScratchS, RMbits, RMsize/16)
]

and EndPass(proc, flag) be
[	if flag then
	[ if (dpasses&1) ne 0 then ShowIM()
	  dpasses = dpasses rshift 1
	]
	if AbortCode ge 0 then End()
	EndP()
	if Usc(proc, Err) gr 0 then	// don't flush if stub!
	   Storage = proc
]

and EndP() be
[	if RealMin ne -1 then [ MinSpace = RealMin; RealMin = -1 ]
	if TraceStorage then PutTemplate(OutputS, "$UO free, $UO min*N", EndStorage-Storage, MinSpace)
]

and ShowIM() be
[	Wss(OutputS, "IM:*N")
	Show(IM, DebugFirstLoc, (DebugLastLoc ge NInstructions? NInstructions-1, DebugLastLoc), lIM, OutputS, Format)
	Wss(OutputS, "*N")
]

and End() be
[	if AbortCode ge 0 then Wss(ErrDspS, "Aborted*N")
	EndP()
	TotalTime = seconds()-StartTime
	Summary(ErrDspS)
	CloseMBS()
	PutTS = Noop
	if OutputS ne 0 then
	[ if ErrStr>>BS.length ne 0 then Wss(OutputS, ErrStr)
	  ErrStr>>BS.length = 0
	  Closes(OutputS)
	]
	ShowDisplayStream(dsp, DSdelete)

	let AfterEnd() be
	[ dsp = saveDsp
	  Ws("*N*N")
	  test ErrStr>>BS.length ne 0
	   ifso Ws(ErrStr)	// copied to safe place below
	   ifnot
	  [ Ws(selecton AbortCode into
	    [ case Fatal: "Fatal error, aborted*N"
	      case -1: ""
	      default: "Aborted*N"
	    ])
	    Summary(dsp)
	  ]
	  finish
	]

	let safe = OsFinishSafeAdr-((lErrStr+2)/2)
	MoveBlock(safe, ErrStr, (lErrStr+2)/2)
	ErrStr = safe
	CounterJunta(AfterEnd)
]

and CloseMBS() be
	if MBS ne 0 then [ TruncateDiskStream(MBS); Closes(MBS); MBS = 0 ]

and Summary(S) be
	PutTemplate(S, "MicroD time: $UD seconds; $D error(s), $D warning(s), $UD words free*N", TotalTime, NErrors, NWarnings, MinSpace)

and seconds() = valof
[	let t = vec 1
	ReadCalendar(t)
	resultis t!1
]

and ErrPuts(st, ch) be
[	test OutputS ne 0
	 ifso Puts(OutputS, ch)
	ifnot test ErrPos ge lErrStr
	 ifso []
	 ifnot
	[ ErrPos = ErrPos+1
	  ErrStr>>BS.char↑ErrPos = ch
	  if ch eq $*N then ErrStr>>BS.length = ErrPos
	]
	Puts(dsp, ch)
]