%begin
{----------------------------------------}
{                                        }
{ MOS Technology M6500 Series Assembler. }
{                                        }
{ Copyright M.R.King, 27/3/1984.         }
{ All rights reserved.                   }
{ <adapted for 6511 by RWT in July 1991> }
{----------------------------------------}

%own %string(255) copyright = %c
"M6500 Series Assembler. Copyright M.R.King, 27/3/1984. All rights reserved."

%constant %integer names = 1023,
                   line width    = 78,
                   lines on page = 66,
                   max line = 512,
                   insert limit = 10,
                   xentries     = 4096
%constinteger ihash=59
%constant %byte %integer %array hilink(0:58) = %c
     13,  28,  69,  70,  36,  72,  29,  50,   0,  25,  26,  75,
      1,  16,  27,  14,  80,  23,   4,   6,  42,  11,  41,  15,
     35,   0,  82,  34,  84,  30,  32,  87,  88,  31,   8,   3,
      5,  62,  43,  64,  51,  92,  48,  12, 100,   0,  49,  19,
     20,   0,   9,  99,   7,  45,   2,  22,   0,   0,  47
%constant %byte %integer %array ilink(1:101) = %c
     76,  90,  10,  24,  40,   0,  17,  59,  18,  60,  52,  33,
     67,  79,   0,  77,  53,   0,  21,   0,  97,  95,  81,   0,
      0,  74,  78,  68,  73,  38,  58,  37,  46,  54,   0,  71,
     39,  85,  86,  61,  56,   0,  44,  63,  57,   0,  55,   0,
      0,  93,  65,  98,   0,  83,  66,   0,   0,  89,   0, 101,
      0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
      0,   0,  91,   0,   0,   0,   0,  96,   0,   0,   0,   0,
      0,   0,   0,   0,   0,   0,   0,  94,   0,   0,   0,   0,
      0,   0,   0,   0,   0
%constant %string(4) %array instr(1:101) = %c
   "LDA","STA","LDX","STX","LDY","STY","JSR","BCC","BCS",
   "BNE","BEQ","BVC","BVS","BPL","BMI","JMP","RTS","CMP",
   "CPX","CPY","DEC","INC","INX","INY","DEX","DEY","AND",
   "ORA","EOR","BIT","LSR","ROR","ASL","LSL","ROL","SBC",
   "ADC","TAX","TAY","TYA","TSX","TXA","TXS","PHA","PHP",
   "PLA","PLP","RTI","BRK","NOP","CLV","CLC","SEC","CLI",
   "SEI","CLD","SED","RMB0","RMB1","RMB2","RMB3","RMB4","RMB5",
   "RMB6","RMB7","SMB0","SMB1","SMB2","SMB3","SMB4","SMB5","SMB6",
   "SMB7","BBR0","BBR1","BBR2","BBR3","BBR4","BBR5","BBR6","BBR7",
   "BBS0","BBS1","BBS2","BBS3","BBS4","BBS5","BBS6","BBS7","FCB",
   "FDB","EQU","ORG","RMB","FCC","NAM","OPT","PAGE","SPC",
   "MON","END"
%constant %byte %integer %array icode(1:101) = %c
   16_A1,16_81,16_A2,16_86,16_A0,16_84,16_20,16_90,16_B0,
   16_D0,16_F0,16_50,16_70,16_10,16_30,16_4C,16_60,16_C1,
   16_E0,16_C0,16_C6,16_E6,16_E8,16_C8,16_CA,16_88,16_21,
   16_01,16_41,16_20,16_46,16_66,16_06,16_06,16_26,16_E1,
   16_61,16_AA,16_A8,16_98,16_BA,16_8A,16_9A,16_48,16_08,
   16_68,16_28,16_40,16_00,16_EA,16_B8,16_18,16_38,16_58,
   16_78,16_D8,16_F8,16_07,16_17,16_27,16_37,16_47,16_57,
   16_67,16_77,16_87,16_97,16_A7,16_B7,16_C7,16_D7,16_E7,
   16_F7,16_0F,16_1F,16_2F,16_3F,16_4F,16_5F,16_6F,16_7F,
   16_8F,16_9F,16_AF,16_BF,16_CF,16_DF,16_EF,16_FF,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:101) = %c
     5,  6, 11, 13, 12, 14,  4,  2,  2,  2,  2,  2,  2,  2,  2,
     3,  1,  5,  9,  9,  8,  8,  1,  1,  1,  1,  5,  5,  5, 10,
     7,  7,  7,  7,  7,  5,  5,  1,  1,  1,  1,  1,  1,  1,  1,
     1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, 26, 26, 26,
    26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27,
    27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 15,
    16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 25
%constant %integer %array icycles(1:101) = %c
     2,  2,  2,  3,  2,  3,  6,  4,  4,  4,  4,  4,  4,  4,  4,
     3,  6,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
     2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  2,  3,  3,
     4,  4,  6,  7,  2,  2,  2,  2,  2,  2,  2,  2,  3,  3,  3,
     3,  3,  3,  3,  3,  3,  3,  3,  3,  3,  3,  3,  3,  4,  4,
     4,  4,  4,  4,  4,  4,  4,  4,  4,  4,  4,  4,  4,  4,  0,
     0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0
%constant %integer no options = 51
%constant %string(10) %array option text(1:no options) = %c
   "BLANK", "B", "NOBLANK", "NOB", "CYCLE", "C", "NOCYCLE", "NOC",
   "DB8", "DB10", "DB16", "ERROR", "E", "SERROR", "SER", "NOERROR",
   "NOE", "FULL", "F", "NOFULL", "NOF",  "GENERATE", "G", "NOGENERATE",
   "NOG", "LIST", "L", "SLIST", "SLIS", "NOLIST", "NOL", "PAGE", "P",
   "NOPAGE", "NOP", "SYMBOL", "S", "NOSYMBOL", "NOS", "TAB", "T",
   "NOTAB", "NOT", "WRAP", "W", "NOWRAP", "NOW", "XREF", "X", "NOXREF",
   "NOX"
%string(255) %function %spec lc(%string(255) source)
%predicate %spec matches(%string(255) source, pattern,
      %integer min, %integer %name i)
%predicate %spec is typed(%string(255) source, %string(255) %name file)
%routine %spec read line
%routine %spec next char
%predicate %spec more items
%integerfn %spec get name(%integername nid)
%predicate %spec get option(%integer %name opt)
%predicate %spec get instr(%integername id)
%integerfn %spec get opd(%integername opd)
%integer %function %spec get term(%integer %name opd)
%integer %function %spec get expression(%integer %name opd)
%routine %spec evaluate(%integer %name a, %integer b, %byte %integer op)
%integerfn %spec get const(%integername cval)
%routine %spec out symbol(%byte %integer char)
%routine %spec out tag(%integer %name i, j, %integer col)
%routine %spec instr out(%integer op,opd,b, cyc)
%routine %spec close
%routine %spec fault(%string(63) s)
%routine %spec nline(%integer n)
%routine %spec back number(%integer n)
%routine %spec print number(%integer n,d)
%predicate %spec indexed(%byte %integer reg)
%predicate %spec acc(%byte %integer acc id)
%routine %spec sqs(%integer l, r)
%routine %spec immediate(%byte %integer order, mcycles)
%routine %spec operand(%byte %integer reg, nreg, order, mcycles)
%routine %spec store(%byte %integer reg, nreg, order, mcycles)
%byte %integer %array buffer(1:16)
%byteinteger %array line(1:max line+1)
%integer ca, pass, faults, lp, opd, iid, lid, ln, nnames, i, j, k, opt,
   order, consistent, last consistent, headset, pres char, delim, drad,
   bchar, pflag, sflag, gflag, eflag, lflag, cflag, wflag, tflag, xflag,
   cont, sp1, sp2, sp3, old ca, mcycles, non dense, reg fault,
   l, xxentries, fflag, ostarted, buffer ca, bp, look ahead
%constant %integer nhash=67
%shortinteger %array hnlink(0:nhash-1)
%string(15)%array name(1:names)
%integer%array nval(1:names)
%byteinteger%array nass(1:names)
%shortinteger%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:27)
%string(line width-45) header
%string(*) %name file
%string(255) params, source, list, object, dummy

   %on %event 9 %start
      select output(0)
      print string(event_message{source." does not exist."})
      new line
      %stop
   %finish

!  params = ""
!  select input(0)
!  read symbol(i)
!  params = params.to string(i) %and read symbol(i) %while i#nl
!  params = lc(params)
   params = lc(cliparam)
   source = ""
   list = ".n"
   object = ""
   dummy = ""
   %cycle
      i = 1
      i = i+1 %while i<=length(params) %and charno(params, i)=' '
      %exit %if i>length(params)
      params = substring(params, i, length(params))
      %unless '-'#charno(params, 1)#'/' %start
         params = substring(params, 2, length(params))
         %if matches(params, "list", 1, i) %start
            list = ""
            file == list
         %finish %else %if matches(params, "object", 1, i) %start
            object = ""
            file == object
         %finish %else %if matches(params, "nolist", 3, i) %start
            list = ".n"
            file == dummy
         %finish %else %if matches(params, "noobject", 3, i) %start
            object = ".n"
            file == dummy
         %else
            i = 1
            file == dummy
         %finish
         %exit %if i>length(params)
         params = substring(params, i, length(params))
         %continue %unless charno(params, 1)='='
         %if length(params)>1 %start
            params = substring(params, 2, length(params))
         %else
            params = ""
         %finish
     %else
         file == source
      %finish
      i = 1
      i = i+1 %while i<=length(params) %and charno(params, i)#' ' %and %c
                                        '-'#charno(params, i)#'/'
      file = substring(params, 1, i-1) %if i>1
      %exit %if i>length(params)
      params = substring(params, i, length(params))
   %repeat

   %if source="" %start
      select output(0)
      print string("No source file specified.")
      new line
      %stop
   %finish

   source = source.".asm" %unless is typed(source, params)

   list   = params %if list=""
   object = params %if object=""
   list = list.".lis" %unless is typed(list, dummy)
   object = object.".obj" %unless is typed(object, dummy)
   list = ":n" %if list=".n"
   object = ":n" %if object=".n"

   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
itype1(26):! RMBx, SMBx
         ca=ca+2
         %continue
!-----------------------------------------------------------------------
itype1(3): ! JMP
itype1(4): ! JSR
itype1(27):! BBRx, BBSx
         ca = ca+3
         %continue
!----------------------------------------------------------------------------
itype1(5): ! immediate, direct, index, indir
         ca = ca+2 %and %continue %if pres char='#'
!-------------------------------------------------------------------------
itype1(6): ! direct, index, indir
         %if pres char='(' %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            %if indexed('Y') %start
               ca = ca+3
            %else
               ca = ca+2
            %finish
         %else
            ca = ca+3
         %finish
         %continue
!-------------------------------------------------------------------------
itype1(7): ! rotate, shift
         ca = ca+1 %and %continue %if acc('A')
itype1(8): ! inc, dec
         %if acc('X') %or indexed('X') %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!-----------------------------------------------------------------------
itype1(9): ! cpy, cpx
         ca = ca+2 %and %continue %if pres char='#'
!----------------------------------------------------------------------
itype1(10): ! bit
         %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!-----------------------------------------------------------------------
itype1(11): ! ldx
         %if pres char = '#' %or acc('Y') %or indexed('Y') %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!----------------------------------------------------------------------
itype1(12): ! ldy
         %if pres char='#' %or acc('X') %or indexed('X') %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!----------------------------------------------------------------------
itype1(13): ! stx
         %if acc('Y') %or indexed('Y') %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %finish %else %if indexed('Y') %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!----------------------------------------------------------------------
itype1(14): ! sty
         %if acc('X') %or indexed('X') %start
            ca = ca+2
         %finish %else %if get opd(opd)#0 %or 0<=opd<=255 %start
            ca = ca+2
         %finish %else %if indexed('X') %start
            ca = ca+2
         %else
            ca = ca+3
         %finish
         %continue
!-----------------------------------------------------------------------
itype1(15): ! fcb
         %cycle
            ca = ca+1
            i = get opd(opd) %unless pres char=','
         %repeat %until %not more items
         %continue
!-----------------------------------------------------------------------
itype1(16): ! fdb
         %cycle
            ca = ca+2
            i = get opd(opd) %unless pres char=','
         %repeat %until %not more items
         %continue
!-----------------------------------------------------------------------
itype1(17):! equ
         %unless lid=0 %start
            %if get opd(opd)=0 %start
              %if pass=1 %start
                  %if nass(lid)=1 %start
                     nval(lid) = opd
                     nass(lid) = 3
                  %finish
               %finish %else %if nass(lid)=3 %and opd#nval(lid) %start
                  nval(lid) = opd
                  consistent = consistent+1
               %finish
            %else
               %unless nass(lid)=2 %start
                  nval(lid) = 0
                  nass(lid) = 4
               %finish
            %finish
         %finish
         %continue
!-----------------------------------------------------------------------
itype1(18):! org
         %unless lid=0 %start
            nval(lid) = 0
            nass(lid) = 4
         %finish
         ca = opd %if get opd(opd)=0
         %continue
!-----------------------------------------------------------------------
itype1(19): ! rmb
          ca = ca+opd %if get opd(opd)=0
          %continue
!-----------------------------------------------------------------------
itype1(20):! fcc
         %if '0'<=pres char<='9' %start
            i = lp
            j = 0
            %cycle
               j = j*10+pres char-'0'
               next char
            %repeat %until %not '0'<=pres char<='9'
            %if pres char=',' %start
               ca = ca+j
               %continue
            %finish
            lp = i-1
            next char
         %finish
         %continue %if pres char<' '
         delim = pres char
         next char
         %cycle
            %exit %if pres char=nl
            %if pres char=delim %start
               next char
               %exit %unless pres char=delim
            %finish
            next char
            ca=ca+1
         %repeat
         %continue
!-----------------------------------------------------------------------
itype1(21): ! nam
         %unless lid=0 %start
            nval(lid) = 0
            nass(lid) = 4
         %finish
         %continue %unless headset=0
         headset = 1
         header = ""
         %while pres char#nl %cycle
            header <- header.to string(line(lp))
            next char
         %repeat
         %continue
!-----------------------------------------------------------------------
itype1(22): ! opt
         %cycle
            %if get option(opt) %start
               %if 1<=opt<=2 %start
                  bchar = ' '
               %finish %else %if 3<=opt<=4 %start
                  bchar = -1
               %finish %else %if 18<=opt<=19 %start
                  fflag = 1
               %finish %else %if 20<=opt<=21 %start
                  fflag = 0
               %finish
            %finish
         %repeat %until %not more items
!-----------------------------------------------------------------------
itype1(23): ! page
!-----------------------------------------------------------------------
itype1(24): ! spc
         %unless lid=0 %start
            nval(lid) = 0
            nass(lid) = 4
         %finish
!-----------------------------------------------------------------------
      %repeat
!-----------------------------------------------------------------------
itype1(25): ! end
      %unless lid=0 %start
         nval(lid) = 0
         nass(lid) = 2
      %finish
      %if pass=1 %start
         pass = 2
      %else
         %exit %if consistent=0 %or %c
            (last consistent#0 %and consistent>=last consistent)
      %finish
      last consistent = consistent
      consistent = 0
      reset input
   %repeat
!-----------------------------------------------------------------------
   nline(0)
   reset input
   pass = 3
   ln=0
   ca=0
   old ca = 0
   lid = 0
   bchar = -1
   fflag = 0
   %cycle
      %unless lid=0 %start
         fault("Multiply defined label") %if nass(lid)=2
         %if nass(lid)=1 %and nval(lid)#old ca %start
            fault("Inconsistent label")
            nval(lid) = old ca
         %finish
      %finish
      old ca = ca
      lid = 0
      read line
      non dense = 0
      instr out(0, 0, -4, 0) %and %continue %if pres char='*'
      lid = 0 %unless get name(lid)=0
      next char %while pres char=' '
      %if pres char=nl %start
         instr out(0, 0, -4, 0)
      %finish %else %if get instr(iid) %start
         order = icode(iid)
         mcycles = icycles(iid)
         next char %while pres char=' '
         ->itype2(itype(iid))
      %else
         instr out(0, 0, -4, 0)
         fault("Unknown operation")
      %finish
      %continue
%conststring ceo="Cannot evaluate operand"
!-----------------------------------------------------------------------
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(ceo)
      %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(ceo) %unless i=0
         %continue
      %finish
!---------------------------------------------------------------------------
itype2(4): ! JSR
      i = get opd(opd)
      instr out(order, opd, 3, mcycles)
      fault(ceo) %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(ceo)
            %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(ceo) %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(ceo) %unless i=0
      %else
         instr out(order+12, opd, 3, mcycles+2)
      %finish
      %continue
!-----------------------------------------------------------------------
itype2(26):! RMBx, SMBx [6511] direct
  i = get opd(opd)
  instr out(order,opd,2,mcycles)
  %if i#0 %or opd&255#opd %then fault(ceo)
  %continue
!-----------------------------------------------------------------------
itype2(27):! BBRx, BBSx [6511] direct, relative
  i = get opd(opd)
  j = opd&255
  i = 1 %unless j=opd
  %if more items %start {and there should be}
    %if get opd(opd)#0 %then i = 1 %elsestart
      opd = opd-ca-3; j = opd<<8+j
    %finish
    instr out(order,j,3,mcycles)
    %if i#0 %then fault(ceo) %elsestart
      fault("Branch out of range") %unless -127<=opd<=127
    %finish
  %else
    instr out(order,j,3,mcycles)
    fault("Jump destination missing")
  %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(ceo) %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(ceo) %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(ceo)
      %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(ceo)
         %finish
      %repeat %until %not more items
      %continue
!-----------------------------------------------------------------------
itype2(23): ! page
      %unless lid=0 %start
         instr out(0, 0, -4, 0)
         fault("Illegal label")
      %finish
      nline(lines on page) %unless lflag=0
      %continue
!-----------------------------------------------------------------------
itype2(24): ! spc
      i = get opd(opd)
      %unless lid=0 %start
         instr out(0, 0, -4, 0)
         fault("Illegal label")
      %finish
      %unless lflag=0 %start
         %if i=0 %start
            nline(opd)
         %else
            nline(1)
         %finish
      %finish
!-----------------------------------------------------------------------
   %repeat
!-----------------------------------------------------------------------
itype2(25):! end
   instr out(0, 0, -4, 0)
   fault("Illegal label") %unless lid=0
   %for i = 1, 1, nnames %cycle
      fault("Symbol ".name(i)." has no value") %if nass(i)=0
   %repeat
!-----------------------------------------------------------------------
   %unless xflag=0 %start
      sqs(1, nnames)
      nline(lines on page)
      print string("   Symbol Cross Reference Table")
      nline(2)
      sp3 = (linewidth-6-sp2)//6
      %for i = 1, 1, nnames %cycle
         print string(name(i))
         spaces(7-length(name(i)))
         %if nass(i)=0 %or nass(i)=2 %or nass(i)=4 %start
            print symbol('*') %for j = 1, 1, sp2
         %else
            print number(nval(i), 2)
         %finish
         j = xhead(i)
         k = 0
         %cycle
            l = xlink(j)
            xlink(j) = k
            k = j
            j = l
         %repeat %until j=0
         j = 0
         %cycle
            %if j=sp3 %start
               nline(1)
               spaces(7+sp2)
               j = 0
            %finish
            write(xentry(k), 5)
            j = j+1
            k = xlink(k)
         %repeat %until k=0
         nline(1)
      %repeat
   %finish %else %unless sflag=0 %start
      sqs(1, nnames)
      nline(lines on page)
      print string("  Symbol Table")
      nline(2)
      sp3 = (line width+8-sp2)//15
      sp1 = (linewidth-sp3*15+9-sp2)>>1
      %for j = 1, 1, nnames %cycle
         %if (j-1)=(j-1)//sp3*sp3 %start
            nline(1)
           spaces(sp2)
         %else
            spaces(8-sp2)
         %finish
         print string(name(j))
         spaces(7-length(name(j)))
         %if nass(j)=0 %or nass(j)=2 %or nass(j)=4 %start
            print symbol('*') %for i = 1, 1, sp2
         %else
            print number(nval(j),2)
         %finish
      %repeat
      nline(1)
   %finish
   nline(2)
   spaces(2)
   %if faults=0 %start
      print string("No")
   %else
      write(faults, 0)
   %finish
   print string(" fault")
   print symbol('s') %unless faults=1
   print string(" in this assembly.")
   newline
   select output(0)
   spaces(2)
   %if faults=0 %start
      write(ln, 0)
      print string(" line")
      print symbol('s') %unless ln=1
      print string(" assembled.")
   %else
      write(faults, 0)
      print string(" fault")
      print symbol('s') %unless faults=1
      print string(" in this assembly.")
   %finish
   new line
   close
   %stop
!---------------------------------------------------------------------
   %predicate is typed(%string(255) source, %string(255)%name file)
      %integer i

      %for i = 1, 1, length(source) %cycle
         file = substring(source, 1, i-1) %and %true %if charno(source, i)='.'
      %repeat
      file = source
      %false
   %end
!-------------------------------------------------------
   %predicate matches(%string(255) source, pattern,
                      %integer min, %integer %name i)
      %integer l
      l = length(pattern)
      %if length(pattern)>=length(source) %start
         l = length(source)
      %else
         l = length(pattern)
      %finish
      %for i = 1, 1, l %cycle
         %unless charno(source, i)=charno(pattern, i) %start
            %if 'A'<=charno(source, i)<='Z' %start
               %false
            %finish %else %if i<=min %start
               %false
            %else
               %true
            %finish
         %finish
      %repeat
      i = i+1
      %false %if i<=min
      %true
   %end
!---------------------------------------------------------------------
   %string(255) %function lc(%string(255) source)
      %string(255) result
      %integer i

      result = ""
      %for i = 1, 1, length(source) %cycle
         %if 'A'<=charno(source, i)&127<='Z' %start
            result = result.tostring((charno(source, i)&127)+'a'-'A')
         %else
            result = result.tostring(charno(source, i)&127)
         %finish
      %repeat
      %result = result
   %end
!-----------------------------------------------------------------------
%routine read line
   %integer i
   %on %event 9 %start
      %if i=1 %start
         line(1) = ' '
         line(2) = 'E'
         line(3) = 'N'
         line(4) = 'D'
         line(5) = nl
      %else
         line(i) = nl
      %finish
      -> eof exit
   %finish

   ln=ln+1
   %for i = 1, 1, max line+1 %cycle
      read symbol(line(i))
      %exit %if line(i)&127=nl %or line(i)&127=12
   %repeat
   read symbol(line(i)) %while line(i)&127#nl %and line(i)&255#12
eof exit:
   lp = 0
   next char
%end
!-----------------------------------------------------------------------
%routine next char

   lp = lp+1
   pres char = line(lp)&127
   %if 'a'<=pres char<='z' %start
      pres char = pres char+'A'-'a'
   %finish %else %if pres char=12 %start
      pres char = nl
   %finish %else %if pres char=9 %start
      pres char = ' '
   %finish
%end
!-----------------------------------------------------------------------
%predicate more items

   next char %while pres char=bchar
   %false %unless pres char=','
   next char %until pres char#bchar
   %true
%end
!-----------------------------------------------------------------------
%predicate get option(%integer %name opt)
   %string(11) option

   %if 'A'<=pres char<='Z' %start
      option = to string(pres char)
      %cycle
         next char
         %exit %unless 'A'<=pres char<='Z' %or '0'<=pres char<='9'
         option <- option.to string(pres char)
      %repeat
      %for opt = 1, 1, no options %cycle
         %true %if option text(opt)=option
      %repeat
      opt = -1
      %true
   %else
      opt = 0
      %false %unless pres char=','
      next char
      %true
   %finish
%end
!-----------------------------------------------------------------------
%integerfn get name(%integername nid)
   %string(15) 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>15
   %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' %or '0'<=pres char<='7'
      h=h<<4+pres char-'0'
      i=i.tostring(pres char)
   %repeat
   next char
   %false %if 'A'<=pres char<='Z'
goti: h=h&32767
   h=h-h//ihash*ihash
   l=hilink(h)
   %while l#0 %cycle
      iid=l %and %true %if instr(l)=i
      l=ilink(l)
   %repeat
   %false
%end
!-----------------------------------------------------------------------
%routine evaluate(%integer %name a, %integer b, %byte %integer op)

   %if op='+' %start
      a = a+b
   %finish %else %if op='-' %start
      a = a-b
   %finish %else %if op='*' %start
      a = a*b
   %finish %else %if op='/' %start
      a = a//b
   %finish %else %if op='|' %start
      a = a-a//b*b
   %finish %else %if op='!' %start
      a = a!b
   %finish %else %if op='&' %start
      a = a&b
   %finish %else %if op='\' %start
      a = a!!b
   %finish %else %if op='<' %start
      a = a<<b
   %finish %else %if op='>' %start
      a = a>>b
   %finish
%end
!-----------------------------------------------------------------------
%integer %function get term(%integer %name opd)
   %integer i

   %while pres char='+' %cycle
      next char %until pres char#bchar
   %repeat
   %if pres char='-' %start
      next char %until pres char#bchar
      i = get term(opd)
      opd = -opd
   %finish %else %if pres char='\' %start
      next char %until pres char#bchar
      i = get term(opd)
      opd = \opd
   %finish %else %if pres char='(' %start
      next char %until pres char#bchar
      i = get expression(opd)
      %if i=0 %start
         next char %while pres char=bchar
         %if pres char=')' %start
            next char
         %else
            i = 0
         %finish
      %finish
   %finish %else %if get name(i)=0 %start
      %if pass=1 %or nass(i)=1 %or nass(i)=3 %start
         opd = nval(i)
         i = 0
      %else
         i = 1
      %finish
   %else
      i = get const(opd)
   %finish
   %result = i
%end
!-----------------------------------------------------------------------
%integer %function get expression(%integer %name opd)
   %integer sp, prio, i
   %byte %integer %array op stk, prio stk(1:5)
   %integer %array opd stk(0:5)

   %result = 1 %unless get term(opd stk(0))=0
   sp = 0
   i = 0
   %cycle
      next char %while pres char=bchar
      %if pres char='!' %or pres char='\' %start
         prio = 0
      %finish %else %if pres char='&' %start
         prio = 1
      %finish %else %if pres char='+' %or pres char='-' %start
         prio = 2
      %finish %else %if pres char='*' %or pres char='/' %or %c
            pres char='|' %start
         prio = 3
      %finish %else %if pres char='<' %or pres char='>' %start
         prio = 4
      %else
         %exit
      %finish
      %while sp>0 %and prio stk(sp)>=prio %cycle
         evaluate(opd stk(sp-1), opd stk(sp), op stk(sp))
         sp = sp-1
      %repeat
      sp = sp+1
      op stk(sp) = pres char
      prio stk(sp) = prio
      next char %until pres char#bchar
      %unless get term(opd stk(sp))=0 %start
         sp = sp-1
         i = 1
         %exit
      %finish
   %repeat
   evaluate(opd stk(sp-1), opd stk(sp), op stk(sp)) %for sp = sp, -1, 1
   opd = opd stk(0) %if i=0
   %result = i
%end
!-----------------------------------------------------------------------
%integer %function get opd(%integername opd)
   %integer nid,op,cval

   %result = get expression(opd) %unless fflag=0
   opd=0
   %if pres char='+' %or pres char='-' %start
      op = pres char
      next char %until pres char#bchar
   %else
      op = '+'
   %finish
   %cycle
      %if get name(nid)=0 %start
         %result=1 %unless pass=1 %or nass(nid)=1 %or nass(nid)=3
         cval=nval(nid)
      %else
         %result=1 %if get const(cval)#0
      %finish
      evaluate(opd, cval, op)
      next char %while pres char=bchar
      op = pres char
      %result=0 %unless op='+' %or op='-' %or op='*' %or op='/'
      next char %until pres char#bchar
   %repeat
%end
!-----------------------------------------------------------------------
%integerfn get const(%integername cval)
   %integer started, dig val, bin val, oct val, hex val,
      bin pos, oct pos, dec pos

   started=1
   %if pres char='*' %start
      next char
      cval = ca
      %result = 0
   %finish
   cval=0
   %if '0'<=pres char<='9' %start    ;! decimal
      bin pos = 0
      oct pos = 0
      dec pos = 0
      bin val = 0
      oct val = 0
      hex val = 0
      %cycle
         %if bin pos=0 %and pres char='B' %start
            next char
            %if '0'<=pres char<='9' %or 'A'<=pres char<='F' %or %c
                  pres char='H' %start
               bin pos = 1
               oct pos = 1
               dec pos = 1
               hex val = (hex val<<4)+11
            %else
               cval = bin val
               %result = 0
            %finish
         %finish
         %if oct pos=0 %and (pres char='O' %or pres char='Q') %start
            cval = oct val
            next char
            %result = 0
         %finish %else %if pres char='H' %start
            cval = hex val
            next char
            %result = 0
         %finish %else %if 'A'<=pres char<='F' %start
            dig val = pres char-'A'+10
         %finish %else %if '0'<=pres char<='9' %start
            dig val = pres char-'0'
         %else
            %result = dec pos
         %finish
         bin pos = 1 %if dig val>1
         oct pos = 1 %if dig val>7
         dec pos = 1 %if dig val>9
         bin val = (bin val<<1)+dig val
         oct val = (oct val<<3)+dig val
         cval = cval*10+dig val
         hex val = (hex val<<4)+dig val
         next char
      %repeat
   %finish
   %if pres char='$' {*temp %or preschar='&' temp*} %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(ceo)
   %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(ceo) %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(ceo) %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 MCS6511Q 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}15) 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(15) name key

   %return %unless l<r
   %while r-l>insert limit %cycle
      lp = l
      rp = r+1
      name key = name(l)
      nass key = nass(l)
      nval key = nval(l)
      xhead key = xhead(l)
      %cycle
         rp = rp-1 %until rp=lp %or name key>name(rp)
         %exit %if lp=rp
         name(lp) = name(rp)
         nass(lp) = nass(rp)
         nval(lp) = nval(rp)
         xhead(lp) = xhead(rp)
         lp = lp+1 %until rp=lp %or name key<=name(lp)
         %exit %if lp=rp
         name(rp) = name(lp)
         nass(rp) = nass(lp)
         nval(rp) = nval(lp)
         xhead(rp) = xhead(lp)
      %repeat
      name(lp) = name key
      nass(lp) = nass key
      nval(lp) = nval key
      xhead(lp) = xhead key
      %if lp-l>r-rp %start
         sqs(rp+1, r)
         r = lp-1
      %else
         sqs(l, lp-1)
         l = rp+1
      %finish
   %repeat
   %for rp = l+1, 1, r %cycle
      name key = name(rp)
      nass key = nass(rp)
      nval key = nval(rp)
      xhead key = xhead(rp)
      lp = l
      lp = lp+1 %while lp#rp %and name key>name(lp)
      %for i = rp-1, -1, lp %cycle
         name(i+1) = name(i)
         nass(i+1) = nass(i)
         nval(i+1) = nval(i)
         xhead(i+1) = xhead(i)
      %repeat
      name(lp) = name key
      nass(lp) = nass key
      nval(lp) = nval key
      xhead(lp) = xhead key
   %repeat
%end
!-----------------------------------------------------------------------
%end %of %program
