%routine Machine Code
   %include "inc.MTABLES"
   %integer Op Num, Op Type, Op Value=0, Op Length
   %integer Operands, N, J, Key, P, X = 0, SymP, Disp
   %integer Rn, Rd, Rs, Rm, Sh, Rot, Ud, Reg1, Reg2
   %integer Fdst, Fs1, Fs2
   %string(7)  Op String
   %record(Varfm)%name W
   %switch Ot(-1:10)

   %routine Mc Error(%string(127) Text)
      %routine Err(%integer Stream)
         Select Output(Stream)
         Printstring("*");  Write(Current Line, 4)
         Printstring(" ".Op String.": ".Text)
         Newline
      %end
      Err(Listing)                                {listing}
      Err(Report)                                 {terminal}
      Fail("Bang") %if Diag&Mon Bang # 0
      Interface_Faults = Interface_Faults+1
      Select Output(Directives Out)
      %signal 14
   %end

   %routine Find Opcode
      %integer Min, Max, P
      %string(4) Key
      Key = 0
      Op Length = Length(Op String)
      %if Op Length <= 3 %start
         SymP = Op Length
         Key = Op String
      %else
         SymP = 3
         Key = Charno(Op String, 1).Charno(Op String, 2).Charno(Op String, 3)
         %if Charno(Op String, 1) = 'B' %and Charno(Op String, 2) = 'L' -
                                        %and Op Length >= 4 %start
            Key = Key.Charno(Op String, 4)
            SymP = 4
         %finish
      %finish
      Min = 1;  Max = Max Opcode
      %while Min <= Max %cycle
         P =(Min+Max)>>1
         %if Opcode(P) = Key %start
            Op Num = P;  Op Type = Type(Op Num);  Op Value = Value(Op Num)
            %return
         %finish
         %if Key > Opcode(P) %then Min = P+1 %else Max = P-1
      %repeat
      %if Op String = "BYTE" %or Op String = "BYTE1" %start
         Op Num = -1;  Op Type = -1;  SymP = OpLength
      %else %if Op String = "BYTE2"
         Op Num = -2;  Op Type = -1;  SymP = OpLength
      %else %if Op String = "BYTE4"
         Op Num = -3;  Op Type = -1;  SymP = OpLength
      %finish %else Mc Error("unknown opcode")
   %end

   %predicate Match(%integer Wanted)
      %false %unless Pending = Wanted
      Readsymbol(Pending)
      %true
   %end

   %predicate PMatch(%integer Wanted)
      %false %unless Pending = Wanted ! 128
      Readsymbol(Pending)
      %true
   %end

   %predicate Literal(%integername N)
      %if Match('N') %start
         N = Four Bytes
         %true
      %finish
      %if Match(128+'b') %start
         N = Pending;  Readsymbol(Pending)
         %true
      %finish
      %false %unless Match('-')
      Mc Error("constant expected") %unless Literal(N)
      N = -N
      %true
   %end

   %routine Want(%integer Sym)
      Mc Error(Tostring(Sym)." expected") %unless Match(Sym)
   %end

   %routine Want Literal(%integername N)
      Mc Error("constant expected") %unless Literal(N)
   %end

   %routine Register(%integername R)
      Mc Error("Register expected") %unless Literal(R) %and 0 <= R <= 15
   %end

   %routine F Register(%integername R)
      Mc Error("Floating register expected") %unless Literal(R) -
                                                %and 16+0 <= R <= 16+7
   %end

   %routine Set CC
      %constintegerarray CC(0:15) =
               'E'<<8 ! 'Q', 'N'<<8 ! 'E', 'C'<<8 ! 'S', 'C'<<8 ! 'C',
               'M'<<8 ! 'I', 'P'<<8 ! 'L', 'V'<<8 ! 'S', 'V'<<8 ! 'C',
               'H'<<8 ! 'I', 'L'<<8 ! 'S', 'G'<<8 ! 'E', 'L'<<8 ! 'T',
               'G'<<8 ! 'T', 'L'<<8 ! 'E', 'A'<<8 ! 'L', 'N'<<8 ! 'V'
      %integer Sym, C
      %if SymP+1 < Op Length %start
         Sym = Charno(Op String, SymP+1)<<8 ! Charno(Op String, SymP+2)
         %for C = 0, 1, 15 %cycle
            %if CC(C) = Sym %start
               Op Value = Op Value ! C<<28
               SymP = SymP+2
               %return
            %finish
         %repeat
      %finish
      Op Value = Op Value ! 16_E000 0000   {default to always}
   %end

   %routine Comma
      Mc Error("comma missing") %unless Match(',')
   %end

   %predicate Omatch(%integer Sym)
      %false %unless SymP < Op Length %and Charno(Op String, SymP+1) = Sym
      SymP = SymP+1
      %true
   %end

   %on 14 %start
      Readsymbol(Pending) %while Pending # ';'
   %else
      Op String = ""
      %while Pending # '_' %cycle
         Op String = Op String.Tostring(Pending) %if Length(Op String) # 7
         Readsymbol(Pending)
      %repeat
      Readsymbol(Pending)
      Find Opcode
      Set CC %if Op Type > 0 {funnies} %and Op Type # 5 {branch}
      ->Ot(Op Type)

   {data processing}

      %constbytearray Litsh(1:4) = 2_100 0000, 2_000 0000,
                                   2_010 0000, 2_110 0000

      %constbytearray Regsh(1:4) = 2_101 0000, 2_001 0000,
                                   2_011 0000, 2_111 0000

      %routine Bad Shift
         Mc Error("unknown type of shift")
      %end

      %routine Get Shift
         %integer Sh
         %if PMatch('A') %start
            %if PMatch('S') %and PMatch('R') %start
               Sh = 1
            %else
               Bad Shift
            %finish
         %else %if PMatch('L')
            %if PMatch('S') %start
               %if PMatch('L') %start
                  Sh = 2
               %else %if PMatch('R')
                  Sh = 3
               %else
                  Bad Shift
               %finish
            %else
               Bad Shift
            %finish
         %else %if PMatch('R')
            %if PMatch('R') %start
               Bad Shift %unless PMatch('X')
               Sh = 0
            %else %if PMatch('O') %and PMatch('R')
               Sh = 4
            %else
               Bad Shift
            %finish
         %else
            Bad Shift
         %finish
         %if Sh = 0 %start
            Op Value = Op Value ! 2_00000 110 <<4   {RRX}
         %else %if Match('#')
            Want Literal(N) 
            Mc Error("shift out of range") %unless 0 <= N <= 32
            Op Value = Op Value ! (N&31)<<7 ! litsh(Sh)
         %else
            Register(Rs)
            Op Value = Op Value ! Rs<<8 ! regsh(Sh)
         %finish
      %end

Ot(1):Key = Op Value>>23&3
      N = Op Value>>21&15
      Rn = 0;  Rd = 0;  Rm = 0; Rs = 0
      %if Omatch('S') %start
         Op Value = Op Value ! 1<<20
      %finish
      %if Omatch('P') %start
         Warn(1, "spurious P qualifier") %unless Key = 2_10
         Rd = 15
      %finish
      Register(Rn)
      %if Key # 2_10 %start
         Rd = Rn;  Rn = 0
         %if N # 13 %and N # 15 %start
            Comma
            Register(Rn)
         %finish
      %finish
      Op Value = Op Value ! Rd<<12 ! Rn<<16
      Comma
      %if Match('#') %start
         Want Literal(N)
         Rot = 16
         %if N # 0 %start
            Rot = Rot-1 %and N = N>>2 %while N&3 = 0
         %finish
         Mc Error("cannot generate constant") %if N>>8 # 0
         Op Value = Op Value ! (Rot&15)<<8 ! N ! 16_0200 0000
      %else
         Register(Rm)
         Get Shift %if Match(',')
         Op Value = Op Value ! Rm
      %finish
      ->OK

      %routine Get Displacement(%integer Mode)
         %integer Rm
         Ud = 1
         %if Match('#') %start
            Want Literal(Disp)
            Ud = 0 %and Disp = -Disp %if Disp < 0
         %else
            Disp = 0
            %if Match('-') %start
               Ud = 0
            %else %if Match('+')
            %finish
            Register(Rm)
            Op Value = Op Value ! Rm ! 16_0200 0000
            Get Shift %if Match(',')
         %finish
         Op Value = Op Value ! Mode
      %end

      %routine Modify Disp
         %integer Sign, Mod
         Sign = Pending
         %return %unless Match('+') %or Match('-')
         Mc Error("constant expected") %unless Literal(Mod)
         Mod = -Mod %if Sign = '-'
         N = N+Mod
      %end

Ot(2):%if Omatch('B') %start
         Op Value = Op Value ! 1<<22   {byte value}
      %finish
      %if Omatch('T') %start
         Op Value = Op Value ! 1<<21   {translate bit}
      %finish
      Register(Rd)
      Op Value = Op Value ! Rd<<12
      Comma
      Ud = 1
      %if Match(' ') %start          {a defined object}
         W == Var(Tag)
         Disp = W_Disp
         Modify Disp
         %if W_Base = Local %start
            Rn = Actual(Fp)
         %else %if W_Base = SB
            Rn = Actual(Sb)
         %else %if W_Base = 0 %and W_Area < 0
            Dir3(Dir Spec Load, Rd, -W_Area)
            Refs = Refs+1;  Ca = Ca+4
            Rn = Rd
            Disp = 0
         %finish %else Mc Error("cannot address non-locals")
         Disp = -Disp %and Ud = 0 %if Disp < 0
         Op Value = Op Value ! 16_0500 0000 ! Rn<<16
      %else
         Want('[')
         Register(Rn)
         Op Value = Op Value ! Rn<<16
         %if Match(',') %start      { [Rn, D] }
            Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0
            Get Displacement(16_0500 0000)
            Want(']')
            Op Value = Op Value ! 1<<21 %if Match('!')
         %else
            Want(']')
            %if Match(',') %start   { [Rn], D }
               Get Displacement(16_0400 0000)
            %else                    { [Rn]    }
               Disp = 0
               Op Value = Op Value ! 16_0400 0000
            %finish
         %finish
      %finish
      Mc Error("displacement too large") %if Disp > 4095
      Op Value = Op Value ! Ud<<23 ! Disp
      ->OK

   {Trap}

Ot(3):Want Literal(N);  Op Value = Op Value ! N&16_00FF FFFF;  ->OK

   {Block data manipulation}

      %routine Rlist
         Want('<')
         %unless Pending = '>' %start
            %cycle
               Register(N)
               Op Value = Op Value ! 1<<N
            %repeat %until %not Match(',')
         %finish
         Want('>')
      %end

Ot(4):%if Omatch('I') %start
         %if Omatch('A') %start
            Op Value = Op Value ! 2_01<<23
         %else %if Omatch('B')
            Op Value = Op Value ! 2_11<<23
         %else
            Mc Error("IA or IB expected")
         %finish
      %else %if Omatch('D')
         %if Omatch('A') %start
            Op Value = Op Value ! 2_00<<23
         %else %if Omatch('B')
            Op Value = Op Value ! 2_10<<23
         %else
            Mc Error("DA or DB expected")
         %finish
      %else
         %if Omatch('F') %start
            Op Value = Op Value ! 2_10<<23
         %else %if Omatch('E')
            Op Value = Op Value ! 2_00<<23
         %finish
         %if Omatch('A') %start
            Op Value = Op Value ! 2_01<<23
         %else %if Omatch('D')
            Op Value = Op Value ! 2_00<<23
         %finish
      %finish
      Register(Rn)
      Op Value = Op Value ! Rn<<16
      Op Value = Op Value ! 1<<21 %if Match('!')  {writeback}
      Comma
      Rlist
      Op Value = Op Value ! 1<<22 %if Match('^')  {set PSR}
      ->OK

Ot(5):%if Match(' ') %start          {a defined object}
         W == Var(Tag)
         %if W_Type = Labels %start
            Dir3(Dir McLabel, W_Disp, Op Value)
            Ca = Ca+4
            ->Done
         %finish
      %finish
      Mc Error("Unimplemented form of branch")

      %routine Set DS(%integer Let P)
         %if Omatch('D') %start
            Op Value = Op Value ! 16_0000 0080
         %else %if Omatch('E')
            Op Value = Op Value ! 16_0008 0000
         %else %if Let P # 0 %and Omatch('P')
            Op Value = Op Value ! 16_0008 0080
         %else %unless Omatch('S')
            McError("D, S, E or P wanted")
         %finish
      %end

      %routine Lit Reg(%integername R)
         %if Match('#') %start
            Want Literal(R)
            %if R = 1 %and Match('/') %start
               Want Literal(R)
               McError("only 1/2 permitted") %if R # 2
               R = 6
            %else
               McError("bad range") %unless 0 <= R <= 5 %or R = 10
               R = 7 %if R = 10
            %finish
            R = R ! 8
         %else
            F Register(R);  R = R&7
         %finish
      %end

Ot(6):   %if Omatch('S') %start
         %else %if Omatch('D')
            Op Value = Op Value ! 2_000000000 0 000000 1 000000000000000
         %else %if Omatch('E')
            Op Value = Op Value ! 2_000000000 1 000000 0 000000000000000
         %else %if Omatch('P')
            Op Value = Op Value ! 2_000000000 1 000000 1 000000000000000
         %finish
         F Register(Fdst);  Comma
         Ud = 1
         %if Match(' ') %start          {a defined object}
            W == Var(Tag)
            Disp = W_Disp
            Modify Disp
            %if W_Base = Local %start
               Rn = Actual(Fp)
            %else %if W_Base = SB
               Rn = Actual(Sb)
            %else %if W_Base = 0 %and W_Area < 0
               Dir3(Dir Spec Load, Rd, -W_Area)
               Refs = Refs+1;  Ca = Ca+4
               Rn = Rd
               Disp = 0
            %finish %else Mc Error("cannot address non-locals")
         %else
            Want('[')
            Register(Rn)
            %if Match(',') %start      { [Rn, D] }
               Warn(1, "spurious translate option") %if Op Value&(1<<21) # 0
               Get Displacement(16_0500 0000)
               Want(']')
               Op Value = Op Value ! 1<<21 %if Match('!')
            %else
               Want(']')
               %if Match(',') %start   { [Rn], D }
                  Get Displacement(16_0400 0000)
               %else                    { [Rn]    }
                  Op Value = Op Value ! 16_0400 0000
               %finish
            %finish
         %finish
         Disp = -Disp %and Ud = 0 %if Disp < 0
         Mc Error("Alignment error") %if Disp&3 # 0
         Disp = Disp>>2
         Mc Error("displacement too large") %if Disp > 255
         Op Value = Op Value ! Disp ! 16_0500 0000 ! Rn<<16 -
                             ! (Fdst&7)<<12 ! Ud<<23
         ->OK

         %routine Set Round
            %if Omatch('P') %start
               Op Value = Op Value ! 16_0000 0020
            %else %if Omatch('M')
               Op Value = Op Value ! 16_0000 0040
            %else %if Omatch('Z')
               Op Value = Op Value ! 16_0000 0060
            %finish
         %end

Ot(7):   Set DS(0)
         Set Round
         N = Op Value>>20&15
         %if N = 0  %start      {flt}
            F Register(Reg1);  Comma;  Register(Reg2)
            Op Value = Op Value ! (Reg1&7)<<16 ! Reg2<<12
         %else %if N = 1        {fix}
            Register(Reg1);  Comma;  F Register(Reg2)
            Op Value = Op Value ! (Reg1)<<12 ! Reg2&7
         %else
            Register(Reg1)
            Op Value = Op Value ! Reg1<<12
         %finish
         ->OK

Ot(9):   F Register(Fs1);  Comma;  Lit Reg(Fs2)
         Op Value = Op Value ! (Fs1&7)<<16 ! Fs2
         ->OK

Ot(10):  Set DS(1)
         Set Round
         F Register(Fdst);  Comma
         %if Op Value&16_0000 8000 = 0 %start     {dyadic}
            F Register(Fs1);   Comma
         %else                                    {monadic}
            Fs1 = 0
         %finish
         Lit Reg(Fs2)
         Op Value = Op Value ! (Fdst&7)<<12 ! (Fs1&7)<<16 ! Fs2
         ->OK

Ot(-1):  %cycle
            Mc Error("constant expected") %unless Literal(N)
            %if Op Num = -1 %start
               Dump Byte(N&255)
            %else %if Op Num = -2
               Dump Byte(N&255)
               Dump Byte(N>>8&255)
            %else
               Dump Word(N)
            %finish
         %repeat %until %not Match(',')
         %if Ca&3 # 0 %start
            Dump Byte(0) %until Ca&3 = 0
            Warn(0, "zero padding bytes added to ensure word alignment")
         %finish
         ->Done

OK:   Dump Word(Op Value)
Done: Mc Error("Too many operands") %unless Match(';')
      Mc Error("spurious operation qualifiers") %if SymP # Op Length
   %finish
%end