!Graham Toal - latest development version of SKIMPE 23/01/80 18.58
external integer array spec a(1 : 500)
external integer array spec taglink(0 : 255)
external integer array spec tag(1 : 512)
external string (5) array spec display(0 : 15)
external integer spec level, condflag, expropt
!-----------------------------------------------------------------------
external string (7) fn spec s(integer i)
external string (255) fn spec strint(integer n, p)
external string (8) fn spec strhex(integer n)
external routine spec fault(string (63) s)
external string (255) fn spec name(integer ident)
external routine spec dump(string (7) lab, op, reg, addr)
external integer fn spec getwork
external routine spec returnwork(integer work)
external routine spec proc(integer ap)
external routine spec array(integer ap)
external integer fn spec getcoti(integer const)
!-----------------------------------------------------------------------
const integer proceedure = -1, arrayelement = -2, scalar = -3, unary = 11, c
complex = -2, terminal = 0, true = 1, load = 0, exp = 6, sub = 10, c
mult = 8, div = 7, shr = 2, shl = 1, cmp = 13
!------------------------------------------------------------------------
external integer fn intstr(string (6) val)
integer i, total
total = 0
for i = 1, 1, length(val) cycle
total = total * 10 + charno(val, i) - '0'
repeat
result = total
end
external routine expr(integer exprp)
integer fn spec totree(integer exprp)
routine spec evaluate(integer exprp)
routine spec opn(integer op, ptr)
integer array tree(1 : 64)
integer treep, treenode, treenode1, treenode2, testp, expr1p, expr2p, compp, i, j, l
const integer array reversecomp(1 : 6) = 1, 2, 5, 6, 3, 4
treep = 1
if condflag = 0 then treenode = totree(exprp) else start
condflag = 0
testp = exprp
! for <test>=<expr><comp><expr>
expr1p = a(testp + 1)
compp = a(testp + 2)
expr2p = a(testp + 3)
treenode1 = totree(expr1p)
treenode2 = totree(expr2p)
tree(treep) = 13
! CMP
if tree(treenode1) = -4 then start
a(compp) = reversecomp(a(compp))
tree(treep + 1) = treenode2
tree(treep + 2) = treenode1
finish else start
tree(treep + 1) = treenode1
tree(treep + 2) = treenode2
finish
treenode = treep
finish
if expropt = 1 then start
newline
if 0 < tree(treenode) <= 10 then l = treenode + 2 else l = treenode + 1
j = 0
for i = 1, 1, l cycle
write(tree(i), 4)
j = j + 5
if i = treenode then printstring("*") and j = j + 1
if tree(i) = -3 then i = i + 1 and printstring(" " . strhex(tree(i))) and j = j + 10
if j > 70 then newline and j = 0
repeat
newlines(2)
finish
evaluate(treenode)
return
!-----------------------------------------------------------------------
integer fn totree(integer exprp)
! create tree form of expression
routine spec pseval(integer type, datum)
integer array os(1 : 4), ps(1 : 5)
! operator & pseudo-evaluation stacks
integer osp, psp, unaryp, operandp, exprrestp, opp, namep, actualp, ident, nametag
const integer array prec(1 : 12) = 3, 3, 2, 1, 1, 3, 2, 2, 1, 1, 1, 4
! <<,>>,&,!!,!,**,/,*,+,-,-(unary),¬
integer fn constop(integer op, val1)
switch exec(1:10)
integer res
-> exec(op)
exec(1):
! <<
res = tree(val1 + 1) << tree(val1 + 3)
-> cont
exec(2):
! >>
res = tree(val1 + 1) >> tree(val1 + 3)
-> cont
exec(3):
! &
res = tree(val1 + 1) & tree(val1 + 3)
-> cont
exec(4):
! !!
res = tree(val1 + 1) !! tree(val1 + 3)
-> cont
exec(5):
! !
res = tree(val1 + 1) ! tree(val1 + 3)
-> cont
exec(6):
! **
res = tree(val1 + 1) ¬¬ tree(val1 + 3)
-> cont
exec(7):
! /
if tree(val1 + 3) = 0 then fault("DIVISION BY ZERO") and res = 0 and -> cont
res = tree(val1 + 1) // tree(val1 + 3)
-> cont
exec(8):
! *
res = tree(val1 + 1) * tree(val1 + 3)
-> cont
exec(9):
! +
res = tree(val1 + 1) + tree(val1 + 3)
-> cont
exec(10):
! -
res = tree(val1 + 1) - tree(val1 + 3)
cont:
result = res
end
unaryp = a(exprp + 1)
operandp = a(exprp + 2)
exprrestp = a(exprp + 3)
if a(unaryp) <= 2 then os(1) = a(unaryp) + 10 and osp = 1 else osp = 0
psp = 0
cycle
! for each operand
if a(operandp) = 1 then start
! <name><actual>
namep = a(operandp + 1)
actualp = a(operandp + 2)
ident = a(namep + 1)
if taglink(ident) = 0 then start
!? fault(name(ident)." NOT DECLARED")
pseval(-3, -ident)
! pseval dummy tag
finish else start
nametag = tag(taglink(ident))
if nametag >> 28 <= 1 then start
! scalar variable
if a(actualp) = 1 then start
fault("SCALAR " . name(ident) . " HAS PARAMETER")
pseval(-3, 0)
finish else pseval(-3, nametag)
finish else start
if nametag >> 28 <= 3 then pseval(-2, operandp) else start
if nametag >> 24 & 16_F = 0 then start
fault("ROUTINE NAME " . name(ident) . " IN EXPRESSION")
pseval(-3, 0)
finish else pseval(-1, operandp)
finish
finish
finish
finish else start
if a(operandp) = 2 then pseval(-4, a(a(operandp + 1) + 1)) c
else psp = psp + 1 and ps(psp) = totree(a(operandp + 1))
finish
if a(exprrestp) = 2 then exit
! no more operands
opp = a(exprrestp + 1)
operandp = a(exprrestp + 2)
exprrestp = a(exprrestp + 3)
pseval(os(osp), 0) and osp = osp - 1 while osp > 0 and prec(a(opp)) <= prec(os(osp))
! unstack while prec(new op)<=
osp = osp + 1
! stack new operator
os(osp) = a(opp)
repeat
pseval(os(osp), 0) and osp = osp - 1 while osp > 0
! unstack rest
result = ps(1)
!-----------------------------------------------------------------------
routine pseval(integer type, datum)
routine spec store(integer t)
integer nodep, temp
nodep = treep
store(type)
if type > 0 then start
! operator
if type > 10 then start
store(ps(psp))
finish else start
if tree(ps(psp - 1)) = -4 and tree(ps(psp)) = -4 c
and ps(psp - 1) = treep - 5 and ps(psp) = treep - 3 start
temp = constop(type, treep - 5)
if temp >= 0 then start
treep = ps(psp - 1) + 2
tree(ps(psp - 1) + 1) = temp
psp = psp - 1
ps(psp) = treep - 2
return
finish else -> over
finish else start
over:
store(ps(psp - 1))
store(ps(psp))
psp = psp - 1
finish
finish
finish else store(datum) and psp = psp + 1
ps(psp) = nodep
!-----------------------------------------------------------------------
routine store(integer t)
if treep > 64 then fault("EXPRESSION TOO LONG") and stop
tree(treep) = t
treep = treep + 1
end
end
end
!-----------------------------------------------------------------------
const string (3) array strop(0 : 13) = "LD", "SHL", "SHR", "AND", "EOR", c
"OR", "EXP", "DIV", "MUL", "ADD", "SUB", "NEG", "COM", "CMP"
const integer array args(0 : 13) = 1, 0, 0, 1, 1, 1, 0, 0, -1, 1, 1, 1, 1, 1
const integer array commut(0 : 13) = 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1
routine doop(integer op, string (10) val)
string (6) const
integer value
switch clever(0:13)
! B op VAL
if args(op) # 1 start
if val -> ("#") . const then start
value = intstr(const)
-> clever(op)
clever(mult):
if value = 2 or value = 4 then start
dump("", "ASL", "B", "") and value = value >> 1 while value # 1
finish
return if value = 1
-> eval
clever(div):
if value = 2 or value = 4 then start
dump("", "ASR", "B", "") and value = value >> 1 while value # 1
finish
return if value = 1
-> eval
clever(exp):
if value = 2 then start
dump("", "TFR", "", "B,A")
dump("", "MUL", "", "")
return
finish else -> eval
clever(shl):
if 1 <= value <= 2 then start
dump("", "LSL", "B", "") and value = value - 1 until value = 0
finish
return unless 3 <= value <= 7
-> eval
clever(shr):
if 1 <= value <= 2 then start
dump("", "LSR", "B", "") and value = value - 1 until value = 0
finish
return unless 3 <= value <= 7
-> eval
clever(*):
eval:
finish
dump("", "LD", "A", val)
if args(op) < 0 start
dump("", "MUL", "", "")
finish else start
dump("", "LBSR", "", strop(op))
finish
finish else start
dump("", strop(op), "B", val)
finish
end
routine opn(integer op, nodep)
integer type, basep, varp, disp
string (4) base
type = tree(nodep)
if type > scalar then fault("*BUG")
varp = tree(nodep + 1)
if varp < 0 then start
doop(op, name(-varp))
finish else start
if type = scalar start
basep = varp >> 16 & 16_F
base = display(basep)
base = ",Y" if basep = level
base = ",X" if basep = 1
disp = varp & 16_FFFF
if varp >> 28 = 1 start
if basep = level # 1 start
doop(op, "[" . "-" . s(disp) . base . "]")
finish else if basep # level # 1 start
dump("", "PSH", "U", "A,B")
dump("", "LD", "D", base)
dump("", "ADD", "D", "#" . s(disp))
dump("", "ST", "D", "0,X")
dump("", "PUL", "U", "A,B")
doop(op, "[0,X]")
finish
return
finish
if basep = level or basep = 1 start
doop(op, "-" . s(disp) . base)
finish else start
dump("", "PSH", "U", "A,B")
dump("", "LD", "D", base)
dump("", "ADD", "D", "#" . s(disp))
dump("", "ST", "D", "0,X")
dump("", "PUL", "U", "A,B")
doop(op, "[0,X]")
finish
finish else start
doop(op, "#" . s(varp))
finish
finish
end
routine regop(integer op, string (7) r1, r2)
! R1 op R2
if args(op) # 1 start
if args(op) < 0 start
dump("", "MUL", "", "")
finish else start
dump("", "LBSR", "", strop(op))
finish
finish else start
dump("", strop(op), r1, r2)
finish
end
routine loadb(integer nodep)
integer type, datum
type = tree(nodep)
datum = tree(nodep + 1)
if type = proceedure start
proc(datum)
return
finish
if type = arrayelement start
array(datum)
dump("", "LD", "B", "[0,X]")
return
finish
opn(load, nodep)
end
routine evaluate(integer nodep)
integer op, opd1p, opd2p
if tree(nodep) <= terminal start
loadb(nodep)
return
finish
op = tree(nodep)
opd1p = tree(nodep + 1)
if cmp > op >= unary start
!
! TEST FOR CONST NODE HERE
!
evaluate(opd1p)
dump("", strop(op), "B", "")
return
finish
opd2p = tree(nodep + 2)
!
! TEST FOR BOTH NODES CONST HERE
!
if tree(opd1p) >= complex start
if tree(opd2p) >= complex start
evaluate(opd2p)
dump("", "PSH", "U", "B")
evaluate(opd1p)
doop(op, ",U+")
finish else start
evaluate(opd1p)
opn(op, opd2p)
finish
finish else start
if tree(opd2p) >= complex start
evaluate(opd2p)
if commut(op) = true start
opn(op, opd1p)
return
finish
if args(op) <= 0 start
dump("", "TFR", "", "B,A")
opn(load, opd1p)
regop(op, "B", "A")
finish else start
dump("", "PSH", "U", "B")
opn(load, opd1p)
doop(op, ",U+")
finish
finish else start
opn(load, opd1p)
opn(op, opd2p)
finish
finish
end
end
end of file