begin
{--------------------------------}
{ }
{ Motorola M6809 Assembler. }
{ }
{ Copyright M.R.King, 26/3/1984. }
{ All rights reserved. }
{ }
{--------------------------------}
own string(255) copyright = c
"Motorola M6809 Assembler. Copyright M.R.King, 26/3/1984. All rights reserved."
constant integer names = 1023,
line width = 78,
lines on page = 66,
max line = 512,
insert limit = 10,
xentries = 4096
constinteger ihash = 59
constant byte integer array hilink(0:58) = c
46, 80, 28, 43, 71, 51, 11, 73, 106, 96, 22, 122,
2, 5, 97, 6, 33, 30, 19, 20, 138, 42, 3, 4,
75, 45, 124, 76, 77, 108, 7, 27, 8, 111, 32, 9,
10, 143, 57, 134, 153, 47, 158, 29, 59, 150, 0, 78,
119, 26, 36, 23, 21, 35, 12, 1, 49, 16, 31
constant byte integer array ilink(1:198) = c
15, 34, 13, 14, 17, 18, 114, 37, 40, 24, 82, 39,
74, 50, 68, 69, 38, 48, 25, 99, 61, 121, 115, 92,
54, 117, 66, 65, 44, 41, 63, 162, 88, 62, 0, 70,
0, 60, 67, 198, 94, 84, 58, 120, 147, 55, 52, 87,
56, 53, 72, 188, 110, 98, 64, 140, 133, 81, 85, 0,
116, 137, 100, 102, 90, 160, 186, 89, 154, 0, 112, 113,
83, 109, 126, 123, 79, 86, 0, 101, 91, 105, 170, 146,
151, 118, 128, 93, 139, 104, 0, 142, 193, 95, 164, 107,
127, 141, 166, 185, 103, 155, 0, 167, 0, 0, 0, 0,
144, 0, 0, 129, 0, 132, 163, 183, 131, 161, 130, 149,
175, 136, 125, 148, 184, 0, 177, 135, 156, 0, 0, 0,
157, 152, 159, 187, 145, 176, 169, 0, 165, 168, 179, 171,
181, 174, 0, 0, 0, 0, 197, 0, 172, 0, 0, 0,
0, 0, 0, 0, 194, 0, 196, 190, 0, 178, 0, 0,
192, 173, 0, 180, 189, 182, 0, 0, 0, 0, 0, 0,
0, 195, 0, 0, 0, 0, 0, 191, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0
constant string(5) array instr(1:198) = c
"LD","LDA","LDAA","LDAB","LDB","LDD","LDS","LDU","LDX",
"LDY","ST","STA","STAA","STAB","STB","STD","STS","STU",
"STX","STY","JSR","BSR","LBSR","BRA","LBRA","BRN","LBRN",
"BHI","LBHI","BLS","LBLS","BCC","LBCC","BHS","LBHS","BCS",
"LBCS","BLO","LBLO","BNE","LBNE","BEQ","LBEQ","BVC","LBVC",
"BVS","LBVS","BPL","LBPL","BMI","LBMI","BGE","LBGE","BLT",
"LBLT","BGT","LBGT","BLE","LBLE","JMP","RTS","SUB","SUBA",
"SUBB","SUBD","ADD","ADDA","ADDB","ADDD","CMP","CMPA","CMPB",
"CMPD","CMPS","CMPU","CMPX","CMPY","CPX","LEA","LEAS","LEAU",
"LEAX","LEAY","EXG","TFR","DEC","DECA","DECB","INC","INCA",
"INCB","CLR","CLRA","CLRB","INX","DEX","AND","ANDA","ANDB",
"OR","ORA","ORAA","ORAB","ORB","EOR","EORA","EORB","BIT",
"BITA","BITB","LSR","LSRA","LSRB","ROR","RORA","RORB","ASR",
"ASRA","ASRB","ASL","ASLA","ASLB","LSL","LSLA","LSLB","ROL",
"ROLA","ROLB","SBC","SBCA","SBCB","ADC","ADCA","ADCB","NEG",
"NEGA","NEGB","COM","COMA","COMB","TST","TSTA","TSTB","TSX",
"INS","PUL","PULA","PULB","PULS","PULU","PSH","PSHA","PSHB",
"PSHS","PSHU","DES","TXS","RTI","WAI","CWAI","ANDCC","ORCC",
"SWI","SWI1","SWI2","SWI3","SBA","CBA","ABA","TAB","TBA",
"DAA","NOP","TAP","TPA","MUL","SEX","ABX","SYNC","CLV",
"SEV","CLC","SEC","CLI","SEI","FCB","FDB","EQU","ORG",
"SETDP","RMB","FCC","NAM","OPT","PAGE","SPC","MON","END"
constant integer array icode(1:198) = c
16_86,16_86,16_86,16_C6,16_C6,16_CC,16_10CE,16_CE,16_8E,
16_108E,16_87,16_87,16_87,16_C7,16_C7,16_CD,16_10CF,16_CF,
16_8F,16_108F,16_8D,16_8D,16_8D,16_20,16_20,16_2100,16_1021,
16_22,16_22,16_23,16_23,16_24,16_24,16_24,16_24,16_25,
16_25,16_25,16_25,16_26,16_26,16_27,16_27,16_28,16_28,
16_29,16_29,16_2A,16_2A,16_2B,16_2B,16_2C,16_2C,16_2D,
16_2D,16_2E,16_2E,16_2F,16_2F,16_0E,16_39,16_80,16_80,
16_C0,16_83,16_8B,16_8B,16_CB,16_C3,16_81,16_81,16_C1,
16_1083,16_118C,16_1183,16_8C,16_108C,16_8C,16_30,16_32,16_33,
16_30,16_31,16_1E,16_1F,16_0A,16_4A,16_5A,16_0C,16_4C,
16_5C,16_0F,16_4F,16_5F,16_3001,16_301F,16_84,16_84,16_C4,
16_8A,16_8A,16_8A,16_CA,16_CA,16_88,16_88,16_C8,16_85,
16_85,16_C5,16_04,16_44,16_54,16_06,16_46,16_56,16_07,
16_47,16_57,16_08,16_48,16_58,16_08,16_48,16_58,16_09,
16_49,16_59,16_82,16_82,16_C2,16_89,16_89,16_C9,16_00,
16_40,16_50,16_03,16_43,16_53,16_0D,16_4D,16_5D,16_1F41,
16_3261,16_35,16_3502,16_3504,16_35,16_37,16_34,16_3402,16_3404,
16_34,16_36,16_327F,16_1F14,16_3B,16_3CFF,16_3C,16_1C,16_1A,
16_3F,16_3F,16_103F,16_113F,16_A0E0,16_A1E0,16_ABE0,16_895D,16_984D,
16_19,16_12,16_1F8A,16_1FA8,16_3D,16_1D,16_3A,16_13,16_1CFD,
16_1A02,16_1CFE,16_1A01,16_1CEF,16_1A10,16_00,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:198) = c
6, 4, 12, 12, 12, 9, 9, 9, 9, 9, 10, 5, 13, 13, 13,
13, 13, 13, 13, 13, 13, 3, 3, 3, 3, 2, 24, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 14,
1, 8, 12, 12, 9, 8, 12, 12, 9, 7, 12, 12, 9, 9, 9,
9, 9, 9, 16, 17, 17, 17, 17, 18, 18, 15, 1, 1, 15, 1,
1, 15, 1, 1, 2, 2, 11, 12, 12, 11, 4, 12, 12, 12, 11,
12, 12, 11, 12, 12, 15, 1, 1, 15, 1, 1, 15, 1, 1, 15,
1, 1, 15, 1, 1, 15, 1, 1, 11, 12, 12, 11, 12, 12, 15,
1, 1, 15, 1, 1, 15, 1, 1, 2, 2, 19, 2, 2, 20, 20,
19, 2, 2, 20, 20, 2, 2, 1, 2, 21, 21, 21, 23, 1, 1,
1, 25, 25, 25, 22, 22, 1, 1, 2, 2, 1, 1, 1, 1, 2,
2, 2, 2, 2, 2, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
36, 37, 37
constant integer array icycles(1:198) = c
2, 2, 2, 2, 2, 3, 4, 3, 3, 4, 2, 2, 2, 2, 2,
3, 4, 3, 3, 4, 5, 7, 7, 3, 3, 3, 5, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1,
5, 2, 2, 2, 4, 2, 2, 2, 4, 2, 2, 2, 5, 5, 5,
4, 5, 4, 2, 2, 2, 2, 2, 8, 7, 2, 2, 2, 2, 2,
2, 2, 2, 2, 5, 5, 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, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 6, 5, 5, 6, 6, 5, 5,
5, 6, 6, 5, 5, 5, 6, 15, 21, 21, 3, 3, 19, 19, 20,
20, 11, 11, 11, 8, 8, 2, 2, 6, 6, 11, 2, 3, 2, 3,
3, 3, 3, 3, 3, 0, 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
routine spec skip blanks
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 analise operand(integer eca,
integer name post, opd, type, cycles)
routine spec out symbol(byte integer char)
routine spec out tag(integer name i, j, integer col)
routine spec instr out(integer op, post,opd,b, cyc)
routine spec close
routine spec fault(string(63) s)
routine spec nline(integer n)
routine spec print number(integer n,d)
predicate spec accumulator
predicate spec acc(byte integer acc id)
predicate spec auto indexed(integer name post, cycles)
predicate spec cc
predicate spec dp
predicate spec pc
predicate spec pc relative
predicate spec index reg(integer name reg)
predicate spec transfer reg(integer name reg)
routine spec sqs(integer l, r)
byte integer array buffer(1:16)
byteinteger 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, accop, buffer ca, bp,
l, xxentries, post, type, acc fault, dp contents, fflag, ostarted,
eca, look ahead, diff, no longs, last no longs
constant integer nhash=67
integer array hnlink(0:nhash-1)
string(6)array name(1:names)
integer array nval, xhead, ndiff, nlink(1:names)
byteintegerarray nass(1:names)
integer array xentry, xlink(1:xentries)
switch option action(-1:no options)
switch itype1,itype3(1:37)
string(line width-37) 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*3-cflag*3-wflag-11
cont = 0
faults=0
nnames=0
xxentries = 0
consistent = 0
last consistent = 0
last no longs = 0
hnlink(i)=0 for i = 0, 1, nhash-1
ostarted = 0
bp = 0
look ahead = 0
!-----------------------------------------------------------------------
select input(1)
pass = 1
cycle
ln = 0
dp contents = 0
ca = 0
bchar = -1
fflag = 0
no longs = 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
diff = nval(lid)-ca
nval(lid) = ca
if pass=3 start
for i = 1, 1, consistent cycle
-> diff found if ndiff(i)=diff
repeat
consistent = consistent+1
ndiff(consistent) = diff
diff found: finish
finish
else
lid = 0
finish
next char while pres char=' '
continue unless get instr(iid)
next char while pres char=' '
if itype(iid)<=25 start
if 0<=icode(iid)<=255 start
ca = ca+1
else
ca = ca+2
finish
finish
->itype1(itype(iid))
!-----------------------------------------------------------------------
itype1(1):! implied
itype1(2): ! 6800 special implied
continue
!-----------------------------------------------------------------------
itype1(3):! relative
if pass<3 or get opd(opd)#0 or -128<=opd-ca-1<=127 start
ca = ca+1
finish else if icode(iid)=16_20 or icode(iid)=16_8D start
ca = ca+2
no longs = no longs+1
else
ca = ca+3
no longs = no longs+1
finish
continue
!-----------------------------------------------------------------------
itype1(4): ! lda, ora
ca = ca+1 and continue if pres char='#'
analise operand(ca, post, opd, type, mcycles)
if 1<=type<=2 start
skip blanks
-> itype1(12)
finish
-> analise double
!----------------------------------------------------------------------
itype1(5): ! sta
analise operand(ca, post, opd, type, mcycles)
if 1<=type<=2 start
skip blanks
-> itype1(13)
finish
-> analise double
!-----------------------------------------------------------------------
itype1(6): ! ld
if accumulator start
skip blanks
-> itype1(12)
finish else if acc('S') or acc('Y') start
ca = ca+1
finish else unless acc('D') or acc('U') or acc('X') start
-> itype1(12)
finish
skip blanks
-> itype1(9)
!-----------------------------------------------------------------------
itype1(7): ! cmp
if accumulator start
skip blanks
-> itype1(12)
finish else if acc('D') or acc('S') or acc('U') or c
acc('Y') start
ca = ca+1
finish else unless acc('X') start
-> itype1(12)
finish
skip blanks
-> itype1(9)
!-----------------------------------------------------------------------
itype1(8): ! add, sub
if accumulator start
skip blanks
-> itype1(12)
finish else if acc('D') start
skip blanks
else
-> itype1(12)
finish
!-----------------------------------------------------------------------
itype1(9): ! immediate(3), direct, index, extend
ca = ca+2 and continue if pres char='#'
->itype1(13)
!-----------------------------------------------------------------------
itype1(10): ! st
if acc('S') or acc('Y') start
ca = ca+1
skip blanks
finish else if acc('D') or acc('U') or acc('X') or c
accumulator start
skip blanks
finish
-> itype1(13)
!-----------------------------------------------------------------------
itype1(11): ! inherent*(immediate(2), direct, index, extend)
skip blanks if accumulator
!-----------------------------------------------------------------------
itype1(12):! immediate(2), direct, index, extend
ca = ca+1 and continue if pres char='#'
!-----------------------------------------------------------------------
itype1(13):! direct, index, extend
itype1(14): ! jmp
analise operand(ca, post, opd, type, mcycles)
analise double:
if type<=3 start
ca = ca+1
finish else if type=4 start
ca = ca+2
no longs = no longs+1
else
ca = ca+type-4
no longs = no longs+type-5
finish
continue
!-----------------------------------------------------------------------
itype1(15): ! inherent, index, extend
analise operand(ca, post, opd, type, mcycles)
if 3<=type<=4 start
ca = ca+type-2
no longs = no longs+type-3
finish else if type>=5 start
ca = ca+type-4
no longs = no longs+type-5
finish
continue
!-----------------------------------------------------------------------
itype1(16): ! lea
skip blanks if index reg(i)
!-----------------------------------------------------------------------
itype1(17):! Load effective address
analise operand(ca, post, opd, type, mcycles)
if type<=5 start
ca = ca+1
else
ca = ca+type-4
no longs = no longs+type-5
finish
continue
!-----------------------------------------------------------------------
itype1(18): ! tfr, exg
itype1(19): ! pul, psh
itype1(20): ! pulu, puls, pshu, pshs
itype1(21): ! cwai, andcc, orcc
itype1(22): ! tab, tba
ca = ca+1
continue
!-----------------------------------------------------------------------
itype1(23): ! swi
ca = ca+1 if acc('2') or acc('3')
continue
!-----------------------------------------------------------------------
itype1(24): ! lbrn
itype1(25): ! sba, cba, aba
ca = ca+2
continue
!-----------------------------------------------------------------------
itype1(26): ! fcb
cycle
ca = ca+1
i = get opd(opd) unless pres char=','
repeat until not more items
continue
!-----------------------------------------------------------------------
itype1(27): ! fdb
cycle
ca = ca+2
i = get opd(opd) unless pres char=','
repeat until not more items
continue
!-----------------------------------------------------------------------
itype1(28):! 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
diff = nval(lid)-opd
nval(lid) = opd
if pass=3 start
for i = 1, 1, consistent cycle
->equ diff found if ndiff(i)=diff
repeat
consistent = consistent+1
ndiff(consistent) = diff
equ diff found: finish
finish
else
unless nass(lid)=2 start
nval(lid) = 0
nass(lid) = 4
finish
finish
finish
continue
!-----------------------------------------------------------------------
itype1(29):! org
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
ca = opd if get opd(opd)=0
continue
!-----------------------------------------------------------------------
itype1(30): ! setdp
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
dp contents = opd<<8 if get opd(opd)=0
continue
!-----------------------------------------------------------------------
itype1(31): ! rmb
ca = ca+opd if get opd(opd)=0
continue
!-----------------------------------------------------------------------
itype1(32):! 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(33): ! 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(34): ! 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(35): ! page
!-----------------------------------------------------------------------
itype1(36): ! spc
unless lid=0 start
nval(lid) = 0
nass(lid) = 4
finish
!-----------------------------------------------------------------------
repeat
!-----------------------------------------------------------------------
itype1(37):! end
unless lid=0 start
nval(lid) = 0
nass(lid) = 2
finish
if pass<3 start
pass = pass+1
else
exit if consistent=0 or c
(last consistent#0 and consistent>=last consistent and c
no longs>=last no longs)
last consistent = consistent
finish
last no longs = no longs
consistent = 0
reset input
repeat
!-----------------------------------------------------------------------
nline(0)
reset input
pass = 4
ln = 0
ca = 0
dp contents = 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
accop = 0
acc fault = 0
non dense = 0
instr out(0, 0, 0, -7, 0) and continue if pres char='*'
lid = 0 unless get name(lid)=0
skip blanks
if pres char=nl start
instr out(0, 0, 0, -7, 0)
finish else if get instr(iid) start
order = icode(iid)
if 0<=order<=255 start
eca = ca+1
else
eca = ca+2
finish
mcycles = icycles(iid)
skip blanks
->itype3(itype(iid))
else
instr out(0, 0, 0, -7, 0)
fault("Unknown operation")
finish
continue
!-----------------------------------------------------------------------
itype3(1):! implied
instr out(order, 0, 0, 1, mcycles)
continue
!-----------------------------------------------------------------------
itype3(2): ! 6800 special implied
instr out((order>>8)&255, order&255, 0, 2, mcycles)
continue
!-----------------------------------------------------------------------
itype3(3):! relative
i=get opd(opd)
j=opd-eca-1
if i#0 or -128<=j<=127 start
instr out(order, j, 0, 2, mcycles)
fault("Cannot evaluate operand") unless i=0
finish else if order=16_20 start
instr out(16_16, j-1, 0, 5, mcycles+2)
finish else if order=16_8D start
instr out(16_17, j-1, 0, 5, mcycles+2)
else
instr out(16_1000+order, j-2, 0, 5, mcycles+3)
finish
continue
!----------------------------------------------------------------------
itype3(4): ! lda, ora
-> itype3(12) if pres char='#'
analise operand(eca, post, opd, type, mcycles)
if 1<=type<=2 start
order = order+16_40 if type=2
accop = 1
skip blanks
-> itype3(12)
finish
-> generate double
!---------------------------------------------------------------------
itype3(5): ! sta
analise operand(eca, post, opd, type, mcycles)
if 1<=type<=2 start
order = order+16_40 if type=2
accop = 1
skip blanks
-> itype3(13)
finish
-> generate double
!----------------------------------------------------------------------
itype3(6): ! ld
accop = 1
if acc('A') start
skip blanks
-> itype3(12)
finish else if acc('B') start
order = 16_C6
skip blanks
-> itype3(12)
finish else if acc('D') start
order = 16_CC
finish else if acc('U') start
order = 16_CE
finish else if acc('X') start
order = 16_8E
finish else if acc('S') start
order = 16_10CE
mcycles = mcycles+1
finish else if acc('Y') start
order = 16_108E
mcycles = mcycles+1
else
acc fault = 2
accop = 0
-> itype3(12)
finish
skip blanks
mcycles = mcycles+1
-> itype3(9)
!----------------------------------------------------------------------
itype3(7): ! cmp
accop = 1
if acc('A') start
skip blanks
-> itype3(12)
finish else if acc('B') start
order = 16_C1
skip blanks
-> itype3(12)
finish else if acc('D') start
order = 16_1083
mcycles = mcycles+1
finish else if acc('U') start
order = 16_1183
mcycles = mcycles+1
finish else if acc('X') start
order = 16_8C
finish else if acc('S') start
order = 16_118C
mcycles = mcycles+1
finish else if acc('Y') start
order = 16_108C
mcycles = mcycles+1
else
acc fault = 2
accop = 0
-> itype3(12)
finish
skip blanks
mcycles = mcycles+2
-> itype3(9)
!-----------------------------------------------------------------------
itype3(8): ! add, sub
accop = 1
if acc('A') start
skip blanks
-> itype3(12)
finish else if acc('B') start
order = order+16_40
skip blanks
-> itype3(12)
finish else if acc('D') start
if order=16_80 start
order = 16_83
else
order = 16_C3
finish
else
acc fault = 1
accop = 0
-> itype3(12)
finish
skip blanks
mcycles = mcycles+2
!-----------------------------------------------------------------------
itype3(9):! immediate(3), direct, index, extend
if pres char='#' start
next char until pres char#bchar
i = get opd(opd)
instr out(order, opd, 0, 5, mcycles)
fault("Cannot evaluate operand") unless i=0
continue
finish
->itype3(13)
!-----------------------------------------------------------------------
itype3(10): ! st
accop = 1
if acc('B') start
order = 16_C7
finish else if acc('D') start
order = 16_CD
mcycles = mcycles+1
finish else if acc('U') start
order = 16_CF
mcycles = mcycles+1
finish else if acc('X') start
order = 16_8F
mcycles = mcycles+1
finish else if acc('S') start
order = 16_10CF
mcycles = mcycles+2
finish else if acc('Y') start
order = 16_108F
mcycles = mcycles+2
finish else unless acc('A') start
acc fault = 2
accop = 0
finish
skip blanks
-> itype3(13)
!-----------------------------------------------------------------------
itype3(11): ! inherent*(immediate(2), direct, index, extend)
accop = 1
if acc('B') start
order = order+16_40
finish else unless acc('A') start
accop = 0
acc fault = 1
finish
skip blanks
!-----------------------------------------------------------------------
itype3(12): ! immediate(2), direct, index, extend
if pres char='#' start
next char until pres char#bchar
i = get opd(opd)
instr out(order, opd, 0, 2, mcycles)
unless i=0 start
fault("Cannot evaluate operand")
finish else unless -128<=opd<=255 start
fault("Invalid constant")
finish
continue
finish
!-----------------------------------------------------------------------
itype3(13):! direct,index,extend
analise operand(eca, post, opd, type, mcycles)
generate double:
if type<=3 start
instr out(order+16_10, opd, 0, 2, mcycles)
if type=0 start
fault("Cannot evaluate operand")
finish else unless type=3 start
fault("Illegal operand")
finish
finish else if type=4 start
instr out(order+16_30, opd, 0, 5, mcycles)
else
instr out(order+16_20, post, opd, type-3, mcycles)
finish
fault("Accumulator not specified") if acc fault=1
fault("Register not specified") if acc fault=2
continue
!----------------------------------------------------------------------
itype3(14): ! jmp
analise operand(eca, post, opd, type, mcycles)
if type<=3 start
instr out(order, opd, 0, 2, mcycles)
if type=0 start
fault("Cannot evaluate operand")
finish else unless type=3 start
fault("Illegal operand")
finish
finish else if type=4 start
instr out(order+16_70, opd, 0, 5, mcycles)
else
instr out(order+16_60, post, opd, type-3, mcycles)
finish
continue
!----------------------------------------------------------------------
itype3(15): ! inherent, direct, indexed, extended
analise operand(eca, post, opd, type, mcycles)
if type<=1 start
accop = 1 if type=1
instr out(order+16_40, 0, 0, 1, mcycles)
fault("Cannot evaluate operand") if type=0
finish else if type=2 start
accop = 1
instr out(order+16_50, 0, 0, 1, mcycles)
finish else if type=3 start
instr out(order, opd, 0, 2, mcycles+2)
finish else if type=4 start
instr out(order+16_70, opd, 0, 5, mcycles+2)
else
instr out(order+16_60, post, opd, type-3, mcycles+2)
finish
continue
!-----------------------------------------------------------------------
itype3(16): ! lea
accop = 1
if acc('X') start
order = 16_30
finish else if acc('Y') start
order = 16_31
finish else if acc('S') start
order = 16_32
finish else if acc('U') start
order = 16_33
else
acc fault = 2
accop = 0
finish
skip blanks
!-----------------------------------------------------------------------
itype3(17): ! load effective address
analise operand(eca, post, opd, type, mcycles)
if type<=5 start
instr out(order, post, opd, 2, mcycles)
if type=0 start
fault("Cannot evaluate operand")
finish else unless type=5 start
fault("Illegal operand")
finish
else
instr out(order, post, opd, type-3, mcycles)
finish
fault("Index register not specified") unless acc fault=0
continue
!-----------------------------------------------------------------------
itype3(18): ! tfr,exg
if transfer reg(post) start
accop = 1 unless more items
if transfer reg(opd) start
instr out(order, (post<<4)!opd, 0, 2, mcycles)
if (post<8 and 8<=opd) or (opd<8 and 8<=post) start
fault("Different size registers")
finish
else
instr out(order, post<<4, 0, 2, mcycles)
fault("Second register not specified")
finish
else
instr out(order, 0, 0, 2, mcycles)
fault("Registers not specified")
finish
continue
!-----------------------------------------------------------------------
itype3(19): ! psh, pul
accop = 1
if acc('A') start
instr out(order, 2, 0, 2, mcycles+1)
continue
finish else if acc('B') start
instr out(order, 4, 0, 2, mcycles+1)
continue
finish else if acc('U') start
order = order+2
finish else unless acc('S') start
accop = 0
acc fault = 1
finish
skip blanks
!-----------------------------------------------------------------------
itype3(20): ! pshu, pshs, pulu, puls
post = 0
i = 0
j = 0
cycle
if cc start
mcycles = mcycles+1 and post = post!1 if post&1=0
finish else if acc('A') start
mcycles = mcycles+1 and post = post!2 if post&2=0
finish else if acc('B') start
mcycles = mcycles+1 and post = post!4 if post&4=0
finish else if acc('D') start
mcycles = mcycles+1 and post = post!2 if post&2=0
mcycles = mcycles+1 and post = post!4 if post&4=0
finish else if dp start
mcycles = mcycles+1 and post = post!8 if post&8=0
finish else if acc('X') start
mcycles = mcycles+2 and post = post!16 if post&16=0
finish else if acc('Y') start
mcycles = mcycles+2 and post = post!32 if post&32=0
finish else if acc('S') start
if 16_36<=order<=16_37 start
mcycles = mcycles+2 and post = post!64 if post&64=0
else
i = i+1
finish
finish else if acc('U') start
if 16_34<=order<=16_35 start
mcycles = mcycles+2 and post = post!64 if post&64=0
else
i = i+1
finish
finish else if pc start
mcycles = mcycles+2 and post = post!128 if post&128=0
finish else if pres char=',' start
next char
else
j = 1
exit
finish
repeat until not more items
instr out(order, post, 0, 2, mcycles)
fault("Stack not specified") unless acc fault=0
fault("Cannot stack stack pointer") for i = i, -1, 1
fault("Illegal operand") unless j=0
continue
!-----------------------------------------------------------------------
itype3(21): ! cwai,andcc,orcc
if pres char='#' start
next char until pres char#bchar
finish
i = get opd(opd)
instr out(order, opd, 0, 2, mcycles)
unless i=0 start
fault("Cannot evaluate operand")
finish else unless 0<=opd<=255 start
fault("Illegal mask")
finish
continue
!-----------------------------------------------------------------------
itype3(22): ! tab, tba
instr out(16_1F, (order>>8)&255, order&255, 3, mcycles)
continue
!-----------------------------------------------------------------------
itype3(23): ! swi
if acc('1') start
accop = 1
finish else if acc('2') start
accop = 1
order = order!16_1000
mcycles = mcycles+1
finish else if acc('3') start
accop = 1
order = order!16_1100
mcycles = mcycles+1
finish
instr out(order, 0, 0, 1, mcycles)
continue
!-----------------------------------------------------------------------
itype3(24): ! lbrn
instr out(order, 0, 0, 5, mcycles)
continue
!-----------------------------------------------------------------------
itype3(25): ! sba, cba, aba
instr out(16_34, 16_04, order, 4, mcycles)
continue
!-----------------------------------------------------------------------
itype3(26): ! 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(0, opd&255, 0, -1, 0)
lp = j-1
next char
cont = 1
else
instr out(0, opd&255, 0, -1, 0)
finish
fault("Invalid constant") unless i=0 and -128<=opd<=255
repeat until not more items
cont = 0
continue
!------------------------------------------------------------------------
itype3(27): ! 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, 0, -2, 0)
lp = j-1
next char
cont = 1
else
instr out(0, opd, 0, -2, 0)
finish
fault("Invalid constant") unless i=0
repeat until not more items
cont = 0
continue
!-----------------------------------------------------------------------
itype3(28):! equ
i = get opd(opd)
instr out(0, opd, 0, -6, 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
!-----------------------------------------------------------------------
itype3(29):! org
i = get opd(opd)
ca = opd if i=0
instr out(0, 0, 0, 0, 0)
fault("Illegal label") unless lid=0
fault("Cannot evaluate operand") unless i=0
continue
!-----------------------------------------------------------------------
itype3(30): ! setdp
i = get opd(opd)
dp contents = opd<<8 if i=0 and 0<=opd<=255
instr out(0, opd, 0, -3, 0)
fault("Illegal label") unless lid=0
unless i=0 start
fault("Cannot evaluate operand")
finish else unless 0<=opd<=255 start
fault("Invalid direct page contents")
finish
continue
!-----------------------------------------------------------------------
itype3(31): ! rmb
i = get opd(opd)
instr out(0, opd, 0, -4, 0)
if i=0 start
ca = ca+opd
else
fault("Cannot evaluate operand")
finish
continue
!-----------------------------------------------------------------------
itype3(32):! 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, 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(0, opd, 0, -1, 0)
lp = j-1
next char
cont = 1
else
instr out(0, 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, 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, 0)
fault("Invalid 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, 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(0, line(i), 0, -1, 0)
lp = i-1
next char
cont = 1
else
instr out(0, line(lp), 0, -1, 0)
finish
next char
repeat
cont = 0
finish
continue
!-----------------------------------------------------------------------
itype3(33): ! nam
non dense = 1
header = ""
while pres char#nl cycle
header <- header.to string(line(lp))
next char
repeat
instr out(0, 0, 0, -7, 0)
fault("Illegal label") unless lid=0
continue
!-----------------------------------------------------------------------
itype3(34): ! 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*3-cflag*3-wflag-11
else
sp3 = line width-wflag-7
finish
instr out(0, 0, 0, -7, 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
!-----------------------------------------------------------------------
itype3(35): ! page
unless lid=0 start
instr out(0, 0, 0, -7, 0)
fault("Illegal label")
finish
nline(lines on page) unless lflag=0
continue
!-----------------------------------------------------------------------
itype3(36): ! spc
i = get opd(opd)
unless lid=0 start
instr out(0, 0, 0, -7, 0)
fault("Illegal label")
finish
unless lflag=0 start
if i=0 start
nline(opd)
else
nline(1)
finish
finish
!-----------------------------------------------------------------------
repeat
!-----------------------------------------------------------------------
itype3(37):! end
instr out(0, 0, 0, -7, 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 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
!---------------------------------------------------------------------
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
!-----------------------------------------------------------------------
routine read line
integer ch
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(ch); line(i) = ch
exit if line(i)&127=nl or line(i)&127=12
repeat
read symbol(ch) and line(i) = ch while line(i)&127#nl and line(i)&127#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
!-----------------------------------------------------------------------
routine skip blanks
next char while pres char=' '
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=4 and xxentries<=xentries and c
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="B" or n="CC" or n="DP" or n="X" or c
n="Y" or n="U" or n="S" or n="PC" or n="PCR" start
nass(nnames) = 2
else
nass(nnames) = 0
finish
nval(nnames) = 0
if pass=4 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(5) i
integer h,l
iid=0
false unless 'A'<=pres char<='Z'
h=pres char-'0'
i=tostring(pres char)
for l = 2, 1, 5 cycle
next char
-> goti unless 'A'<=pres char<='Z' or '0'<=pres char<='9'
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 = 1
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
!-----------------------------------------------------------------------
routine analise operand(integer eca,
integer name post, opd, type, cycles)
integer indirect, i
type = 5
if pres char='[' start
next char until pres char#bchar
indirect = 1
else
indirect = 0
finish
if more items start
if pc start
opd = 0
post = 16_8C
type = 6
cycles = cycles+3
finish else if pc relative start
opd = -2-eca
if pass<3 or -128<=opd<=127 start
post = 16_8C
type = 6
cycles = cycles+3
else
opd = opd-1
post = 16_8D
type = 7
cycles = cycles+7
finish
finish else unless auto indexed(post, cycles) start
type = 0
finish
finish else if pc start
opd = 0
post = 16_8C
type = 6
cycles = cycles+3
finish else if pc relative start
opd = -2-eca
if pass<3 or -128<=opd<=127 start
post = 16_8C
type = 6
cycles = cycles+3
else
opd = opd-1
post = 16_8D
type = 7
cycles = cycles+7
finish
finish else unless auto indexed(post, cycles) start
if acc('A') start
type = 1 and -> check indirect unless more items
post = 16_86
cycles = cycles+3
finish else if acc('B') start
type = 2 and -> check indirect unless more items
post = 16_85
cycles = cycles+3
finish else if acc('D') start
type = 0 and -> check indirect unless more items
post = 16_8B
cycles = cycles+6
finish else if pres char='<' start
next char until pres char#b char
if get opd(opd)=0 start
type = 4
else
type = 0
finish
cycles = cycles+3
-> check indirect
finish else if pres char='>' start
next char until pres char#b char
if get opd(opd)=0 start
if indirect=0 start
type = 3
else
type = 4
cycles = cycles+1
finish
else
type = 0
finish
cycles = cycles+2
-> check indirect
else
if get opd(opd)=0 start
if more items start
if pc start
if pass<3 or -128<=opd<=127 start
post = 16_8C
type = 6
cycles = cycles+3
else
post = 16_8D
type = 7
cycles = cycles+7
finish
-> check indirect
finish else if pc relative start
opd = opd-eca-2
if pass<3 or -128<=opd<=127 start
post = 16_8C
type = 6
cycles = cycles+3
else
opd = opd-1
post = 16_8D
type = 7
cycles = cycles+7
finish
->check indirect
finish else if pass<3 or opd=0 start
type = 0 unless auto indexed(post, cycles)
-> check indirect
finish else if indirect=0 and -16<=opd<=15 start
post = opd&31
cycles = cycles+3
finish else if -128<=opd<=127 start
post = 16_88
type = 6
cycles = cycles+3
else
post = 16_89
type = 7
cycles = cycles+6
finish
else
if indirect=0 and 0<=opd-dp contents<=255 start
type = 3
cycles = cycles+2
else
type = 4
cycles = cycles+3
finish
-> check indirect
finish
else
type = 0
finish
finish
if index reg(i) start
post = post!(i<<5)
else
type = 0
finish
finish
check indirect:
unless indirect=0 start
type = 0 if 1<=type<=2 or c
(type=5 and (post=16_80 or post=16_82))
next char while pres char=b char
if pres char=']' start
next char
cycles = cycles+3
if 3<=type<=4 start
post = 16_9F
cycles = cycles+4-type
type = 7
else
post = post!16_10
finish
else
type = 0
finish
finish
end
!-----------------------------------------------------------------------
predicate auto indexed(integer name post, cycles)
integer old lp, reg
old lp = lp
if pres char='-' start
next char until pres char#b char
if pres char='-' start
next char until pres char#bchar
post = 16_83
else
post = 16_82
finish
else
post = 16_84
finish
if index reg(reg) start
if post = 16_84 start
next char while pres char=b char
if pres char='+' start
next char until pres char#b char
if pres char='+' start
next char
post = 16_81
cycles = cycles+5
else
post = 16_80
cycles = cycles+4
finish
else
cycles = cycles+2
finish
else
cycles = cycles+4+(post&1)
finish
post = post!(reg<<5)
true
finish
lp = old lp-1
next char
false
end
!-----------------------------------------------------------------------
predicate accumulator
true if acc('A')
true if acc('B')
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
!-----------------------------------------------------------------------
predicate index reg(integer name reg)
reg = 0 and true if acc('X')
reg = 1 and true if acc('Y')
reg = 2 and true if acc('U')
reg = 3 and true if acc('S')
false
end
!-----------------------------------------------------------------------
predicate transfer reg(integer name reg)
reg = 0 and true if acc('D')
reg = 1 and true if acc('X')
reg = 2 and true if acc('Y')
reg = 3 and true if acc('U')
reg = 4 and true if acc('S')
reg = 5 and true if pc
reg = 8 and true if acc('A')
reg = 9 and true if acc('B')
reg = 10 and true if cc
reg = 11 and true if dp
false
end
!-----------------------------------------------------------------------
predicate cc
false unless pres char='C'
next char
true if acc('C')
lp = lp-2
next char
false
end
!-----------------------------------------------------------------------
predicate dp
false unless pres char='D'
next char
true if acc('P')
lp = lp-2
next char
false
end
!-----------------------------------------------------------------------
predicate pc
false unless pres char='P'
next char
true if acc('C')
lp = lp-2
next char
false
end
!-----------------------------------------------------------------------
predicate pc relative
false unless pres char='P'
next char
if pres char='C' start
next char
true if acc('R')
lp = lp-1
finish
lp = lp-2
next char
false
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, post, 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<=-5 start
spaces(sp2)
else
print number(ca, 2)
finish
space
if -6<=b<=-1 start
spaces(sp2+1)
if b&1=0 start
print number(post, 2)
else
print number(post, 1)
spaces(sp2-sp1)
finish
spaces(sp1+1)
else
if b<=0 start
spaces(sp2)
finish else if 0<=op<=255 start
print number(op, 1)
spaces(sp2-sp1)
else
print number(op, 2)
finish
space
if b<=1 start
spaces(sp1+sp2+1)
finish else if b<=4 start
print number(post, 1)
space
if b<=2 start
spaces(sp2)
finish else if b=3 start
print number(opd, 1)
spaces(sp2-sp1)
else
print number(opd, 2)
finish
else
print number(post, 2)
spaces(sp1+1)
finish
finish
unless cflag=0 start
if cyc=0 start
spaces(3)
else
write(cyc, 2)
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) if accop=1
out tag(i, j, 15)
k = 0
lit = 0
while i#lp cycle
if line(i)&127=' ' start
k = k+1 if non dense=1 or lit=1
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>>8)&255) unless 0<=op<=255
dump(op&255)
dump((post>>8)&255) if b=5
dump(post&255) if b>=2
dump((opd>>8)&255) if b=4
dump(opd&255) if 3<=b<=4
finish else if -2<=b<=-1 start
dump((post>>8)&255) if b=-2
dump((post&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(" Motorola M6809 Assembler ")
spaces((line width-37-length(header))//2)
print string(header)
spaces((line width-36-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 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