%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) %byteinteger%array 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 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)&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 %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 linsert 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