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