// MICRO Builtins
// last edited July 7, 1980 9:21 AM
// Copyright Xerox Corporation 1979, 1980
get "micdecl.d"
external
[ // MICBIX
xinsert; xfield; xdefmac; xmemory; xlst; xbuiltin; xcchar; xbittable; xfindbit
mement
entarg; looktype; checkbtx; valsize
// defined here for MICBIX
minbi; maxbi
// O.S.
MoveBlock; Zero
Usc
]
static
[ minbi = 1
maxbi = 44
]
// Structure for BIAC table of indices, maxs and mins.
structure bdt:
[ setup bit 8 // Setup inst index
minna bit 4 // Minimum number of args
maxna bit 4 // Maximum number of args
]
// Literals for building structure BIAC table
manifest [
// Minna values
min0=0; min1=16; min2=32; min3=48; min4=64; min5=80; min6=96; min7=112
// Maxna values
max0=0; max1=1; max2=2; max3=3; max4=4; max5=5; max6=6; max7=7; nomax = 15
// Setup values
s = #400 // setup field position
ev1 = 1*s // eval 1st arg
ev2 = 2*s // eval 2nd arg
ev12 = 3*s // eval 1st and 2nd args
ev23 = 4*s // eval 2nd and 3rd args
look1 = 5*s // lookup 1st arg
mem1 = 6*s // lookup 1st arg as memory
bt1ev2 = 7*s // lookup 1st arg as bittable, eval 2nd arg
ev3 = 8*s // eval 3rd arg
fld1 = 9*s // lookup 1st arg as field name
exp1 = 10*s // expand 1st arg
// Empty entry
empty = min0+nomax
]
let dobi(bep,na,ac) be
// Do builtin
[ let biac = table [
min0+max0; // filler
min2+max2+ev2; // builtin
min2+max2+exp1; // m (macro)
min1+max1+exp1; // n (neutral)
min5+max5+ev23; // memory
min1+max1+look1; // target
min2+max2+mem1; // default
min3+max3+ev23; // f (field)
min2+max2+fld1; // pf (preassign)
min2+max2+ev2; // set
min0+nomax; // add
min1+max1+look1; // ip (integer part)
min3+max4+exp1; // ifse (if string eq)
min2+max3+fld1; // ifset (if any bits of field)
min3+max4+ev12; // ife (if integers equal)
min3+max4+ev12; // ifg (if int 1 > int 2)
min2+max3+look1; // ifdef (if sym in symtab and not unbound address)
min3+max4+look1; // ifme (if mem part = string)
min1+max3+exp1; // er
min2+max2+ev2; // set list mode for memory
min1+max1+exp1; // insert file
min1+max1+ev1; // 1's complement
min2+max2+ev1; // repeat text #2 #1 times
min1+nomax; // logical or
min1+nomax; // logical xor
min1+nomax; // logical and
min1+max1+exp1; // set comment char
min2+max2+ev2; // bittable
min2+max2+bt1ev2; // get bit
min2+max5+bt1ev2; // set bit(s)
min2+max6+bt1ev2; // find bit(s)
empty; // ** unused
min2+max2+ev12; // lshift
min2+max2+ev12; // rshift
min1+max1+fld1; // get field value
min1+nomax; // select
min2+max2+mem1; // set postmacro
min2+max2+mem1; // set tag macro
min2+max2+mem1; // set listing fields
min1+max1+exp1; // set binary output extension
min1+nomax; // subtract
min2+max2+exp1; // equate
min1+max1+ev1; // set ignore mode
min2+max2+ev12; // set trace mode
min2+max2 // while #1 repeat #2
]
let v1,v2,v3,v4,v5,v6,v7 = nil,nil,nil,nil,nil,nil,nil
// *** Don't reorder the next line ***
let ap1,l1, ap2,l2, ap3,l3, ap4,l4, ap5,l5, ap6,l6, ap7,l7 =
nil,nil, nil,nil, nil,nil, nil,nil, nil,nil, nil,nil, nil,nil
let no = bep!bsno
let k = biac!no
let m = k << bdt.maxna
if (na gr m) % (na ls k<<bdt.minna) then
[ errx("WRONG NUMBER OF ARGS FOR '@S'",false,bep)
return
]
let ap = ac
let lvap1 = lv ap1
if m ne nomax then
[ let p = lvap1
for i = 1 to na do
[ @p, p!1 = ap+1, @ap-1
ap = ap+@ap
p = p+2
]
]
let oldfslim = fslim // Mark top of temp storage
switchon k << bdt.setup into
[ case ev23/s:
v2 = evarg(ap2,l2)
case ev3/s:
v3 = evarg(ap3,l3)
endcase
case ev12/s:
v1 = evarg(ap1,l1)
case ev2/s:
v2 = evarg(ap2,l2)
endcase
case ev1/s:
v1 = evarg(ap1,l1)
endcase
case look1/s:
if l1 gr 2 then expand(lvap1)
v1 = lookup(ap1,l1)
endcase
case mem1/s:
expand(lvap1)
v1 = looktype(ap1,l1,memtype)
endcase
case fld1/s:
if l1 gr 2 then expand(lvap1)
v1 = looktype(ap1,l1,fldtype)
endcase
case bt1ev2/s:
expand(lvap1)
v1 = looktype(ap1, l1, bttype)
v2 = evarg(ap2, l2)
endcase
case exp1/s:
expand(lvap1)
endcase
]
let t = nil
let typ, ep = nil, nil
let ptr, len = nil, nil
switchon no into
[ default:
errx("UNDEFINED BUILTIN @S", false, bep)
endcase
case 1: // BUILTIN
expand(lvap1)
xbuiltin(ap1,l1,v2)
endcase
case 2: // M (MACRO)
t = macdef(ap2, l2)
xdefmac(ap1, l1, fstop-t, false)
endcase
case 3: // N (NEUTRAL)
entarg(ap1,l1,neutype)
endcase
case 4: // MEMORY
expand(lvap1)
xmemory(ap1,l1,v2,v3, mement(ap4,l4), mement(ap5,l5))
endcase
case 5: // TARGET
targset(v1)
endcase
case 6: // DEFAULT
defaultbi(v1,ap2,l2)
endcase
case 7: // F (FIELD)
expand(lvap1)
xfield(ap1,l1,v2,v3)
endcase
case 8: // PF (PREASSIGN)
dofld(v1,ap2,l2,false)
endcase
case 9: // SET
if l1 gr 2 then expand(lvap1)
ep = lookup(ap1,l1)
if ep eq 0 then ep = putin(inttype)
typ = ep!stype
test typ eq inttype
ifso ep!isval = v2
ifnot
test (typ eq nultype) % (typ eq undtype)
ifso
[ ep!stype = inttype
ep!isval = v2
]
ifnot
redeferr(ep, inttype)
endcase
case 10: // ADD
v1 = 0
for k = 1 to na do
[ v1 = evarg(ap+1, @ap-1) + v1
ap = ap+@ap
]
goto av
case 11: // IP
if (v1 eq 0) % (v1!stype ge 0) then
[ process(ap1, l1, valmode, lv typ, lv v1)
if typ ne adrtype then
[ errx("'IP[@B]' - ARG NOT ADDRESS",false,ap1,l1)
endcase
]
]
v1 = v1!asval
goto av
case 12: // IFSE
expand(lv ap2)
if l1 ne l2 then goto bf
for k = 0 to l1-1 do
if ap1!k ne ap2!k then goto bf
goto bt
case 13: // IFSET
t = aused(v1)
goto bx
case 14: // IFE
t = v1 eq v2
goto bx
case 15: // IFG
t = v1 gr v2
goto bx
case 16: // IFDEF
t = (v1 ne 0) & (v1!stype ne nultype) &
(v1!stype ne undtype)
goto bx
case 17: // IFME
expand(lv ap2)
v2 = looktype(ap2,l2,memtype)
t = (v1 ne 0) & (v1!stype eq v2-fstop)
goto bx
case 18: // ER
v2 = (na ls 2? 0, evarg(ap2,l2))
t = false
if na ge 3 then v3 = evarg(ap3,l3)
switchon v2 into
[ default: coderr(bep, v2); endcase
case 1: t = true // fatal error
case 2: endcase // ordinary error
case 3: warncnt = warncnt+1 // warning
case 0: errcnt = errcnt-1 // not a real error
]
test na ge 3
ifso errx("@B@V", t, ap1, l1, v3)
ifnot errx("@B", t, ap1, l1)
endcase
case 19: // LIST
expand(lvap1)
xlst(ap1,l1,v2)
endcase
case 20: // INSERT
xinsert(ap1,l1)
endcase
case 21: // NOT
v1 = -1-v1
goto av
case 22: // REPEAT
for k = 1 to v1 do
process(ap2,l2,accmode)
endcase
case 23: // OR
v1 = false
for k = 1 to na do
[ v1 = evarg(ap+1, @ap-1) % v1
ap = ap+@ap
]
goto av
case 24: // XOR
v1 = false
for k = 1 to na do
[ v1 = evarg(ap+1, @ap-1) xor v1
ap = ap+@ap
]
goto av
case 25: // AND
v1 = true
for k = 1 to na do
[ v1 = evarg(ap+1, @ap-1) & v1
ap = ap+@ap
]
goto av
case 26: // COMMENTCHAR
xcchar(ap1,l1)
endcase
case 27: // BITTABLE
expand(lvap1)
xbittable(entarg(ap1, l1, bttype), v2)
endcase
case 28: // GETBIT
if checkbtx(v2, v1) then
[ v1 = getbits(v1!bttab+fstop, v2, 1); goto av ]
endcase
case 29: // SETBIT
v3 = (na ls 3? 1, evarg(ap3,l3))
v4 = (na ls 4? 1, evarg(ap4,l4))
v5 = (na ls 5? 1, evarg(ap5,l5)&1)
while v3 ne 0 do
[ unless checkbtx(v2, v1) break
setbits(v1!bttab+fstop, v2, 1, v5)
v2, v3 = v2+v4, v3-1
]
endcase
case 30: // FINDBIT
if xfindbit(v1, lv v2,
(na ls 3? 1, evarg(ap3,l3)),
(na ls 4? 1, evarg(ap4,l4)),
(na ls 5? 1, evarg(ap5,l5)),
(na ls 6? -1, evarg(ap6,l6)) ) then
[ v1 = v2; goto av ]
endcase
case 32: // LSHIFT
v1 = v1 lshift v2
goto av
case 33: // RSHIFT
v1 = v1 rshift v2
goto av
case 34: // FVAL
v1 = gtfield(v1)
goto av
case 35: // SELECT
v1 = evarg(ap+1, @ap-1)
test (v1 ls 0) % (v1 gr na-2)
ifso errx("INDEX @V TOO BIG IN 'SELECT'", false, v1)
ifnot
[ for j = 0 to v1 do
ap = ap+@ap
ptr, len = ap+1, @ap-1
goto ba
]
endcase
case 36: // SETPOST
v1!mspost = (l2 eq 0? 0, mement(ap2, l2)-fstop)
endcase
case 37: // SETTAG
v1!mstagmac = (l2 eq 0? 0, mement(ap2, l2)-fstop)
endcase
case 38: // SETLISTFIELDS
setlfbi(v1, ap2, l2)
endcase
case 39: // SETMBEXT
if outchan ne fakeoutchan then
errx("SETMBEXT GIVEN AFTER OUTPUT STARTED")
t = alloc(l1/2+1)
bcplpak(t, ap1, l1)
mbext = t-fstop
endcase
case 40: // SUB
v1 = evarg(ap+1, @ap-1)
for k = 2 to na do
[ ap = ap+@ap
v1 = v1 - evarg(ap+1, @ap-1)
]
goto av
case 41: // EQUATE
expand(lv ap2)
ep = lookup(ap2, l2)
ap1 = lookup(ap1, l1)
if ep eq 0 then
[ errx("@B not defined in EQUATE", false, ap2, l2); endcase ]
v1 = valsize(ep)
test ap1 eq 0
ifso ap1 = putin(ep!stype)
ifnot if v1 ne valsize(ap1) then
[ errx("EQUATE[@S,@S] -- different types", false, ap1, ep); endcase ]
MoveBlock(ap1-v1, ep-v1, v1)
endcase
case 42: // PROCESSMODE
switchon v1 into
[ case 0: ignore = false; endcase
case 1: ignore = true; endcase
default: coderr(bep, v1)
]
endcase
case 43: // TRACEMODE
t = v2 ne 0
switchon v1 into
[ case 0: tracesyms = t; endcase
case 1: tracecalls = t; endcase
default: coderr(bep, v1)
]
endcase
case 44: // WHILE
while evarg(ap1, l1) ne 0 do
process(ap2, l2, accmode)
endcase
bt:
t = true
bx:
if t then m = m-1
bf:
if na ls m endcase
t = lvap1+m*2
ptr, len = t!-2, t!-1
ba: // Append len char.s at ptr
test sttop+len ge tlbot
ifso
errx("Statement too long")
ifnot
[ MoveBlock(sttop, ptr, len)
sttop = sttop+len
]
endcase
av: // Append v1 as number
test sttop+2 ge tlbot
ifso
errx("Statement too long")
ifnot
[ @sttop, sttop!1 = v1, numc
sttop = sttop+2
]
endcase
]
// Deallocate any expansion blocks
fslim = oldfslim
]
and coderr(ep, v) be
errx("Invalid code @V for @S", false, v, ep)