Z80 iToZ80 is8080 is6502 im6809 im6502 i 0?¿Ë°d ª0?×Ê= 0?¡ÂÍ ÷0?ðà %begin ! 666 555555 0000 2222 ! 66 55 00 00 22 22 ! 66 55555 00 000 22 ! 66666 55 000000 22 ! 66 66 55 000 00 22 ! 66 66 55 55 00 00 22 ! 6666 5555 0000 222222 %external %integer %fn %spec Proc ID (%routine X) %external %routine %spec Stop(%integer res) %external %integer %fn %spec Verbosity Required(%integer Handle) %external %integer %fn %spec ArgumentInit(%c %integer %name Handle, %string(255) keyString, %integer Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %external %integer %fn %spec XGetPresence(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetStateArg(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetCardinalArg(%c %string(255) key, %integer Index, %integer Handle) %external %integer %fn %spec XGetStringArg(%c %string(*) %name argument, %string(255) Key, %integer Index, handle) %external %integer %fn %spec XGetNumberOfValues(%c %string(255) Key, %integer handle) %integer string length, handle, result, verbosity level { M6502 Cross assembler - Fred King } { Edinburgh University Computer Science Department } %routine rd line (%string (*) %name s) %integer ch s = "" %cycle read symbol (ch) %exit %if ch = nl s = s . ch %repeat %end %string (255) %fn cli param %string (255) s Prompt ("M6502>") Rd line (s) %result = s %end %routine Help printstring("M6502 - EUCSD assembler".snl) printstring(snl) printstring(" -source Prog (prog-6502) keyword may be omitted".snl) printstring(" -object objfile / -noobject Prog-obj6502 by default".snl) printstring(" -list listfile / -nolist no list by default".snl) printstring(snl) %end %string (255) %fn sub string (%string (255) s, %integer first, last) %integer i %string (255) sub sub = "" %for i = first, 1, last %cycle sub = sub. Z80 iToZ80 is8080 is6502 im6809 im6502 i ies = 1024 %constinteger ihash=59 %constant %byte %integer %array hilink(0:58) = %c 13, 28, 0, 0, 36, 0, 29, 50, 0, 25, 26, 59, 1, 16, 27, 14, 64, 23, 4, 6, 42, 11, 41, 15, 35, 0, 0, 34, 0, 30, 32, %begin ! 666 555555 0000 2222 ! 66 55 00 00 22 22 ! 66 55555 00 000 22 ! 66666 55 000000 22 ! 66 66 55 000 00 22 ! 66 66 55 55 00 00 22 ! 6666 5555 0000 222222 %external3, 0, 0, 0, 0, 53, 0, 21, 0, 65, 63, 0, 0, 0, 0, 0, 0, 0, 38, 0, 37, 46, 54, 0, 0, 39, 0, 0, 0, 56, 0, 44, 0, 57, 0, 55, 0, 0, 61, 0, 66, 0, 0, 0, 0, 0, 0, 0, 6eger Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %external %integer %fn %spec XGetPresence(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetStateArg(%c %string(255) key, %integer Handle),"DEY","AND", "ORA","EOR","BIT","LSR","ROR","ASL","LSL","ROL","SBC", "ADC","TAX","TAY","TYA","TSX","TXA","TXS","PHA","PHP", "PLA","PLP","RTI","BRK","NOP","CLV","CLC","SEC","CLI", "SEI","CLD","SED","FCB","FDB","EQU","ORG","RMB","FCC", "NAM","ger %fn %spec XGetNumberOfValues(%c %string(255) Key, %integer handle) %integer string length, handle, result, verbosity level { M6502 Cross assembler - Fred King } { Edinburgh University Computer Science Department } %routine rd line (%string (*) %name s) %integer ch s = "" %cycle read symbol (ch) %exit %if ch = nl s = s . ch %repeat %end %string (255) %fn cli param %string (255) s Prompt ("M6502>") Rd line (s) %result = s %end %routine Help printstring("M6502 - EUCSD assembler".snl) printstring(snl) printstring(" -source Prog (prog-6502) keyword may be omitted".snl) printstring(" -object objfile / -noobject Prog-obj6502 by default".snl) printstring(" -list listfile / -nolist no list by default".snl) printstring(snl) %end %string (255) %fn sub string (%string (255) s, %integer first, last) %integer i %string (255) sub sub = "" %for i = first, 1, last %cycle sub = sub. 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 4, 4, 6, 7, 2, 2, 2, 2, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 %constant %integer no options = 51 %constant %string(10) %array option text(1:no options) = %c "BLANK", "B", "NOBLANK", "NOB", "CYCLE", "C", "NOCYCLE", "NOC", "DB8", "DB10", "DB16", "ERROR", "E", "SERROR", "SER", "NOERROR", "NOE", "FULL", "F", "NOFULL", "NOF", "GENERATE", "G", "NOGENERATE", "NOG", "LIST", "L", "SLIST", "SLIS", "NOLIST", "NOL", "PAGE", "P", "NOPAGE", "NOP", "SYMBOL", "S", "NOSYMBOL", "NOS", "TAB", "T", "NOTAB", "NOT", "WRAP", "W", "NOWRAP", "NOW", "XREF", "X", "NOXREF", "NOX" %string(255) %function %spec uc(%string(255) source) %predicate %spec matches(%string(255) source, pattern, %integer min, %integer %name i) %predicate %spec is typed(%string(255) source, %string(255) %name file) %routine %spec read line %routine %spec next char %predicate %spec more items %integerfn %spec get name(%integername nid) %predicate %spec get option(%integer %name opt) %predicate %spec get instr(%integername id) %integerfn %spec get opd(%integername opd) %integer %function %spec get term(%integer %name opd) %integer %function %spec get expression(%integer %name opd) %routine %spec evaluate(%integer %name a, %integer b, %byte %integer op) %integerfn %spec get const(%integername cval) %routine %spec out symbol(%byte %integer char) %routine %spec out tag(%integer %name i, j, %integer col) %routine %spec instr out(%integer op,opd,b, cyc) %routine %spec close %routine %spec fault(%string(63) s) %routine %spec nline(%integer n) %routine %spec back number(%integer n) %routine %spec print number(%integer n,d) %predicate %spec indexed(%byte %integer reg) %predicate %spec acc(%byte %integer acc id) %routine %spec sqs(%integer l, r) %routine %spec immediate(%byte %integer order, mcycles) %routine %spec operand(%byte %integer reg, nreg, order, mcycles) %routine %spec store(%byte %integer reg, nreg, order, mcycles) %byte %integer %array buffer(1:16) %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 = 0, non dense, reg fault, l, xxentries, fflag, ostarted, buffer ca, bp, look ahead %constant %integer nhash=67 %byteinteger %array hnlink(0:nhash-1) %string(6)%array name(1:names) %integer%array nval(1:names) %byteinteger%array nass(1:names) %byteinteger%array nlink(1:names) %integer %array xhead(1:names) %integer %array xentry, xlink(1:xentries) %switch option action(-1:no options) %switch itype1,itype2(1:25) %string(line width-45) header %string(255) params, source, list, object, dummy, file {-------------------------------------------------------------------------} result = ArgumentInit(%c handle, "INput=FROM=SOUrce/A/E-6502 ". %c "OUTput=TO=OBJect/N[] ". %c "List/N[]", 0 , 0, "M6502 Assembler (c) EUCSD", Proc ID(Help)) %if result < 0 %then Stop(result) verbosity level = Verbosity Required(handle) string length = XGetStringArg(file, "INPUT", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length source = file %if XGetStateArg("LIST", handle) # 0 %start %if XGetNumberOfValues("LIST", handle) = 1 %start string length = XGetStringArg(file, "LIST", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length list = file %else list = "" %finish %else list = "NULL:" %finish %if XGetPresence("OBJECT", handle) = 0 %start object = "" %elseif XGetStateArg("OBJECT", handle) # 0 %if XGetNumberOfValues("OBJECT", handle) = 1 %start string length = XGetStringArg(file, "OBJECT", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length object = file %else object = "" %finish %else object = "NULL:" %finish {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} ! params = uc(cliparam) ! source = "" ! list = "NULL:" ! 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 = "NULL:" ! file == dummy ! %finish %else %if matches(params, "NOOBJECT", 3, i) %start ! object = "NULL:" ! 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 %stop %if source="" source = source."-6502" %unless is typed(source, params) list = params %if list="" object = params %if object="" list = list."-LIS" %unless is typed(list, dummy) object = object."-OBJ6502" %unless is typed(object, dummy) open input(1, source) open output(1, object) open output(2, list) select output(2) headset = 0 header = "" drad = 8 sp1 = 2 sp2 = 4 pflag = 3 sflag = 0 eflag = 1 gflag = 1 lflag = 2 cflag = 0 wflag = 0 tflag = 1 xflag = 0 sp3 = line width-sp1-sp2*2-cflag*2-wflag-10 cont = 0 faults=0 nnames=0 xxentries = 0 consistent = 0 hnlink(i)=0 %for i = 0, 1, nhash-1 bp = 0 ostarted = 0 look ahead = 0 !----------------------------------------------------------------------- select input(1) pass = 1 %cycle ln = 0 ca = 0 bchar = -1 fflag = 0 %cycle read line %continue %if pres char='*' %if get name(lid)=0 %start %if pass=1 %start %if nass(lid)=0 %start nval(lid) = ca nass(lid) = 1 %else nval(lid) = 0 nass(lid) = 2 %finish %finish %else %if nass(lid)=1 %and ca#nval(lid) %start nval(lid) = ca consistent = consistent+1 %finish %else lid = 0 %finish next char %while pres char=' ' %continue %unless get instr(iid) next char %while pres char=' ' ->itype1(itype(iid)) !----------------------------------------------------------------------- itype1(1):! implied ca=ca+1 %continue !----------------------------------------------------------------------- itype1(2):! relative ca=ca+2 %continue !----------------------------------------------------------------------- itype1(3): ! JMP itype1(4): ! JSR ca = ca+3 %continue !---------------------------------------------------------------------------- itype1(5): ! immediate, direct, index, indir ca = ca+2 %and %continue %if pres char='#' !------------------------------------------------------------------------- itype1(6): ! direct, index, indir %if pres char='(' %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start %if indexed('Y') %start ca = ca+3 %else ca = ca+2 %finish %else ca = ca+3 %finish %continue !------------------------------------------------------------------------- itype1(7): ! rotate, shift ca = ca+1 %and %continue %if acc('A') itype1(8): ! inc, dec %if acc('X') %or indexed('X') %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %else ca = ca+3 %finish %continue !----------------------------------------------------------------------- itype1(9): ! cpy, cpx ca = ca+2 %and %continue %if pres char='#' !---------------------------------------------------------------------- itype1(10): ! bit %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %else ca = ca+3 %finish %continue !----------------------------------------------------------------------- itype1(11): ! ldx %if pres char = '#' %or acc('Y') %or indexed('Y') %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %else ca = ca+3 %finish %continue !---------------------------------------------------------------------- itype1(12): ! ldy %if pres char='#' %or acc('X') %or indexed('X') %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %else ca = ca+3 %finish %continue !---------------------------------------------------------------------- itype1(13): ! stx %if acc('Y') %or indexed('Y') %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %finish %else %if indexed('Y') %start ca = ca+2 %else ca = ca+3 %finish %continue !---------------------------------------------------------------------- itype1(14): ! sty %if acc('X') %or indexed('X') %start ca = ca+2 %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start ca = ca+2 %finish %else %if indexed('X') %start ca = ca+2 %else ca = ca+3 %finish %continue !----------------------------------------------------------------------- itype1(15): ! fcb %cycle ca = ca+1 i = get opd(opd) %unless pres char=',' %repeat %until %not more items %continue !----------------------------------------------------------------------- itype1(16): ! fdb %cycle ca = ca+2 i = get opd(opd) %unless pres char=',' %repeat %until %not more items %continue !----------------------------------------------------------------------- itype1(17):! equ %unless lid=0 %start %if get opd(opd)=0 %start %if pass=1 %start %if nass(lid)=1 %start nval(lid) = opd nass(lid) = 3 %finish %finish %else %if nass(lid)=3 %and opd#nval(lid) %start nval(lid) = opd consistent = consistent+1 %finish %else %unless nass(lid)=2 %start nval(lid) = 0 nass(lid) = 4 %finish %finish %finish %continue !----------------------------------------------------------------------- itype1(18):! org %unless lid=0 %start nval(lid) = 0 nass(lid) = 4 %finish ca = opd %if get opd(opd)=0 %continue !----------------------------------------------------------------------- itype1(19): ! rmb ca = ca+opd %if get opd(opd)=0 %continue !----------------------------------------------------------------------- itype1(20):! fcc %if '0'<=pres char<='9' %start i = lp j = 0 %cycle j = j*10+pres char-'0' next char %repeat %until %not '0'<=pres char<='9' %if pres char=',' %start ca = ca+j %continue %finish lp = i-1 next char %finish %continue %if pres char<' ' delim = pres char next char %cycle %exit %if pres char=nl %if pres char=delim %start next char %exit %unless pres char=delim %finish next char ca=ca+1 %repeat %continue !----------------------------------------------------------------------- itype1(21): ! nam %unless lid=0 %start nval(lid) = 0 nass(lid) = 4 %finish %continue %unless headset=0 headset = 1 header = "" %while pres char#nl %cycle header <- header.tostring(line(lp)) next char %repeat %continue !----------------------------------------------------------------------- itype1(22): ! opt %cycle %if get option(opt) %start %if 1<=opt<=2 %start bchar = ' ' %finish %else %if 3<=opt<=4 %start bchar = -1 %finish %else %if 18<=opt<=19 %start fflag = 1 %finish %else %if 20<=opt<=21 %start fflag = 0 %finish %finish %repeat %until %not more items !----------------------------------------------------------------------- itype1(23): ! page !----------------------------------------------------------------------- itype1(24): ! spc %unless lid=0 %start nval(lid) = 0 nass(lid) = 4 %finish !----------------------------------------------------------------------- %repeat !----------------------------------------------------------------------- itype1(25): ! end %unless lid=0 %start nval(lid) = 0 nass(lid) = 2 %finish %if pass=1 %start pass = 2 %else %exit %if consistent=0 %or %c (last consistent#0 %and consistent>=last consistent) %finish last consistent = consistent consistent = 0 reset input %repeat !----------------------------------------------------------------------- nline(0) reset input pass = 3 ln=0 ca=0 old ca = 0 lid = 0 bchar = -1 fflag = 0 %cycle %unless lid=0 %start fault("Multiply defined label") %if nass(lid)=2 %if nass(lid)=1 %and nval(lid)#old ca %start fault("Inconsistent label") nval(lid) = old ca %finish %finish old ca = ca lid = 0 read line non dense = 0 instr out(0, 0, -4, 0) %and %continue %if pres char='*' lid = 0 %unless get name(lid)=0 next char %while pres char=' ' %if pres char=nl %start instr out(0, 0, -4, 0) %finish %else %if get instr(iid) %start order = icode(iid) mcycles = icycles(iid) next char %while pres char=' ' ->itype2(itype(iid)) %else instr out(0, 0, -4, 0) fault("Unknown operation") %finish %continue !----------------------------------------------------------------------- itype2(1):! implied instr out(order,0,1, mcycles) %continue !----------------------------------------------------------------------- itype2(2):! relative i=get opd(opd) j=opd-ca-2 instr out(order,j,2, mcycles) %unless i=0 %start fault("Cannot evaluate operand") %finish %else %unless -127<=j<=127 %start fault("Branch out of range") %finish %continue !----------------------------------------------------------------------- itype2(3):! JMP %if pres char='(' %start next char %until pres char#bchar i = get opd(opd) next char %while pres char=bchar %if pres char=')' %start next char instr out(order+16_20, opd, 3, mcycles+2) %else instr out(order+16_20, opd, 3, mcycles+2) fault("Missing right parenthesis") %finish fault("Cannot evaluate operand") %unless i=0 %continue %finish !--------------------------------------------------------------------------- itype2(4): ! JSR i = get opd(opd) instr out(order, opd, 3, mcycles) fault("Cannot evaluate operand") %unless i=0 %continue !-------------------------------------------------------------------------- itype2(5): ! immediate, direct, index, indir immediate(order+8, mcycles) %and %continue %if pres char='#' !-------------------------------------------------------------------------- itype2(6): ! direct, index, indir %if pres char='(' %start next char %until pres char#bchar %if acc('X') %or indexed('X') %start next char %while pres char=bchar %if pres char=')' %start next char instr out(order, 0, 2, mcycles+4) %else instr out(order, 0, 2, mcycles+4) fault("Missing right parenthesis") %finish %finish %else %if acc('Y') %or indexed('Y') %start next char %while pres char=bchar %if pres char=')' %start next char instr out(order, 0, 2, mcycles+4) %else instr out(order, 0, 2, mcycles+4) fault("Missing right parenthesis") %finish fault("Invalid index register") %else i = get opd(opd) %if indexed('X') %start next char %while pres char=bchar %if pres char=')' %start next char instr out(order, opd, 2, mcycles+4) %else instr out(order, opd, 2, mcycles+4) fault("Missing right parenthesis") %finish %else %if indexed('Y') %start reg fault = 1 %else reg fault = 0 %finish next char %while pres char=bchar %if pres char=')' %start next char %until pres char#bchar %if indexed('Y') %start instr out(order+16_10, opd, 2, mcycles+4) %finish %else %if indexed('X') %start instr out(order+16_10, opd, 2, mcycles+4) fault("Invalid index register") %else instr out(order, opd, 2, mcycles+4) fault("Index register not specified") %if reg fault=0 %finish %else instr out(order, opd, 2, mcycles+4) fault("Missing right parenthesis") fault("Index register not specified") %if reg fault=0 %finish fault("Invalid index register") %unless reg fault=0 %finish %unless i=0 %start fault("Cannot evaluate operand") %finish %else %unless 0<=opd<=255 %start fault("Invalid page zero address") %finish %finish %finish %else %if acc('X') %or indexed('X') %start instr out(order+16_14, 0, 2, mcycles+2) %finish %else %if acc('Y') %or indexed('Y') %start instr out(order+16_18, 0, 3, mcycles+3) %else i = get opd(opd) %if indexed('X') %start %if i#0 %or 0<=opd<=255 %start instr out(order+16_14, opd, 2, mcycles+2) %else instr out(order+16_1C, opd, 3, mcycles+3) %finish %finish %else %if indexed('Y') %start instr out(order+16_18, opd, 3, mcycles+3) %finish %else %if i#0 %or 0<=opd<=255 %start instr out(order+4, opd, 2, mcycles+1) %else instr out(order+12, opd, 3, mcycles+2) %finish fault("Cannot evaluate operand") %unless i=0 %finish %continue !----------------------------------------------------------------------- itype2(7): ! rotate, shift %if acc('A') %start instr out(order+4, 0, 1, mcycles) %continue %finish !----------------------------------------------------------------------- itype2(8): ! inc, dec operand('X', 'Y', order, mcycles+2) %continue !----------------------------------------------------------------------- itype2(9): ! cpx,cpy immediate(order, mcycles) %and %continue %if pres char='#' !----------------------------------------------------------------------- itype2(10):! BIT i = get opd(opd) %if i#0 %or 0<=opd<=255 %start instr out(order+4, opd, 2, mcycles+1) fault("Cannot evaluate operand") %unless i=0 %else instr out(order+12, opd, 3, mcycles+2) %finish %continue !----------------------------------------------------------------------- itype2(11): ! ldx %if pres char='#' %start immediate(order, mcycles) %else operand('Y', 'X', order+4, mcycles) %finish %continue !--------------------------------------------------------------------- itype2(12): ! LDY %if pres char='#' %start immediate(order, mcycles) %else operand('X', 'Y', order+4, mcycles) %finish %continue !----------------------------------------------------------------------- itype2(13):! STX store('Y', 'X', order, mcycles) %continue !----------------------------------------------------------------------- itype2(14): ! STY store('X', 'Y', order, mcycles) %continue !----------------------------------------------------------------------- itype2(15): ! fcb %cycle %if pres char=',' %start opd = 0 i = 0 %else i = get opd(opd) %finish %if cont=0 %start j = lp look ahead = 1 %while more items %cycle k = get opd(k) %unless pres char=',' %repeat look ahead = 0 instr out(opd, 0, 1, 0) lp = j-1 next char cont = 1 %else instr out(opd, 0, 1, 0) %finish fault("Invalid constant") %unless i=0 %and 0<=opd<=255 %repeat %until %not more items cont = 0 %continue !------------------------------------------------------------------------ itype2(16): ! fdb %cycle %if pres char=',' %start opd = 0 i = 0 %else i = get opd(opd) %finish %if cont=0 %start j = lp look ahead = 1 %while more items %cycle k = get opd(k) %unless pres char=',' %repeat look ahead = 0 instr out(0, opd, -2, 0) lp = j-1 next char cont = 1 %else instr out(0, opd, -2, 0) %finish fault("Invalid constant") %unless i=0 %repeat %until %not more items cont = 0 %continue !----------------------------------------------------------------------- itype2(17):! equ i = get opd(opd) instr out(0, opd, -3, 0) fault("No name to equate") %if lid=0 fault("Cannot evaluate operand") %unless i=0 %if lid#0 %and i=0 %and nass(lid)=3 %and nval(lid)#opd %start fault("Inconsistent label") nval(lid) = opd %finish %continue !----------------------------------------------------------------------- itype2(18):! org i = get opd(opd) ca = opd %if i=0 instr out(0, 0, 0, 0) fault("Illegal label") %unless lid=0 fault("Cannot evaluate operand") %unless i=0 %continue !----------------------------------------------------------------------- itype2(19): ! rmb i = get opd(opd) instr out(0, opd, -1, 0) %if i=0 %start ca = ca+opd %else fault("Cannot evaluate operand") %finish %continue !----------------------------------------------------------------------- itype2(20):! fcc non dense = 1 %if '0'<=pres char<='9' %start i = 0 j = lp %cycle i = i*10+pres char-'0' next char %repeat %until %not '0'<=pres char<='9' %if pres char=',' %start next char %if i=0 %start instr out(0, 0, 0, 0) fault("Invalid string") %else %while i>0 %cycle %if pres char=nl %start opd = ' ' %else opd = line(lp) next char %finish i = i-1 %if cont=0 %start j = lp %for k = 1, 1, i %cycle %exit %if pres char=nl next char %repeat instr out(opd, 0, 1, 0) lp = j-1 next char cont = 1 %else instr out(opd, 0, 1, 0) %finish %repeat cont = 0 %finish %continue %else lp = j-1 next char %finish %finish %if pres char<' ' %start next char %while pres char#nl instr out(0, 0, 0, 0) fault("Invalid string delimiter") %else delim = pres char next char %cycle %if pres char=nl %start %if cont=0 %start instr out(0, 0, 0, 0) fault("Illegal string") %finish %exit %finish %if pres char=delim %start next char %unless pres char=delim %start %if cont=0 %start instr out(0, 0, 0, 0) fault("Invalid string") %finish %exit %finish %finish %if cont=0 %start i = lp %cycle next char %while pres char#delim %and pres char#nl %if pres char=delim %start next char %finish %exit %unless pres char=delim next char %repeat instr out(line(i), 0, 1, 0) lp = i-1 next char cont = 1 %else instr out(line(lp), 0, 1, 0) %finish next char %repeat cont = 0 %finish %continue !----------------------------------------------------------------------- itype2(21): ! nam non dense = 1 header = "" %while pres char#nl %cycle header <- header.to string(line(lp)) next char %repeat instr out(0, 0, -4, 0) fault("Illegal label") %unless lid=0 %continue !----------------------------------------------------------------------- itype2(22): ! opt i = lp j = bchar %cycle %if get option(opt) %start ->option action(opt) option action(1): option action(2): bchar = ' ' -> next option option action(3): option action(4): bchar = -1 -> next option option action(5): option action(6): cflag = 1 -> next option option action(7): option action(8): cflag = 0 -> next option option action(9): drad = 4 sp1 = 3 sp2 = 6 -> next option option action(10): drad = 5 sp1 = 3 sp2 = 5 -> next option option action(11): drad = 8 sp1 = 2 sp2 = 4 -> next option option action(12): option action(13): option action(14): option action(15): eflag = 1 -> next option option action(16): option action(17): eflag = 0 -> next option option action(18): option action(19): fflag = 1 -> next option option action(20): option action(21): fflag = 0 -> next option option action(22): option action(23): gflag = 1 -> next option option action(24): option action(25): gflag = 0 -> next option option action(26): option action(27): lflag = 2 -> next option option action(28): option action(29): lflag = 1 -> next option option action(30): option action(31): lflag = 0 -> next option option action(32): option action(33): pflag = 3 -> next option option action(34): option action(35): pflag = 0 -> next option option action(36): option action(37): sflag = 1 -> next option option action(38): option action(39): sflag = 0 -> next option option action(40): option action(41): tflag = 1 -> next option option action(42): option action(43): tflag = 0 -> next option option action(44): option action(45): wflag = 1 -> next option option action(46): option action(47): wflag = 0 -> next option option action(48): option action(49): xflag = 1 -> next option option action(50): option action(51): xflag = 0 option action(-1): option action(0): next option: %finish %repeat %until %not more items %if lflag=2 %start sp3 = line width-sp1-sp2*2-cflag*2-wflag-10 %else sp3 = line width-wflag-7 %finish instr out(0, 0, -4, 0) fault("Illegal label") %unless lid=0 lp = i-1 next char bchar = j %cycle %if get option(opt) %start %if opt=1 %or opt=2 %start bchar = ' ' %finish %else %if opt=3 %or opt=4 %start bchar = -1 %finish %else %if opt<0 %start fault("Unknown option") %finish %else fault("Cannot evaluate operand") %finish %repeat %until %not more items %continue !----------------------------------------------------------------------- itype2(23): ! page %unless lid=0 %start instr out(0, 0, -4, 0) fault("Illegal label") %finish nline(lines on page) %unless lflag=0 %continue !----------------------------------------------------------------------- itype2(24): ! spc i = get opd(opd) %unless lid=0 %start instr out(0, 0, -4, 0) fault("Illegal label") %finish %unless lflag=0 %start %if i=0 %start nline(opd) %else nline(1) %finish %finish !----------------------------------------------------------------------- %repeat !----------------------------------------------------------------------- itype2(25):! end instr out(0, 0, -4, 0) fault("Illegal label") %unless lid=0 %for i = 1, 1, nnames %cycle fault("Symbol ".name(i)." has no value") %if nass(i)=0 %repeat !----------------------------------------------------------------------- %unless xflag=0 %start sqs(1, nnames) nline(lines on page) print string(" Symbol Cross Reference Table") nline(2) sp3 = (linewidth-6-sp2)//6 %for i = 1, 1, nnames %cycle print string(name(i)) spaces(7-length(name(i))) %if nass(i)=0 %or nass(i)=2 %or nass(i)=4 %start print symbol('*') %for j = 1, 1, sp2 %else print number(nval(i), 2) %finish j = xhead(i) k = 0 %cycle l = xlink(j) xlink(j) = k k = j j = l %repeat %until j=0 j = 0 %cycle %if j=sp3 %start nline(1) spaces(7+sp2) j = 0 %finish write(xentry(k), 5) j = j+1 k = xlink(k) %repeat %until k=0 nline(1) %repeat %finish %else %unless sflag=0 %start sqs(1, nnames) nline(lines on page) print string(" Symbol Table") nline(2) sp3 = (line width+8-sp2)//15 sp1 = (linewidth-sp3*15+9-sp2)>>1 %for j = 1, 1, nnames %cycle %if (j-1)=(j-1)//sp3*sp3 %start nline(1) spaces(sp2) %else spaces(8-sp2) %finish print string(name(j)) spaces(7-length(name(j))) %if nass(j)=0 %or nass(j)=2 %or nass(j)=4 %start print symbol('*') %for i = 1, 1, sp2 %else print number(nval(j),2) %finish %repeat nline(1) %finish nline(2) spaces(2) %if faults=0 %start print string("No") %else write(faults, 0) %finish print string(" fault") print symbol('s') %unless faults=1 print string(" in this assembly.") newline select output(0) spaces(2) %if faults=0 %start %if verbosity level > 0 %start write(ln, 0) print string(" line") print symbol('s') %unless ln=1 print string(" assembled.") new line %finish %else write(faults, 0) print string(" fault") print symbol('s') %unless faults=1 print string(" in this assembly.") new line %finish close %stop !--------------------------------------------------------------------- %predicate is typed(%string(255) source, %string(255)%name file) %integer i file <- source %for i = length(file),-1,1 %cycle %if charno(file,i)='-' %then %start length(file)=i-1 %true %finish %repeat %false %end !------------------------------------------------------- %predicate matches(%string(255) source, pattern, %integer min, %integer %name i) %integer l l = length(pattern) %if length(pattern)>=length(source) %start l = length(source) %else l = length(pattern) %finish %for i = 1, 1, l %cycle %unless charno(source, i)=charno(pattern, i) %start %if 'A'<=charno(source, i)<='Z' %start %false %finish %else %if i<=min %start %false %else %true %finish %finish %repeat i = i+1 %false %if i<=min %true %end !--------------------------------------------------------------------- %string(255) %function uc(%string(255) source) %string(255) result %integer i result = "" %for i = 1, 1, length(source) %cycle %if 'a'<=charno(source, i)&127<='z' %start result = result.tostring((charno(source, i)&127)-'a'+'A') %else result = result.tostring(charno(source, i)&127) %finish %repeat %result = result %end !----------------------------------------------------------------------- %routine read line %integer i %on %event 9 %start %if i=1 %start line(1) = ' ' line(2) = 'E' line(3) = 'N' line(4) = 'D' line(5) = nl %else line(i) = nl %finish -> eof exit %finish ln=ln+1 %for i = 1, 1, max line+1 %cycle read symbol(line(i)) %exit %if line(i)&127=nl %or line(i)&127=12 %repeat read symbol(line(i)) %while line(i)&127#nl %and line(i)&255#12 eof exit: lp = 0 next char %end !----------------------------------------------------------------------- %routine next char lp = lp+1 pres char = line(lp)&127 %if 'a'<=pres char<='z' %start pres char = pres char+'A'-'a' %finish %else %if pres char=12 %start pres char = nl %finish %else %if pres char=9 %start pres char = ' ' %finish %end !----------------------------------------------------------------------- %predicate more items next char %while pres char=bchar %false %unless pres char=',' next char %until pres char#bchar %true %end !----------------------------------------------------------------------- %predicate get option(%integer %name opt) %string(11) option %if 'A'<=pres char<='Z' %start option = to string(pres char) %cycle next char %exit %unless 'A'<=pres char<='Z' %or '0'<=pres char<='9' option <- option.to string(pres char) %repeat %for opt = 1, 1, no options %cycle %true %if option text(opt)=option %repeat opt = -1 %true %else opt = 0 %false %unless pres char=',' next char %true %finish %end !----------------------------------------------------------------------- %integerfn get name(%integername nid) %string(6) n %integer h,l nid = 0 %and %result = 1 %unless 'A'<=pres char<='Z' h=pres char-'0' n=tostring(pres char) l = 1 %cycle next char %exit %unless 'A'<=pres char<='Z' %or '0'<=pres char<='9' l = l+1 h=h<<4+pres char-'0' %and n=n.tostring(pres char) %unless l>6 %repeat h=h&32767 h=h-h//nhash*nhash l=hnlink(h) %while l#0 %cycle %if name(l)=n %start nid = l %if pass=3 %and xxentries<=xentries %and look ahead=0 %start xxentries = xxentries+1 %if xxentries>xentries %start fault("Too many references") %else xlink(xxentries) = xhead(l) xentry(xxentries) = ln xhead(l) = xxentries %finish %finish %result = 0 %finish l=nlink(l) %repeat fault("Too many names") %and %stop %if nnames=names nnames = nnames+1 name(nnames) = n nlink(nnames) = hnlink(h) %if n="A" %or n="X" %or n="Y" %start nass(nnames) = 2 %else nass(nnames) = 0 %finish nval(nnames) = 0 %if pass=3 %and xxentries<=xentries %start xxentries = xxentries+1 %if xxentries>xentries %start fault("Too many references") %else xlink(xxentries) = 0 xentry(xxentries) = ln xhead(nnames) = xxentries %finish %else xhead(nnames) = 0 %finish hnlink(h) = nnames nid = nnames %result = 0 %end !----------------------------------------------------------------------- %predicate get instr(%integername iid) %string(4) i %integer h,l iid=0 %false %unless 'A'<=pres char<='Z' h=pres char-'0' i=tostring(pres char) %for l = 2, 1, 4 %cycle next char -> goti %unless 'A'<=pres char<='Z' h=h<<4+pres char-'0' i=i.tostring(pres char) %repeat next char %false %if 'A'<=pres char<='Z' goti: h=h&32767 h=h-h//ihash*ihash l=hilink(h) %while l#0 %cycle iid=l %and %true %if instr(l)=i l=ilink(l) %repeat %false %end !----------------------------------------------------------------------- %routine evaluate(%integer %name a, %integer b, %byte %integer op) %if op='+' %start a = a+b %finish %else %if op='-' %start a = a-b %finish %else %if op='*' %start a = a*b %finish %else %if op='/' %start a = a//b %finish %else %if op='|' %start a = a-a//b*b %finish %else %if op='!' %start a = a!b %finish %else %if op='&' %start a = a&b %finish %else %if op='\' %start a = a!!b %finish %else %if op='<' %start a = a<>b %finish %end !----------------------------------------------------------------------- %integer %function get term(%integer %name opd) %integer i %while pres char='+' %cycle next char %until pres char#bchar %repeat %if pres char='-' %start next char %until pres char#bchar i = get term(opd) opd = -opd %finish %else %if pres char='\' %start next char %until pres char#bchar i = get term(opd) opd = \opd %finish %else %if pres char='(' %start next char %until pres char#bchar i = get expression(opd) %if i=0 %start next char %while pres char=bchar %if pres char=')' %start next char %else i = 0 %finish %finish %finish %else %if get name(i)=0 %start %if pass=1 %or nass(i)=1 %or nass(i)=3 %start opd = nval(i) i = 0 %else i = 1 %finish %else i = get const(opd) %finish %result = i %end !----------------------------------------------------------------------- %integer %function get expression(%integer %name opd) %integer sp, prio, i %byte %integer %array op stk, prio stk(1:5) %integer %array opd stk(0:5) %result = 1 %unless get term(opd stk(0))=0 sp = 0 i = 0 %cycle next char %while pres char=bchar %if pres char='!' %or pres char='\' %start prio = 0 %finish %else %if pres char='&' %start prio = 1 %finish %else %if pres char='+' %or pres char='-' %start prio = 2 %finish %else %if pres char='*' %or pres char='/' %or %c pres char='|' %start prio = 3 %finish %else %if pres char='<' %or pres char='>' %start prio = 4 %else %exit %finish %while sp>0 %and prio stk(sp)>=prio %cycle evaluate(opd stk(sp-1), opd stk(sp), op stk(sp)) sp = sp-1 %repeat sp = sp+1 op stk(sp) = pres char prio stk(sp) = prio next char %until pres char#bchar %unless get term(opd stk(sp))=0 %start sp = sp-1 i = 1 %exit %finish %repeat evaluate(opd stk(sp-1), opd stk(sp), op stk(sp)) %for sp = sp, -1, 1 opd = opd stk(0) %if i=0 %result = i %end !----------------------------------------------------------------------- %integer %function get opd(%integername opd) %integer nid,op,cval %result = get expression(opd) %unless fflag=0 opd=0 %if pres char='+' %or pres char='-' %start op = pres char next char %until pres char#bchar %else op = '+' %finish %cycle %if get name(nid)=0 %start %result=1 %unless pass=1 %or nass(nid)=1 %or nass(nid)=3 cval=nval(nid) %else %result=1 %if get const(cval)#0 %finish evaluate(opd, cval, op) next char %while pres char=bchar op = pres char %result=0 %unless op='+' %or op='-' %or op='*' %or op='/' next char %until pres char#bchar %repeat %end !----------------------------------------------------------------------- %integerfn get const(%integername cval) %integer started, dig val, bin val, oct val, hex val, bin pos, oct pos, dec pos started=1 %if pres char='*' %start next char cval = ca %result = 0 %finish cval=0 %if '0'<=pres char<='9' %start ;! decimal bin pos = 0 oct pos = 0 dec pos = 0 bin val = 0 oct val = 0 hex val = 0 %cycle %if bin pos=0 %and pres char='B' %start next char %if '0'<=pres char<='9' %or 'A'<=pres char<='F' %or %c pres char='H' %start bin pos = 1 oct pos = 1 dec pos = 1 hex val = (hex val<<4)+11 %else cval = bin val %result = 0 %finish %finish %if oct pos=0 %and (pres char='O' %or pres char='Q') %start cval = oct val next char %result = 0 %finish %else %if pres char='H' %start cval = hex val next char %result = 0 %finish %else %if 'A'<=pres char<='F' %start dig val = pres char-'A'+10 %finish %else %if '0'<=pres char<='9' %start dig val = pres char-'0' %else %result = dec pos %finish bin pos = 1 %if dig val>1 oct pos = 1 %if dig val>7 dec pos = 1 %if dig val>9 bin val = (bin val<<1)+dig val oct val = (oct val<<3)+dig val cval = cval*10+dig val hex val = (hex val<<4)+dig val next char %repeat %finish %if pres char='$' %start ;! hex %cycle next char %if '0'<=pres char<='9' %start cval = cval<<4!(pres char-'0') %finish %else %if 'A'<=pres char<='F' %start cval = cval<<4!(pres char-'A'+10) %else %result = started %finish started = 0 %repeat %finish %if pres char='@' %start ;! octal %cycle next char %result = started %unless '0'<=pres char<='7' cval = (cval<<3)!(pres char-'0') started = 0 %repeat %finish %if pres char='%' %start %cycle next char %result = started %unless '0'<=pres char<='1' cval = (cval<<1)!(pres char-'0') started = 0 %repeat %finish %if pres char='''' %start next char %result=1 %if lp=max line+1 cval=line(lp) next char %result=0 %finish %result=1 %end !----------------------------------------------------------------------- %predicate indexed(%byte %integer reg) %integer i i = lp %true %if more items %and acc(reg) lp = i-1 next char %false %end !----------------------------------------------------------------------- %predicate acc(%byte %integer acc id) %false %unless pres char=acc id next char %true %unless 'A'<=pres char<='Z' %or '0'<=pres char<='9' lp = lp-2 next char %false %end !----------------------------------------------------------------------- %routine immediate(%byte %integer order, mcycles) %integer i, opd next char %until pres char#bchar i = get opd(opd) instr out(order, opd, 2, mcycles) %unless i= 0 %start fault("Cannot evaluate operand") %finish %else %unless 0<=opd<=255 %start fault("Invalid constant") %finish %end !----------------------------------------------------------------------- %routine operand(%byte %integer reg, nreg, order, mcycles) %integer i, opd, reg fault %if acc(reg) %or indexed(reg) %start instr out(order+16_10, 0, 2, mcycles+2) %finish %else %if acc(nreg) %or indexed(nreg) %start instr out(order+16_10, 0, 2, mcycles+2) fault("Invalid index register") %else i = get opd(opd) %if indexed(reg) %start %if i#0 %or 0<=opd<=255 %start instr out(order+16_10, opd, 2, mcycles+2) %else instr out(order+16_18, opd, 3, mcycles+3) %finish %else %if indexed(nreg) %start reg fault = 1 %else reg fault = 0 %finish %if i#0 %or 0<=opd<=255 %start instr out(order, opd, 2, mcycles+1) %else instr out(order+8, opd, 3, mcycles+2) %finish fault("Invalid index register") %unless reg fault=0 %finish fault("Cannot evaluate operand") %unless i=0 %finish %end !----------------------------------------------------------------------- %routine store(%byte %integer reg, nreg, order, mcycles) %integer i, opd, reg fault %if acc(reg) %or indexed(reg) %start instr out(order+16_10, 0, 2, mcycles+1) %finish %else %if acc(nreg) %or indexed(nreg) %start instr out(order+16_10, 0, 2, mcycles+1) fault("Invalid index register") %else i = get opd(opd) %if indexed(reg) %start instr out(order+16_10, opd, 2, mcycles+1) %unless i#0 %or 0<=opd<=255 %start fault("Invalid page zero address") %finish %else %if indexed(nreg) %start reg fault = 1 %else reg fault = 0 %finish %if i#0 %or 0<=opd<=255 %start instr out(order, opd, 2, mcycles) %else instr out(order+8, opd, 3, mcycles+1) %finish fault("Invalid index register") %unless reg fault=0 %finish fault("Cannot evaluate operand") %unless i=0 %finish %end !----------------------------------------------------------------------- %routine dump block %integer checksum, old rad, i select output(1) old rad = drad drad = 8 print string("S1") print number(bp+3, 1) print number(buffer ca, 2) checksum = ((buffer ca>>8)&255)+(buffer ca&255)+bp+3 %for i = 1, 1, bp %cycle checksum = check sum+buffer(i) print number(buffer(i), 1) %repeat print number(\(checksum&255), 1) {print symbol(13)} new line drad = old rad select output(2) bp = 0 %end !-------------------------------------------------------------------------- %routine dump(%byte %integer byte) %if ostarted=0 %start select output(1) {print symbol(13)} new line print string("S00600004844521B") {print symbol(13)} new line select output(2) ostarted = 1 %finish buffer ca = ca %if bp=0 dump block %and buffer ca = ca %unless buffer ca+bp=ca bp = bp+1 buffer(bp) = byte ca = ca+1 dump block %if bp=16 %end !--------------------------------------------------------------------------- %routine close %unless ostarted=0 %start dump block %unless bp=0 select output(1) print string("S9030000FC") {print symbol(13)} new line select output(2) %finish %end !----------------------------------------------------------------------- %routine instr out(%integer op, opd, b, cyc) %integer i, j, k, lit i = 1 %unless lflag=0 %or ((gflag=0 %or lflag=1) %and cont=1) %start write(ln, 5) space %unless wflag=0 %if lflag=2 %start space %if b<=-3 %start spaces(sp2) %else print number(ca, 2) %finish space %if b=-3 %start print number(opd, 2) spaces(sp1+1) %finish %else %if -2<=b<=-1 %start back number(opd) spaces(sp1+1) %else %if b<=0 %start spaces(sp1) %else print number(op, 1) %finish space %if b<=1 %start spaces(sp2) %finish %else %if b=2 %start print number(opd, 1) spaces(sp2-sp1) %else back number(opd) %finish %finish %unless cflag=0 %start %if cyc=0 %start spaces(2) %else write(cyc, 1) %finish %finish %finish %if cont=0 %start space %if tflag=0 %start %cycle out symbol(line(i)) %exit %if line(i)&127=nl %or line(i)&127=12 i = i+1 %repeat %else j = 1 out tag(i, j, 8) out tag(i, j, 12) lit = 0 k = 0 %while i#lp %cycle %if line(i)&127=' ' %start k = k+1 %if non dense=1 %and lit=0 %else j = j+k+1 out symbol(' ') %and k = k-1 %while k>0 out symbol(line(i)) %finish %if line(i)&127='''' %start lit = 1 %else lit = 0 %finish i = i+1 %repeat i = i+1 %while line(i)&127=' ' %unless lp=1 %or line(i)&127=nl %or line(i)&127=12 %start out symbol(' ') %and j = j+1 %until j>=24 %finish %cycle out symbol(line(i)) %exit %if line(i)&127=nl %or line(i)&127=12 i = i+1 %repeat %finish %else nline(1) %finish %else i = i+1 %while line(i)&127#nl %and line(i)&127#12 %finish fault("Truncated line") %if i=max line+1 %if b>=1 %start dump(op&255) %unless b=1 %start dump(opd&255) dump((opd>>8)&255) %if b=3 %finish %finish %else %if b=-2 %start dump(opd&255) dump((opd>>8)&255) %finish %end !----------------------------------------------------------------------- %routine out tag(%integer %name i, j, %integer col) %while line(i)&127#' ' %and i#lp %cycle out symbol(line(i)) i = i+1 j = j+1 %repeat i = i+1 %while line(i)&127=' ' %and i#lp %unless i=lp %start out symbol(' ') %and j = j+1 %until j>=col %finish %end !------------------------------------------------------------------------ %routine out symbol(%byte %integer char) %own %integer optr = 0 %if char&127=nl %start optr = 0 nline(1) %finish %else %if char&127=12 %start optr = 0 nline(lines on page) %else %if optr=sp3 %start %return %if wflag=0 nline(1) write(ln, 5) print symbol('+') spaces(line width-sp3-7) optr = 0 %finish print symbol(char) optr = optr+1 %finish %end !----------------------------------------------------------------------- %routine fault(%string(63) s) faults=faults+1 %unless eflag=0 %start print string("**** ".s.". ****") nline(1) %finish %end !----------------------------------------------------------------------- %routine nline(%integer n) %own %integer line on page = lines on page+1, page no = 0 %unless n<0 %start %if line on page+pflag+n>lines on page %start page no = page no+1 %unless n=0 %start %if line on page=lines on page %start new line %else print symbol(12) %finish %finish %if pflag=0 %start line on page = 1 %else new line print string(" MOS Technology MCS650X Assembler ") spaces((line width-45-length(header))//2) print string(header) spaces((line width-44-length(header))//2) print string(" Page") write(page no, 2) new lines(2) line on page = 4 %finish %else new lines(n) line on page = line on page+n %finish %finish %end !----------------------------------------------------------------------- %routine back number(%integer n) print number(((n&255)<<8)!((n>>8)&255), 2) %end !----------------------------------------------------------------------- %routine print number(%integer n,d) %conststring(1)%array h(0:15)="0","1","2","3","4","5","6","7","8","9", "A","B","C","D","E","F" %integer model, nn %string(6) s model = 1<<(d*8-1) s="" %cycle model =(model>>1)//drad nn = (n>>1)//drad s=h(n-((nn*drad)<<1)).s n = nn %repeat %until model=0 print string(s) %end !----------------------------------------------------------------------- %routine sqs(%integer l, r) %integer nass key, nval key, xhead key, lp, rp, i %string(6) name key %return %unless 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 %begin ! 666 8888 0000 9999 ! 66 88 88 00 00 99 99 ! 66 88 88 00 000 99 99 ! 66666 8888 000000 99999 ! 66 66 88 88 000 00 99 ! 66 66 88 88 00 00 99 ! 6666 8888 0000 999 %external %integer %fn %spec Proc ID (%routine X) %external %routine %spec Stop(%integer res) %external %integer %fn %spec Verbosity Required(%integer Handle) %external %integer %fn %spec ArgumentInit(%c %integer %name Handle, %string(255) keyString, %integer Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %external %integer %fn %spec XGetPresence(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetStateArg(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetCardinalArg(%c %string(255) key, %integer Index, %integer Handle) %external %integer %fn %spec XGetStringArg(%c %string(*) %name argument, %string(255) Key, %integer Index, handle) %external %integer %fn %spec XGetNumberOfValues(%c %string(255) Key, %integer handle) %integer string length, handle, result, verbosity level { M6809 Assembler } { EUCSD - Fred King } %routine rd line (%string (*) %name s) %integer ch s = "" %cycle read symbol (ch) %exit %if ch = nl s = s . ch %repeat %end %string (255) %fn cli param %string (255) s Prompt ("M6809>") Rd line (s) %result = s %end %routine Help printstring("M6809 - EUCSD assembler".snl) printstring(snl) printstring(" -source Prog (prog-6809) keyword may be omitted".snl) printstring(" -object objfile / -noobject Prog-obj6809 by default".snl) printstring(" -list listfile / -nolist no list by default".snl) printstring(snl) %end %string (255) %fn sub string (%string (255) s, %integer first, last) %integer i %string (255) sub sub = "" %for i = first, 1, last %cycle sub = sub. char no (s, i) %repeat %result = sub %end %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 %intC,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, 15p) %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), 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 %intongs %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(255) params, source, list, object, file, dummy {-------------------------------------------------------------------------} result = ArgumentInit(%c handle, "INput=FROM=SOUrce/A/E-6809 ". %c "OUTput=TO=OBJect/N[] ". %c "List/N[]", 0 , 0, "M6809 Assembler (c) EUCSD", Proc ID(Help)) %if result < 0 %then Stop(result) verbosity level = Verbosity Required(handle) string length = XGetStringArg(file, "INPUT", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length source = file %if XGetStateArg("LIST", handle) # 0 %start %if XGetNumberOfValues("LIST", handle) = 1 %start string length = XGetStringArg(file, "LIST", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length list = file %else list = "" %finish %else list = "NULL:" %finish %if XGetPresence("OBJECT", handle) = 0 %start object = "" %elseif XGetStateArg("OBJECT", handle) # 0 %if XGetNumberOfValues("OBJECT", handle) = 1 %start string length = XGetStringArg(file, "OBJECT", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length object = file %else object = "" %finish %else object = "NULL:" %finish {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++} ! params = uc(cliparam) ! source = "" ! list = "NL:" ! 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 = "NL:" ! file == dummy ! %finish %else %if matches(params, "NOOBJECT", 3, i) %start ! object = "NL:" ! 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 {-------------------------------------------------------------------------} %stop %if source="" source = source."-6809" %unless is typed(source, params) list = params %if list="" object = params %if object="" list = list."-LIS" %unless is typed(list, dummy) object = object."-OBJ6809" %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): ! trf, 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): ! trf,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<=opd %or opd<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 faults") %else write(faults, 0) print string(" fault") print symbol('s') %unless faults=1 %finish print string(" in this assembly.") newline select output(0) %if faults=0 %start %if verbosity level > 0 %start spaces(2) write(ln, 0) print string(" line") print symbol('s') %unless ln=1 print string(" assembled.") new line %finish %else spaces(2) write(faults, 0) print string(" fault") print symbol('s') %unless faults=1 print string(" in this assembly.") new line %finish 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 uc(%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 file <- source %for i = length(file),-1,1 %cycle %if charno(file,i)='-' %then %start length(file)=i-1 %true %finish %repeat %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-{??disk error fixed??}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 %begin ! 666 555555 0000 2222 ! 66 55 00 00 22 22 ! 66 55555 00 000 22 ! 66666 55 000000 22 ! 66 66 55 000 00 22 ! 66 66 55 55 00 00 22 ! 6666 5555 0000 222222 %external %integer %fn %spec Proc ID (%routine X) %external %routine %spec Stop(%integer res) %external %integer %fn %spec Verbosity Required(%integer Handle) %external %integer %fn %spec ArgumentInit(%c %integer %name Handle, %string(255) keyString, %integer Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %external %integer %fn %spec XGetPresence(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetStateArg(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetCardinalArg(%c %string(255) key, %integer Index, %integer Handle) %external %integer %fn %spec XGetStringArg(%c %string(*) %name argument, %string(255) Key, %integer Index, handle) %external %integer %fn %spec XGetNumberOfValues(%c %string(255) Key, %integer handle) %integer string length, handle, result, verbosity level, i, j { M6502 emulator - Graham Toal } { Edinburgh University Computer Science Department } %routine Help printstring("M6502 - EUCSD assembler".snl) printstring(snl) printstring(" -source Prog (prog-6502) keyword may be omitted".snl) printstring(" -object objfile / -noobject Prog-obj6502 by default".snl) printstring(" -list listfile / -nolist no list by default".snl) printstring(snl) %end %string (255) %fn sub string (%string (255) s, %integer first, last) %integer i %string (255) sub sub = "" %for i = first, 1, last %cycle sub = sub. char no (s, i) %repeat %result = sub %end %string(255) params, source, list, object, dummy, file %integer bbcrom=0 {-------------------------------------------------------------------------} result = ArgumentInit(%c handle, "INput=FROM=OBJect/A/E ". %c "OUTput=TO=List/N[Vdu:] ". %c "ROM/K/P/=0", 0 , 0, "M6502 emulator (c) GRaham Toal", Proc ID(Help)) %if result < 0 %then Stop(result) verbosity level = Verbosity Required(handle) %if XGetPresence("ROM", handle) # 0 %then %start bbcrom = 1 %finish string length = XGetStringArg(file, "INPUT", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length source = file %if XGetStateArg("LIST", handle) # 0 %start %if XGetNumberOfValues("LIST", handle) = 1 %start string length = XGetStringArg(file, "LIST", 1, handle) %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length list = file %else list = "" %finish %else list = "VDU:" %finish open output(1, list) select output(1) %const %string(4) %array Decode(0:255) = %c "Brk ","Ora(","????","????","????","Oraz","Aslz","????","Php ","Ora#","AslA", "????","????","Ora&","Asl&","????","BplR","Ora)","????","????","????","Orax", "Aslx","????","Clc ","OraY","????","????","????","OraX","AslX","????","Jsr&", "And(","????","????","Bitz","Andz","Rolz","????","Plp ","And#","RolA","????", "Bit&","And&","Rol&","????","BmiR","And)","????","????","????","Andx","Rolx", "????","Sec ","AndY","????","????","????","AndX","RolX","????","Rti ","Eor(", "????","????","????","Eorz","Lsrz","????","Pha ","Eor#","LsrA","????","Jmp&", "Eor&","Lsr&","????","BvcR","Eor)","????","????","????","Eorx","Lsrx","????", "Cli ","EorY","????","????","????","EorX","LsrX","????","Rts ","Adc(","????", "????","????","Adcz","Rorz","????","Pla ","Adc#","RorA","????","JmpI","Adc&", "Ror&","????","BvsR","Adc)","????","????","????","Adcx","Rorx","????","Sei ", "AdcY","????","????","????","AdcX","????","????","????","Sta(","????","????", "Styz","Staz","Stxz","????","Dey ","????","Txa ","????","Sty&","Sta&","Stx&", "????","BccR","Sta)","????","????","Styx","Stax","Stxy","????","Tya ","StaY", "Txs ","????","????","StaX","????","????","Ldy#","Lda(","Ldx#","????","Ldyz", "Ldaz","Ldxz","????","Tay ","Lda#","Tax ","????","Ldy&","Lda&","Ldx&","????", "BcsR","Lda)","????","????","Ldyx","Ldax","Ldxy","????","Clv ","LdaY","Tsx ", "????","LdyX","LdaX","LdxY","????","Cpy#","Cmp(","????","????","Cpyz","Cmpz", "Decz","????","Iny ","Cmp#","Dex ","????","Cpy&","Cmp&","Dec&","????","BneR", "Cmp)","????","????","????","Cmpx","Decx","????","Cld ","CmpY","????","????", "????","CmpX","DecX","????","Cpx#","Sbc(","????","????","Cpxz","Sbcz","Incz", "????","Inx ","Sbc#","Nop ","????","Cpx&","Sbc&","Inc&","????","BeqR","Sbc)", "????","????","????","Sbcx","Incx","????","Sed ","SbcY","????","????","????", "SbcX","IncX","????" %byte %array B(0:65535) %short %array T(0:65535) %integer load address, execaddr, file length, ca %integer Defined max = 0 %integer %array defined address(0:100) %string(15) %array defined name(0:100) %routine Define(%string(15) Tag, %integer a) %integer i defined name(Defined max+1) = Tag defined address(Defined max+1) = a %for i = 1, 1, defined max %cycle %if defined name(i) = Tag %then %return %repeat Defined max = Defined max + 1 %end %integerfn Sex(%integer i) %if i&128 # 0 %then i=i+255<<8 %result = i %end %integerfn bfetch(%integername ca) %integer i = B(ca) ca=ca+1 %result = i %end %integerfn wfetch(%integername ca) %result = bfetch(ca) + bfetch(ca)<<8 %end %const %byte %array Hex(0:15) = %c '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' %string(15) %fn address(%integer a) %string(5) s %integer i %if a < 0 %or a > 16_ffff %start a=a&16_ffff %finish %for i = 1, 1, defined max %cycle %if defined address(i) = a %then %result = defined name(i) %repeat s = "" %for i = 12,-4,0 %cycle s = s.Hex((a>>i)&15) %repeat %if load address <= a <= Load address+file length %then s = "L".s %else s = "$".s %result = s %end %string(3) %fn zp address(%integer i) %if i > 255 %then printstring("??? zp address > 255?".snl) %result = "$".Hex((i>>4)&15).Hex(i&15) %end %string(15) %fn const(%integer c) %result = itos(c,0) %end %const %integer %c INSTR = 1, BRDEST = 2, JMPDEST = 4, JSRDEST = 8, DEC = 16, ASCII = 32, HEXDATA = 64, OTHER = 128, VARIABLE = 256, JSRABS = 16_20, JUMPABS = 16_4C, JUMPIND = 16_6C, BRK = 0, RTS = 16_60, RTI = 16_40 %string(15) LABS = "" %string(15) EAS = "Unass" %string(4) OPS = "XXX" %routine Disassemble(%integername ca) %string(4) s %integer opc, idx %switch itype(32:126) %if T(ca)&(JMPDEST!JSRDEST!BRDEST!VARIABLE) # 0 %start %if T(ca)&JSRDEST # 0 %then Printstring("*".snl) LABS = address(ca) %else LABS = "" %finish %if T(ca)&INSTR=0 %start %if T(ca)&DEC # 0 %start OPS = "EQUB"; EAS = itos(B(ca),0) %else %if T(ca)&ASCII # 0 %and (32 <= B(ca) <= 126) OPS = "EQUB"; EAS = "'".B(ca) %else OPS = "EQUB"; EAS = itos(B(ca),0) %finish ca=ca+1 %return %finish opc = bfetch(ca) s = Decode(opc) OPS = s; LENGTH(OPS) = 3 -> itype(CHARNO(s,4)) itype(' '): ! Implied EAS = "" %return itype('A'): ! Acc EAS = "A" %return itype('R'): ! Relative EAS = address((ca+sex(bfetch(ca)))&16_ffff) %return itype('I'): ! Indirect EAS = "(".address(wfetch(ca)).")" %return itype('&'): ! Absolute EAS = address(wfetch(ca)) %return itype('#'): ! Immediate EAS = "#".const(bfetch(ca)) %return itype('z'): ! Zpage EAS = zp address(bfetch(ca)) %return itype('x'): ! Zpage,X EAS = zp address(bfetch(ca)).",X" %return itype('y'): ! Zpage,Y EAS = zp address(bfetch(ca)).",Y" %return itype('X'): ! Abs,X EAS = address(wfetch(ca)).",X" %return itype('Y'): ! Abs,Y EAS = address(wfetch(ca)).",Y" %return itype('('): ! Ind,X EAS = "(".zp address(bfetch(ca)).",X)" %return itype(')'): ! Ind,Y EAS = "(".zp address(bfetch(ca))."),Y" %return itype('?'): ! Illegal EAS = " = ".itos(opc, 0) %if ' ' <= opc <= 126 %then EAS = EAS." = '".opc."'" %end %routine DFS(%integer ca) %string(4) s %integer opc, castart, EA %switch itype(32:126) %if verbosity level > 4 %then %c printstring("DFS: starting at ".address(ca).snl) %cycle %if ca >= load address + file length %then %return %if T(ca)&INSTR # 0 %start %if verbosity level > 4 %then printstring("Already been here: ". %c address(ca).snl) %return %finish castart = ca opc = bfetch(ca) s = Decode(opc) -> itype(CHARNO(s,4)) itype(' '): ! Implied T(castart)=T(castart)!INSTR %if opc=RTS %or opc=RTI %then T(ca)=T(ca)!OTHER %and %return %if opc=BRK %then %start %begin %integer i T(ca)=T(ca)!DEC i = bfetch(ca) %cycle T(ca) = T(CA)!ASCII i = bfetch(ca) %repeat %until i=0 %or T(ca)&INSTR # 0 %or ca >= load address+file length %end %finish %continue itype('A'): ! Acc T(castart)=T(castart)!INSTR %continue itype('R'): ! Relative T(castart)=T(castart)!INSTR T(castart+1)=0 EA = (ca+sex(bfetch(ca)))&16_ffff T(EA)=T(EA)!BRDEST DFS(EA) %continue itype('I'): ! Indirect T(castart)=T(castart)!INSTR T(castart+1)=0 T(castart+2)=0 EA = wfetch(ca) T(EA)=T(EA)!HEXDATA!VARIABLE %if opc=JUMPIND %start T(ca)=T(ca)!OTHER %return %finish %continue itype('&'): ! Absolute T(castart)=T(castart)!INSTR T(castart+1)=0 T(castart+2)=0 EA = wfetch(ca) %if opc=JUMPABS %start T(EA)=T(EA)!JMPDEST DFS(EA) %return %finish %if opc=JSRABS %start T(EA)=T(EA)!JSRDEST DFS(EA) %continue %finish T(EA)=T(EA)!HEXDATA!VARIABLE %continue itype('#'): ! Immediate T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) %continue itype('z'): ! Zpage T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) %continue itype('x'): ! Zpage,X T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) %continue itype('y'): ! Zpage,Y T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) %continue itype('X'): ! Abs,X T(castart)=T(castart)!INSTR T(castart+1)=0 T(castart+2)=0 EA = wfetch(ca) T(EA)=T(EA)!HEXDATA!VARIABLE %continue itype('Y'): ! Abs,Y T(castart)=T(castart)!INSTR T(castart+1)=0 T(castart+2)=0 EA = wfetch(ca) T(EA)=T(EA)!HEXDATA!VARIABLE %continue itype('('): ! Ind,X T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) T(EA)=T(EA)!HEXDATA!VARIABLE %continue itype(')'): ! Ind,Y T(castart)=T(castart)!INSTR T(castart+1)=0 EA = bfetch(ca) T(EA)=T(EA)!HEXDATA!VARIABLE %continue itype('?'): ! Illegal T(castart)=T(castart)!OTHER %if verbosity level > 4 %then printstring("Illegal inst at ".address(castart).snl) %return %repeat %end %predicate Test code(%integer ca, limit) %string(4) s %integer opc, castart, EA %switch itype(32:126) %if verbosity level > 2 %then printstring("Entering ".snl) %while ca itype(CHARNO(s,4)) itype(' '): ! Implied %continue itype('A'): ! Acc %continue itype('R'): ! Relative EA = (ca+sex(bfetch(ca)))&16_ffff %continue itype('I'): ! Indirect EA = wfetch(ca) %continue itype('&'): ! Absolute EA = wfetch(ca) %continue itype('#'): ! Immediate EA = bfetch(ca) %continue itype('z'): ! Zpage EA = bfetch(ca) %continue itype('x'): ! Zpage,X EA = bfetch(ca) %continue itype('y'): ! Zpage,Y EA = bfetch(ca) %continue itype('X'): ! Abs,X EA = wfetch(ca) %continue itype('Y'): ! Abs,Y EA = wfetch(ca) %continue itype('('): ! Ind,X EA = bfetch(ca) %continue itype(')'): ! Ind,Y EA = bfetch(ca) %continue itype('?'): ! Illegal %if verbosity level > 2 %then printstring("Exit - not all code".snl) %false %repeat %if verbosity level > 2 %then printstring("Exit - was all code".snl) %true %end %routine Check gaps(%integer first, last) %integer ca,s1,s2 ca = first %if verbosity level > 0 %then printstring(">> check gaps".snl) %while ca < last %cycle %if T(ca)&OTHER # 0 %and T(ca)&(HEX DATA!ASCII!DEC)=0 %start s1=ca; s2=ca %while s2 < last %cycle s2=s2+1 %repeat %until T(s2)&INSTR # 0 %if s2-s1>3 %start %if verbosity level>2 %then Printstring(%c "Checking gap between ".address(s1)." and ".address(s2).snl) %if TestCode(s1,s2) %start %if verbosity level > 2 %then printstring("!!! Code!".snl) DFS(s1) %else %if TestCode(s1+1,s2) %if verbosity level > 2 %then printstring("!!! Code!".snl) DFS(s1) %else %if TestCode(s1+2,s2) %if verbosity level > 2 %then printstring("!!! Code!".snl) DFS(s1) %finish %finish ca=s2 %else ca=ca+1 %finish %repeat %if verbosity level > 0 %then printstring("<< check gaps".snl) %end %record %format osfile fm(%integer load addr, exec addr, length, attr) %record %format time fm(%integer low, high) %external %integer %fn %spec XGetFileInformation(%c %record(osfile fm)%name o, %record(time fm) %name t, %string(255) s) %external %routine %spec XLoadFile(%string(255) S, %integer maxl, ad) %routine LoadBBCFile(%integername address, length, start) %record(time fm) datestampblk %record(osfile fm) osfileblk %integer la, i = XGetFileInformation(osfileblk, datestampblk, source) address = osfileblk_load addr length = osfileblk_length start = osfileblk_exec addr %if address>>16=16_ffff %start address=address&16_ffff; start=start&16_ffff %finish %if address<0 %or address>16_ffff %or bbcrom#0 %start address=16_8000; start=16_8000 %finish %if start+length>=16_10000 %start Printstring(source." is probably not a BBC IO proc program".snl) %stop %finish %if verbosity level > 0 %start Printstring("File ".source.": Load ".itos(address,0)." Length: ". %c itos(length,0).snl) %finish la = Addr(B(0))+start XLoadFile(source, length, la) %end Define("osfind", 16_FFCE) Define("osgbpb", 16_FFD1) Define("osbput", 16_FFD4) Define("osbget", 16_FFD7) Define("osargs", 16_FFDA) Define("osfile", 16_FFDD) Define("osrdch", 16_FFE0) Define("osasci", 16_FFE3) Define("osnewl", 16_FFE7) Define("oswrch", 16_FFEE) Define("osword", 16_FFF1) Define("osbyte", 16_FFF4) Define("oscli", 16_FFF7) %for i = 0, 1, 65535 %cycle B(i) = 0; T(i) = 0 %repeat LoadBBCFile(load address, file length, execaddr) ca = load address %if bbcrom # 0 %start DFS(16_8000); DFS(16_8003) %else DFS(execaddr) %finish Check gaps(ca, ca+file length) %cycle %if verbosity level > 0 %start printstring("[".address(ca)."] ") %finish Disassemble(ca) i = LENGTH(LABS) printstring(LABS); spaces(10-i) i = LENGTH(OPS) printstring(OPS); spaces(6-i) printstring(EAS) newline %repeat %until ca > load address+file length %Endofprogram %begin ! 8888 0000 8888 0000 555555 ! 88 88 00 00 88 88 00 00 // 55 ! 88 88 00 000 88 88 00 000 // 55555 ! 8888 000000 8888 000000 // 55 ! 88 88 000 00 88 88 000 00 // 55 ! 88 88 00 00 88 88 00 00 // 55 55 ! 8888 0000 8888 0000 5555 %integerfn CPU Time {MT} %record %format tfm(%integer low, %byte high) %record (tfm) T *MovQB _ #1, 1 *Addr _ T, 2 *Svc _ 7 %result = T_low %end %external %integer %fn %spec Proc ID (%routine X) %external %routine %spec Stop(%integer res) %external %integer %fn %spec Verbosity Required(%integer Handle) %external %integer %fn %spec ArgumentInit(%c %integer %name Handle, %string(255) keyString, %integer Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %external %integer %fn %spec XGetPresence(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetStateArg(%c %string(255) key, %integer Handle) %external %integer %fn %spec XGetCardinalArg(%c %string(255) key, %integer Index, %integer Handle) %external %integer %fn %spec XGetStringArg(%c %string(*) %name argument, %string(255) Key, %integer Index, handle) %external %integer %fn %spec XGetNumberOfValues(%c %string(255) Key, %integer handle) { 8080/5 emulator - Graham Toal } { Manchester University Computer Science Department } %constinteger true=0, false=1 %string(255) object, progin, progout, list %integer debug = true, verbosity level = 0 {-------------------------------------------------------------------------} %begin %routine Help printstring("S8080 - Intel 8080/5 emulator".snl) printstring(snl) printstring(" -object Prog (prog-obj8080) (produced by Ass8080 prog-8080)".snl) printstring(" -progin File (tt:) Program I/O file".snl) printstring(" -progout File (tt:) Program I/O file".snl) printstring(" -debug Allow interactive debugging".snl) printstring(" -list File (Null:) Trace output file".snl) printstring(" (if not debugging)".snl) printstring(snl) %end %string(255) %fn sfn(%string(255) file, %integer string length) %integer j %for j = string length, -1, 1 %cycle charno(file, j) = charno(file, j-1) %repeat length(file) = string length %result = file %end %integer result, handle %string(255) file result = ArgumentInit( handle, "INPUT=FROM=OBJect/A/E-obj8080 ". %c "OUTPUT=TO=List/N[Vdu:] ". %c "PROGIN=IN/P/E[null] ". %C "PROGOUT=OUT/P[TT:] ". %C "DEBUG/S", 0 , 0, "8080/5 emulator (c) Graham Toal", Proc ID(Help)) %if result < 0 %then Stop(result) verbosity level = Verbosity Required(handle) object = sfn(file, XGetStringArg(file, "Object", 1, handle)) progin = sfn(file, XGetStringArg(file, "ProgIn", 1, handle)) progout = sfn(file, XGetStringArg(file, "ProgOut", 1, handle)) %if XGetStateArg("Debug", handle) # False %start Debug = True %if XGetNumberOfValues("LIST", handle) = 1 %start list = sfn(file, XGetStringArg(file, "List", 1, handle)) %else list = "TT:" %finish %else Debug = False list = "NULL:" %finish %end {-------------------------------------------------------------------------} %short OLD PC, Code pointer %integer abend, last cycles, delta cycles, instrs, elapsed time, start time, i, start address, end address %record %format Register set(%c %byte h, l, %c d, e, %c b, c, %c a, f) %record %format memory( %byte %array B(-16_8000:16_7fff) ) %record (memory) M %record (Register set) R %short HL, DE, BC, AF %byte %map ByteAt(%short address) { Sometimes parameter is an INTEGER } %result == M_B(address) { so would be out of range } %end {-------------------------------------------------------------------------} %integer Defined max = 0 %integer %array defined address(0:100) %string(15) %array defined name(0:100) %routine Define(%string(15) Tag, %integer a) %integer i defined name(Defined max+1) = Tag defined address(Defined max+1) = a %for i = 1, 1, defined max %cycle %if defined name(i) = Tag %then %return %repeat Defined max = Defined max + 1 %end %integerfn Sex(%integer i) %if i&128 # 0 %then i=i+255<<8 %result = i %end %integerfn bfetch(%integername ca) %integer i = M_B(ca) ca=ca+1 %result = i %end %integerfn wfetch(%integername ca) %result = bfetch(ca) + bfetch(ca)<<8 %end %const %byte %array Hex(0:15) = %c '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' %string(15) %fn address(%integer a) %string(5) s %integer i %if a < 0 %or a > 16_ffff %start a=a&16_ffff %finish %for i = 1, 1, defined max %cycle %if defined address(i) = a %then %result = defined name(i) %repeat s = "" %for i = 12,-4,0 %cycle s = s.Hex((a>>i)&15) %repeat %result = s %end %string(6)%fn ItoH2(%integer N) %string(6) S = "" %integer Shift %for Shift = 4, -4, 0 %cycle s = s.Hex((N>>Shift)&15) %repeat %result=s %end %string(15) %fn const(%integer c) %result = itos(c,0) %end {-------------------------------------------------------------------------} %routine Dump line(%short address) %integer i %for address = address, 1, address+15 %cycle print string(ItoH2(ByteAt(address))." ") %repeat print string(": ") %for address = address, -1, address-15 %cycle i = ByteAt(address) %if i < 32 %or i > 126 %then i='.' print symbol(i) %repeat %end %routine dump page(%short address) %for address = address, 16, address+16*15 %cycle dump line(address) %repeat %end %byte %fn rhex1 %integer i %cycle read symbol(i) %if 'A' <= i <= 'F' %then %result = i-'A'+10 %if 'a' <= i <= 'f' %then %result = i-'a'+10 %if '0'<=i<='9' %then %result=i-'0' printstring ("Invalid character '".i."' in object file".snl) %repeat %end %byte %fn rhex2 %result=rhex1<<4!rhex1 %end %byte %fn rhex4 %result=rhex2<<8!rhex2 %end %routine skip past(%integer sym) skip symbol %while next symbol#sym; skipsymbol %end %routine load object(%integer %name end address, start address) %integer load address, each one, data bytes, val start address=16_ffff; end address = 0; print string("Loading ".object.snl) open input(1, object) select input(1) %cycle skip past('S') read symbol(val) %if val='0' %start skip past(nl) %else %if val = '1' data bytes = rhex2 load address = rhex4 %if (load address&16_ffff) < (start address&16_ffff) %then %c start address = load address %for each one = 0, 1, data bytes-4 %cycle ByteAt(load address+each one) = rhex2 %if (load address+each one)&16_ffff > end address&16_ffff %then %c end address = (load address+each one)&16_ffff %repeat val = rhex2 {CRC} %else %if val = '9' %exit %finish %repeat select input(0) print string(object." loaded".snl) %end {-------------------------------------------------------------------------} %include "sim8080-inc" M = 0 ; ! Clear memory Printstring("Starting...".snl) load object(start address, end address) simulate(start address) %Endofprogram %begin ! Convert from Intel 8080/8085 Assembly Mnemonics to Z80 ones (EUCSD style) %string(1) Tab = ToString('I'&31) %external %routine %spec Stop(%integer res) %external %integer %fn %spec Proc ID (%routine X) %external %integer %fn %spec XArgumentInit(%c %string(255) keyString, %integer Input wanted, Output wanted, %string(255) Identification, %integer Help proc) %string(255) FullLine = ".END", Line = ".END" %const %string(23) %array Opd2(1:90*2) = %C { } %C { First - treat OPD ... } %C { M,X -> (HL),X } %C { X,M -> X,(HL) } %C { M -> (HL) } %C { Then treat as single unit } %C { } %C ".PROC", "* = .", ".END", "END", ".EQU", "