!Graham Toal - new development version of SKIMPD 13/02/80 13.27
const string (1) snl = "
"
const integer true = 0, false = 1
external integer array spec a(1 : 500)
external byte integer array spec named(1 : 1024)
external integer array spec namedlink(0 : 255)
external integer array spec taglink(0 : 255)
external integer array spec tag(1 : 512)
external integer array spec link(1 : 512)
external integer array spec nextrad(0 : 15)
external integer array spec rt(0 : 15)
external integer array spec parms(0 : 15)
external string (5) array spec display(0 : 15)
external integer faults = 0
external integer spec tagasl, level, tagsopt, nextcad, namedp, c
traceopt, aopt, pstr
!-----------------------------------------------------------------------
external integer fn spec intstr(string (6) val)
external routine spec expr(integer exprp)
routine spec popitem(integer name f, l)
! Local
external integer fn spec outstream
!-----------------------------------------------------------------------
own integer array used(0 : 15) = 0(*)
own integer array worklist(0 : 15) = 0(16)
own integer array namelist(0 : 15) = 0(16)
own integer array branchlist(0 : 15) = 0(16)
own integer array startlist(0 : 15) = 0(16)
own integer array cot(0 : 127)
own integer cotp, params
!-----------------------------------------------------------------------
external string (255) fn strint(integer n, p)
string (255) r
string (1) s
if n < 0 then s = "-" and n = -n else s = ""
r = ""
r = tostring(n - n // 10 * 10 + '0') . r and n = n // 10 until n = 0
r = s . r
r = " " . r while length(r) < p
result = r
end
!-----------------------------------------------------------------------
external string (7) fn s(integer i)
result = strint(i, 0)
end
!-----------------------------------------------------------------------
external string (8) fn strhex(integer n)
const string (1) array h(0 : 15) = c
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F"
integer i
string (8) sh
sh = ""
for i = 1, 1, 8 cycle
sh = h(n & 16_F) . sh
n = n >> 4
repeat
result = sh
end
!-----------------------------------------------------------------------
external routine fault(string (63) mess)
integer st
printstring("? " . mess . "
")
st = outstream
selectoutput(0)
printstring("*" . mess . snl)
selectoutput(st)
faults = faults + 1
end
!-----------------------------------------------------------------------
external routine dump(string (7) lab, op, reg, addr)
own string (7) label = ""
routine spec codeout(string (7) l, o, r, a)
if label # "" start
if lab = "" then lab = label else start
codeout(label, "EQU", "", "*")
label = ""
finish
finish
if (op = "ADD" or op = "SUB" or op = "EOR" or op = "OR") and addr = "#0" then return
if (op = "AND" or op = "LD") and reg # "D" and addr = "#0" then op = "CLR" and addr = ""
if op = "ADD" and addr = "#1" and reg # "D" then start
op = "INC"
addr = ""
finish
if op = "SUB" and addr = "#1" and reg # "D" then start
op = "DEC"
addr = ""
finish
if op = "CMP" and addr = "#0" and reg # "D" then op = "TST" and addr = ""
if op = "EQU" and addr = "*" then label = lab c
else label = "" and codeout(lab, op, reg, addr)
routine codeout(string (7) lab, op, reg, addr)
string (6) nums
integer i
routine dump2(string (7) lab, op, reg, addr)
own string (7) lastop = "silly"
own integer inhibit = 0
if reg = "B" and op = "LD" and addr -> ("#") . nums c
and (not nums -> ("-") . nums) and intstr(nums) > 255 then reg = "D"
if lab # "" then start
if op = "EQU" and addr = "*" then inhibit = 0
if op # "EQU" then inhibit = 0
finish
if inhibit = 0 or op = "EQU" then start
lastop = op
return if op = "TST" and reg = "B" and lab = ""
! ****FRIG****
if op = "CMP" and addr = "#1" then addr = "" and op = "DEC"
printstring(lab)
spaces(10 - length(lab))
op = op . reg
printstring(op)
spaces(10 - length(op))
printstring(addr)
newline
nextcad = nextcad + 1
finish
if op = "LBRA" or op = "SWI2" or (op = "SWI" and reg = "2") c
then inhibit = 1
return unless op = "LBSR"
if addr = "SHL" then used(12) = 1
if addr = "SHR" then used(13) = 1
if addr = "EXP" then used(14) = 1
if addr = "DIV" then used(15) = 1
end
own string (7) array l(1 : 2) = ""(2)
own string (7) array o(1 : 2) = ""(2)
own string (7) array r(1 : 2) = ""(2)
own string (7) array a(1 : 2) = ""(2)
own integer buffptr = 0
switch load(0:2)
switch store(0:2)
routine flushbuffer
integer i
for i = 1, 1, buffptr cycle
dump2(l(i), o(i), r(i), a(i))
repeat
buffptr = 0
end
routine checklabel(integer buff)
if buff = 3 then start
if lab # "" then dump2(lab, "EQU", "", "*")
return
finish
if l(buff) # "" then dump2(l(buff), "EQU", "", "*")
end
routine savethisinstr
buffptr = buffptr + 1
if buffptr > 2 then start
printstring("*?????Buffer full..." . snl)
flushbuffer
finish
l(buffptr) = lab
o(buffptr) = op
r(buffptr) = reg
a(buffptr) = addr
end
if op = "SEX" and buffptr # 0 and o(buffptr) = "LD" c
and a(buffptr) -> ("#") . nums and (not nums -> ("-") . nums) c
and intstr(nums) > 255 then return
if reg # "B" then start
flushbuffer
dump2(lab, op, reg, addr)
return
finish
if op = "LD" then start
-> load(buffptr)
load(0):
savethisinstr
return
load(1):
if o(1) = "LD" then checklabel(1) and buffptr = 0 else start
if o(1) = "ST" and a(1) = addr then start
if lab # "" then start
flushbuffer
savethisinstr
return
finish else return
finish
finish
savethisinstr
return
load(2):
dump2(l(1), o(1), r(1), a(1))
l(1) = l(2)
r(1) = r(2)
o(1) = o(2)
a(1) = a(2)
buffptr = 1
printstring("?***** Unexpected third el = load" . snl)
-> load(1)
finish
if op = "ST" then start
-> store(buffptr)
store(0):
savethisinstr
return
store(1):
if o(1) = "LD" or o(1) = "ST" then start
if a(1) = addr then start
if lab # "" then start
flushbuffer
savethisinstr
return
finish else return
finish else start
flushbuffer
savethisinstr
return
finish
finish
if o(1) = "CLR" then start
checklabel(1)
buffptr = 0
dump2(lab, "CLR", "", addr)
return
finish
flushbuffer
savethisinstr
return
store(2):
if o(1) = "LD" and a(1) = addr and (o(2) = "INC" or o(2) = "DEC" c
or o(2) = "NEG" or o(2) = "COM") then start
checklabel(2)
checklabel(3)
dump2(l(1), o(2), "", addr)
buffptr = 0
return
finish
dump2(l(1), o(1), r(1), a(1))
l(1) = l(2)
o(1) = o(2)
r(1) = r(2)
a(1) = a(2)
buffptr = 1
-> store(1)
finish
if op = "TST" then start
if buffptr # 0 then start
if o(buffptr) = "LD" then start
dump2(l(buffptr), op, "", a(buffptr))
checklabel(3)
buffptr = buffptr - 1
return
finish
finish
flushbuffer
dump2(lab, op, reg, addr)
return
finish
if op = "INC" or op = "DEC" or op = "CLR" or op = "NEG" c
or op = "COM" then start
if buffptr = 2 then start
dump2(l(1), o(1), r(1), a(1))
l(1) = l(2)
o(1) = o(2)
r(1) = r(2)
a(1) = a(2)
l(2) = lab
o(2) = op
r(2) = reg
a(2) = addr
buffptr = 2
return
finish
savethisinstr
return
finish
flushbuffer
dump2(lab, op, reg, addr)
end
end
!-----------------------------------------------------------------------
external string (255) fn name(integer ident)
unless 0 <= ident <= 255 and namedlink(ident) # 0 then result = ""
result = string(addr(named(namedlink(ident))))
end
!-----------------------------------------------------------------------
external integer fn newtag
integer i
if tagasl = 0 then fault("TAG SPACE FULL") and stop
i = tagasl
tagasl = link(tagasl)
result = i
end
!-----------------------------------------------------------------------
external integer fn returntag(integer tagi)
integer l
l = link(tagi)
link(tagi) = tagasl
tagasl = tagi
result = l
end
!-----------------------------------------------------------------------
external integer fn getwork
!%integername cell
! cell==worklist(level)
! %while cell#0 %cycle
! %if tag(cell)<0 %then tag(cell)=-tag(cell) %and %result=tag(cell)
! cell==link(cell)
! %repeat
! cell=newtag
! tag(cell)=nextrad(level)
! nextrad(level)=nextrad(level)+1
! link(cell)=0
! %result=tag(cell)
result = 0
end
!-----------------------------------------------------------------------
external routine returnwork(integer work)
!%integer cell
! cell=worklist(level)
! %while cell#0 %cycle
! %if tag(cell)=work %then tag(cell)=-work %and %return
! cell=link(cell)
! %repeat
end
!-----------------------------------------------------------------------
external routine clearwork
integer cell
cell = worklist(level)
cell = returntag(cell) while cell # 0
worklist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn getcoti(integer const)
integer coti
if cotp > 0 then start
for coti = 0, 1, cotp - 1 cycle
if cot(coti) = const then result = coti
repeat
finish
if cotp = 128 then fault("CONSTANT TABLE FULL") and stop
cot(cotp) = const
cotp = cotp + 1
result = cotp - 1
end
!-----------------------------------------------------------------------
external routine pushtag(integer ident, form, type, dim, level, rad)
integer tagi
if taglink(ident) # 0 and tag(taglink(ident)) >> 16 & 16_F = level c
then fault("NAME " . name(ident) . " DECLARED TWICE")
tagi = newtag
tag(tagi) = form << 28 ! type << 24 ! dim << 20 ! level << 16 ! rad
link(tagi) = taglink(ident)
taglink(ident) = tagi
tagi = newtag
tag(tagi) = ident
link(tagi) = namelist(level)
namelist(level) = tagi
end
!-----------------------------------------------------------------------
external routine poptags
integer cell, ident, nametag, params
string (63) s
if tagsopt = 1 then newline
cell = namelist(level)
while cell # 0 cycle
ident = tag(cell)
cell = returntag(cell)
nametag = tag(taglink(ident))
taglink(ident) = returntag(taglink(ident))
if tagsopt = 1 then start
s = name(ident)
printstring(strint(ident, 3) . " " . s)
spaces(10 - length(s))
printstring(strhex(nametag))
finish
if nametag >> 28 = 4 then start
! procedure type
params = nametag >> 20 & 16_F
while params # 0 cycle
if tagsopt = 1 then printstring("
" . strhex(tag(taglink(ident))))
taglink(ident) = returntag(taglink(ident))
params = params - 1
! pop up parameter tags
repeat
finish
if tagsopt = 1 then newline
if taglink(ident) = 0 then namedp = namedlink(ident) and namedlink(ident) = 0
! backtrack name dictionary
repeat
if tagsopt = 1 then newline
namelist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn getlabel(integer constp)
integer label
label = a(constp + 1)
if label > 9999 then fault("LABEL " . strint(label, 1) . " TOO LARGE") c
and result = -1 else result = label
end
!-----------------------------------------------------------------------
external routine filllabel(integer label)
!%integer cell
return if label < 0
! for conditional statements
! cell=branchlist(level)
! %while cell#0 %cycle
! %if tag(cell)>>16=label %then %start
! %if tag(cell)&16_8000=0 %then fault("DUPLICATE LABEL ". ! strint(label,1)) %else %start
dump("L" . s(label), "EQU", "", "*")
! tag(cell)=label<<16!nextcad
! %finish
! %return
! %finish
! cell=link(cell)
! %repeat
! cell=newtag
! link(cell)=branchlist(level)
! branchlist(level)=cell
! tag(cell)=label<<16!nextcad
end
!-----------------------------------------------------------------------
external integer fn fillbranch(integer label)
integer cell, cad
result = 0 if label < 0
cell = branchlist(level)
while cell # 0 cycle
if tag(cell) >> 16 = label then start
cad = tag(cell) & 16_7FFF
if tag(cell) & 16_8000 # 0 then tag(cell) = label << 16 ! 16_8000 ! nextcad
result = cad
finish
cell = link(cell)
repeat
cell = newtag
link(cell) = branchlist(level)
branchlist(level) = cell
tag(cell) = label << 16 ! 16_8000 ! nextcad
result = 0
end
!-----------------------------------------------------------------------
external routine poplabels
integer cell
cell = branchlist(level)
while cell # 0 cycle
if tag(cell) & 16_8000 # 0 then fault("LABEL " . strint(tag(cell) >> 16, 1) . c
" NOT SET (BRANCH LIST " . strint(tag(cell) & 16_7FFF, 1) . ")")
cell = returntag(cell)
repeat
branchlist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn nextplabel
own integer plabel = 9999
plabel = plabel + 1
result = plabel
end
!-----------------------------------------------------------------------
external routine pushstart(integer flag, plab)
integer cell
cell = newtag
tag(cell) = flag << 16 ! plab & 16_FFFF
! plab may be -1
link(cell) = startlist(level)
startlist(level) = cell
end
external integer fn find(integer type, integer name t, lab)
integer cell
cell = startlist(level)
while cell # 0 cycle
t = tag(cell) >> 16
if t & 2 = type then start
lab = tag(cell) & 16_FFFF
result = true
finish
cell = link(cell)
repeat
t = 0
lab = 0
result = false
end
external routine findcontinue(integer name type, lab)
if find(2, type, lab) = true then lab = lab + 1 c
else type = 0 and lab = 0 and fault("%CYCLE MISSING")
end
external routine findexit(integer name type, lab)
if find(2, type, lab) = true then lab = lab + 2 c
else type = 0 and lab = 0 and fault("%CYCLE MISSING")
end
integer fn findcycle
integer t, l
if find(2, t, l) = true then result = true
result = false
end
integer fn findstart
integer t, l
if find(0, t, l) = true then result = true
result = false
end
external routine popcycle(integer name type, lab)
popitem(type, lab)
if type & 2 = 0 then start
if findcycle = true then start
fault("%FINISH MISSING {Or spurious %REPEAT??}")
finish else start
fault("SPURIOUS %REPEAT")
pushstart(type, lab) if lab # 0
finish
lab = 0
type = 3
finish
end
external routine popstart(integer name type, lab)
popitem(type, lab)
if type & 2 = 2 or lab = 0 then start
if findstart = true then start
fault("%REPEAT MISSING {Or spurious %FINISH??}")
finish else start
fault("SPURIOUS %FINISH")
pushstart(type, lab) if lab # 0
finish
lab = 0
type = 0
finish
end
!-----------------------------------------------------------------------
routine popitem(integer name flag, plab)
integer cell
cell = startlist(level)
if cell = 0 then start
flag = 0
plab = 0
finish else start
flag = tag(cell) >> 16
plab = tag(cell) & 16_FFFF
if plab = 16_FFFF then plab = -1
startlist(level) = returntag(cell)
finish
end
!-----------------------------------------------------------------------
external routine clearstart
integer cell
const string (7) array what(0 : 1) = "%FINISH", "%REPEAT"
cell = startlist(level)
while cell # 0 cycle
fault(what(tag(cell) >> 17) . " MISSING")
cell = returntag(cell)
repeat
startlist(level) = 0
end
!-----------------------------------------------------------------------
external integer fn enter
own string (4) array regs(1 : 2) = "A", "A,B"
string (4) base
integer alloc, dim
if level = 1 then start
if nextcad # 1 then fault("%BEGIN NOT FIRST STATEMENT")
dump("", "ORG", "", "$F800")
dump("START", "EQU", "", "*")
dump("", "SWI", "3", "") if traceopt = 1
dump("", "LD", "U", "#STACK")
dump("", "LEA", "X", "-USTK,U")
base = ",X"
alloc = 34
! Already set up by calling program
! Rest for I/O buffers and perm locations.
finish else start
! STORE STP (=Y) IF NECCESARY
if level > 2 start
dump("", "ST", "Y", display(level - 1))
finish
dump("", "PSH", "S", "Y")
dump("", "TFR", "", "S,Y")
alloc = 0
base = ",Y"
finish
! cad=nextcad
if level # 1 then start
! REMOVED TO 'SKIMPB'
finish else start
dump("", "LEA", "S", "-A" . s(rt(level)) . ",X")
finish
nextrad(level) = alloc
result = alloc
end
!-----------------------------------------------------------------------
external routine dumpreturn
dump("", "TFR", "", "Y,S")
dump("", "PUL", "S", "Y,PC")
end
!-----------------------------------------------------------------------
external routine array(integer arrayp)
integer namep, actualp, exprp, exprsp, ident, nametag, basep, disp
string (4) base
namep = a(arrayp + 1)
actualp = a(arrayp + 2)
ident = a(namep + 1)
if a(actualp) = 1 then start
dump(" ", "CLR", "A", "")
dump("", "ANDCC", "", "0")
exprp = a(actualp + 1)
exprsp = a(actualp + 2)
expr(exprp)
nametag = tag(taglink(ident))
basep = nametag >> 16 & 16_F
base = display(basep)
base = ",Y" if basep = level
base = ",X" if basep = 1
disp = nametag & 16_FFFF
dump("", "BCC", "", "*+3")
dump("", "INC", "A", "")
if basep = 1 or basep = level start
dump("", "ADD", "D", "-" . s(disp) . base)
finish else start
dump("", "PSH", "U", "A,B")
dump("", "LD", "D", display(basep))
dump("", "SUB", "D", "#" . s(disp))
dump("", "ST", "D", "0,X")
dump("", "LD", "D", "[0,X]")
dump("", "ADD", "D", ",U++")
finish
dump("", "ST", "D", "0,X") if aopt = 0
aopt = 0
! dump("ADD","ACC",display(nametag>>16&16_f),nametag&16_ffff)
if a(exprsp) = 1 then fault("ARRAY " . name(ident) . " HAS EXTRA INDEX")
finish else fault("ARRAY " . name(ident) . " HAS NO INDEX")
end
!-----------------------------------------------------------------------
external routine proc(integer procp)
string (4) opn, base, reg
integer namep, ident, nametag, ptagl, l, actualp, exprp, unaryp, operandp, c
npars, ptag, pnamep, pident, pnametag, pactualp, disp, exprrestp, exprsp, c
oldparams, basep, size
! %if params>2 %then dump("LDA","STP","STP",params)
!***! hack !***!
if params >= 2 then dump("", "LEA", "S", "-" . s(params + 1) . ",S")
!***! hack !***!
oldparams = params
params = 4
namep = a(procp + 1)
actualp = a(procp + 2)
ident = a(namep + 1)
l = taglink(ident)
nametag = tag(l)
ptagl = link(l)
npars = nametag >> 20 & 16_F
if npars = 0 then start
if a(actualp) = 1 then fault(name(ident) . " HAS PARAMETERS") and return
finish else start
if a(actualp) = 2 then fault(name(ident) . " MISSING PARAMETERS") and return
exprp = a(actualp + 1)
exprsp = a(actualp + 2)
cycle
! for each parameter
ptag = tag(ptagl)
if ptag >> 28 = 0 then expr(exprp) and reg = "B" else start
reg = "D"
unaryp = a(exprp + 1)
operandp = a(exprp + 2)
exprrestp = a(exprp + 3)
unless a(unaryp) = 4 and a(operandp) = 1 and a(exprrestp) = 2 c
then fault("NOT A %NAME PARAMETER") else start
pnamep = a(operandp + 1)
pactualp = a(operandp + 2)
pident = a(pnamep + 1)
!? %if taglink(pident)=0 %then fault(name(pident). !? " NOT DECLARED") %else %start
if taglink(pident) = 0 then start
dump("", "LD", "B", name(pident))
finish else start
pnametag = tag(taglink(pident))
if pnametag >> 28 = 4 then fault(name(pident) . " NOT A %NAME") else start
basep = pnametag >> 16 & 16_F
base = display(basep)
disp = pnametag & 16_FFFF
base = "Y" if basep = level
base = "X" if basep = 1
if ptag >> 28 = 1 then start
! %name
if pnametag >> 28 >= 2 then aopt = 1 and array(operandp) else start
if pnametag >> 28 = 1 then start
if 1 < basep < level start
dump("", "LD", reg, base)
dump("", "SUB", reg, "#" . s(disp))
dump("", "ST", reg, "0,X")
dump("", "LD", reg, "[0,X]")
finish else start
dump("", "LD", reg, "-" . s(disp) . "," . base)
finish
finish else start
if 1 < basep < level start
dump("", "LD", reg, base)
dump("", "SUB", reg, "#" . 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", reg, "#" . s(disp))
finish
! GET ADDRESS OF A %NAME INTO B
finish
finish
! CHECK FOR SILLY BASE REGISTER
! dump(opn,"ACC",base,disp)
if a(pactualp) = 1 then fault(name(pident) . " DECLARED AS SCALAR")
finish
finish else start
! dump("LOAD","ACC",base,disp) ;! %array
if base = "Y" or base = "X" start
dump("", "LD", reg, "-" . s(disp) . "," . base)
finish else start
dump("", "LD", reg, base)
dump("", "SUB", reg, "#" . s(disp))
dump("", "ST", reg, "0,X")
dump("", "LD", reg, "[0,X]")
finish
! CHECK SILLY BASE REGISTER
if a(pactualp) = 1 then fault("%ARRAYNAME " . name(pident) . " HAS INDEX")
finish
finish
finish
finish
finish
! dump("STR","ACC","STP",params)
if reg = "D" or reg = "Y" then size = 2 else size = 1
params = params + size
dump("", "ST", reg, "-" . s(params) . ",S")
npars = npars - 1
if npars = 0 then start
if a(exprsp) = 1 then fault(name(ident) . " HAS EXTRA PARAMETERS")
exit
finish
ptagl = link(ptagl)
if a(exprsp) = 2 then fault(name(ident) . " IS MISSING PARAMETERS") and exit
exprp = a(exprsp + 1)
exprsp = a(exprsp + 2)
repeat
finish
! external i/o routines at level 0
if nametag >> 16 & 16_F = 0 then base = "EXT" else base = "E"
if nametag >> 16 & 16_F = 0 then start
used(nametag & 16_F) = 1
finish
dump("", "LBSR", "", base . s(nametag & 16_FFFF))
params = oldparams
! EH??????
!***! frig !***!
if params >= 2 then dump("", "LEA", "S", s(params + 1) . ",S")
! %if params>2 %then dump("SUB","STP","COT",getcoti(params))
end
!-----------------------------------------------------------------------
external routine endofprog
integer i
dump("", "SWI", "2", "")
dump("STACK", "EQU", "", "$0800-1")
dump("USTK", "EQU", "", "$20")
! DUMP("EXT1","EQU","","") %IF USED(1)=1
! DUMP("EXT2","EQU","","") %IF USED(2)=1
! DUMP("EXT3","EQU","","") %IF USED(3)=1
! DUMP("EXT4","EQU","","") %IF USED(4)=1
! DUMP("EXT5","EQU","","") %IF USED(5)=1
! DUMP("EXT6","EQU","","") %IF USED(6)=1
! DUMP("EXT7","EQU","","") %IF USED(7)=1
! DUMP("EXT8","EQU","","") %IF USED(8)=1
! DUMP("EXT9","EQU","","") %IF USED(9)=1
! DUMP("EXT10","EQU","","") %IF USED(10)=1
!! READSYMBOL POSING AS READ
! DUMP("EXT11","EQU","","") %AND USED(15)=1 %IF USED(11)=1
if used(12) = 1 then start
dump("DOSHL", "LSL", "B", "")
dump("", "SUB", "A", "#1")
dump("SHL", "CMP", "A", "#0")
dump("", "BGT", "", "DOSHL")
dump("", "RTS", "", "")
finish
if used(13) = 1 then start
dump("DOSHR", "LSR", "B", "")
dump("", "SUB", "A", "#1")
dump("SHR", "CMP", "A", "#0")
dump("", "BGT", "", "DOSHR")
dump("", "RTS", "", "")
finish
if used(14) = 1 then start
dump("EXP", "PSH", "S", "B")
dump("EXP2", "CMP", "A", "#1")
dump("", "BGT", "", "DOEXP")
dump("", "LEA", "S", "1,S")
dump("", "RTS", "", "")
dump("DOEXP", "PSH", "U", "A")
dump("", "LDA", "", "0,S")
dump("", "MUL", "", "")
dump("", "PUL", "U", "A")
dump("", "SUB", "A", "#1")
dump("", "BRA", "", "EXP2")
finish
if used(15) = 1 then start
! 'B'//'A'
dump("DIV", "EQU", "", "*")
dump("", "CLR", "", "-1,S")
dump("", "CLR", "", "-2,S")
dump("", "INC", "", "-2,S")
dump("", "TST", "B", "")
dump("", "BGE", "", "TRYA")
dump("", "NEG", "B", "")
dump("", "CLR", "", "-2,S")
dump("TRYA", "TST", "A", "")
dump("", "BGE", "", "OK")
dump("", "NEG", "A", "")
dump("", "TST", "", "-2,S")
dump("", "BNE", "", "OK")
dump("", "INC", "", "-2,S")
dump("OK", "TST", "B", "")
dump("", "BLT", "", "DONE")
dump("", "INC", "", "-1,S")
dump("", "PSH", "U", "A")
dump("", "SUB", "B", ",U+")
dump("", "BRA", "", "OK")
dump("DONE", "DEC", "", "-1,S")
dump("", "TST", "", "-2,S")
dump("", "BNE", "", "RET")
dump("", "NEG", "", "-1,S")
dump("RET", "LD", "B", "-1,S")
dump("", "RTS", "", "")
finish else dump("DIV", "EQU", "", "0")
! newline
if pstr # 0 then start
dump("OUTCH", "LD", "A", "ACIAS")
dump("", "AND", "A", "#2")
dump("", "BEQ", "", "OUTCH")
dump("", "ST", "B", "ACIAD")
dump("WAITX", "LD", "B", "#$FF")
dump("", "DEC", "B", "")
dump("", "BNE", "", "WAITX")
dump("PSTR", "LD", "B", "[0,S]")
dump("", "INC", "", "1,S")
dump("", "BNE", "", "NOCAR")
dump("", "INC", "", "0,S")
dump("NOCAR", "CMP", "B", "#$80")
dump("", "BNE", "", "OUTCH")
dump("", "RTS", "", "")
finish
if faults > 0 start
begin
integer st
st = outstream
selectoutput(0)
printstring("Program contains " . s(faults) . " fault")
printsymbol('s') if faults > 1
newline
selectoutput(st)
end
finish
newline
if faults > 0 then printstring("?" . strint(faults, 4)) else printstring("*NO")
printstring(" FAULT")
printsymbol('S') if faults # 1
printstring(" IN THIS PROGRAM
")
signal event 13
! Not again!!!
end
end of file