// MICRO Listing and Errors
// last edited July 7, 1980  9:24 AM
// Copyright Xerox Corporation 1979, 1980

get "micdecl.d"

external	// O.S.
[	Puts
]

// Static Storage
static [
abortflag = false
   ]

let lcrlf() be
// Lists carriage return, line feed.
[	Puts(lchan, $*N)
	Puts(lchan, $*L)
]

and lstr(s) be
// Write BCPL Format string on listing.
[	for i = 1 to s>>BS.length do Puts(lchan, s>>BS.char↑i)
]

and llstr(s) be
// List literal string.  Separate routine to enhance
//	system independence.
[	llstr = lstr	// overwrite static
	lstr(s)
]

and lchr(ch) be
	Puts(lchan, ch)

and lblnks(n) be
// List n blanks.
for i = 1 to n do
	Puts(lchan,$*S)

and lsym(ep) = valof
// Write symbol on listing.
[	let i = sname*2
	 [ let ch = ep>>BS.char↑i
	   if ch eq 0 break
	   Puts(lchan,ch)
	   i = i+1
	 ] repeat
	resultis i-sname*2
]

and lblk(addr, nc) be
// Write unpacked string on listing.
[	let len = expandlength(addr, nc)
	test len eq -1
	ifso for i = 0 to nc-1 do Puts(lchan, addr!i)
	ifnot
	[ expand(lv addr)
	  lblk(addr, nc)
	  dalloctemp(addr)
	]
]

and lval(n) be
// Write value on listing.
  [	let s = vec 6
	let nc = num2blk(s,n,8)
	lblk(s, nc)
   ]

and ldec(n) be
// Write decimal value.
  [	if n ls 0 then [ lchr($-); n = -n ]
	let s = vec 6
	let nc = num2blk(s,n,10)
	lblk(s, nc)
   ]

and lloc(sym,inc) be
// Write location.
  [	if sym ne 0 then
	  [	lsym(sym)
		if inc gr 0 then lchr($+)
	   ]
	if inc ne 0 then ldec(inc)
   ]

and error(s) be
// Internal error procedure.
  [	lchan = ettchan
	llstr(s)
	lcrlf()
	if s>>BS.char↑1 ne $** then	// not called from errx
	[ llstr("****** Fatal error, abnormal termination")
	  lcrlf()
	]
	if errcnt eq 0 then errcnt = 1	// to warn user
	endmic()
   ]

and errx(es,aflag,par1,nil,nil,nil,nil,nil;numargs na) be
[	if na ls 2 then aflag = false
	lchan = ettchan
	printstat(lchan)
	errm(es, lv par1, true)
	if aflag then error("**** Fatal error, abort")
	errcnt = errcnt+1
	if errcnt gr errmax then error("**** Too many errors, abort")
	lchan = lstchan
   ]

and errm(es, ap, locflag) be
[	if locflag then
	[ lloc(lbsym,stlct-lblct)
	  llstr("........")
	]
	for i = 1 to es>>BS.length do
	 [ let ch = es>>BS.char↑i
	   if ch ne $@ then
	    [ Puts(lchan,ch)
	      loop
	    ]
	   i = i+1
	   ch = es>>BS.char↑i
	   switchon ch into
	    [ case $S:
	         lsym(@ap)
	         endcase
	      case $V:
	         lval(@ap)
	         endcase
	      case $D:
	         ldec(@ap)
	         endcase
	      case $B:
	         lblk(@ap,ap!1)
	         ap = ap+1
	         endcase
	      case $L:
	         lstr(@ap)
	         endcase
	      default:
	         Puts(lchan,ch)
	         loop
	    ]
	   ap = ap+1
	 ]
	lcrlf()
   ]


// Produce expanded listing of word

let lstword(awd, axlb, mem, loc, opt) be
  [	let vs = vec 6
	let nb = mem!mswidth
	let n = num2blk(vs, loc, 8)
	let pos = lsym(mem)+n+1
	lchr($*S)
	lblk(vs, n)
	let ep = mem!msltag + fstop
	if (ep ne 0) & (ep!asval eq loc) then
	  [	llstr(" (")
		pos = lsym(ep)+pos+3
		lchr($))
	   ]
	if (opt & LFbinary) ne 0 then
	[ lblnks((pos ge 19 ? 1, 19-pos))
	  let bn, map = 0, mem!mslfields + fstop
	  let dnb = ((opt & LF16bit) ne 0? 16, 12)
	  while bn ne nb do
	  [ let nm = @map
	    until nm eq 0 do
	    [ let n1 = nm rem dnb
	      if n1 eq 0 then n1 = dnb
	      Puts(lchan, $*S)
	      let val = getbits(awd, bn, n1)
	      for sh = ((n1-1)/3)*3 by -3 to 0 do
	        Puts(lchan, ((val rshift sh) & 7)+$0)
	      bn, nm = bn+n1, nm-n1
	    ]
	    map = map+1
	  ]
	  lcrlf()
	  pos = 0
	]
	if (opt & LFfields) eq 0 then return
	let f = true
	for bitno = 0 to nb-1 do
	  [	let ep = axlb!bitno
		if ep ne 0 then
		  [	let width = ep!fsbits & #377
			let vp = getbits(awd,bitno,width)
			let n = num2blk(vs,vp,8)
			let nc = lenname(ep)+n+3
			test f ifso
			  [	f = false
				let k = (pos gr 14 ? 2,16-pos)
				lblnks(k)
				pos = pos+k
			   ]
			ifnot test pos+nc gr lllength ifso
			  [	llstr(",*N             ")
				pos = 13
			   ]
			ifnot llstr(", ")
		   	lsym(ep)
			lchr($←)
			lblk(vs, n)
			pos = pos + nc
		   ]
	   ]
	if pos ne 0 then llstr(";*N")
   ]