// MICRO Macros
// last edited February 13, 1981  10:20 AM
// Copyright Xerox Corporation 1979, 1981

get "micdecl.d"

external	// O.S.
[	MoveBlock; SetBlock
	CleanupDiskStream	// for trace listing
]

// literals
manifest [
	argbl = 600	// argument buffer length
   ]

// Static Storage
static [
	@argbuf	// bottom of argument buffer
	@argend	// end of argument buffer
	@argp	// points to current bottom of arg buffer
]


let argstr(nc) = valof
// Allocate an n-char. argument string
test (argp-nc-1 ls argbuf)
ifso errx("Macro argument storage full")
ifnot
[	argp = argp-nc-1
	@argp = nc+1
	resultis argp+1
]

and colargs() = valof
// Collect macro arguments, return # of args.
// Note: the statement reading routine guarantees proper nesting
// of parens and brackets, and nothing in the language can destroy it,
// so no stack is necessary here.
  [	let stptr = sttop	// Define first for assembly code
	let nest = 0	// Ditto
	let nargs = 0
	let osptr = stptr
	  [	static [ @achar ]
		// Process character
			// other characters
		goto achar	// Stbuf!-1 contains endc, no need for end check

let initmac() be
// Initialize switch for colargs
  [	argbuf = alloctemp(argbl)
	argend = argbuf+argbl
	argp = argend
	let aswitch = alloctemp(#200)	// no characters above #177
	let arpb = table[
	  #11005	// ISZ nest,2
	  #20405	// achar: LDA 0 aswitch
	  #15004	// achar1: DSZ stptr,2
	  #37004	// LDA 3 @stptr,2
	  #117000	// ADD 0 3
	  #3400	// JMP @0,3
	  0		// aswitch:
	  #15004	// avalc: DSZ stptr,2
	  #772	// JMP achar1
	 ]
	achar = arpb+1
	achar!5 = aswitch
	let avalc = arpb+7
	SetBlock(aswitch, achar+1, #200)
	aswitch!$( = alpar
	aswitch!$) = arpb
	aswitch!$, = acomma
	aswitch!$[ = albr
	aswitch!$] = arpb
	aswitch!endc = aend
	aswitch!symc = avalc
	aswitch!numc = avalc
	aswitch!num6c = avalc
   ]

aend:			// ran off stbuf -- can't happen
		error("BRACKETS MISPAIRED -- BUG")
alpar:			// (
		nest = nest-1
		goto achar
albr:			// [
		if nest ne 0 then
		  [	nest = nest-1
			goto achar
		   ]
		@stptr = osptr-stptr
		nargs = nargs+1
		break
acomma:		// ,
		if nest ne 0 goto achar	// enclosed in () or []
		@stptr = osptr-stptr
		nargs = nargs+1
		osptr = stptr
		goto achar
	   ] repeat
	let nw = sttop-stptr
	sttop = stptr
	test argp-nw ls argbuf
	 ifso
	 [	errx("MACRO ARGUMENT STORAGE FULL")
		nargs = 0
	 ]
	 ifnot
	 [	argp = argp-nw
		MoveBlock(argp, stptr, nw)
	 ]
	resultis nargs
   ]

let mcall(ep, nargs) be
// Do macro call
[	if tracecalls then tracemcall(ep, nargs)
	let dp = nil	// define first for assembly code
	let typ = ep!stype
	test typ gr maxtype
	ifso	// Expand macro
  [	dp = fstop-(ep!mcsp)
	let free = tlbot-sttop-@dp
	test free le 0
	ifso
	  errx("STATEMENT TOO LONG")
	ifnot
	  [	static [ @cleft; @cright; @cac1 ]
		let np, nl = nil, nil	// argument pointer, length
		let param = nil	// argument #
		let mask = nil	// left/right mask
		goto cleft

let initmac1() be
[	let cswitch = alloctemp(#240)
	let cchar = table [
	   11006b	// cleft: ISZ dp,2
	   23006b	// LDA 0 @dp,2
	   24415b	// LDA 1 c177400
	  123700b	// ANDS 1 0
	   34412b	// LDA 3 cswitch
	  117000b	// ADD 0 3
	    7400b	// JSR @0,3
	   23006b	// cright: LDA 0 @dp,2
	   24410b	// LDA 1 c377
	  123400b	// AND 1 0
	   34404b	// LDA 3 cswitch
	  117000b	// ADD 0 3
	    7400b	// JSR @0,3
	     763b	// JMP cleft
	       0	// cswitch: .-.
	  177400b	// c177400: 177400
	     377b	// c377: 377
	       0	// ccopy: STA 0 @sttop
	       0	// ISZ sttop
	    1400b	// cskip: JMP 0,3
	 ]
	cleft = cchar
	cright = cchar+7
	cchar!16b = cswitch
	cchar!21b = #42000 + lv sttop
	cchar!22b = #10000 + lv sttop
	SetBlock(cswitch, cchar+21b, #200)
	cswitch!Aend = actend
	cswitch!Aargn = actargn
	cswitch!Aarg2 = actarg2
	cswitch!Aarg1 = actarg1
	cswitch!Anargs = actnargs
	cswitch!Askip = cchar+23b
	cswitch!symc = actval
	cswitch!numc = actval
	cswitch!num6c = actval
	SetBlock(cswitch+200b, actlong, 40b)
	cac1 = table [
	  121000b	// MOV 1 0
	    1401b	// JMP 1,3
	 ]
]

actargn:		// Copy param'th argument
		mask = not cac1()
		test mask ls 0
		 ifso [ dp = dp+1; param = (@dp)<<lh ]
		 ifnot param = (@dp)<<rh
		if param gr nargs goto cnext
		np = argp
		for i = 2 to param do
		  np = np+@np
		goto argn
actarg2:		// Copy argument 2
		mask = cac1()
		if nargs le 1 goto cnext
		np = argp+@argp
		goto argn
actarg1:		// Copy argument 1
		mask = cac1()
		if nargs eq 0 goto cnext
		np = argp
argn:			// Copy argument
		nl = @np-1
		if nl eq 0 goto cnext
		if nl ge free then
		  [	errx("STATEMENT TOO LONG")
			goto actend
		   ]
		free = free-nl
		MoveBlock(sttop, np+1, nl)
		sttop = sttop+nl
cnext:	test mask ls 0
		 ifso goto cright
		 ifnot goto cleft
actnargs:		// Give number of args
		mask = cac1()
		if nargs ge 8 then
		[ @sttop = (nargs rshift 3) + $0
		  sttop = sttop + 1
		]
		@sttop = (nargs&7) + $0
		sttop = sttop + 1
		goto cnext
actval:		// Packed value, short
		test cac1() ls 0
		 ifso	// just did left byte
		[ @sttop, sttop!1 = (@dp)<<rh, (@dp)<<lh
		  sttop = sttop+2
		  goto cleft
		]
		 ifnot	// just did right byte
		[ sttop!1 = (@dp)<<rh
		  dp = dp+1
		  @sttop = (@dp)<<lh
		  sttop = sttop+2
		  goto cright
		]
actlong:		// Packed value, long
		test cac1() ls 0
		 ifso	// just did left byte
		[ sttop!1 = (@dp)<<lh - 200b
		  @sttop = (@dp lshift 8) + ((dp!1)<<lh)
		  sttop, dp = sttop+2, dp+1
		  goto cright
		]
		 ifnot	// just did right byte
		[ sttop!1 = (@dp)<<rh - 200b
		  dp = dp+1
		  @sttop = @dp
		  sttop = sttop+2
		  goto cleft
		]
actend:		// End of definition
	   ]
   ]
	ifnot switchon typ into
	[ case fldtype:
		test nargs eq 1
			ifso dofld(ep,argp+1,@argp-1,true)
			ifnot mcerr(ep)
		endcase
	  case bitype:
		dobi(ep,nargs,argp)
		endcase
	  case memtype:
		test nargs eq 2
			ifso
			  [	let sp, l = argp+1, @argp-1
				expand(lv sp)
				let a2p = argp+@argp
				doaddr(sp,l,ep,evarg(a2p+1, @a2p-1))
			   ]
			ifnot mcerr(ep)
		endcase
	  default:
		test typ ls 0
		ifso test nargs eq 1
			ifso dosta(ep,argp+1,@argp-1)
			ifnot mcerr(ep)
		ifnot errx("@S MAY NOT BE FOLLOWED BY []",false,ep)
	]
	// clear away arglist
	for i = 1 to nargs do
		argp = argp+@argp
   ]

and mcerr(ep) be
	errx("WRONG # OF ARGS FOR @S", false, ep)

and tracemcall(ep, nargs) be
// Trace the call for debugging
[	let old = lchan
	lchan = erlchan
	lchr($**)
	lsym(ep)
	let ap = argp
	for i = 1 to nargs do
	[ llstr("*N***T")
	  lblk(ap+1, @ap-1)
	  ap = ap+@ap
	]
	lcrlf()
	CleanupDiskStream(lchan)
	lchan = old
]

and macdef(ap, l) = valof
[	// Parse macro definition.  Ok to do this "in place" since
	// arg buffer is scratch storage, and parsed version is
	// always smaller than unpacked original.
	if l eq 0 then	// avoids negative di below
	[ let dp = alloc(2)
	  @dp, dp!1 = 0, Aend lshift 8
	  resultis dp
	]
	let endp = ap+l
	let cp, di = endp, (l lshift 1) - 1
	let cklen = l	// Length for initial check at call time
	let ch = -1
	until cp eq ap do
	[ cp, di = cp-1, di-1
	  let lastch = ch
	  ch = @cp
	  test (ch eq $#) & (lastch ge $0) & (lastch le $9)
	   ifso	// Argument
	  [ di = di+1	// overwrite digit
	    let ac = cp!1
	    ch = selecton ac into
	    [ case $0: Anargs
	      case $1: Aarg1
	      case $2: Aarg2
	      default: valof
	      [ ap>>bytes^di = ac-$0
	        di = di-1
	        resultis Aargn
	      ]
	    ]
	    if ac ne $0 then cklen = cklen-2
	  ]
	   ifnot
	  if ch ls 40b then	// Packed value
	  [ cp = cp-1
	    let val = @cp
	    ap>>bytes^di = val<<rh
	    if val<<lh ne 0 then	// need long format
	    [ ch, di = ch+200b, di-1
	      ap>>bytes^di = val<<lh
	    ]
	    di = di-1
	  ]
	  ap>>bytes^di = ch
	]
	let nw = l - (di rshift 1)	// space for packed body
	let dp = alloc(nw+1)
	MoveBlock(dp+1, endp-nw, nw)
	if (di & 1) ne 0 then dp>>bytes^2 = Askip	// skip first byte
	(dp+nw)>>rh = Aend	// mark end
	@dp = cklen
	resultis dp
]