!Graham Toal - latest development version of SKIMPB 12/02/80 16.25
const integer true = 0, false = 1
external integer fn spec find(integer flag, integer name ty, la)
external integer array spec a(1 : 500)
external integer array spec taglink(0 : 255)
external integer array spec tag(1 : 512)
external integer array spec link(1 : 512)
!-----------------------------------------------------------------------
external routine spec expr(integer exprp)
external integer fn spec cond(integer condp, tlabel, flabel)
external string (7) fn spec s(integer n)
external string (255) fn spec strint(integer n, p)
external integer fn spec getwork
external routine spec returnwork(integer work)
external routine spec clearwork
external integer fn spec newtag
external routine spec pushtag(integer ident, form, type, dim, level, rad)
external routine spec poptags
external integer fn spec getlabel(integer constp)
external routine spec filllabel(integer label)
external integer fn spec fillbranch(integer label)
external routine spec poplabels
external integer fn spec nextplabel
external routine spec dump(string (7) lab, op, reg, addr)
external routine spec fault(string (63) mess)
external string (255) fn spec name(integer ident)
external routine spec pushstart(integer flag, plab)
external routine spec popstart(integer name flag, plab)
external routine spec findcontinue(integer name type, flag)
external routine spec findexit(integer name type, flag)
external routine spec popcycle(integer name type, lab)
external routine spec clearstart
external integer fn spec enter
external routine spec dumpreturn
external routine spec proc(integer procp)
external routine spec array(integer arrayp)
external routine spec endofprog
!-----------------------------------------------------------------------
external integer array nextrad(0 : 15)
external string (5) array display(0 : 15) = "Bug", "-2,X", "-4,X", c
"-6,X", "-8,X", "-10,X", "-12,X", "-14,X", "-16,X", "-18,X", "-20,X", c
"-22,X", "-24,X", "-26,X", "-28,X", "-30,X"
external integer level, nextcad = 1, pstr = 0
!-----------------------------------------------------------------------
own integer array proctype(0 : 15)
own integer array staticalloc(0 : 15)
own string (3) array regs(1 : 2) = "A", "A,B"
external integer array rt(0 : 15)
external integer array parms(0 : 15)
external integer spec traceopt, checkopt
external integer aopt = 0
!-----------------------------------------------------------------------
external routine statement(integer statementp)
own integer access = 1
routine spec doloop(integer loopsp)
routine spec instr(integer instrp)
string (4) base, b1, b2
switch sttype(1:13)
integer condp, instrp, elsep, constp, arrayp, namep, namesp, expr1p, c
expr2p, instr2p, tlabel, flabel, label, fplabel, tplabel, work1, work2, c
flag, plabel, procp, formalp, formp, params, procid, ident, form, paramt, c
paraml, dim, basep, type, cyclab, cntlab, extlab
-> sttype(a(statementp))
!-----------------------------------------------------------------------
sttype(1):
! <instr><CYCLAUSE>
if access = 0 then fault("ACCESS?") and access = 1
dump("", "SWI", "3", "") if traceopt = 1
unless a(a(a(statementp + 2) + 1)) = 2 then doloop(a(statementp + 2))
instr(a(statementp + 1))
if a(a(a(statementp + 2) + 1)) = 2 then return
if access = 0 then fault("DUBIOUS STATEMENT") and access = 1
condp = a(a(a(statementp + 2) + 1) + 1)
a(1) = 1
a(2) = 3
if a(a(statementp + 2)) <= 2 then a(3) = 2 else a(3) = 1
statementp = 1
-> untilst
!-----------------------------------------------------------------------
sttype(2):
! "IF"<cond>"THEN"<instr><else>
condp = a(statementp + 1)
instrp = a(statementp + 2)
elsep = a(statementp + 3)
if access = 0 then fault("ACCESS?") and access = 1
dump("", "SWI", "3", "") if traceopt = 1
if 7 <= a(instrp) <= 8 or a(instrp) = 2 then start
! branch
if a(instrp) = 7 then findcontinue(type, tlabel) c
else if a(instrp) = 8 then findexit(type, tlabel) else start
constp = a(instrp + 1)
tlabel = getlabel(constp)
finish
if a(elsep) = 2 then filllabel(cond(condp, tlabel, -1)) else start
instrp = a(elsep + 1)
if 7 <= a(instrp) <= 8 or a(instrp) = 2 then start
! branch
if a(instrp) = 7 then findcontinue(type, flabel) c
else if a(instrp) = 8 then findexit(type, flabel) else start
constp = a(instrp + 1)
flabel = getlabel(constp)
finish
access = 0
filllabel(cond(condp, tlabel, flabel))
dump("", "LBRA", "", "L" . s(flabel))
return
finish else start
filllabel(cond(condp, tlabel, -1))
if a(instrp) = 3 then pushstart(1, -1) else instr(instrp)
finish
finish
finish else start
if a(elsep) = 2 then start
fplabel = cond(condp, -1, -1)
if a(instrp) = 3 then pushstart(0, fplabel) else instr(instrp) and filllabel(fplabel)
finish else start
instr2p = a(elsep + 1)
if 7 <= a(instr2p) <= 8 or a(instr2p) = 2 then start
! branch
if a(instr2p) = 7 then findcontinue(type, flabel) c
else if a(instr2p) = 8 then findexit(type, flabel) else start
constp = a(instr2p + 1)
flabel = getlabel(constp)
finish
fplabel = cond(condp, -1, flabel)
! result always -1
instr(instrp)
finish else start
fplabel = cond(condp, -1, -1)
instr(instrp)
tplabel = nextplabel
dump("", "LBRA", "", "L" . s(tplabel))
filllabel(fplabel)
if a(instr2p) = 3 then pushstart(1, tplabel) c
else instr(instr2p) and filllabel(tplabel)
finish
finish
finish
access = 1
return
!-----------------------------------------------------------------------
sttype(3):
! <const>':'<statement>
access = 1
constp = a(statementp + 1)
statementp = a(statementp + 2)
label = getlabel(constp)
filllabel(label)
statement(statementp)
return
!-----------------------------------------------------------------------
sttype(4):
! "FINISH"<else>
access = 1
elsep = a(statementp + 1)
popstart(flag, plabel)
if flag = 0 then start
! first %start/%finish
if a(elsep) = 1 then start
instrp = a(elsep + 1)
tplabel = nextplabel
dump("", "LBRA", "", "L" . s(tplabel))
filllabel(plabel)
if a(instrp) = 3 then pushstart(1, tplabel) c
else instr(instrp) and filllabel(tplabel)
finish else filllabel(plabel)
finish else start
! second %start/%finish
if a(elsep) = 1 then fault("SPURIOUS %ELSE") else filllabel(plabel)
finish
return
!-----------------------------------------------------------------------
sttype(5):
! "INTEGER"<array>
arrayp = a(statementp + 1)
namep = a(arrayp + 1)
namesp = a(arrayp + 2)
if a(arrayp) = 1 then start
! array declaration
dump("", "SWI", "3", "") if traceopt = 1
if access = 0 then fault("ACCESS?") and access = 1
if find(2, cyclab, type) = true then fault("ORDER?")
if level = 1 then base = ",X" else base = ",Y"
cycle
expr1p = a(arrayp + 3)
expr2p = a(arrayp + 4)
expr(expr1p)
dump("", "SEX", "", "")
dump("", "PSH", "U", "A,B")
work1 = getwork
!***dump("STR","ACC",display(level),work1)
expr(expr2p)
dump("", "SEX", "", "")
dump("", "ADD", "D", "#1")
dump("", "PSH", "U", "A,B")
dump("", "TFR", "", "S,D")
!***dump("LDA","ACC","ACC",1)
work2 = getwork
!***dump("STR","ACC",display(level),work2)
cycle
staticalloc(level) = staticalloc(level) + 2
nextrad(level) = nextrad(level) + 2
pushtag(a(namep + 1), 2, 1, 2, level, nextrad(level))
dump("", "SUB", "D", "0,U")
dump("", "ST", "D", "-" . s(nextrad(level)) . base)
dump("", "ADD", "D", "2,U")
! DUMP("","SUB","D","#1")
!***dump("SUB","STP",display(level),work1)
!***dump("STR","STP",display(level),nextrad(level))
!***dump("ADD","STP",display(level),work2)
if a(namesp) = 2 then exit
namep = a(namesp + 1)
namesp = a(namesp + 2)
repeat
dump("", "TFR", "", "D,S")
dump("", "LEA", "U", "4,U")
returnwork(work1)
returnwork(work2)
if a(a(arrayp + 5)) = 1 then start
arrayp = a(arrayp + 5)
namep = a(arrayp + 1)
namesp = a(arrayp + 2)
continue
finish else return
repeat
finish else start
cycle
staticalloc(level) = staticalloc(level) + 1
nextrad(level) = nextrad(level) + 1
pushtag(a(namep + 1), 0, 1, 1, level, nextrad(level))
if a(namesp) = 2 then exit
namep = a(namesp + 1)
namesp = a(namesp + 2)
repeat
finish
return
!-----------------------------------------------------------------------
sttype(6):
! <proc><name><formal>
if level = 0 then fault("PROCEDURE BEFORE %BEGIN")
if level = 15 then fault("PROCEDURE NESTING TOO DEEP")
access = 1
procp = a(statementp + 1)
namep = a(statementp + 2)
formalp = a(statementp + 3)
procid = a(namep + 1)
! skipproc(level)=nextcad
pushtag(procid, 4, a(procp) - 1, 0, level, nextcad)
level = level + 1
rt(level) = tag(taglink(procid)) & 16_FFFF
dump("", "LBRA", "", "S" . s(rt(level)))
dump("E" . s(rt(level)), "EQU", "", "*")
proctype(level) = a(procp)
staticalloc(level) = enter
! nextrad(level)=2
parms(level) = 0
if a(formalp) = 2 then -> retn
! no parameters
params = 0
paraml = taglink(procid)
cycle
formp = a(formalp + 1)
namep = a(formalp + 2)
namesp = a(formalp + 3)
formalp = a(formalp + 4)
if a(formp) = 1 then form = 3 and dim = 2 else start
if a(formp) = 2 then form = 1 and dim = 2 c
else form = 0 and dim = 1
finish
cycle
ident = a(namep + 1)
! declare parameters as locals
nextrad(level) = nextrad(level) + dim
staticalloc(level) = staticalloc(level) + dim
pushtag(ident, form, 1, dim, level, nextrad(level))
! DUMP("","PUL","U",REGS(DIM))
! DUMP("","PSH","S",REGS(DIM))
! append parameter tag cells to procedure tag cell
paramt = newtag
tag(paramt) = tag(taglink(ident))
link(paramt) = link(paraml)
link(paraml) = paramt
paraml = paramt
parms(level) = parms(level) + dim
params = params + 1
if params > 15 then fault(name(procid) . " HAS TOO MANY PARAMETERS") and stop
if a(namesp) = 2 then exit
namep = a(namesp + 1)
namesp = a(namesp + 2)
repeat
repeat until a(formalp) = 2
! insert number of parameters into tag cell
tag(taglink(procid)) = tag(taglink(procid)) ! params << 20
retn:
dump("", "LEA", "S", "-A" . s(rt(level)) . ",S")
return
!-----------------------------------------------------------------------
sttype(7):
! "END"<ofprog>
if level > 1 start
! DUMP("P".S(RT(LEVEL)),"EQU","",S(PARMS(LEVEL)))
if proctype(level) # 1 and checkopt = 1 then dump("", "SWI", "", "")
! %RESULT NOT ENCOUNTERED
! DUMP("R".S(RT(LEVEL)),"EQU","","*")
finish
poptags
poplabels
clearstart
clearwork
dump("A" . s(rt(level)), "EQU", "", s(staticalloc(level)))
if proctype(level) >= 1 and access = 1 then dumpreturn
access = 1
level = level - 1
if a(a(statementp + 1)) = 2 then start
! %end
if level <= 0 then fault("SPURIOUS %END") and endofprog
dump("S" . s(rt(level + 1)), "EQU", "", "*")
finish else start
! %endofprogram
if level # 0 then fault("TOO FEW %ENDS")
endofprog
finish
return
!-----------------------------------------------------------------------
sttype(8):
! "BEGIN"
if level # 0 then fault("SPURIOUS %BEGIN") else start
rt(1) = 0
level = 1
proctype(1) = 0
staticalloc(1) = enter
nextrad(1) = staticalloc(1)
finish
return
sttype(9):
! <LOOPS>%CYCLE
if access = 0 then fault("WARNING - ACCESS???") and access = 1
dump("", "SWI", "3", "") if traceopt = 1
doloop(a(statementp + 1))
return
sttype(10):
! %REPEAT<UNTIL>
condp = a(a(statementp + 1) + 1)
dump("", "SWI", "3", "") if traceopt = 1
untilst:
access = 1
popcycle(type, cyclab)
cntlab = cyclab + 1
extlab = cntlab + 1
if a(a(statementp + 1)) # 2 then start
dump("L" . s(cntlab), "EQU", "", "*")
tplabel = cond(condp, -1, cyclab)
if type = 2 then dump("L" . s(extlab), "LEA", "U", "4,U") c
else dump("L" . s(extlab), "EQU", "", "*")
finish else start
dump("L" . s(cntlab), "LBRA", "", "L" . s(cyclab))
if type = 2 then dump("L" . s(extlab), "LEA", "U", "4,U") c
else dump("L" . s(extlab), "EQU", "", "*")
finish
return
sttype(13):
! "PRINTTEXT" <STRING>
pstr = 1
fault("ACCESS?") and access = 1 if access = 0
dump("", "SWI", "3", "") if traceopt = 1
dump("", "LBSR", "", "PSTR")
printstring(" FCB ")
work1 = 4
cycle
work2 = a(work1)
if work2 # 16_80 then write(work2, 0) else printstring("$80") and exit
printsymbol(',')
work1 = work1 + 1
repeat
newline
return
sttype(11):
! "CONSTANT" <NAME) '=' <VALUE>
dump(name(a(a(statementp + 1) + 1)), "EQU", "", s(a(a(statementp + 2) + 1)))
return
sttype(12):
! "LABEL" <NAME>
dump(name(a(a(statementp + 1) + 1)), "EQU", "", "*")
return
!-----------------------------------------------------------------------
routine instr(integer instrp)
switch instype(1:14)
string (4) base
integer namep, assignp, constp, ident, actualp, exprp, nametag, c
disp, work, rinstrp, type, lab
-> instype(a(instrp))
!-----------------------------------------------------------------------
instype(1):
! <name><actual><assign>
namep = a(instrp + 1)
actualp = a(instrp + 2)
assignp = a(instrp + 3)
rinstrp = a(instrp + 4)
ident = a(namep + 1)
!? %if taglink(ident)=0 %then fault(name(ident)." NOT DECLARED") !? %and %return
if taglink(ident) = 0 start
if a(assignp) # 1 then dump("", "FDB", "", name(ident)) c
else expr(a(assignp + 1)) and dump("", "ST", "B", name(ident))
finish else start
nametag = tag(taglink(ident))
! %ROUTINE GET NAME ADDRESS ????
if a(assignp) = 1 then start
if nametag >> 28 = 4 then fault(name(ident) . " NOT A DESTINATION") and return
exprp = a(assignp + 1)
if nametag >> 28 >= 2 then start
! array variable
expr(exprp)
work = getwork
dump("", "PSH", "U", "B")
array(instrp)
dump("", "PUL", "U", "B")
dump("", "ST", "B", "[0,X]")
returnwork(work)
finish else start
expr(exprp)
basep = nametag >> 16 & 16_F
disp = nametag & 16_FFFF
base = display(basep)
base = ",Y" if basep = level
base = ",X" if basep = 1
if basep = level or basep = 1 start
if nametag >> 28 = 1 then b1 = "[" and b2 = "]" else b1 = "" and b2 = ""
dump("", "ST", "B", b1 . "-" . s(disp) . base . b2)
finish else start
dump("", "PSH", "U", "A,B")
dump("", "LD", "D", base)
dump("", "SUB", "D", "#" . s(disp))
dump("", "ST", "D", "0,X")
if nametag >> 28 = 1 then start
dump("", "LD", "D", "[0,X]")
dump("", "ST", "D", "0,X")
finish
dump("", "PUL", "U", "A,B")
dump("", "ST", "B", "[0,X]")
finish
if a(actualp) = 1 then fault(name(ident) . " DECLARED AS SCALAR")
finish
! %END OF ROUTINE GET NAME ADDRESS???
finish else start
if nametag >> 28 = 4 and nametag >> 24 & 16_F = 0 c
then proc(instrp) else fault(name(ident) . " NOT A ROUTINE NAME")
finish
finish
if a(rinstrp) = 1 then instrp = a(rinstrp + 1) and -> instype(a(instrp))
return
!-----------------------------------------------------------------------
instype(2):
! '->'<const>
access = 0
constp = a(instrp + 1)
label = getlabel(constp)
dump("", "LBRA", "", "L" . s(label))
return
!-----------------------------------------------------------------------
instype(3):
! "START"
fault("ILLEGAL %START")
return
!-----------------------------------------------------------------------
instype(4):
! "RETURN"
if proctype(level) # 1 then fault("%RETURN OUT OF CONTEXT")
access = 0
dumpreturn
! DUMP("","LBRA","","R".S(RT(LEVEL)))
return
!-----------------------------------------------------------------------
instype(5):
! "RESULT"'='<expr>
if proctype(level) # 2 then fault("%RESULT OUT OF CONTEXT")
access = 0
expr(a(instrp + 1))
dumpreturn
! DUMP("","LBRA","","R".S(RT(LEVEL)))
return
!-----------------------------------------------------------------------
instype(6):
! "STOP"
access = 0
dump("", "SWI", "2", "")
! CALL MONITOR AND HALT?
return
instype(7):
access = 0
findcontinue(type, lab)
dump("", "LBRA", "", "L" . s(lab))
return
instype(8):
access = 0
findexit(type, lab)
dump("", "LBRA", "", "L" . s(lab))
return
instype(9):
! <OPCODE> # <CONST>
dump("", name(a(a(instrp + 1) + 1)), "", "#" . s(a(a(instrp + 2) + 1)))
return
instype(10):
! <OPCODE> <CONST>
dump("", name(a(a(instrp + 1) + 1)), "", s(a(a(instrp + 2) + 1)))
return
instype(11):
! <OPCODE> # <NAME>
namep = a(instrp + 2)
ident = a(namep + 1)
dump("", name(a(a(instrp + 1) + 1)), "", "#" . name(ident))
return
instype(12):
! <OPCODE> <NAME>
namep = a(instrp + 2)
ident = a(namep + 1)
nametag = tag(taglink(ident)) if taglink(ident) # 0
if taglink(ident) = 0 or nametag >> 28 = 4 start
dump("", name(a(a(instrp + 1) + 1)), "", name(ident))
finish else start
basep = nametag >> 16 & 15
disp = nametag & 16_FFFF
base = display(basep)
base = ",Y" if basep = level
base = ",X" if basep = 1
b1 = ""
b2 = ""
b1 = "[" and b2 = "]" if nametag >> 28 = 1
dump("", name(a(a(instrp + 1) + 1)), "", b1 . "-" . s(disp) . base . b2)
finish
return
instype(13):
! <OPCODE> <STRING>
begin
string (255) addr
integer i, sym
addr = ""
i = 10
cycle
sym = a(i)
i = i + 1
exit if sym = 128
addr = addr . tostring(sym)
repeat
dump("", name(a(a(instrp + 1) + 1)), "", addr)
end
return
instype(14):
! <OPCODE>
dump("", name(a(a(instrp + 1) + 1)), "", "")
return
end
routine doloop(integer loopsp)
integer type, cyclab, cntlab, extlab, namep, actualp, forp, c
initp, incrp, finalp, tplabel, condp, whilep, disp, nametag
string (7) base, reg
switch cycle(1:3)
if a(loopsp) = 1 then type = 2 else type = 3
cyclab = nextplabel
cntlab = nextplabel
extlab = nextplabel
pushstart(type, cyclab)
-> cycle(a(loopsp))
cycle(1):
!FOR
forp = a(loopsp + 1)
namep = a(forp + 1)
actualp = a(forp + 2)
initp = a(forp + 3)
incrp = a(forp + 4)
finalp = a(forp + 5)
ident = a(namep + 1)
reg = "D"
!? %if taglink(ident)=0 %then fault(name(ident)." NOT DECLARED") %andreturn
if taglink(ident) = 0 then start
dump("", "LD", "D", "#" . name(ident))
finish else start
nametag = tag(taglink(ident))
if nametag >> 28 = 4 then start
fault("NOT A DESTINATION")
return
finish
if nametag >> 28 = 2 start
aopt = 1
array(forp)
finish else start
basep = nametag >> 16 & 16_F
base = display(basep)
disp = nametag & 16_FFFF
base = "Y" if basep = level
base = "X" if basep = 1
if nametag >> 28 = 1 then start
if 1 < basep < level then start
dump("", "LD", "D", base)
dump("", "SUB", "D", "#" . s(disp))
dump("", "ST", "D", "0,X")
dump("", "LD", "D", "[0,X]")
finish else start
dump("", "LD", "D", "-" . s(disp) . "," . base)
finish
finish else start
if 1 < basep < level then start
dump("", "LD", "D", base)
dump("", "SUB", "D", "#" . s(disp))
finish else start
if basep = 1 = level then start
dump("", "LEA", "Y", "-" . s(disp) . ",X")
reg = "Y"
finish else start
dump("", "TFR", "", base . ",D")
dump("", "SUB", "D", "#" . s(disp))
finish
finish
if a(actualp) = 1 then fault(name(ident) . " DECLARED AS SCALAR")
finish
finish
finish
dump("", "PSH", "U", reg)
expr(finalp)
dump("", "PSH", "U", "B")
expr(incrp)
dump("", "PSH", "U", "B")
expr(initp)
dump("", "SUB", "B", ",U")
dump("", "ST", "B", "[2,U]")
dump("L" . s(cyclab), "EQU", "", "*")
dump("", "LD", "B", "[2,U]")
dump("", "CMP", "B", "1,U")
dump("", "LBEQ", "", "L" . s(extlab))
dump("", "ADD", "B", ",U")
dump("", "ST", "B", "[2,U]")
return
cycle(*):
dump("L" . s(cyclab), "EQU", "", "*")
return if a(loopsp) # 2
whilep = a(loopsp + 1)
condp = a(whilep + 1)
tplabel = cond(condp, -1, extlab)
end
end
end of file