// 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
]