! Basic 8086 Assembler (August 1980)
! extended 1984 for 80286 opcodes
! bugs fixed 1986,1987

%include "inc:util.imp"
%option "-nodiag"
%begin

%constinteger dictmax=300;   ! Dictionary
%recordformat dictfm(%integer p1,p2,type,val)
%record(dictfm)%array dict(1:dictmax)
%record(dictfm)%name pos,defpos

%integer type,val;   ! Tag control

%integerarray buf(1:100);  ! Code buffer
%integer bpos=0

%integerarray line(1:100);  !  Source line buffer
%integer sym,pend=-1,lpos=0

%integer fsym=' ',fpos=0;  ! Fault reporting

! Tag types

%constinteger unknown=-1
%constinteger constant=0
%constinteger register=1
%constinteger instruction=2
%constinteger mem=3;   ! in unspecified segment
%constinteger meme=4;  ! in extra segment
%constinteger memc=5;  ! in code segment
%constinteger mems=6;  ! in stack segment
%constinteger memd=7;  ! in data segment
%constinteger bytebit=8
%constinteger bpbit=16;  ! indexed by BP
%constinteger bxbit=32;  ! indexed by BX
%constinteger dibit=64;  ! indexed by DI
%constinteger sibit=128; ! indexed by SI

! Some registers

%constinteger es=8
%constinteger ds=11
%constinteger ax=0
%constinteger cl=1
%constinteger dx=2
%constinteger bx=3
%constinteger bp=5
%constinteger si=6
%constinteger di=7

%constbyteintegerarray hex(0:127)=255('0'),
0,1,2,3,4,5,6,7,8,9, 255('A'-'9'-1),
10,11,12,13,14,15,16,17,18,19,20,21,22,
23,24,25,26,27,28,29,30,31,32,33,34,35, 255('a'-'Z'-1),
10,11,12,13,14,15,16,17,18,19,20,21,22,
23,24,25,26,27,28,29,30,31,32,33,34,35, 255(*)

%constbyteintegerarray packed(0:127)=0('0'),
1,2,3,4,5,6,7,8,9,10, 0('A'-'9'-1),
11,12,13,14,15,16,17,18,19,20,21,22,23,
24,25,26,27,28,29,30,31,32,33,34,35,36, 0('a'-'Z'-1),
11,12,13,14,15,16,17,18,19,20,21,22,23,
24,25,26,27,28,29,30,31,32,33,34,35,36, 0(*)

%routine read sym
%integer i
  sym=pend; pend=-1; %returnunless sym<0
  %if lpos=0 %start;  ! need to read another line
    %for i=1,1,99 %cycle
      readsymbol(sym); line(i)=sym&127
      %exitif sym&127=nl
    %repeat
    line(100)=nl;  ! just in case
    lpos=1
  %finish
  sym=line(lpos); lpos=lpos+1 %unless sym=nl
%end

%routine skip rest of line; ! The only way new input can be read
  lpos=0; pend=-1
%end

%routine skip
%constinteger space=' ',tab='	'
  read sym %until space#sym#tab
%end

%routine bhex(%integer x)
%constintegerarray h(0:15)=
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
  printsymbol(h(x>>4&15)); printsymbol(h(x&15))
%end

%routine fault(%integer x)
  fsym=x %and fpos=lpos-1 %if fsym=' '
%end

%integer codeloc=0,dataloc=0,pass=0,list=1
%integername loc==codeloc
%string(31)name

%routine dump(%integer byte)
  bpos=bpos+1; buf(bpos)=byte&255; loc=loc+1
%end

! NB Object format

! 1 select code
! 2 select data
! 3 set loc (word)
! 4 dump (word, n bytes)
! 5 patch (2 words: offset, value)
! 6 extdef (string)
! 7 segref (string)
! 8 extref (string)
! 9 End of module
! A End of file

%routine code
  printsymbol(1)
%end

%routine data
  printsymbol(2)
%end

%routine setloc
  printsymbol(3)
  printsymbol(loc&255); printsymbol(loc>>8&255)
%end

%routine flush; ! generates both object and listing
%integer i,j

  %routine printline(%integer stream)
    selectoutput(stream)
    printsymbol(fsym); space
    %unless stream=0 %start
      %if bpos#0 %start
        %if loc==codeloc %then printsymbol('C') %else printsymbol('D')
        loc=loc-bpos
        bhex(loc>>8); bhex(loc)
        loc=loc+bpos
        %for i=1,1,4 %cycle
          %if bpos>=i %start
            space; bhex(buf(i))
          %finishelse spaces(3)
        %repeat
        space
      %finishelse spaces(18)
    %finish
    %for i=1,1,100 %cycle
      printsymbol('^') %if fpos=i
      sym=line(i); printsymbol(sym)
      %exitif sym=nl
    %repeat
    %unless stream=0 %start
      j=4
      %while j<bpos %cycle
        spaces(7)
        %for i=1,1,4 %cycle
          %if i+j<=bpos %start
            space; bhex(buf(i+j))
          %finishelse spaces(3)
        %repeat
        j=j+4; newline
      %repeat
    %finish
  %end

  %if bpos#0 %and pass=2 %start; ! generate object
    printsymbol(4); printsymbol(bpos); printsymbol(0); ! assume bpos<256
    printsymbol(buf(i)) %for i=1,1,bpos
  %finish
  %if pass=2 %or (pass=0 %and fsym#' ') %start; ! listing or fault
    printline(2) %if list#0 %or fsym#' '
    printline(0) %unless fsym=' '
    selectoutput(1)
  %finish
  bpos=0; fpos=0; fsym=' '
%end

%routine external
  printsymbol(6)
  printsymbol(length(name))
  printstring(name)
%end

%routine segspec
  printsymbol(7)
  printsymbol(length(name))
  printstring(name)
%end

%routine extspec
  printsymbol(8)
  printsymbol(length(name))
  printstring(name)
%end

%integerfn number(%integer radix)
%integer n,digit
  %cycle
    n=0
    %cycle
      readsym
      radix=n %andexitif sym='_'
      digit=hex(sym)
      pend=sym %andresult=n %if digit>=radix
      n=n*radix+digit
    %repeat
  %repeat
%end

%integerfn pack
%integer p,i,c
  p=0
  %for i=1,1,3 %cycle
    readsym
    c=packed(sym)
    pend=sym %andresult=p %if c=0
    p=p*37+c
  %repeat
  %result=p
%end

%routine read tag; ! reads name or signed number
%integer sign,i,p1,p2
  skip; sign=sym
  pend=sym %and sign=0 %unless sign='-' %or sign='\'
  readsym; pend=sym; type=constant; val=0
  %if sym='''' %start; ! Quoted constant
    readsym;  ! Skip initial quote
    readsym; val=sym
    readsym; fault('F') %unless sym=''''
  %finishelseif hex(sym)<10 %start; ! Decimal digit
    val=number(10)
  %finishelseif packed(sym)#0 %start;  ! Part of tag name
    p1=pack; p2=pack; i=pack %until i=0
    %cycle; ! Look up name in dictionary
      i=i+1; fault('D') %andreturnif i>dictmax; ! full
      pos==dict(i)
      %if pos_p1=-1 %start; ! end marker reached: enter new name
        pos_p1=p1; pos_p2=p2
        type=unknown; pos_type=unknown; pos_val=0
        dict(i+1)_p1=-1 %unless i=dictmax; ! propagate end marker
        %return
      %finish
      %if pos_p1=p1 %and pos_p2=p2 %start; ! name match
        type=pos_type; val=pos_val
        fault('I') %if sign#0 %and type#constant
        %exit
      %finish
    %repeat
  %finishelse fault('F')
  val=-val %if sign='-'
  val=\val %if sign='\'
%end

%routine ensure constant(%integer type)
! Be lenient: allow unindexed labels to pass as constants
  %returnif type&7>=mem %and type>>4=0
  fault('I') %unless type=constant
%end

%routine read operand; !including constant expressions
%constinteger maxop=8
%constintegerarray op(1:maxop)='+','-','&','!','\','<','>','('
%switch s(1:maxop)
%integer t,v,i

  readtag; v=val; t=type; fault('U') %if t=unknown
  %cycle
    skip
    %for i=1,1,maxop %cycle; ! see if sym is operator
      %if op(i)=sym %start
        ensure constant(t)
        %if i=6 %or i=7 %start; ! special case << and >>
          readsym
          fault('F') %andexitunless op(i)=sym
        %finish
        readtag %and ensure constant(type) %unless i=8
        ->s(i)
      %finish
    %repeat
    pend=sym; type=t; val=v; %return
s(1): v=v+val; %continue
s(2): v=v-val; %continue
s(3): v=v&val; %continue
s(4): v=v!val; %continue
s(5): v=v!!val; %continue
s(6): v=v<<val; %continue
s(7): v=v>>val
%repeat
s(8):  ! Open bracket for indexing
  t=mem %if t=constant
  %cycle
    readtag
    %if type=constant %start
      v=v+val
    %finishelseif type=register %start
      %if val=bx %start
        t=t+bxbit
      %finishelseif val=bp %start
        t=t+bpbit
      %finishelseif val=si %start
        t=t+sibit
      %finishelseif val=di %start
        t=t+dibit
      %finishelseif es<=val<=ds %start; ! change default segment
        fault('I') %unless t&7=mem
        t=t-mem+meme-es+val
      %finishelse fault('I')
    %finishelse fault('I')
    skip
    %if sym=')' %start
      type=t; val=v; %return
    %finish
    %unless sym='+' %start
      pend=sym; fault('F'); %return
    %finish
  %repeat
%end; ! of read operand

%routine address(%integer type,disp,extra,opcode)
! This dumps the opcode, followed by the address mode byte
! and optional displacement for the operand described by
! type and disp.  If necessary, a segment override prefix
! is generated before the instruction.
%integer mode,xbits
%constintegerarray default(0:15)=
mem, mems,memd,0,
memd,mems,memd,0,
memd,mems,memd,0,
0,   0,   0,   0
%constintegerarray rm(0:15)=
 6, 6, 7,-1,
 5, 3, 1,-1,
 4, 2, 0,-1,
-1,-1,-1,-1

  extra=(extra&7)<<3
  %if type&7=register %start
    fault('?') %unless disp&(\7)=0
    dump(opcode)
    dump(16_C0+extra+disp)
  %finishelseif type&7>=mem %start
    xbits=type>>4&15
    %if type&7>mem %start; !Segment specified
      dump((type&3)<<3+16_26) %unless default(xbits)=type&7; !Override
    %finish
    dump(opcode)
    mode=rm(xbits)
    fault('I') %if mode<0; ! Illegal combination of index registers
    %if xbits=0 %start
      dump(extra+6); dump(disp); dump(disp>>8)
    %finishelseif disp=0 %and mode#6 %start
      dump(mode+extra)
    %finishelseif -128<=disp<=127 %start
      dump(mode+16_40+extra)
      dump(disp)
    %else
      dump(mode+16_80+extra)
      dump(disp)
      dump(disp>>8)
    %finish
  %finishelse fault('I')
%end; ! of address

%routine obey(%integer inst); ! directive or instruction
%integer t,v;  ! for first of 2 operands
%integer op
%switch s(0:15); ! for instruction classes
%switch d(1:11); ! for directives

  %routine readname
    name=""
    skip
    fault('F') %if packed(sym)=0
    %cycle
      sym=sym-32 %if sym>'Z'
      name=name.tostring(sym) %unless length(name)=31
      readsym
      pend=sym %andreturnif packed(sym)=0
    %repeat
  %end

  %routine xdump(%integer x); ! dump word or byte
    dump(x); dump(x>>8) %if inst=10
  %end

  %routine get constant
    read operand; ensure constant(type)
  %end

  %routine ensure register(%integer t,v)
    fault('I') %unless t&7=register %and v<es
  %end

  %predicate ok(%integer reg,type); !tests for AX with unindexed mem
    %falseunless reg=ax
    %falseif type>>4#0
    type=type&7
    %falseif type<mem
    dump(16_26+(type&3)<<3) %unless type=mem %or type=memd; ! Seg override
    %true
  %end

  %routine get operands
    read operand; t=type; v=val
    read sym; fault('F') %unless sym=','
    read operand
  %end

  %routine swap operands
  %integer z
    z = t; t = type; type = z
    z = v; v = val; val = z
  %end

  ->s(inst>>12)

s(0): ->d(inst);   ! Direcive

d(1): loc==codeloc; code %if pass=2; %return; ! Select code segment
d(2): loc==dataloc; data %if pass=2; %return; ! Select data segment
d(3): get constant; loc=val;                  ! Set location counter
      setloc %if pass=2
      %return
d(4): readname; external %if pass=2; %return; ! Define external symbol
d(5): readname; segspec  %if pass=2; ->bump;  ! Refer to segment of ext sym
d(6): readname; extspec  %if pass=2;          ! Refer to ext sym
bump: loc=loc+2; %return
d(7): loc==codeloc;                           ! End of module
      printsymbol(9) %if pass=2; %return
d(8): %signal 9;                              ! End of file
d(9):d(10):                                   ! Byte, Word
      %cycle
        skip
        %if sym='"' %start; ! text string
          %cycle
            readsym; %exitif sym='"' %or sym=nl
            xdump(sym)
          %repeat
        %else
          pend=sym; get constant; xdump(val)
        %finish
        readsym
      %repeatuntil sym#','
      pend=sym; %return
d(11): get constant; list=val; %return;       ! List

s(1):    ! MOV
  get operands
  swap operands
  %if t=constant %start
    %if type&7=register %start; ! const to reg
      fault('I') %if val>=es
      op=16_B0; op=op+8 %if type&bytebit=0
      dump(val&7+op)
    %else;           ! const to mem
      op=16_C6; op=op+1 %if type&bytebit=0
      address(type,val,0,op)
    %finish
    dump(v); dump(v>>8) %if type&bytebit=0
  %finishelseif t=register %and v>=es %start; ! from seg reg
    address(type,val,v&3,16_8C)
  %finishelseif type=register %and val>=es %start; ! to seg reg
    address(t,v,val&3,16_8E)
  %finishelseif type&7=register %start; ! to reg
    %if ok(val,t) %start;  ! mem to AC
      op=16_A0; op=op+1 %if type&bytebit=0
      dump(op); dump(v); dump(v>>8)
    %else;  ! to ordinary reg
      op=16_8A; op=op+1 %if type&bytebit=0
      address(t,v,val,op)
    %finish
  %finishelseif t&7=register %start; ! from reg
    %if ok(v,type) %start; ! from AC to mem
      op=16_A2; op=op+1 %if t&bytebit=0
      dump(op); dump(val); dump(val>>8)
    %else;     ! from ordinary reg
      op=16_88; op=op+1 %if t&bytebit=0
      address(type,val,v,op)
    %finish
  %finishelse fault('I')
  %return

s(2):  ! ADD, ADC, SUB, SBB, CMP, AND, OR, XOR, TEST
  get operands
  %if type=constant %start
    %if t&7=register %and v=ax %start;   ! immediate to AC
      op=(inst&7)<<3+4
      op=op+1 %if t&bytebit=0
      op=op&1+16_A8 %if inst&15=8; ! TEST
      dump(op); dump(val); dump(val>>8) %if t&bytebit=0
    %else;   ! immediate to reg/mem
      op=16_80; op=16_F6 %if inst&15=8
      %if t&bytebit=0 %start
        op=op+1; op=op+2 %if -128<=val<=127 %and inst&16=0
      %finish
      address(t,v,inst,op)
      dump(val); dump(val>>8) %if op&3=1
    %finish
  %else;  ! source not constant
    op=2;  ! register is default destination
    %if type&7=register %and t&7#register %start; ! swap if reg not dest
      swap operands
      op=0
    %finish
    op=(inst&7)<<3+op
    op=16_84 %if inst&15=8;  ! TEST
    op=op+1 %if t&bytebit=0
    ensure register(t,v)
    address(type,val,v,op)
  %finish
  %return

s(3):  ! LEA, LDS, LES, BOUND, ARPL
  get operands
  ensure register(t,v)
  fault('I') %unless type&7>=mem
  address(type,val,v,inst&255)
  %return

s(4):  ! XCHG
  get operands
  ensure register(t,v)
  %if type=register %and val=ax %start
    dump(16_90+v)
  %else
    op=16_86; op=op+1 %if t&bytebit=0
    address(type,val,v,op)
  %finish
  %return

s(5):  ! Shifts and rotates
  get operands; op=16_D0
  %if type&7=register %and val=cl %start
    op=op+2
  %finishelseunless type=constant %start
    fault('I')
  %finishelseunless val=1 %start
    op = op-16
  %finish
  op=op+1 %if t&bytebit=0
  address(t,v,inst,op)
  dump(val) %if op&16=0
  %return

s(6):   ! IN, OUT
  get operands
  swap operands %if inst&2=0
  fault('I') %unless type&7=register %and val=ax
  inst = inst+1 %if type&bytebit=0
  %if t=register %and v=dx %start
    dump(inst+8)
  %finishelseif t=constant %start
    dump(inst); dump(v)
  %finishelse fault('I')
  %return

s(7):  ! PUSH, POP
  read operand
  %if type=register %start
    %if val>=es %start
      dump(inst&1+(val&7)<<3+6)
    %else
      dump((inst&1)<<3+val&7+16_50)
    %finish
  %elseif type=constant
    fault('I') %unless op&1=0
    %if -128<=val<=127 %start
      dump(16_6a); dump(val)
    %else
      dump(16_68); dump(val); dump(val>>8)
    %finish
  %else
    op=255; op=16_8F %if inst&1#0
    address(type,val,((inst&1)<<1+6),op)
  %finish
  %return

s(8):  ! INC, DEC
  read operand
  %if type=register %start
    fault('I') %if val>=es
    dump(val+16_40+(inst&1)<<3)
  %else
    op=254; op=op+1 %if type&bytebit=0
    address(type,val,inst&1,op)
  %finish
  %return

s(9):  ! NEG, NOT, (I)MUL, (I)DIV, (X)CALLI, (X)JUMPI
  read operand
  op=inst&255
  op=op+1 %if op#255 %and type&bytebit=0
  address(type,val,inst>>8,op)
  %return

s(10):  ! Parameterless instructions
  dump(inst)
  op=inst>>8&15
  dump(op) %unless op=0; ! Special for AAM/AAD
  %return

s(11):  ! INT and other miscellanies
  op = inst&255
  %if op=16_69 %start;    !IMULI
    read operand; ensure register(type,val)
    fault('I') %unless type&bytebit=0
    get constant
    op = op+2 %unless -128<=val<=127
    address(t,v,0,op)
    dump(val); dump(val>>8) %if op&2=0
  %elseif op=16_c8;   !ENTER
    get constant
    get constant
    fault('I') %unless v>=0 %and 0<=val<=255
    dump(op); dump(v); dump(v>>8); dump(val)
  %else;              !INT
    get constant
    dump(16_CD); dump(val)
  %finish
  %return

s(12):  ! Short jumps
  read operand
  fault('I') %unless type=memc
  dump(inst); op=val-loc-1; dump(op)
  fault('T') %unless -128<=op<=127
  %return

s(13):  ! (X)CALL, (X)JUMP
  read operand
  %if inst&256=0 %start; ! Intrasegment
    fault('I') %unless type=memc
    dump(inst); op=val-loc-2
    dump(op); dump(op>>8)
  %else;  ! Intersegment
    readsym; fault('F') %unless sym=':'
    ensure constant(type); v=val
    get constant
    dump(inst)
    dump(val); dump(val>>8)
    dump(v); dump(v>>8)
  %finish
  %return

s(14):  ! (X)RET
  skip; pend=sym
  %if packed(sym)#0 %start; ! operand present
    get constant; dump(inst)
    dump(val); dump(val>>8)
  %else; !    operand absent
    dump(inst+1)
  %finish
  %return

s(15):  ! 286 descriptor instructions
  dump(15)
  %if inst&2=0 %start
    read operand
    address(type,val,inst>>8,inst)
  %else
    get operands
    address(type,val,v,inst)
  %finish
%end; ! of obey

%routine set up files
%string(255)file,pre="assem:ass86.def",out,lis
%constinteger o=1<<31,l=1<<30
%integer flags=o
%integer sym
  %onevent 9 %start
    printstring(event_message); newline; %stop
  %finish
  define param("File",file,pamnodefault)
  define param("Pre",pre,0)
  define boolean params("Obj,List",flags,0)
  process parameters(cliparam)
  openinput(1,file.".86")
  openinput(2,pre)
  %if flags&o=0 %then out = ":n" %else out = file.".iob"
  %if flags&l=0 %then lis = ":n" %else lis = file.".lis"
  openoutput(1,out)
  openoutput(2,lis)
%end

!   Main program

%on %event 9 %start; ! End of input (or directive END)
  %if pass=2 %start
    printsymbol(10); flush; %stop
  %finish
  skip rest of line
  pass=pass+1
  codeloc=0; dataloc=0; loc==codeloc
  selectinput(1); resetinput
  ->loop
%finish

dict(1)_p1=-1; ! First end marker
set up files
selectinput(2); ! predef file
selectoutput(1); ! object file

loop:
%cycle
  skip
  %if nl#sym#'/' %start;  ! non-comment non-blank line
    pend=sym
    read tag
    read sym
    %if sym=':' %start; ! Label definition
      %if loc==codeloc %then pos_type=memc %else pos_type=memd
      fault('P') %unless pos_val=loc
      pos_val=loc
      %continue
    %finish
    %if sym='=' %start; ! Value definition
      defpos==pos
      read operand; readsym
      %if sym='.' %start; !Predef special
        type=val; val=number(16)
      %finishelse pend=sym
      defpos_type=type
      fault('M') %if pass=2 %and defpos_val#val
      defpos_val=val
    %else;  ! Instruction or directive
      pend=sym; fault('U') %if type=unknown
      %if type=instruction %then obey(val) %else fault('I')
    %finish
    skip; fault('F') %unless sym=nl %or sym='/' %or sym=';'
  %finish
  ->loop %if sym=';'
  skip rest of line
  flush
%repeat

%endofprogram
