// MICRO Word Accumulation
// last edited July 7, 1980  9:19 AM
// Copyright Xerox Corporation 1979, 1980

get "micdecl.d"

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


// Static storage
// DO NOT REORDER, see mempush and mempop
static
  [	awstk	// chain word
	aword	// word being assembled
	awused	// bits already stored into
	awmem	// current memory
	awxlb	// listing buffer or 0
	awflag	// true if any stores done
	awloc	// current location
	awtep	// location counter ep
   ]
manifest
  [	lasr = 8
   ]

let clraw(ep) be
// Clear Assembled Word
  [	if awmem ne 0 then
	  [	let nb = awmem!mswidth
		let nw = (nb+15) rshift 4
		if awxlb ne 0 then Zero(awxlb, nb)
		MoveBlock(aword, awmem!msdflt + fstop, nw)
		Zero(awused, nw)
		awmem!msltag = 0
	   ]
	awflag = false
	awtep = ep
	awloc = ep!asval
   ]

and initacc() be
//Initialize accumulator
  [	awmem = 0
	awstk = 0
	clraw(0)
	if targsym ne 0 then targset(targsym+fstop)
   ]

and produce() be
// Produce assembled word
  [	if awloc ge awmem!mssize then
	  [	errx("STORE OUT OF RANGE TO @V IN @S",false,awloc,awmem)
		return
	   ]
	wword(aword,awmem,awloc)
	if awxlb ne 0 then
	  [	let opt = awmem!mslist
		if (opt & LFany) ne 0 then
			lstword(aword,awxlb,awmem,awloc,opt)
	   ]
	awtep = adef(awtep,awmem,awloc+1)
   ]

and stfield(ep,val,set) be
// Store val into field with name ep.  Message if something is
//    field already, value too big for field, or field too big
//    for memory.
test awmem eq 0
ifso errx("NO TARGET FOR FIELD SET",true)
ifnot
  [	let n = ep!fsbits
	let bitno = n rshift 8
	n = n & #377
	test bitno+n gr awmem!mswidth ifso
		errx("FIELD @S DOES NOT FIT IN MEMORY @S",false,ep,awmem)
	ifnot test (val rshift n) ne 0 ifso
		errx("VALUE @V DOES NOT FIT IN FIELD @S",false,val,ep)
	ifnot
	  [	let used = getbits(awused, bitno, n)
		test set
		ifso
		 test (used ne 0) & ((getbits(aword, bitno, n)&used) ne (val&used))
		 ifso
			errx("FIELD @S ALREADY SET",false,ep)
		 ifnot 
		  [	setbits(awused, bitno, n, -1)
			setbits(aword,bitno,n,val)
		   ]
		ifnot
		 if used ne (1 lshift n)-1 then
			setbits(aword, bitno, n, (used eq 0? val,
			  (getbits(aword, bitno, n)&used)+(val&not used)))
	   ]
	awflag = true
	if awxlb ne 0 then awxlb!bitno = ep
   ]

and gtfield(ep) = valof
test awmem eq 0
ifso	errx("NO TARGET FOR 'FVAL'", true)
ifnot	resultis getbits(aword, ep!fsbits rshift 8, ep!fsbits & #377)

and mempush(mem) be
// Push current accumulator
  [	if awmem ne 0 then
	  [	let rp = alloc(lasr)
		MoveBlock(rp, lv awstk, lasr)
		awstk = rp
	   ]
	awmem = mem
	let nb = awmem!mswidth
	let nw = (nb+15) rshift 4
	aword = alloc(nw)
	awused = alloc(nw)
	awxlb = (xlistflag & ((awstk eq 0) % (ltoflag eq false))? alloc(nb), 0)
   ]

and mempop() be
// Pop old accumulator
  [	if awmem ne 0 then
	[ if awxlb ne 0 then dalloc(awxlb)	// LIFO works best
	  dalloc(awused)
	  dalloc(aword)
	]
	test awstk ne 0
	 ifso
	[ let rp = awstk
	  MoveBlock(lv awstk, rp, lasr)
	  dalloc(rp)
	]
	 ifnot
	[ awmem = 0
	  awflag = false
	]
   ]

and targset(ep) be
// Set target address
test awstk ne 0
ifso	errx("'TARGET' NOT LEGAL INSIDE STORE",true)
ifnot
  [	if awflag then errx("'TARGET' GIVEN AFTER FIELD SET",true)
	mempop()
	mempush(ep!asmem + fstop)
	clraw(ep)
	targsym = ep-fstop
   ]

and aldef(ep) be
// Define Label
  [	if ep eq 0 then ep = putin(awmem-fstop)
	ep = adef(ep,awmem,awloc)
	if awstk eq 0 then
	  [	lbsym = ep
		lblct = stlct
	   ]
   ]

and assem() be
// Assemble top level word
  [	if awmem ne 0 then clraw(awtep)
	pr1(accmode,false)
	if awflag then
	  [	if awmem!mspost ne 0 then apost(awmem)
		produce()
	   ]
   ]

and auref(fep,ep) be
// Write undefined reference
test awtep eq 0
ifso errx("UNDEFINED SYMBOL @S IN 'DEFAULT'",false,ep)
ifnot
  [	wfixup(awmem,awloc,fep,ep)
	awflag = true
   ]

and aused(ep) = 
// Test if field has been set
0 ne getbits(awused, ep!fsbits rshift 8, ep!fsbits & #377)

and dosta(ep, ap, l) be
// Store builtin
  [	let mem = ep!asmem + fstop
	mempush(mem)
	clraw(ep)
	process(ap,l,accmode)
	if mem!mspost ne 0 then apost(mem)
	produce()
	mempop()
   ]

and defaultbi(mem,ap,l) be
// Default Builtin
  [	mempush(mem)
	clraw(0)
	process(ap,l,accmode)
	MoveBlock((mem!msdflt)+fstop,aword,((awmem!mswidth)+15) rshift 4)
	mempop()
   ]

and setlfbi(mem, ap, l) be
// Set list fields builtin
  [	mempush(mem)
	clraw(0)
	process(ap, l, accmode)
	let map = mem!mslfields+fstop
	let mw = mem!mswidth
	let bn = 0
	while bn ne mw do
	[ let bn1 = bn
	  [ bn = bn+1 ] repeatuntil (bn eq mw) % (getbits(aword, bn-1, 1) ne 0)
	  @map = bn-bn1
	  map = map+1
	]
	mempop()
   ]

and apost(mem) be
// Do the post-macro for memory mem
  [	let old = tlbot
	@sttop = endc	// set end mark
	sttop = sttop+1
	mcall(mem!mspost+fstop, 0)
	pr1(accmode, false)
	tlbot = old
   ]