// Micro main processor
// last edited December 13, 1979  9:19 PM
// Copyright Xerox Corporation 1979

get "micdecl.d"

external	// O.S.
  [	MoveBlock; SetBlock
   ]

// Static Storage
static [
	@stbot	// bottom of statement buffer
	@sttop	// current top of statement buffer
	@tlbot	// current bottom of tail
	@tltop	// current top of tail
]


// Expand packed values

let expandsize(val, valc) =
// Compute size of expanded value
selecton valc into
[ case symc: lenname(val+fstop)
  case num6c: 6
  case numc: valof
	[ let n = 0
	  val, n = val rshift 3, n+1
	    repeatuntil val eq 0
	  resultis n
	]
]

and expandval(val, valc, ptr; numargs na) be
// Expand encoded value
[	let len = expandsize(val, valc)
	if na ls 3 then
	[ ptr = tlbot-len
	  if ptr le sttop then
	  [ errx("Statement too long"); return ]
	  tlbot = ptr
	]
	switchon valc into
	[ case symc:
		unpak(ptr, val+fstop+sname, len)
		endcase
	  case numc:
	  case num6c:
		ptr = ptr+len
		for j = 1 to len do
		[ ptr = ptr-1
		  @ptr = (val&7)+$0
		  val = val rshift 3
		]
		endcase
	  default:
		error("Expandval error")
	]
]

and expandlength(ap, l) = valof
// Give the length of an expanded block, or -1 if no encoded data
[	let p, len, any = ap+l, l, false
	until p eq ap do
	[ p = p-1
	  if @p ge 40b loop
	  any = true
	  len = expandsize(p!-1, @p) + len-2
	  p = p-1
	]
	resultis (any? len, -1)
]

and expand(lvapl, ptr; numargs na) = valof
// Expand a block possibly containing encoded data
// Return true iff expansion actually occurred
[	let ap, l = @lvapl, lvapl!1
	if l ls 2 resultis false
	let len = expandlength(ap, l)
	if len eq -1 resultis false
	if na ls 2 then ptr = alloctemp(len)
	let rp = ptr+len
	let p = ap+l
	until p eq ap do
	[ p = p-1
	  test @p ge 40b
	  ifso [ rp = rp-1; @rp = @p ]
	  ifnot
	  [ let n = expandsize(p!-1, @p)
	    rp = rp-n
	    expandval(p!-1, @p, rp)
	    p = p-1
	  ]
	]
	@lvapl, lvapl!1 = ptr, len
	resultis true
]


// Main Lexical scan

let lscan(symflag, top) = valof
// If symflag=true, return the ep of a symbol, delete it from tail
// If symflag=false, leave value on tail
// Expand encoded values whenever tlbot#top
  [	static [ @lgel ]	// to pass back length from recursive call
	let tlorg = tlbot
	  [	static [ @lloop; @lchar ]
		// Stbuf!-1 contains endc, so no need to check sttop=stbot here
		goto lloop

let initscan() be
  [	let lswitch = alloctemp(#200)
	lchar = table[
	  0	// LDA 0 @sttop
	  0	// lchar1: DSZ tlbot
	  0	// STA 0 @tlbot
	  0	// lloop: DSZ sttop
	  0	// LDA 0 @sttop
	  #34403	// LDA 3 lswitch
	  #117000	// ADD 0 3
	  #7400	// JSR @0,3
	  0	// lswitch:
	 ]
	lloop = lchar+3
	lchar!0 = #22000 + lv sttop
	lchar!1 = #14000 + lv tlbot
	lchar!2 = #42000 + lv tlbot
	lchar!3 = #14000 + lv sttop
	lchar!4 = lchar!0
	lchar!8 = lswitch
	SetBlock(lswitch, lchar+1, #200)
	lswitch!$) = lrpar
	lswitch!$: = lcolon
	lswitch!$( = lbreak
	lswitch!$, = lbreak
	lswitch!endc = lbreak
	lswitch!sepc = lsepc
	lswitch!$] = lrbr
	lswitch!$_ = llarr
	lswitch!symc = lvalc
	lswitch!numc = lvalc
	lswitch!num6c = lvalc
   ]

lrpar:		// )
		  [	let ptop = tlbot
			pr1(accmode,true)
			if (ptop!-1 ls 40b) & (tlbot ne ptop) & (ptop ne top) then
			  expandtail(ptop)
			goto lloop
		   ]
lcolon:		// :
		  [	let lgep = lscan(true, tlbot)
			let type = lgep!stype
			test (lgep eq 0) % (type eq nultype)
				% (type eq undtype)
			ifso	aldef(lgep)
			ifnot	errx("TAG @S ALREADY DEFINED",false,lgep)
			goto lloop
		   ]
lbreak:		// (, ,, endc
		  [	sttop = sttop+1
			break
		   ]
lrbr:			// ]
		  [	let na = colargs()
			let lgep = lscan(true, tlbot)
			test lgep eq 0
			ifso	errx("MACRO NAME @B NOT DEFINED", false, tlbot-lgel, lgel)
			ifnot	mcall(lgep, na)
			goto lloop
		   ]
llarr:		// _
		if tlbot eq tlorg goto lchar
		sttop!1 = sepc
		sttop = sttop+2
		break
lsepc:		// sepc
		goto lloop
lvalc:		// encoded value
		if tlbot eq top then
		[	tlbot = tlbot-1
			@tlbot = @sttop
			sttop = sttop-1
			goto lchar
		]
		sttop = sttop-1
		expandval(@sttop, sttop!1)
		goto lloop
	   ] repeat
	lgel = tlorg-tlbot
	if lgel eq 0 then
	  [	if symflag then errx("MISSING MACRO NAME OR TAG SYMBOL")
		resultis 0
	   ]
	if tlorg!-1 ls 40b then
	[ let val, valc = tlorg!-2, tlorg!-1
	  if lgel eq 2 then
	  [ if symflag then tlbot = tlorg
	    if valc eq symc resultis val+fstop
	    if symflag then errx("Found number instead of symbol")
	    resultis 0
	  ]
	  // Expand the datum after-the-fact
	  expandtail(tlorg)
	  lgel = tlorg-tlbot
	]
	unless symflag resultis 0
	tlbot = tlorg
	resultis lookup(tlbot-lgel, lgel)
   ]

and expandtail(top) be
// Expand an encoded datum just below top
[	let len = top-tlbot-2
	let b = alloctemp(len)
	MoveBlock(b, tlbot, len)
	tlbot = top
	expandval(top!-2, top!-1)
	let bot = tlbot-len
	test bot gr sttop
	ifnot errx("Statement too long")
	ifso
	[ MoveBlock(bot, b, len)
	  tlbot = bot
	]
	dalloctemp(b)
]

and pr1(mode,flag) be
// Process one clause
[	let typ, val = nil, nil
	let otltop = tltop
	tltop = tlbot
	let otlbot = tlbot
lp:
	let tlold = tlbot
	lscan(false, tltop)
	let term = sttop!-1
	if tlbot ne tlold then

  [	if (tltop!-1 ls 40b) & (tlold ne tltop) then	// expand old value
	[ let bot = tlbot
	  expandtail(tltop)
	  tlold = tlold+tlbot-bot	// adjust for expanded length
	]
sym:
// Process symbol just found by scanner, set val and typ
// Val, Typ may be:
//	int	value	(valmode, fldmode only)
//	adr	ep	(valmode, fldmode only)
//	und	ep	(fldmode only)
	let tlnew = tlbot
	let addr = tlbot
	let nc = tlold - tlbot
	tlbot = tlold
	let ep =
	 (tlold!-1 eq symc? tlold!-2+fstop,
	  tlold!-1 ls 40b? 1,
	  lookup(addr, nc))
	test ep eq 0
	ifso
	  [	// Look inside symbol name
		test tlold!-1 eq $_ ifso	// might be a store
		  [	ep = lookup(addr,nc-1)
			if (ep ne 0) & (ep!stype ls 0) then
			  [	let ap = argstr(2)
				@ap, ap!1 = ep-fstop, symc
				mcall((ep!asmem+fstop)!mssink + fstop, 1)
				goto lp
			   ]
		   ]
		ifnot	// Try for a number
		  [	val = 0
			let sgn, ovf = 0, false
			if @addr eq $- then sgn = 1
			let a, e = addr+sgn, addr+nc
			while (a ne e) & (@a le $7) & (@a ge $0) do
			 [ if (val&#160000) ne 0 then ovf = true
			   val = val lshift 3 + @a - $0
			   a = a+1
			 ]
			test a eq addr+sgn ifso [ ]	// no digits
			ifnot test a eq e ifso	// all digits
			 [ if ovf then errx("INTEGER @B TOO LARGE", false, addr, nc)
			   if sgn ne 0 then val = -val
			   typ = inttype
			   goto numok
			 ]
			ifnot	// literal
			 [ litsplit(addr, nc, a-addr)
			   goto lp
			 ]
		   ]
		// Undefined symbol
		if mode ne fldmode then
		  [	errx("@B UNDEFINED",false,addr,nc)
			goto lp
		   ]
		val, typ = putin(undtype), undtype
	  numok:
	   ]
	ifnot
	test ep eq 1
	ifso	// Encoded number
	  val, typ = tlold!-2, inttype
	ifnot
	  [	// Dispatch on symbol type
		typ = ep!stype
		test typ gr maxtype ifso
		  [	mcall(ep, 0)
			goto lp
		   ]
		ifnot test typ ls 0 ifso
		  [	if mode eq accmode then
			  [	let ap = argstr(2)
				@ap, ap!1 = ep-fstop, symc
				mcall((ep!asmem+fstop)!mssource + fstop, 1)
				goto lp
			   ]
			val, typ = ep, adrtype
		   ]
		ifnot test (typ eq inttype) & (mode ne accmode) ifso
			val = ep!isval
		ifnot test (typ eq undtype) & (mode eq fldmode) ifso
			val = ep
		ifnot test typ eq neutype ifso
		  [	tlbot = tlnew
			if tlold ne tltop then
			  [	tlold = tltop
				goto sym
			   ]
		   ]
		ifnot
		  [	errx("SYMBOL @B NOT LEGAL AS TOKEN",false,addr,nc)
			goto lp
		   ]
	   ]
	test tlold ne tltop ifso
		errx("BAD SYNTAX WHERE VALUE REQUIRED")
	ifnot
	if (typ ne neutype) & (term ne sepc) then
	  [	tlbot = tlold - 2
		@tlbot, tlbot!1 = typ, val
	   ]
   ]
	sttop = sttop - 1
	if (term ne $() & (term ne endc) then
	  [	if term eq $, then
		  [	tlbot = otlbot
			tltop = otlbot
		   ]
		goto lp
	   ]
	tltop = otltop
]

and litsplit(addr,nc,k) be
// Split literal and set up macro call.
//	First K characters are numeric part.
  [	if @addr eq $- then	// move - from numeric part to symbol
	[ k = k-1
	  MoveBlock(addr, addr+1, k)
	  addr!k = $-
	]
	let n = ((k-1) & 3) + 1
	let i = 0
	while i ls k do
	[ MoveBlock(argstr(n), addr+i, n)
	  i = i+n
	  n = 4
	]
	let ap, l = addr+k, nc-k
	let lep = lookup(ap, l)
	test lep eq 0
	 ifso errx("Undefined literal symbol in @B @B", false, addr, k, ap, l)
	 ifnot mcall(lep, (k+3) rshift 2)
   ]


and process(stp, l, mode, lvtyp, lvval; numargs na) be
// Internal entry to processing loop.
[	// Quick check for a number
	if (l eq 2) & ((stp!1 eq numc) % (stp!1 eq num6c)) then
	[ if na gr 3 then @lvtyp, @lvval = inttype, @stp
	  return
	]
	if sttop+l+1 gr tlbot then
	[ errx("Statement too long"); return ]
	@sttop = $(
	MoveBlock(sttop+1,stp,l)
	sttop = sttop+l+1
	let old = tlbot
	pr1(mode,true)
	if na gr 3 then
	 test tlbot eq old
	  ifso	@lvtyp, @lvval = inttype, 0
	  ifnot	@lvtyp, @lvval = old!-2, old!-1
	tlbot = old
]

and evarg(stp, l) = valof
// Evaluate argument
[	// Quick check for a number
	if (l eq 2) & (stp!1 ls 40b) then
	 switchon stp!1 into
	[ case numc:
	  case num6c: resultis @stp
	  case symc:
	  [ let ep = @stp+fstop
	    if ep!stype eq inttype resultis ep!isval
	  ]
	]
	if sttop+l+1 gr tlbot then
	[ errx("Statement too long"); resultis 0 ]
	@sttop = $(
	MoveBlock(sttop+1,stp,l)
	sttop = sttop+l+1
	let old = tlbot
	pr1(valmode, true)
	let val = nil
	test tlbot eq old
	ifso	val = 0
	ifnot
	  [	if old!-2 ne inttype then errx("ARG '@B' DOES NOT YIELD INTEGER VALUE", false, stp, l)
		val = old!-1
	   ]
	tlbot = old
	resultis val
]