begin
{----------------------------------------}
{ }
{ MOS Technology M6500 Series Assembler. }
{ }
{ Copyright M.R.King, 27/3/1984. }
{ All rights reserved. }
{ }
{----------------------------------------}
own string(255) copyright = c
"M6500 Series Assembler. Copyright M.R.King, 27/3/1984. All rights reserved."
constant integer names = 255,
line width = 78,
lines on page = 66,
max line = 512,
insert limit = 10,
xentries = 1024
constinteger ihash=59
constant byte integer array hilink(0:58) = c
13, 28, 0, 0, 36, 0, 29, 50, 0, 25, 26, 59,
1, 16, 27, 14, 64, 23, 4, 6, 42, 11, 41, 15,
35, 0, 0, 34, 0, 30, 32, 0, 0, 31, 8, 3,
5, 0, 43, 0, 51, 60, 48, 12, 68, 0, 49, 19,
20, 0, 9, 67, 7, 45, 2, 22, 0, 0, 47
constant byte integer array ilink(1:69) = c
0, 58, 10, 24, 40, 0, 17, 0, 18, 69, 52, 33,
0, 0, 0, 0, 53, 0, 21, 0, 65, 63, 0, 0,
0, 0, 0, 0, 0, 38, 0, 37, 46, 54, 0, 0,
39, 0, 0, 0, 56, 0, 44, 0, 57, 0, 55, 0,
0, 61, 0, 66, 0, 0, 0, 0, 0, 0, 0, 62,
0, 0, 0, 0, 0, 0, 0, 0, 0
constant string(4) array instr(1:69) = c
"LDA","STA","LDX","STX","LDY","STY","JSR","BCC","BCS",
"BNE","BEQ","BVC","BVS","BPL","BMI","JMP","RTS","CMP",
"CPX","CPY","DEC","INC","INX","INY","DEX","DEY","AND",
"ORA","EOR","BIT","LSR","ROR","ASL","LSL","ROL","SBC",
"ADC","TAX","TAY","TYA","TSX","TXA","TXS","PHA","PHP",
"PLA","PLP","RTI","BRK","NOP","CLV","CLC","SEC","CLI",
"SEI","CLD","SED","FCB","FDB","EQU","ORG","RMB","FCC",
"NAM","OPT","PAGE","SPC","MON","END"
constant byte integer array icode(1:69) = c
16_A1,16_81,16_A2,16_86,16_A0,16_84,16_20,16_90,16_B0,
16_D0,16_F0,16_50,16_70,16_10,16_30,16_4C,16_60,16_C1,
16_E0,16_C0,16_C6,16_E6,16_E8,16_C8,16_CA,16_88,16_21,
16_01,16_41,16_20,16_46,16_66,16_06,16_06,16_26,16_E1,
16_61,16_AA,16_A8,16_98,16_BA,16_8A,16_9A,16_48,16_08,
16_68,16_28,16_40,16_00,16_EA,16_B8,16_18,16_38,16_58,
16_78,16_D8,16_F8,16_00,16_00,16_00,16_00,16_00,16_00,
16_00,16_00,16_00,16_00,16_00,16_00
constant byte integer array itype(1:69) = c
5, 6, 11, 13, 12, 14, 4, 2, 2, 2, 2, 2, 2, 2, 2,
3, 1, 5, 9, 9, 8, 8, 1, 1, 1, 1, 5, 5, 5, 10,
7, 7, 7, 7, 7, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 15, 16, 17,
18, 19, 20, 21, 22, 23, 24, 25, 25
constant integer array icycles(1:69) = c
2, 2, 2, 3, 2, 3, 6, 4, 4, 4, 4, 4, 4, 4, 4,
3, 6, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3,
4, 4, 6, 7, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0
constant integer no options = 51
constant string(10) array option text(1:no options) = c
"BLANK", "B", "NOBLANK", "NOB", "CYCLE", "C", "NOCYCLE", "NOC",
"DB8", "DB10", "DB16", "ERROR", "E", "SERROR", "SER", "NOERROR",
"NOE", "FULL", "F", "NOFULL", "NOF", "GENERATE", "G", "NOGENERATE",
"NOG", "LIST", "L", "SLIST", "SLIS", "NOLIST", "NOL", "PAGE", "P",
"NOPAGE", "NOP", "SYMBOL", "S", "NOSYMBOL", "NOS", "TAB", "T",
"NOTAB", "NOT", "WRAP", "W", "NOWRAP", "NOW", "XREF", "X", "NOXREF",
"NOX"
string(255) function spec lc(string(255) source)
predicate spec matches(string(255) source, pattern,
integer min, integer name i)
predicate spec is typed(string(255) source, string(255) name file)
routine spec read line
routine spec next char
predicate spec more items
integerfn spec get name(integername nid)
predicate spec get option(integer name opt)
predicate spec get instr(integername id)
integerfn spec get opd(integername opd)
integer function spec get term(integer name opd)
integer function spec get expression(integer name opd)
routine spec evaluate(integer name a, integer b, byte integer op)
integerfn spec get const(integername cval)
routine spec out symbol(byte integer char)
routine spec out tag(integer name i, j, integer col)
routine spec instr out(integer op,opd,b, cyc)
routine spec close
routine spec fault(string(63) s)
routine spec nline(integer n)
routine spec back number(integer n)
routine spec print number(integer n,d)
predicate spec indexed(byte integer reg)
predicate spec acc(byte integer acc id)
routine spec sqs(integer l, r)
routine spec immediate(byte integer order, mcycles)
routine spec operand(byte integer reg, nreg, order, mcycles)
routine spec store(byte integer reg, nreg, order, mcycles)
byte integer array buffer(1:16)
{%byte}integer array line(1:max line+1)
integer ca, pass, faults, lp, opd, iid, lid, ln, nnames, i, j, k, opt,
order, consistent, last consistent, headset, pres char, delim, drad,
bchar, pflag, sflag, gflag, eflag, lflag, cflag, wflag, tflag, xflag,
cont, sp1, sp2, sp3, old ca, mcycles, non dense, reg fault,
l, xxentries, fflag, ostarted, buffer ca, bp, look ahead
constant integer nhash=67
byteinteger array hnlink(0:nhash-1)
string(6)array name(1:names)
integerarray nval(1:names)
byteintegerarray nass(1:names)
byteintegerarray nlink(1:names)
integer array xhead(1:names)
integer array xentry, xlink(1:xentries)
switch option action(-1:no options)
switch itype1,itype2(1:25)
string(line width-45) header
string(*) name file
string(255) params, source, list, object, dummy
on event 9 start
select output(0)
print string(event_message{source." does not exist."})
new line
stop
finish
! params = ""
! select input(0)
! read symbol(i)
! params = params.to string(i) %and read symbol(i) %while i#nl
! params = lc(params)
params = lc(cliparam)
source = ""
list = ".n"
object = ""
dummy = ""
cycle
i = 1
i = i+1 while i<=length(params) and charno(params, i)=' '
exit if i>length(params)
params = substring(params, i, length(params))
if charno(params, 1)='/' start
params = substring(params, 2, length(params))
if matches(params, "list", 1, i) start
list = ""
file == list
finish else if matches(params, "object", 1, i) start
object = ""
file == object
finish else if matches(params, "nolist", 3, i) start
list = ".n"
file == dummy
finish else if matches(params, "noobject", 3, i) start
object = ".n"
file == dummy
else
i = 1
file == dummy
finish
exit if i>length(params)
params = substring(params, i, length(params))
continue unless charno(params, 1)='='
if length(params)>1 start
params = substring(params, 2, length(params))
else
params = ""
finish
else
file == source
finish
i = 1
i = i+1 while i<=length(params) and charno(params, i)#' ' and c
charno(params, i)#'/'
file = substring(params, 1, i-1) if i>1
exit if i>length(params)
params = substring(params, i, length(params))
repeat
if source="" start
select output(0)
print string("No source file specified.")
new line
stop
finish
source = source.".asm" unless is typed(source, params)
list = params if list=""
object = params if object=""
list = list.".lis" unless is typed(list, dummy)
object = object.".obj" unless is typed(object, dummy)
open input(1, source)
open output(1, object)
open output(2, list)
select output(2)
headset = 0
header = ""
drad = 8
sp1 = 2
sp2 = 4
pflag = 3
sflag = 0
eflag = 1
gflag = 1
lflag = 2
cflag = 0
wflag = 0
tflag = 1
xflag = 0
sp3 = line width-sp1-sp2*2-cflag*2-wflag-10
cont = 0
faults=0
nnames=0
xxentries = 0
consistent = 0
hnlink(i)=0 for i = 0, 1, nhash-1
bp = 0
ostarted = 0
look ahead = 0
!-----------------------------------------------------------------------
select input(1)
pass = 1
cycle
ln = 0
ca = 0
bchar = -1
fflag = 0
cycle
read line
continue if pres char='*'
if get name(lid)=0 start
if pass=1 start
if nass(lid)=0 start
nval(lid) = ca
nass(lid) = 1
else
nval(lid) = 0
nass(lid) = 2
finish
finish else if nass(lid)=1 and ca#nval(lid) start
nval(lid) = ca
consistent = consistent+1
finish
else
lid = 0
finish
next char while pres char=' '
continue unless get instr(iid)
next char while pres char=' '
->itype1(itype(iid))
!-----------------------------------------------------------------------
itype1(1):! implied
ca=ca+1
continue
!-----------------------------------------------------------------------
itype1(2):! relative
ca=ca+2
continue
!-----------------------------------------------------------------------
itype1(3): ! JMP
itype1(4): ! JSR
ca = ca+3
continue
!----------------------------------------------------------------------------
itype1(5): ! immediate, direct, index, indir
ca = ca+2 and continue if pres char='#'
!-------------------------------------------------------------------------
itype1(6): ! direct, index, indir
if pres char='(' start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
if indexed('Y') start
ca = ca+3
else
ca = ca+2
finish
else
ca = ca+3
finish
continue
!-------------------------------------------------------------------------
itype1(7): ! rotate, shift
ca = ca+1 and continue if acc('A')
itype1(8): ! inc, dec
if acc('X') or indexed('X') start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
else
ca = ca+3
finish
continue
!-----------------------------------------------------------------------
itype1(9): ! cpy, cpx
ca = ca+2 and continue if pres char='#'
!----------------------------------------------------------------------
itype1(10): ! bit
if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
else
ca = ca+3
finish
continue
!-----------------------------------------------------------------------
itype1(11): ! ldx
if pres char = '#' or acc('Y') or indexed('Y') start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
else
ca = ca+3
finish
continue
!----------------------------------------------------------------------
itype1(12): ! ldy
if pres char='#' or acc('X') or indexed('X') start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
else
ca = ca+3
finish
continue
!----------------------------------------------------------------------
itype1(13): ! stx
if acc('Y') or indexed('Y') start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
finish else if indexed('Y') start
ca = ca+2
else
ca = ca+3
finish
continue
!----------------------------------------------------------------------
itype1(14): ! sty
if acc('X') or indexed('X') start
ca = ca+2
finish else if get opd(opd)#0 or 0<=opd<=255 start
ca = ca+2
finish else if indexed('X') start
ca = ca+2
else
ca = ca+3
finish
continue
!-----------------------------------------------------------------------
itype1(15): ! fcb
cycle
ca = ca+1
i = get opd(opd) unless pres char=','
repeat until not more items
continue
!-----------------------------------------------------------------------
itype1(16): ! fdb
cycle
ca = ca+2
i = get opd(opd) unless pres char=','
repeat until not more items
continue
!-----------------------------------------------------------------------
itype1(17):! equ
unless lid=0 start
if get opd(opd)=0 start
if pass=1 start
if nass(lid)=1 start
nval(lid) = opd
nass(lid) = 3
finish
finish else if nass(lid)=3 and opd#nval(lid) start
nval(lid) = opd
consistent = consistent+1
finish
else
unless nass(lid)=2 start
nval(lid) = 0
nass(lid) = 4
finish
finish
finish
continue
!-----------------------------------------------------------------------
itype1(18):! org
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
ca = opd if get opd(opd)=0
continue
!-----------------------------------------------------------------------
itype1(19): ! rmb
ca = ca+opd if get opd(opd)=0
continue
!-----------------------------------------------------------------------
itype1(20):! fcc
if '0'<=pres char<='9' start
i = lp
j = 0
cycle
j = j*10+pres char-'0'
next char
repeat until not '0'<=pres char<='9'
if pres char=',' start
ca = ca+j
continue
finish
lp = i-1
next char
finish
continue if pres char<' '
delim = pres char
next char
cycle
exit if pres char=nl
if pres char=delim start
next char
exit unless pres char=delim
finish
next char
ca=ca+1
repeat
continue
!-----------------------------------------------------------------------
itype1(21): ! nam
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
continue unless headset=0
headset = 1
header = ""
while pres char#nl cycle
header <- header.to string(line(lp))
next char
repeat
continue
!-----------------------------------------------------------------------
itype1(22): ! opt
cycle
if get option(opt) start
if 1<=opt<=2 start
bchar = ' '
finish else if 3<=opt<=4 start
bchar = -1
finish else if 18<=opt<=19 start
fflag = 1
finish else if 20<=opt<=21 start
fflag = 0
finish
finish
repeat until not more items
!-----------------------------------------------------------------------
itype1(23): ! page
!-----------------------------------------------------------------------
itype1(24): ! spc
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
!-----------------------------------------------------------------------
repeat
!-----------------------------------------------------------------------
itype1(25): ! end
unless lid=0 start
nval(lid) = 0
nass(lid) = 2
finish
if pass=1 start
pass = 2
else
exit if consistent=0 or c
(last consistent#0 and consistent>=last consistent)
finish
last consistent = consistent
consistent = 0
reset input
repeat
!-----------------------------------------------------------------------
nline(0)
reset input
pass = 3
ln=0
ca=0
old ca = 0
lid = 0
bchar = -1
fflag = 0
cycle
unless lid=0 start
fault("Multiply defined label") if nass(lid)=2
if nass(lid)=1 and nval(lid)#old ca start
fault("Inconsistent label")
nval(lid) = old ca
finish
finish
old ca = ca
lid = 0
read line
non dense = 0
instr out(0, 0, -4, 0) and continue if pres char='*'
lid = 0 unless get name(lid)=0
next char while pres char=' '
if pres char=nl start
instr out(0, 0, -4, 0)
finish else if get instr(iid) start
order = icode(iid)
mcycles = icycles(iid)
next char while pres char=' '
->itype2(itype(iid))
else
instr out(0, 0, -4, 0)
fault("Unknown operation")
finish
continue
!-----------------------------------------------------------------------
itype2(1):! implied
instr out(order,0,1, mcycles)
continue
!-----------------------------------------------------------------------
itype2(2):! relative
i=get opd(opd)
j=opd-ca-2
instr out(order,j,2, mcycles)
unless i=0 start
fault("Cannot evaluate operand")
finish else unless -127<=j<=127 start
fault("Branch out of range")
finish
continue
!-----------------------------------------------------------------------
itype2(3):! JMP
if pres char='(' start
next char until pres char#bchar
i = get opd(opd)
next char while pres char=bchar
if pres char=')' start
next char
instr out(order+16_20, opd, 3, mcycles+2)
else
instr out(order+16_20, opd, 3, mcycles+2)
fault("Missing right parenthesis")
finish
fault("Cannot evaluate operand") unless i=0
continue
finish
!---------------------------------------------------------------------------
itype2(4): ! JSR
i = get opd(opd)
instr out(order, opd, 3, mcycles)
fault("Cannot evaluate operand") unless i=0
continue
!--------------------------------------------------------------------------
itype2(5): ! immediate, direct, index, indir
immediate(order+8, mcycles) and continue if pres char='#'
!--------------------------------------------------------------------------
itype2(6): ! direct, index, indir
if pres char='(' start
next char until pres char#bchar
if acc('X') or indexed('X') start
next char while pres char=bchar
if pres char=')' start
next char
instr out(order, 0, 2, mcycles+4)
else
instr out(order, 0, 2, mcycles+4)
fault("Missing right parenthesis")
finish
finish else if acc('Y') or indexed('Y') start
next char while pres char=bchar
if pres char=')' start
next char
instr out(order, 0, 2, mcycles+4)
else
instr out(order, 0, 2, mcycles+4)
fault("Missing right parenthesis")
finish
fault("Invalid index register")
else
i = get opd(opd)
if indexed('X') start
next char while pres char=bchar
if pres char=')' start
next char
instr out(order, opd, 2, mcycles+4)
else
instr out(order, opd, 2, mcycles+4)
fault("Missing right parenthesis")
finish
else
if indexed('Y') start
reg fault = 1
else
reg fault = 0
finish
next char while pres char=bchar
if pres char=')' start
next char until pres char#bchar
if indexed('Y') start
instr out(order+16_10, opd, 2, mcycles+4)
finish else if indexed('X') start
instr out(order+16_10, opd, 2, mcycles+4)
fault("Invalid index register")
else
instr out(order, opd, 2, mcycles+4)
fault("Index register not specified") if reg fault=0
finish
else
instr out(order, opd, 2, mcycles+4)
fault("Missing right parenthesis")
fault("Index register not specified") if reg fault=0
finish
fault("Invalid index register") unless reg fault=0
finish
unless i=0 start
fault("Cannot evaluate operand")
finish else unless 0<=opd<=255 start
fault("Invalid page zero address")
finish
finish
finish else if acc('X') or indexed('X') start
instr out(order+16_14, 0, 2, mcycles+2)
finish else if acc('Y') or indexed('Y') start
instr out(order+16_18, 0, 3, mcycles+3)
else
i = get opd(opd)
if indexed('X') start
if i#0 or 0<=opd<=255 start
instr out(order+16_14, opd, 2, mcycles+2)
else
instr out(order+16_1C, opd, 3, mcycles+3)
finish
finish else if indexed('Y') start
instr out(order+16_18, opd, 3, mcycles+3)
finish else if i#0 or 0<=opd<=255 start
instr out(order+4, opd, 2, mcycles+1)
else
instr out(order+12, opd, 3, mcycles+2)
finish
fault("Cannot evaluate operand") unless i=0
finish
continue
!-----------------------------------------------------------------------
itype2(7): ! rotate, shift
if acc('A') start
instr out(order+4, 0, 1, mcycles)
continue
finish
!-----------------------------------------------------------------------
itype2(8): ! inc, dec
operand('X', 'Y', order, mcycles+2)
continue
!-----------------------------------------------------------------------
itype2(9): ! cpx,cpy
immediate(order, mcycles) and continue if pres char='#'
!-----------------------------------------------------------------------
itype2(10):! BIT
i = get opd(opd)
if i#0 or 0<=opd<=255 start
instr out(order+4, opd, 2, mcycles+1)
fault("Cannot evaluate operand") unless i=0
else
instr out(order+12, opd, 3, mcycles+2)
finish
continue
!-----------------------------------------------------------------------
itype2(11): ! ldx
if pres char='#' start
immediate(order, mcycles)
else
operand('Y', 'X', order+4, mcycles)
finish
continue
!---------------------------------------------------------------------
itype2(12): ! LDY
if pres char='#' start
immediate(order, mcycles)
else
operand('X', 'Y', order+4, mcycles)
finish
continue
!-----------------------------------------------------------------------
itype2(13):! STX
store('Y', 'X', order, mcycles)
continue
!-----------------------------------------------------------------------
itype2(14): ! STY
store('X', 'Y', order, mcycles)
continue
!-----------------------------------------------------------------------
itype2(15): ! fcb
cycle
if pres char=',' start
opd = 0
i = 0
else
i = get opd(opd)
finish
if cont=0 start
j = lp
look ahead = 1
while more items cycle
k = get opd(k) unless pres char=','
repeat
look ahead = 0
instr out(opd, 0, 1, 0)
lp = j-1
next char
cont = 1
else
instr out(opd, 0, 1, 0)
finish
fault("Invalid constant") unless i=0 and 0<=opd<=255
repeat until not more items
cont = 0
continue
!------------------------------------------------------------------------
itype2(16): ! fdb
cycle
if pres char=',' start
opd = 0
i = 0
else
i = get opd(opd)
finish
if cont=0 start
j = lp
look ahead = 1
while more items cycle
k = get opd(k) unless pres char=','
repeat
look ahead = 0
instr out(0, opd, -2, 0)
lp = j-1
next char
cont = 1
else
instr out(0, opd, -2, 0)
finish
fault("Invalid constant") unless i=0
repeat until not more items
cont = 0
continue
!-----------------------------------------------------------------------
itype2(17):! equ
i = get opd(opd)
instr out(0, opd, -3, 0)
fault("No name to equate") if lid=0
fault("Cannot evaluate operand") unless i=0
if lid#0 and i=0 and nass(lid)=3 and nval(lid)#opd start
fault("Inconsistent label")
nval(lid) = opd
finish
continue
!-----------------------------------------------------------------------
itype2(18):! org
i = get opd(opd)
ca = opd if i=0
instr out(0, 0, 0, 0)
fault("Illegal label") unless lid=0
fault("Cannot evaluate operand") unless i=0
continue
!-----------------------------------------------------------------------
itype2(19): ! rmb
i = get opd(opd)
instr out(0, opd, -1, 0)
if i=0 start
ca = ca+opd
else
fault("Cannot evaluate operand")
finish
continue
!-----------------------------------------------------------------------
itype2(20):! fcc
non dense = 1
if '0'<=pres char<='9' start
i = 0
j = lp
cycle
i = i*10+pres char-'0'
next char
repeat until not '0'<=pres char<='9'
if pres char=',' start
next char
if i=0 start
instr out(0, 0, 0, 0)
fault("Invalid string")
else
while i>0 cycle
if pres char=nl start
opd = ' '
else
opd = line(lp)
next char
finish
i = i-1
if cont=0 start
j = lp
for k = 1, 1, i cycle
exit if pres char=nl
next char
repeat
instr out(opd, 0, 1, 0)
lp = j-1
next char
cont = 1
else
instr out(opd, 0, 1, 0)
finish
repeat
cont = 0
finish
continue
else
lp = j-1
next char
finish
finish
if pres char<' ' start
next char while pres char#nl
instr out(0, 0, 0, 0)
fault("Invalid string delimiter")
else
delim = pres char
next char
cycle
if pres char=nl start
if cont=0 start
instr out(0, 0, 0, 0)
fault("Illegal string")
finish
exit
finish
if pres char=delim start
next char
unless pres char=delim start
if cont=0 start
instr out(0, 0, 0, 0)
fault("Invalid string")
finish
exit
finish
finish
if cont=0 start
i = lp
cycle
next char while pres char#delim and pres char#nl
if pres char=delim start
next char
finish
exit unless pres char=delim
next char
repeat
instr out(line(i), 0, 1, 0)
lp = i-1
next char
cont = 1
else
instr out(line(lp), 0, 1, 0)
finish
next char
repeat
cont = 0
finish
continue
!-----------------------------------------------------------------------
itype2(21): ! nam
non dense = 1
header = ""
while pres char#nl cycle
header <- header.to string(line(lp))
next char
repeat
instr out(0, 0, -4, 0)
fault("Illegal label") unless lid=0
continue
!-----------------------------------------------------------------------
itype2(22): ! opt
i = lp
j = bchar
cycle
if get option(opt) start
->option action(opt)
option action(1):
option action(2):
bchar = ' '
-> next option
option action(3):
option action(4):
bchar = -1
-> next option
option action(5):
option action(6):
cflag = 1
-> next option
option action(7):
option action(8):
cflag = 0
-> next option
option action(9):
drad = 4
sp1 = 3
sp2 = 6
-> next option
option action(10):
drad = 5
sp1 = 3
sp2 = 5
-> next option
option action(11):
drad = 8
sp1 = 2
sp2 = 4
-> next option
option action(12):
option action(13):
option action(14):
option action(15):
eflag = 1
-> next option
option action(16):
option action(17):
eflag = 0
-> next option
option action(18):
option action(19):
fflag = 1
-> next option
option action(20):
option action(21):
fflag = 0
-> next option
option action(22):
option action(23):
gflag = 1
-> next option
option action(24):
option action(25):
gflag = 0
-> next option
option action(26):
option action(27):
lflag = 2
-> next option
option action(28):
option action(29):
lflag = 1
-> next option
option action(30):
option action(31):
lflag = 0
-> next option
option action(32):
option action(33):
pflag = 3
-> next option
option action(34):
option action(35):
pflag = 0
-> next option
option action(36):
option action(37):
sflag = 1
-> next option
option action(38):
option action(39):
sflag = 0
-> next option
option action(40):
option action(41):
tflag = 1
-> next option
option action(42):
option action(43):
tflag = 0
-> next option
option action(44):
option action(45):
wflag = 1
-> next option
option action(46):
option action(47):
wflag = 0
-> next option
option action(48):
option action(49):
xflag = 1
-> next option
option action(50):
option action(51):
xflag = 0
option action(-1):
option action(0):
next option:
finish
repeat until not more items
if lflag=2 start
sp3 = line width-sp1-sp2*2-cflag*2-wflag-10
else
sp3 = line width-wflag-7
finish
instr out(0, 0, -4, 0)
fault("Illegal label") unless lid=0
lp = i-1
next char
bchar = j
cycle
if get option(opt) start
if opt=1 or opt=2 start
bchar = ' '
finish else if opt=3 or opt=4 start
bchar = -1
finish else if opt<0 start
fault("Unknown option")
finish
else
fault("Cannot evaluate operand")
finish
repeat until not more items
continue
!-----------------------------------------------------------------------
itype2(23): ! page
unless lid=0 start
instr out(0, 0, -4, 0)
fault("Illegal label")
finish
nline(lines on page) unless lflag=0
continue
!-----------------------------------------------------------------------
itype2(24): ! spc
i = get opd(opd)
unless lid=0 start
instr out(0, 0, -4, 0)
fault("Illegal label")
finish
unless lflag=0 start
if i=0 start
nline(opd)
else
nline(1)
finish
finish
!-----------------------------------------------------------------------
repeat
!-----------------------------------------------------------------------
itype2(25):! end
instr out(0, 0, -4, 0)
fault("Illegal label") unless lid=0
for i = 1, 1, nnames cycle
fault("Symbol ".name(i)." has no value") if nass(i)=0
repeat
!-----------------------------------------------------------------------
unless xflag=0 start
sqs(1, nnames)
nline(lines on page)
print string(" Symbol Cross Reference Table")
nline(2)
sp3 = (linewidth-6-sp2)//6
for i = 1, 1, nnames cycle
print string(name(i))
spaces(7-length(name(i)))
if nass(i)=0 or nass(i)=2 or nass(i)=4 start
print symbol('*') for j = 1, 1, sp2
else
print number(nval(i), 2)
finish
j = xhead(i)
k = 0
cycle
l = xlink(j)
xlink(j) = k
k = j
j = l
repeat until j=0
j = 0
cycle
if j=sp3 start
nline(1)
spaces(7+sp2)
j = 0
finish
write(xentry(k), 5)
j = j+1
k = xlink(k)
repeat until k=0
nline(1)
repeat
finish else unless sflag=0 start
sqs(1, nnames)
nline(lines on page)
print string(" Symbol Table")
nline(2)
sp3 = (line width+8-sp2)//15
sp1 = (linewidth-sp3*15+9-sp2)>>1
for j = 1, 1, nnames cycle
if (j-1)=(j-1)//sp3*sp3 start
nline(1)
spaces(sp2)
else
spaces(8-sp2)
finish
print string(name(j))
spaces(7-length(name(j)))
if nass(j)=0 or nass(j)=2 or nass(j)=4 start
print symbol('*') for i = 1, 1, sp2
else
print number(nval(j),2)
finish
repeat
nline(1)
finish
nline(2)
spaces(2)
if faults=0 start
print string("No")
else
write(faults, 0)
finish
print string(" fault")
print symbol('s') unless faults=1
print string(" in this assembly.")
newline
select output(0)
spaces(2)
if faults=0 start
write(ln, 0)
print string(" line")
print symbol('s') unless ln=1
print string(" assembled.")
else
write(faults, 0)
print string(" fault")
print symbol('s') unless faults=1
print string(" in this assembly.")
finish
new line
close
stop
!---------------------------------------------------------------------
predicate is typed(string(255) source, string(255)name file)
integer i
for i = 1, 1, length(source) cycle
file = substring(source, 1, i-1) and true if charno(source, i)='.'
repeat
file = source
false
end
!-------------------------------------------------------
predicate matches(string(255) source, pattern,
integer min, integer name i)
integer l
l = length(pattern)
if length(pattern)>=length(source) start
l = length(source)
else
l = length(pattern)
finish
for i = 1, 1, l cycle
unless charno(source, i)=charno(pattern, i) start
if 'A'<=charno(source, i)<='Z' start
false
finish else if i<=min start
false
else
true
finish
finish
repeat
i = i+1
false if i<=min
true
end
!---------------------------------------------------------------------
string(255) function lc(string(255) source)
string(255) result
integer i
result = ""
for i = 1, 1, length(source) cycle
if 'A'<=charno(source, i)&127<='Z' start
result = result.tostring((charno(source, i)&127)+'a'-'A')
else
result = result.tostring(charno(source, i)&127)
finish
repeat
result = result
end
!-----------------------------------------------------------------------
routine read line
integer i
on event 9 start
if i=1 start
line(1) = ' '
line(2) = 'E'
line(3) = 'N'
line(4) = 'D'
line(5) = nl
else
line(i) = nl
finish
-> eof exit
finish
ln=ln+1
for i = 1, 1, max line+1 cycle
read symbol(line(i))
exit if line(i)&127=nl or line(i)&127=12
repeat
read symbol(line(i)) while line(i)&127#nl and line(i)&255#12
eof exit:
lp = 0
next char
end
!-----------------------------------------------------------------------
routine next char
lp = lp+1
pres char = line(lp)&127
if 'a'<=pres char<='z' start
pres char = pres char+'A'-'a'
finish else if pres char=12 start
pres char = nl
finish else if pres char=9 start
pres char = ' '
finish
end
!-----------------------------------------------------------------------
predicate more items
next char while pres char=bchar
false unless pres char=','
next char until pres char#bchar
true
end
!-----------------------------------------------------------------------
predicate get option(integer name opt)
string(11) option
if 'A'<=pres char<='Z' start
option = to string(pres char)
cycle
next char
exit unless 'A'<=pres char<='Z' or '0'<=pres char<='9'
option <- option.to string(pres char)
repeat
for opt = 1, 1, no options cycle
true if option text(opt)=option
repeat
opt = -1
true
else
opt = 0
false unless pres char=','
next char
true
finish
end
!-----------------------------------------------------------------------
integerfn get name(integername nid)
string(6) n
integer h,l
nid = 0 and result = 1 unless 'A'<=pres char<='Z'
h=pres char-'0'
n=tostring(pres char)
l = 1
cycle
next char
exit unless 'A'<=pres char<='Z' or '0'<=pres char<='9'
l = l+1
h=h<<4+pres char-'0' and n=n.tostring(pres char) unless l>6
repeat
h=h&32767
h=h-h//nhash*nhash
l=hnlink(h)
while l#0 cycle
if name(l)=n start
nid = l
if pass=3 and xxentries<=xentries and look ahead=0 start
xxentries = xxentries+1
if xxentries>xentries start
fault("Too many references")
else
xlink(xxentries) = xhead(l)
xentry(xxentries) = ln
xhead(l) = xxentries
finish
finish
result = 0
finish
l=nlink(l)
repeat
fault("Too many names") and stop if nnames=names
nnames = nnames+1
name(nnames) = n
nlink(nnames) = hnlink(h)
if n="A" or n="X" or n="Y" start
nass(nnames) = 2
else
nass(nnames) = 0
finish
nval(nnames) = 0
if pass=3 and xxentries<=xentries start
xxentries = xxentries+1
if xxentries>xentries start
fault("Too many references")
else
xlink(xxentries) = 0
xentry(xxentries) = ln
xhead(nnames) = xxentries
finish
else
xhead(nnames) = 0
finish
hnlink(h) = nnames
nid = nnames
result = 0
end
!-----------------------------------------------------------------------
predicate get instr(integername iid)
string(4) i
integer h,l
iid=0
false unless 'A'<=pres char<='Z'
h=pres char-'0'
i=tostring(pres char)
for l = 2, 1, 4 cycle
next char
-> goti unless 'A'<=pres char<='Z'
h=h<<4+pres char-'0'
i=i.tostring(pres char)
repeat
next char
false if 'A'<=pres char<='Z'
goti: h=h&32767
h=h-h//ihash*ihash
l=hilink(h)
while l#0 cycle
iid=l and true if instr(l)=i
l=ilink(l)
repeat
false
end
!-----------------------------------------------------------------------
routine evaluate(integer name a, integer b, byte integer op)
if op='+' start
a = a+b
finish else if op='-' start
a = a-b
finish else if op='*' start
a = a*b
finish else if op='/' start
a = a//b
finish else if op='|' start
a = a-a//b*b
finish else if op='!' start
a = a!b
finish else if op='&' start
a = a&b
finish else if op='¬' start
a = a!!b
finish else if op='<' start
a = a<<b
finish else if op='>' start
a = a>>b
finish
end
!-----------------------------------------------------------------------
integer function get term(integer name opd)
integer i
while pres char='+' cycle
next char until pres char#bchar
repeat
if pres char='-' start
next char until pres char#bchar
i = get term(opd)
opd = -opd
finish else if pres char='¬' start
next char until pres char#bchar
i = get term(opd)
opd = ¬opd
finish else if pres char='(' start
next char until pres char#bchar
i = get expression(opd)
if i=0 start
next char while pres char=bchar
if pres char=')' start
next char
else
i = 0
finish
finish
finish else if get name(i)=0 start
if pass=1 or nass(i)=1 or nass(i)=3 start
opd = nval(i)
i = 0
else
i = 1
finish
else
i = get const(opd)
finish
result = i
end
!-----------------------------------------------------------------------
integer function get expression(integer name opd)
integer sp, prio, i
byte integer array op stk, prio stk(1:5)
integer array opd stk(0:5)
result = 1 unless get term(opd stk(0))=0
sp = 0
i = 0
cycle
next char while pres char=bchar
if pres char='!' or pres char='¬' start
prio = 0
finish else if pres char='&' start
prio = 1
finish else if pres char='+' or pres char='-' start
prio = 2
finish else if pres char='*' or pres char='/' or c
pres char='|' start
prio = 3
finish else if pres char='<' or pres char='>' start
prio = 4
else
exit
finish
while sp>0 and prio stk(sp)>=prio cycle
evaluate(opd stk(sp-1), opd stk(sp), op stk(sp))
sp = sp-1
repeat
sp = sp+1
op stk(sp) = pres char
prio stk(sp) = prio
next char until pres char#bchar
unless get term(opd stk(sp))=0 start
sp = sp-1
i = 1
exit
finish
repeat
evaluate(opd stk(sp-1), opd stk(sp), op stk(sp)) for sp = sp, -1, 1
opd = opd stk(0) if i=0
result = i
end
!-----------------------------------------------------------------------
integer function get opd(integername opd)
integer nid,op,cval
result = get expression(opd) unless fflag=0
opd=0
if pres char='+' or pres char='-' start
op = pres char
next char until pres char#bchar
else
op = '+'
finish
cycle
if get name(nid)=0 start
result=1 unless pass=1 or nass(nid)=1 or nass(nid)=3
cval=nval(nid)
else
result=1 if get const(cval)#0
finish
evaluate(opd, cval, op)
next char while pres char=bchar
op = pres char
result=0 unless op='+' or op='-' or op='*' or op='/'
next char until pres char#bchar
repeat
end
!-----------------------------------------------------------------------
integerfn get const(integername cval)
integer started, dig val, bin val, oct val, hex val,
bin pos, oct pos, dec pos
started=1
if pres char='*' start
next char
cval = ca
result = 0
finish
cval=0
if '0'<=pres char<='9' start ; ! decimal
bin pos = 0
oct pos = 0
dec pos = 0
bin val = 0
oct val = 0
hex val = 0
cycle
if bin pos=0 and pres char='B' start
next char
if '0'<=pres char<='9' or 'A'<=pres char<='F' or c
pres char='H' start
bin pos = 1
oct pos = 1
dec pos = 1
hex val = (hex val<<4)+11
else
cval = bin val
result = 0
finish
finish
if oct pos=0 and (pres char='O' or pres char='Q') start
cval = oct val
next char
result = 0
finish else if pres char='H' start
cval = hex val
next char
result = 0
finish else if 'A'<=pres char<='F' start
dig val = pres char-'A'+10
finish else if '0'<=pres char<='9' start
dig val = pres char-'0'
else
result = dec pos
finish
bin pos = 1 if dig val>1
oct pos = 1 if dig val>7
dec pos = 1 if dig val>9
bin val = (bin val<<1)+dig val
oct val = (oct val<<3)+dig val
cval = cval*10+dig val
hex val = (hex val<<4)+dig val
next char
repeat
finish
if pres char='$' start ; ! hex
cycle
next char
if '0'<=pres char<='9' start
cval = cval<<4!(pres char-'0')
finish else if 'A'<=pres char<='F' start
cval = cval<<4!(pres char-'A'+10)
else
result = started
finish
started = 0
repeat
finish
if pres char='@' start ; ! octal
cycle
next char
result = started unless '0'<=pres char<='7'
cval = (cval<<3)!(pres char-'0')
started = 0
repeat
finish
if pres char='%' start
cycle
next char
result = started unless '0'<=pres char<='1'
cval = (cval<<1)!(pres char-'0')
started = 0
repeat
finish
if pres char='''' start
next char
result=1 if lp=max line+1
cval=line(lp)
next char
result=0
finish
result=1
end
!-----------------------------------------------------------------------
predicate indexed(byte integer reg)
integer i
i = lp
true if more items and acc(reg)
lp = i-1
next char
false
end
!-----------------------------------------------------------------------
predicate acc(byte integer acc id)
false unless pres char=acc id
next char
true unless 'A'<=pres char<='Z' or '0'<=pres char<='9'
lp = lp-2
next char
false
end
!-----------------------------------------------------------------------
routine immediate(byte integer order, mcycles)
integer i, opd
next char until pres char#bchar
i = get opd(opd)
instr out(order, opd, 2, mcycles)
unless i= 0 start
fault("Cannot evaluate operand")
finish else unless 0<=opd<=255 start
fault("Invalid constant")
finish
end
!-----------------------------------------------------------------------
routine operand(byte integer reg, nreg, order, mcycles)
integer i, opd, reg fault
if acc(reg) or indexed(reg) start
instr out(order+16_10, 0, 2, mcycles+2)
finish else if acc(nreg) or indexed(nreg) start
instr out(order+16_10, 0, 2, mcycles+2)
fault("Invalid index register")
else
i = get opd(opd)
if indexed(reg) start
if i#0 or 0<=opd<=255 start
instr out(order+16_10, opd, 2, mcycles+2)
else
instr out(order+16_18, opd, 3, mcycles+3)
finish
else
if indexed(nreg) start
reg fault = 1
else
reg fault = 0
finish
if i#0 or 0<=opd<=255 start
instr out(order, opd, 2, mcycles+1)
else
instr out(order+8, opd, 3, mcycles+2)
finish
fault("Invalid index register") unless reg fault=0
finish
fault("Cannot evaluate operand") unless i=0
finish
end
!-----------------------------------------------------------------------
routine store(byte integer reg, nreg, order, mcycles)
integer i, opd, reg fault
if acc(reg) or indexed(reg) start
instr out(order+16_10, 0, 2, mcycles+1)
finish else if acc(nreg) or indexed(nreg) start
instr out(order+16_10, 0, 2, mcycles+1)
fault("Invalid index register")
else
i = get opd(opd)
if indexed(reg) start
instr out(order+16_10, opd, 2, mcycles+1)
unless i#0 or 0<=opd<=255 start
fault("Invalid page zero address")
finish
else
if indexed(nreg) start
reg fault = 1
else
reg fault = 0
finish
if i#0 or 0<=opd<=255 start
instr out(order, opd, 2, mcycles)
else
instr out(order+8, opd, 3, mcycles+1)
finish
fault("Invalid index register") unless reg fault=0
finish
fault("Cannot evaluate operand") unless i=0
finish
end
!-----------------------------------------------------------------------
routine dump block
integer checksum, old rad, i
select output(1)
old rad = drad
drad = 8
print string("S1")
print number(bp+3, 1)
print number(buffer ca, 2)
checksum = ((buffer ca>>8)&255)+(buffer ca&255)+bp+3
for i = 1, 1, bp cycle
checksum = check sum+buffer(i)
print number(buffer(i), 1)
repeat
print number(¬(checksum&255), 1)
print symbol(13)
new line
drad = old rad
select output(2)
bp = 0
end
!--------------------------------------------------------------------------
routine dump(byte integer byte)
if ostarted=0 start
select output(1)
print symbol(13)
new line
print string("S00600004844521B")
print symbol(13)
new line
select output(2)
ostarted = 1
finish
buffer ca = ca if bp=0
dump block and buffer ca = ca unless buffer ca+bp=ca
bp = bp+1
buffer(bp) = byte
ca = ca+1
dump block if bp=16
end
!---------------------------------------------------------------------------
routine close
unless ostarted=0 start
dump block unless bp=0
select output(1)
print string("S9030000FC")
print symbol(13)
new line
select output(2)
finish
end
!-----------------------------------------------------------------------
routine instr out(integer op, opd, b, cyc)
integer i, j, k, lit
i = 1
unless lflag=0 or ((gflag=0 or lflag=1) and cont=1) start
write(ln, 5)
space unless wflag=0
if lflag=2 start
space
if b<=-3 start
spaces(sp2)
else
print number(ca, 2)
finish
space
if b=-3 start
print number(opd, 2)
spaces(sp1+1)
finish else if -2<=b<=-1 start
back number(opd)
spaces(sp1+1)
else
if b<=0 start
spaces(sp1)
else
print number(op, 1)
finish
space
if b<=1 start
spaces(sp2)
finish else if b=2 start
print number(opd, 1)
spaces(sp2-sp1)
else
back number(opd)
finish
finish
unless cflag=0 start
if cyc=0 start
spaces(2)
else
write(cyc, 1)
finish
finish
finish
if cont=0 start
space
if tflag=0 start
cycle
out symbol(line(i))
exit if line(i)&127=nl or line(i)&127=12
i = i+1
repeat
else
j = 1
out tag(i, j, 8)
out tag(i, j, 12)
lit = 0
k = 0
while i#lp cycle
if line(i)&127=' ' start
k = k+1 if non dense=1 and lit=0
else
j = j+k+1
out symbol(' ') and k = k-1 while k>0
out symbol(line(i))
finish
if line(i)&127='''' start
lit = 1
else
lit = 0
finish
i = i+1
repeat
i = i+1 while line(i)&127=' '
unless lp=1 or line(i)&127=nl or line(i)&127=12 start
out symbol(' ') and j = j+1 until j>=24
finish
cycle
out symbol(line(i))
exit if line(i)&127=nl or line(i)&127=12
i = i+1
repeat
finish
else
nline(1)
finish
else
i = i+1 while line(i)&127#nl and line(i)&127#12
finish
fault("Truncated line") if i=max line+1
if b>=1 start
dump(op&255)
unless b=1 start
dump(opd&255)
dump((opd>>8)&255) if b=3
finish
finish else if b=-2 start
dump(opd&255)
dump((opd>>8)&255)
finish
end
!-----------------------------------------------------------------------
routine out tag(integer name i, j, integer col)
while line(i)&127#' ' and i#lp cycle
out symbol(line(i))
i = i+1
j = j+1
repeat
i = i+1 while line(i)&127=' ' and i#lp
unless i=lp start
out symbol(' ') and j = j+1 until j>=col
finish
end
!------------------------------------------------------------------------
routine out symbol(byte integer char)
own integer optr = 0
if char&127=nl start
optr = 0
nline(1)
finish else if char&127=12 start
optr = 0
nline(lines on page)
else
if optr=sp3 start
return if wflag=0
nline(1)
write(ln, 5)
print symbol('+')
spaces(line width-sp3-7)
optr = 0
finish
print symbol(char)
optr = optr+1
finish
end
!-----------------------------------------------------------------------
routine fault(string(63) s)
faults=faults+1
unless eflag=0 start
print string("**** ".s.". ****")
nline(1)
finish
end
!-----------------------------------------------------------------------
routine nline(integer n)
own integer line on page = lines on page+1, page no = 0
unless n<0 start
if line on page+pflag+n>lines on page start
page no = page no+1
unless n=0 start
if line on page=lines on page start
new line
else
print symbol(12)
finish
finish
if pflag=0 start
line on page = 1
else
new line
print string(" MOS Technology MCS650X Assembler ")
spaces((line width-45-length(header))//2)
print string(header)
spaces((line width-44-length(header))//2)
print string(" Page")
write(page no, 2)
new lines(2)
line on page = 4
finish
else
new lines(n)
line on page = line on page+n
finish
finish
end
!-----------------------------------------------------------------------
routine back number(integer n)
print number(((n&255)<<8)!((n>>8)&255), 2)
end
!-----------------------------------------------------------------------
routine print number(integer n,d)
conststring(1)array h(0:15)="0","1","2","3","4","5","6","7","8","9",
"A","B","C","D","E","F"
integer model, nn
string(6) s
model = 1<<(d*8-1)
s=""
cycle
model =(model>>1)//drad
nn = (n>>1)//drad
s=h(n-((nn*drad)<<1)).s
n = nn
repeat until model=0
print string(s)
end
!-----------------------------------------------------------------------
routine sqs(integer l, r)
integer nass key, nval key, xhead key, lp, rp, i
string(6) name key
return unless l<r
while r-l>insert limit cycle
lp = l
rp = r+1
name key = name(l)
nass key = nass(l)
nval key = nval(l)
xhead key = xhead(l)
cycle
rp = rp-1 until rp=lp or name key>name(rp)
exit if lp=rp
name(lp) = name(rp)
nass(lp) = nass(rp)
nval(lp) = nval(rp)
xhead(lp) = xhead(rp)
lp = lp+1 until rp=lp or name key<=name(lp)
exit if lp=rp
name(rp) = name(lp)
nass(rp) = nass(lp)
nval(rp) = nval(lp)
xhead(rp) = xhead(lp)
repeat
name(lp) = name key
nass(lp) = nass key
nval(lp) = nval key
xhead(lp) = xhead key
if lp-l>r-rp start
sqs(rp+1, r)
r = lp-1
else
sqs(l, lp-1)
l = rp+1
finish
repeat
for rp = l+1, 1, r cycle
name key = name(rp)
nass key = nass(rp)
nval key = nval(rp)
xhead key = xhead(rp)
lp = l
lp = lp+1 while lp#rp and name key>name(lp)
for i = rp-1, -1, lp cycle
name(i+1) = name(i)
nass(i+1) = nass(i)
nval(i+1) = nval(i)
xhead(i+1) = xhead(i)
repeat
name(lp) = name key
nass(lp) = nass key
nval(lp) = nval key
xhead(lp) = xhead key
repeat
end
!-----------------------------------------------------------------------
end of program