// End processing for MICRO
// last edited August 11, 1978  3:22 PM
// Copyright Xerox Corporation 1979

	get "micdecl.d"

external
[		// O.S.
	Gets; Puts
	SetFilePos
	TruncateDiskStream
	Zero
	FalsePredicate
		// MICSTATS
	symstats
]

manifest	// for symbol listing
  [	scols = 4
	scwidth = 18
   ]


// Finish listing

let filtsyms(typ, bot) = valof
// Collect all symbols whose stype = typ and whose ep-fstop le bot.
// Put them in a newly allocated block and return it.
  [	let mask = -1
	if typ eq adrtype then mask, typ = #100000, #100000
	let count = 0
	scinit(stype, mask, typ)
	 [ let ep = scnext()
	   if ep eq 0 break
	   if ep-fstop le bot then count = count+1
	 ] repeat
	if bot eq ofbot then	// count redefined symbols
	  while nsnext() ne 0 do count = count+1
	let blk = alloc(count)
	scinit(stype, mask, typ)
	let ptr = blk
	 [ let ep = scnext()
	   if ep eq 0 break
	   if ep-fstop le bot then [ @ptr = ep; ptr = ptr+1 ]
	 ] repeat
	if bot eq ofbot then	// pick up redefined symbols
	[ let ep = nsnext()
	  if ep eq 0 break
	  [ @ptr = ep; ptr = ptr+1 ]
	] repeat
	resultis blk
   ]

and sort(addr,n,fld) be
// Sorts an array by the algorithm of treesort 3
//	(Algorithm 245, CACM 12/64).  The n words at addr
//	are pointers: word fld relative to each pointer is
//	used as the key.
// If fld=sname, alphabetically sorts symbols.
  [	let siftup(i,n,addr,fld) be
	  [	let j = nil
		let cpy = addr!i
		let siftcomp = (fld eq sname? scompare, FalsePredicate)
	     lp:
		j = i lshift 1
		if j le n then
		  [	if j ls n then
			  [	let d = (addr!(j+1))!fld - (addr!j)!fld
				if (d gr 0) % ((d eq 0) & (siftcomp(addr!(j+1), addr!j) gr 0)) then
				   j = j+1
			   ]
			let d = (addr!j)!fld - cpy!fld
			if (d gr 0) % ((d eq 0) & (siftcomp(addr!j, cpy) gr 0)) then
			  [	addr!i = addr!j
				i = j
				goto lp
			   ]
		   ]
		addr!i = cpy
	   ]
	// adjust addr for 1-origin indexing.
	addr = addr-1
	for i = n rshift 1 step -1 to 2 do siftup(i,n,addr,fld)
	for i = n step -1 to 2 do
	  [	siftup(1,i,addr,fld)
		// addr(j/2) >= addr(j) for 1 < j <= i
		let tp = addr!1
		addr!1 =addr!i
		addr!i = tp
		// addr(1::n) is fully sorted
	   ]
   ]

and scompare(ep1, ep2) = valof
// Compare symbol names ep1, ep2, return >0, 0, or <0
[	let d = ep1!sname - ep2!sname
	if d ne 0 resultis d
	if ((ep1!sname)&#377) eq 0 resultis 0	// end of name
	ep1, ep2 = ep1+1, ep2+1
] repeat

and endlist(xlf) be
// Terminate listing, list symbol tables.
  [	if xlf then
	  [	let mp = filtsyms(memtype, -1)
		for i = 0 to bsize(mp)-1 do
		  [	let mem = mp!i
			let f = mem!mslist
			if (f & (LFnumeric+LFalphabetic)) ne 0 then
			  [	lcrlf()
				lsym(mem)
				llstr(" MEMORY*N")
				let sp = filtsyms(mem - fstop, ofbot)
				if (f & LFnumeric) ne 0 then
				  [ llstr("NUMERIC ORDER*N")
				    sort(sp,bsize(sp),asval)
				    lstsyms(sp,asval)
				   ]
				if (f & LFalphabetic) ne 0 then
				  [ llstr("ALPHABETIC ORDER*N")
				    sort(sp,bsize(sp),sname)
				    lstsyms(sp,asval)
				   ]
				dalloc(sp)
			   ]
		   ]
		dalloc(mp)
	   ]
	let sp = filtsyms(undtype, ofbot)
	if bsize(sp) gr 0 then
	  [	let lstund(sp) be
		  [	llstr("*N*NUNDEFINED SYMBOLS*N*N")
			lstsyms(sp,0)
		   ]
		sort(sp,bsize(sp),sname)
		lstund(sp)
		lchan = erlchan
		lstund(sp)
		lchan = lstchan
	   ]
	dalloc(sp)
	symstats()
	llstr("*NEND*N")
   ]

and lstsyms(blk,fld) be
// List symbols in block.  Listed value from field.
  [	let s = vec 6
	let l = bsize(blk)
	let pos = 0
	let j = 0
	for k = 0 step 1 to l-1 do
	  [	let ep = blk!k
		let n = 2 + j*scwidth - pos
		if n le 0 then n = 1
		lblnks(n)
		pos = lsym(ep)+pos+n+1
		lchr($*S)
		if fld ne 0 then
		  [	let n = num2blk(s,ep!fld,8)
			lblk(s, n)
			pos = pos + n
		   ]
		j = j + 1
		if j eq scols then
		  [	lcrlf()
			pos = 0
			j = 0
		   ]
	   ]
	if pos ne 0 then lcrlf()
   ]

let endout() be
  [	lchan = erlchan
	copyfixups()
	SetFilePos(fixchan, 0, 0)
	TruncateDiskStream(fixchan)	// delete all data
	close(fixchan)
	lchan = lstchan
	let sp = filtsyms(adrtype, ofbot)
	sort(sp, bsize(sp), sname)
	for i = 0 to bsize(sp)-1 do
	  [	let ep = sp!i
		Puts(outchan,MBsymbol)
		Puts(outchan,(ep!asmem+fstop)!msno)
		Puts(outchan,ep!asval)
		wsym(ep)
	   ]
	dalloc(sp)
	Puts(outchan,MBend)
   ]

and copyfixups() be
// Copy fixups to output file
  [	Puts(fixchan, 0)	// end marker
	SetFilePos(fixchan, 0, 0)
     [	let mem = Gets(fixchan)
	if mem eq 0 break
	let loc = Gets(fixchan)
	let fep = Gets(fixchan)
	let ep = Gets(fixchan)
	let lb = Gets(fixchan)
	let ln = Gets(fixchan)
	let memno = mem!msno
	let bits = fep!fsbits
	bits = bits + bits rshift 8 - 1	// low-order bit #
	let val = nil
	test ep!stype eq undtype
	 ifso
	  [	Puts(outchan, MBext)
		Puts(outchan, memno)
		Puts(outchan, loc)
		Puts(outchan, bits)
		wsym(ep)
		loop
	   ]
	ifnot test ep!stype ls 0
	 ifso val = ep!asval
	ifnot test ep!stype eq inttype
	 ifso val = ep!isval
	ifnot
	  [	llstr("UNDEFINED SYMBOL ")
		lsym(ep)
		llstr(" IN FIELD ")
		lsym(fep)
		llstr(" OF ")
		lsym(mem)
		llstr(" AT ")
		lloc(lb, ln)
		lcrlf()
		loop
	   ]
	Puts(outchan, MBfixup)
	Puts(outchan, memno)
	Puts(outchan, loc)
	Puts(outchan, bits)
	Puts(outchan, val)
      ] repeat
   ]