%include "inc:util.imp" {for PAM}

%begin  {ARM assembler - RWT October 1988}

%constinteger -
  mincond=1,maxcond=18,
  mincode=19,
  and=19,eor=20,sub=21,rsb=22,add=23,adc=24,sbc=25,rsc=26,
  tst=27,teq=28,cmp=29,cmn=30,orr=31,mov=32,bic=33,mvn=34,
  mul=35,mla=36,str=37,ldr=38,stm=39,ldm=40,swi=41,b=42,bl=43,
  end=44,org=45,data=46,
  maxcode=46,
  minshift=47,maxshift=51,rrx=52,
  minmulti=53,maxmulti=60,
  minop=61,star=68,maxop=70,
  predeflim=70

%constinteger codelimit = 4096 {words}
%integerarray code buffer(0:codelimit-1)
%integer lineno=0, pass, origin, codepointer, pos, i,j,k
%string(255)source,binary="",listing="",line="",item,label,message=""

%routine parterror(%string(255)s)
! Accumulate an error message
  message = message.s %unless pass=1
%end

%routine error(%string(255)s)
! Output an error message.
! NB error lines in the listing appear BEFORE the line to which they refer.
! On the report stream the offending line is printed first (but once only).
%owninteger errorline=0
%integer o
  %returnif pass=1
  s = message.s; message = ""
  %for o = 0,1,1 %cycle
    selectoutput(o)
    %if o=0 %and errorline#lineno %start
      errorline = lineno
      write(lineno,3); space; printstring(line); newline
    %finish
    write(lineno,3); printstring(" ** "); printstring(s); newline
  %repeat
%end

%routine printline(%integer which,n2,n1)
! Print a "normal" line to the listing file.
! Bits in WHICH determine which of the numbers N2 and/or N1 should be printed.
  %returnunless pass=2
  write(lineno,3)
  %if which&2#0 %start
    space; phex(n2)
  %elseif which&1#0 %or line#""
    spaces(9)
  %finish
  %if which&1#0 %start
    space; phex(n1)
    space %if line#""
  %elseif line#""
    spaces(10)
  %finish
  printstring(line)
  newline
%end

! Symbol table management

%constinteger symbol limit = 1000, char limit = 6000, hash mask = 31
%recordformat hash fm (%integer next,index,value)
%bytearray char store (1:char limit)
%record(hash fm)%array cell(1:symbol limit)
%integerarray hash table(0:hash mask)

%integerfn encode(%string(255)s,%integer add,value)
! Code S as a dense number (i.e. the first name will encode as 1,
! the next as 2, etc).  If the name is already in the symbol table,
! return the number already allocated to it.
! ADD#0:  Insert symbol if not there, check value if there already.
! ADD=0:  Lookup only.
%record(hash fm)%name c
%integer cno,k,i,hashval = 0
%owninteger charpos = 1, freelist = 1
  %if charpos+length(s)+1>charlimit %start
    error("Too many long symbols")
    %result = freelist-1
  %finish
  charstore(charpos) = length(s)
  %for i = 1,1,length(s) %cycle
    k = charno(s,i)
    charstore(charpos+i) = k
    hashval = hashval<<1!!k
  %repeat
  hashval = hashval&hashmask
  k = length(s)
  cno = hashtable(hashval)
  %while cno#0 %cycle
    c == cell(cno)
    %if charstore(c_index)=k %start
      i = k
      %cycle
        %if i=0 %start
          %if add>0 %and c_value#value %start
            %if cno<=predeflim %start
              parterror("Cannot redefine built-in symbol ")
            %else
              parterror("Discrepancy "); parterror(itos(value-c_value,0))
              parterror(" for symbol ")
            %finish
            error(s)
          %finish
          %result = cno
        %finish
        %exitunless charstore(c_index+i)=charstore(charpos+i)
        i = i-1
      %repeat
    %finish
    cno = c_next
  %repeat
  %result = -1 %if add=0
  cno = freelist
  %if cno>symbollimit %start
    error("Symbol table full")
    %result = cno-1
  %finish
  c == cell(cno); freelist = freelist+1
  c_next = hashtable(hashval); hashtable(hashval) = cno
  c_index = charpos; c_value = value
  charpos = charpos+k+1
  %result = cno
%end

%routine setup symbol table
! Initialise the raw table and then insert the prefdefined symbols
! into it.  The dense encoding scheme means we know what codes each
! of the symbols will have, and these are used later on.
%integer i
  %routine insert(%string(5)s,%integer v)
    i = encode(s,1,v)
  %end
  hashtable(i) = 0 %for i = 0,1,hashmask
! Condition codes
  insert("EQ",16_00000000); insert("NE",16_10000000)
  insert("CS",16_20000000); insert("CC",16_30000000)
  insert("HS",16_20000000); insert("LO",16_30000000)  {alternatives}
  insert("MI",16_40000000); insert("PL",16_50000000)
  insert("VS",16_60000000); insert("VC",16_70000000)
  insert("HI",16_80000000); insert("LS",16_90000000)
  insert("GE",16_A0000000); insert("LT",16_B0000000)
  insert("GT",16_C0000000); insert("LE",16_D0000000)
  insert("AL",16_E0000000); insert("NV",16_F0000000)
! Opcodes
  insert("AND",16_00000000); insert("EOR",16_00200000)
  insert("SUB",16_00400000); insert("RSB",16_00600000)
  insert("ADD",16_00800000); insert("ADC",16_00A00000)
  insert("SBC",16_00C00000); insert("RSC",16_00E00000)
  insert("TST",16_01000000); insert("TEQ",16_01200000)
  insert("CMP",16_01400000); insert("CMN",16_01600000)
  insert("ORR",16_01800000); insert("MOV",16_01A00000)
  insert("BIC",16_01C00000); insert("MVN",16_01E00000)
  insert("MUL",16_00000090); insert("MLA",16_00200090)
  insert("STR",16_04000000); insert("LDR",16_04100000)
  insert("STM",16_08000000); insert("LDM",16_08100000)
  insert("SWI",16_0F000000)
  insert("B",16_0A000000); insert("BL",16_0B000000)
! Miscellaneous directives
  insert("END",0); insert("ORG",0); insert("DATA",0)
! Shift codes
  insert("LSL",0);  insert("LSR",32)
  insert("ASR",64); insert("ROR",96)
  insert("ASL",0);  insert("RRX",96)
! STM/LDM suffices
  insert("DA",16_0000000); insert("IA",16_0800000)
  insert("DB",16_1000000); insert("IB",16_1800000)
  insert("ED",16_0000000); insert("EA",16_0800000)
  insert("FD",16_1000000); insert("FA",16_1800000)
! Operators for literal expressions
  insert("+",0); insert("-",1); insert("&",2); insert("!",3)
  insert("!!",4); insert("<<",5); insert(">>",6)
  insert("*",7); insert("/",8); insert("%",9)
! Ordinary symbols, beginning with register names
  insert("R0",0);    insert("R1",1);    insert("R2",2);    insert("R3",3)
  insert("R4",4);    insert("R5",5);    insert("R6",6);    insert("R7",7)
  insert("R8",8);    insert("R9",9);    insert("R10",10);  insert("R11",11)
  insert("R12",12);  insert("R13",13);  insert("R14",14);  insert("R15",15)
  insert("PC",15);   insert("LINK",14)
%end

%integerfn valof(%integer cellno)
  %result = cell(cellno)_value
%end

%integerfn value
! Returns the value of ITEM.
! ITEM is either a literal number or a symbol.
%integer n=0,b=10,m,k,l=length(item),p=1
  k = charno(item,p)
  %if '0'<=k<='9' %start
    %if charno(item,l)='H' {"Standard" grotty hex notation} %start
      b = 16; l = l-1
    %finish
    m = '0'+b-1
    m = m+7 %if b>10
    %cycle
      n = n*b-'0'+k; p = p+1; %exitif p>l; k = charno(item,p)
      %if k='_' %start    {preferred notation for arbitrary radix}
        b = n
        m = '0'+b-1
        m = m+7 %if b>10
        n = 0; k = '0'
      %elseif k<'0' %or k>m %or '9'<k<'A'
        parterror("Dubious digit "); parterror(tostring(k))
        parterror(" in number "); error(item)
        %exit
      %else
        k = k-7 %if k>'9'
      %finish
    %repeat
    %result = n
  %finish
  k = encode(item,0,0)
  %if k<=predeflim %start
    %result = codepointer<<2+origin %if k=star
    %if k<0 %start
      parterror("Unknown symbol ")
    %else
      parterror("Inappropriate context for symbol ")
    %finish
    error(item)
    %result = 0
  %finish
  %result = valof(k)
%end

%routine readline
! Increment the line number, then read a new line from the
! source file into string LINE (the NL is not put into the string).
! Set POS to 1 for subsequent scanning.
%integer k
  lineno = lineno+1
  line = ""
  %cycle
    readsymbol(k); %exitif k=nl
    line = line.tostring(k)
  %repeat
  pos = 1
%end

%integerfn getsym
! Read one character out of the stored line, advancing POS past it.
! Return -1 if off end.
  %result = -1 %if pos>length(line)
  pos = pos+1; %result = charno(line,pos-1)
%end

%predicate nextis(%integer k)
! If the next character on the line is K, skip it and return true.
! Ignore spaces (unless K=' ').
! If K=';' we are testing for either start of comment or end of line.
  %unless k=' ' %start
    pos = pos+1 %while pos<=length(line) %and charno(line,pos)=' '
  %finish
  %if pos>length(line) %start
    %trueif k=';'; %false
  %finish
  %falseunless charno(line,pos)=k
  pos = pos+1; %true
%end

%routine expect(%integer e)
! The next character on the line should be E.  If it isn't, report
! everything we encounter until E or end-of-line as spurious.
%integer k
  %returnif nextis(e)
  k = getsym
  %unless k<0 %start
    parterror("Spurious """)
    %cycle
      parterror(tostring(k)); k = getsym
    %repeatuntil k=e %or k<0
    error("""") %andreturnif e=';'
    parterror(""" when ")
  %finish
  parterror(""""); parterror(tostring(e))
  error(""" expected")
%end

%routine getitem
! Read into ITEM a string of alphanumerics (upper case, including '_')
! or a single non-alphanumeric symbol or one of the double symbols
! "!!" or "<<" or ">>" or "//".  Spaces are ignored.
! Return with ITEM="" if nothing relevant remains on line.
%integer k
  item = ""
  k = getsym %until k#' '        {skip spaces}
  pos = pos-1 %andreturnif k=';' {comment reached}
  %returnif k<0                  {end of line reached}
  %while 'a'<=k!32<='z' -
  %or '0'<=k<='9' -
  %or k='_' %cycle               {accumulate item}
    k = k-32 %if 'a'<=k<='z'     {force upper case}
    item = item.tostring(k)
    k = getsym
  %repeat
  %if item="" %start             {first K was non-alphanumeric}
    item = tostring(k)
    %if (k='!' %or k='/' %or k='<' %or k='>') -
    %and nextis(k) %start        {double symbol}
      item = item.tostring(k) %unless k='/'
    %finish
  %else
    pos = pos-1 %unless k<0
  %finish
%end

%predicate begins(%integer k)
! If ITEM begins with K, strip it off and return TRUE.
  %falseif item="" %or charno(item,1)#k
  item = substring(item,2,length(item))
  %true
%end

%integerfn expr {accumulate literal expression}
! NB operator precedence strictly left to right, an initial
! minus or not sign is allowed and applies to the first item only.
%integer val1,val2,op
%conststring junk="Literal expected"
%switch sw(minop:maxop)

  %integerfn thing
  ! Read either a quoted (multi-)character or other literal or a symbol.
  %integer val,k
    %if nextis('''') %start
      val = 0
      %cycle
        k = getsym
        %if k<0 %start
          expect(''''); %result = val
        %finish
        %if k='''' %start
          %result = val %unless nextis(k)
        %finish
        val = val<<8+k
        %if val&16_ff000000#0 %start
          expect(''''); %result = val
        %finish
      %repeat
    %finish
    getitem
    %if item="" %or item="," %start
      pos = pos-1 %unless item=""
      error(junk)
      %result = 0
    %finish
    %result = value
  %end

  %if nextis('-') %start
    val1 = -thing
  %elseif nextis('\')
    val1 = \thing
  %finishelse val1 = thing
  %cycle
    getitem
    %result = val1 %if item=""
    op = encode(item,0,0)
    %if minop<=op<=maxop %start
      val2 = thing
      ->sw(op)
    %finish
    pos = pos-length(item)
    %result = val1
sw(minop+0): val1 = val1+val2; %continue
sw(minop+1): val1 = val1-val2; %continue
sw(minop+2): val1 = val1&val2; %continue
sw(minop+3): val1 = val1!val2; %continue
sw(minop+4): val1 = val1!!val2; %continue
sw(minop+5): val1 = val1<<val2; %continue
sw(minop+6): val1 = val1>>val2; %continue
sw(minop+7): val1 = val1*val2; %continue
sw(minop+8): val1 = val1//val2; %continue
sw(minop+9): val1 = rem(val1,val2)
  %repeat
%end

%integerfn register
! Read a literal or symbol, expecting it to be in the range 0-15.
%integer r
  getitem
  %if item="," %start
    pos = pos-1; item = ""
  %finish
  %if item="" %start
    error("Register expected"); %result = 0
  %finish
  r = value
  %result = r %if r=r&15
  parterror("Register "); parterror(itos(r,0)); error("?")
  %result = 0
%end

%integerfn registerlist
! Read a single register or a list enclosed in {}.
! Within the list individual registers are separated by commas,
! register ranges are indicated by separating two register names with a dash.
%integer list=0,r1,r2,t
  %result = 1<<register %unless nextis('{')
  %cycle
    r1 = register; r2 = r1
    r2 = register %if nextis('-')
    %if r1>r2 %start
      t = r1; r1 = r2; r2 = t
    %finish
    r1 = 1<<r1; r2 = 1<<r2
    %cycle
      list = list!r1; %exitif r1=r2
      r1 = r1<<1
    %repeat
  %repeatuntilnot nextis(',')
  expect('}')
  %result = list
%end

%integerfn shift(%integer full)
! FULL=0:  Read SHIFTSPEC (disallowing version with shift count in register)
! FULL#0:  Read  REGISTER  COMMA  SHIFTSPEC
%integer m,t,s
  %unless full=0 %start
    m = register
    %result = m %unless nextis(',')
  %finishelse m=0
  getitem
  t = encode(item,0,0)
  %result = m+valof(t) %if t=rrx
  %if minshift<=t<=maxshift %start
    t = valof(t)
    %if nextis('#') %start  {literal shift count}
      s = expr
      %if s<0 %or s>32 %start
        error("Invalid shift count")
        s = s&31
      %elseif s=0 %and t#0
        error("Warning: shift type changed to LSL")
        t = 0
      %elseif s=32
        s = 0
        %if t=96 {ror} %start
          error("Warning: ROR #32 changed to LSL #0")
          t = 0
        %elseif t=0
          error("Warning: LSL #32 means LSL #0")
        %finish
      %finish
      %result = m+t+s<<7
    %finish                   {otherwise shift count in register}
    %if full=0 %start
      error("Shift count cannot be register in this context")
      %result = m+t
    %finish
    s = register
    %result = m+t+s<<8+16
  %finish
  error("Shift type expected")
  %result = m
%end

%integerfn operand
! Read operand for DP instructions: 8 bit rotated literal or shifted register
%integer imm,rot=0
  %if nextis('#') %start
    imm = expr
    %cycle
      %exitif imm=imm&255
      imm = imm<<2+imm>>30; rot = (rot+1)&15
      %if rot=0 %start
        parterror(itos(imm,0))
        error(" is not a suitable immediate value")
        imm = 0; %exit
      %finish
    %repeat
    %result = 1<<25+rot<<8+imm
  %finish
  %result = shift(1)
%end

%integerfn address(%integer must be postinc)
! Read address for LDR/STR instruction: PC-relative label
! or pre-indexed:   [R{,{#expr|{+|-|}R{,shift}}]{!}
! or post-indexed:  [R],{#expr|{+|-|}R{,shift}}
%conststring wrongmode="T suffix requires post-increment mode"
%integer m,n,o

  %routine offset
    %if nextis('#') %start    {immediate offset}
      o = expr
      o = o-8 %if n>>16&15=15
    %else                     {register offset}
      n = n+1<<25
      %unless nextis('-') %start
        n = n+1<<23
        %if nextis('+') %start; %finish
      %finish
      m = register
      o = shift(0) %if nextis(',')
    %finish
  %end

  m = 0; o = 0
  %unless nextis('[') %start    {PC relative label}
    error(wrongmode) %unless mustbepostinc=0
    n = 16_10F0000
    o = expr-codepointer<<2-8-origin
  %else                         {otherwise indexed}
    n = register<<16
    %if nextis(',') %start      {pre-indexed with nonzero offset}
      error(wrongmode) %unless mustbepostinc=0
      n = n+1<<24
      offset
      expect(']')
      n = n+1<<21 %if nextis('!')
    %else                       {post-indexed (or pre with zero offset)}
      expect(']')
      %if nextis(',') %start    {post-indexed}
        offset
      %elseif mustbepostinc=0   {zero offset}
        n = n+1<<24
      %finish
    %finish
  %finish
  %if n&1<<25=0 %start
    %unless |o|<=16_FFF %start
      parterror("Offset "); parterror(itos(|o|,0)); error(" too big")
    %finish
    %if o<0 %then o = -o %else n = n+1<<23
  %finish
  %result = o&16_FFF+n+m
%end

%integerfn condition(%integer default)
! Strip the (by now leading) condition code characters off the opcode.
! Return the appropriate result if a valid condition was recognised.
! Otherwise return DEFAULT, which is either ALWAYS or INVALID.
%integer x
  %result = default %if length(item)<2
  x = encode(substring(item,1,2),0,0)
  %result = default %unless mincond<=x<=maxcond
  item = substring(item,3,length(item))
  %result = valof(x)
%end

%routine suffix
! Ensure all characters in the opcode mnemonic have been used up.
  %returnif item=""
  parterror("Spurious opcode suffix "); error(item)
%end

%routine assemble line
%constinteger invalid=1,always=16_E0000000,never=16_F0000000,CCbit=1<<20
%constinteger Lbit=CCbit,Wbit=1<<21,BSbit=1<<22
%integer op,cond,d,s,m,n
%switch sw(mincode:maxcode)
  %unless nextis(' ') %start         {maybe label}
    getitem
    %if item="" %start               {no: blank line or comment only}
      printline(0,0,0)
      %return
    %finish
    label = item
    %if nextis('=') %start           {literal definition}
      %if label="*" %start           {Setting origin}
sw(org):op = expr
        %if origin!codepointer=0 %start
          error("Origin must be word-aligned") %if op&3#0
          origin = op
        %else
          error("Origin can only be defined at beginning")
        %finish
      %else
        op = valof(encode(label,1,expr))
      %finish
      expect(';')
      printline(1,0,op)
      %return
    %finish
    %if nextis(':') %start; %finish  {label definition}
    op = encode(label,1,codepointer<<2+origin)
  %finish
  getitem
  %if item="" %start                 {null statement}
    printline(0,0,0)
    %return
  %finish
  cond = invalid
  op = encode(item,0,0)
  %if mincode<=op<=maxcode %start
    cond = always; item = ""
  %elseif length(item)=3 %and charno(item,1)='B'
    item = substring(item,2,3)
    cond = condition(invalid)
    op = b
  %elseif length(item)=4 %and substring(item,1,2)="BL"
    item = substring(item,3,4)
    cond = condition(invalid)
    op = bl
  %elseif length(item)>3                                {basic opcode}
    op = encode(substring(item,1,3),0,0)
    %if mincode<=op<maxcode %start
      item = substring(item,4,length(item))
      cond = condition(always)
    %finish
  %finish
  %if cond=invalid %start
    parterror("Unrecognised opcode "); error(item)
    cond = never; op = 16_0FFAECE5 {SWINV any-old-rubbish}
    ->done
  %finish
  ->sw(op)
sw(and):sw(eor):sw(sub):sw(rsb):
sw(add):sw(adc):sw(sbc):sw(rsc):
sw(orr):sw(bic):
  op = valof(op)
  op = op+CCbit %if begins('S')
  suffix; d = register<<12; expect(',')
binary:
  n = register<<16
unary:
  expect(',')
  op = op+d+n+operand
  ->done
sw(tst):sw(teq):sw(cmp):sw(cmn):
  op = valof(op)!CCbit
  %if begins('S') %start; %finish
  d = 0; d = 16_F000 {%and op = op!CCbit} %if begins('P')
  suffix; ->binary
sw(mov):sw(mvn):
  op = valof(op)
  op = op!CCbit %if begins('S')
  suffix; d = register<<12
  n = 0; ->unary
sw(mul):sw(mla):
  op = valof(op)
  op = op!CCbit %if begins('S')
  suffix; d = register
  expect(','); m = register
  expect(','); s = register
  n = 0
  %if op&Wbit#0 %start
    expect(','); n = register
  %finish
  %if d=15 %start
    error("Destination must not be PC")
  %elseif d=m
    %if d=s %start
      error("Destination must differ from first operand")
    %else
      m = s; s = d
      error("Warning: source operands switched round")
    %finish
  %finish
  op = op+((d<<4+n)<<4+s)<<8+m
  ->done
sw(str):sw(ldr):
  op = valof(op)
  op = op!BSbit %if begins('B')
  op = op!Wbit %if begins('T')
  suffix
  op = op+register<<12
  expect(',')
  op = op+address(op&Wbit)
  ->done
sw(stm):sw(ldm):
  op = valof(op)
  %if length(item)<2 %then d = 0 %else d = encode(substring(item,1,2),0,0)
  %if minmulti<=d<=maxmulti %start
    op = op!!16_1800000 %if op&Lbit#0 %and d-minmulti>=4
    op = op!!valof(d)
    item = substring(item,3,length(item))
  %elseif item=""
    error("Suffix expected")
  %else
    parterror("Unrecognised suffix "); error(item)
  %finish
  op = op+register<<16
  op = op+Wbit %if nextis('!')
  expect(',')
  op = op+registerlist
  op = op!BSbit %if nextis('^')
  ->done
sw(swi):
  suffix
  op = expr&16_ffffff+valof(op)
  ->done
sw(b):sw(bl):
  suffix
  d = expr-codepointer<<2-8-origin
  error("Destination must be word-aligned") %unless d&3=0
  error("Destination too far") %unless -16_4000000<=d<=16_3fffffc
  op = d>>2&16_ffffff+valof(op)
  ->done
sw(end):
  expect(';')
  printline(2,codepointer<<2,0)
  %signal 9
sw(data):
  cond = 0; op = expr
done:
  op = op+cond
  expect(';')
  printline(3,codepointer<<2+origin,op)
  codebuffer(codepointer) = op
  codepointer = codepointer+1
%end

%routine extend(%string(255)%name s,%string(3)x)
%string(255)aft,temp
  temp = s
  temp = aft %while temp -> (":").aft
  s = s.".".x %unless s -> (".").aft
%end

! Acquire parameters

  defineparam("Source file",source,pamnodefault)
  defineparam("Binary file",binary,pamnewgroup)
  defineparam("Listing file",listing,0)
  processparameters(cliparam)
  binary = source.".obj" %if binary=""
  listing = source.".lis" %if listing=""
  extend(source,"arm")
  extend(binary,"obj")
  extend(listing,"lis")

! Initialise

  pass = 0
  setup symbol table

! Process source file twice

  openinput(1,source); selectinput(1)

  %begin
    %on 9 %start
      %if pass=2 %start
        closeoutput
        %return
      %finish
      resetinput
      openoutput(1,listing); selectoutput(1)
    %finish
    pass = pass+1; codepointer = 0; origin = 0; lineno = 0
    %cycle
      read line
      assemble line
    %repeat
  %end

! Output code buffer

  openoutput(1,binary); selectoutput(1)
  %for i = 0,1,codepointer-1 %cycle
    k = code buffer(i)
    printsymbol(k>>j&255) %for j = 24,-8,0
  %repeat

%end