Postfix 8086 assembler in Forth

8086.fth

oct

( register / memory )

: reg/mem?  ( m -- ? )  70 and 0 = ;
: ?reg/mem  ( m -- m )
  dup  70 and 0 <>  ?abort" reg/mem? " ;
: ?memory   ( m -- m )
  dup  70 and 0 <>  over 300 and 300 = ?abort" memory? " ;

: mode  ( # -- ) ( E: a -- a m )
  create  200 or ,  ;does:  @  over -200 200 within
  if 100 - then  over 0= if 100 - then ;

0 mode bx+si)   1 mode bx+di)   2 mode bp+si)  3 mode bp+di)
4 mode    si)   5 mode    di)                  7 mode    bx)
: bp)  206  over -200 200 within  if 100 - then ;
: )  ( a -- a m )  006 ;

: register?  ( m -- ? )  370 and 300 = ;
: ?register  ( m -- r )
  dup 370 and 300 <> ?abort" register? "  7 and ;

: register  ( # -- ) ( E: -- m )  300 or constant ;

0 register ax   1 register cx   2 register dx   3 register bx
4 register sp   5 register bp   6 register si   7 register di
0 register al   1 register cl   2 register dl   3 register bl
4 register ah   5 register ch   6 register dh   7 register bh

( immediates )

: ?j  ( n -- n )
  dup -200 200 within 0= ?abort" out of range "  ;
: ?p  ( n -- n )
  dup 0 400 within 0= ?abort" not a port " ;
: ?1  ( n -- )
  dup 1 <> ?abort" not one" ;

: immediate?  ( m -- ? )  10 = ;
: #  ( i -- i m )  10 ;

: relative?  ( m -- ? ) 11 = ;
: ?relative  ( m -- )   11 <> ?abort" relative?" ;

: &        ( a -- a m )  here -  11 ;
: forward  ( -- r a m )  here  -176 11 ;  
: resolve  ( r -- )      dup  2 + here swap - ?j  swap 1 +  b! ;
: mark     ( -- a )      here ;
: backward ( a -- a m )  & ;

( segments )

: ?segment  ( m -- n )
  dup 70 and 20 <> ?abort" segment?"  7 and 3 lshift ;

: segment  ( # -- )  20 or  constant ;
0 segment es  1 segment cs  2 segment ss  3 segment ds

( encoding )

variable wide
: w+ ( add size flag )  wide @ + ;
: .b ( set byte size )  0 wide ! ;
: .w ( set word size )  1 wide ! ;
: ?w ( word-only ins )  wide @ 0= ?abort" word size only " ;

: imm, ( n -- ) ( compile immediate )
  wide @ if  w,  else
  dup -200 400 within 0= ?abort" out of range "  b,  then ;
: disp, ( n? m -- ) ( compile displacement )
  dup 300 and 200 =  over 307 and 006 =  or if  swap w,  else
    300 and  dup 100 = if swap b, then  dup 000 = if nip then
  then ( m ) drop ;

: mov,  ( special MOV )
  dup immediate? if ( r/m imm )
    drop push  dup register? if ( reg imm )
      7 and  260 or  wide @ if 10 + then b,  pop imm,
    else ( mem imm )
      306 w+ b,  dup b, disp,  pop imm,  then
  else ( r/m reg, reg r/m )
    210 w+ push
    dup register? unless  pop 2 + push  ?reg/mem rot  then
    over 006 = over ax = and if ( direct offset )
      2drop  pop 52 xor b, w,  else  ( modr/m form )
      7 and 3 lshift or  pop b, dup b, disp,  then
  then .w ;

( special MOV -- segment registers )
: stosg,  ?w  ?segment push  ?reg/mem  pop or  214 b,
  dup b, disp, ;
: lodsg,  ?w  ?reg/mem  dup register? if swap else tor then
  ?segment or  216 b,  dup b,  disp, ;

: xchg,  ( special XCHG )
  ?register push  ?reg/mem  dup ax = wide @  and if ( ax reg )
    drop  220 pop + b,
  else ( r/m reg )
    206 w+ b,  pop 3 lshift or  dup b, disp,
  then .w ;

: lea,  ?memory rot  ?register 3 lshift or  215 b, b, disp, ;

: lfp  ( load far pointer )  create , ;does: @ push  ?w  ?memory
  rot ?register  3 lshift or  pop b, b, disp, ;

304 lfp les,    305 lfp lds,

: i/o  ( IN and OUT )
  create , ;does:  @ push
  dup 010 = if ( imm ) pop w+ b, b,  else
  dup 302 = if ( dx ) pop 010 + w+ b,  else
  abort" dx/imm? " then then .w ;

340 i/o in,     342 i/o out,

: alu  ( ALU binary )
  create , ;does:  @ push  dup immediate? if ( r/m imm )
    drop  over ax = if ( ax imm )
      pop 4 + w+ b,  imm,  drop
    else ( r/m imm )
      200 w+  over -200 200 within if ( short imm ) .b 2 +  then
      b,  over pop or b,   push disp,  pop imm,  then
  else ( r/m reg, reg r/m )
    dup register? 0= if  pop 2 + push   ?reg/mem rot  then
    pop w+ b,  ?register 3 lshift over or b,  disp,
  then .w ;

000 alu add,    010 alu or,    020 alu adc,   030 alu sbb,
040 alu and,    050 alu sub,   060 alu xor,   070 alu cmp, 

: test,  ( special TEST )
  dup immediate? if ( r/m imm )
    drop  over ax = if ( ax imm )
      nip  250 w+ b,  imm,
    else ( r/m imm )
      366 w+ b,  push  dup b, disp,  pop imm,  then
  else ( r/m reg )
    ?register  push ?reg/mem  pop 3 lshift or  204 w+ b,
    dup b, disp,
  then .w ;

: shf  ( shifts )
  create , ;does:  @ push
  dup 301 = if ( cx ) drop 322  else  010 = andif 1 = then
  if ( 1 ) 320  else  abort" shift? " then  w+ b,  pop or
  dup b, disp,  then .w ;

000 shf rol,    010 shf ror,   020 shf rcl,   030 shf rcr,
040 shf shl,    050 shf shr,   060 shf sal,   070 shf sar,

: mul  ( ALU unary )  create , ;does:  @ push  ?reg/mem
  366 w+ b,  dup  pop or b,  disp,  .w ;

020 mul not,    030 mul neg,   040 mul mul,   050 mul imul,
060 mul div,    070 mul idiv,

: inc,  ?reg/mem  dup register? if  7 and 100 or b,  else
  376 w+ b,  dup b,  disp,  then .w ;
: dec,  ?reg/mem  dup register? if  7 and 110 or b,  else
  376 w+ b,  dup 10 or b,  disp,  then .w ;
: push,  ?w  ?reg/mem  dup register? if  7 and 120 or b,  else
  377 b,  dup 60 or b,  disp,  then ;
: pop,  ?w  ?reg/mem  dup register? if  7 and 130 or b,  else
  217 b,  dup b,  disp,  then ;

: seg  ( segment unary )
  create , ;does:  @ swap  ?segment  or b, ;

006 seg pushsg, 007 seg popsg, 046 seg seg,

: jcc  ( conditional jumps )
  create , ;does:  @ b,  ?w ?relative  2 - ?j b, ;

160 jcc jov,    161 jcc jno,   162 jcc jlo,   163 jcc jhs,
164 jcc jeq,    165 jcc jne,   166 jcc jls,   167 jcc jhi,
170 jcc jmi,    171 jcc jpl,   172 jcc jev,   173 jcc jod,
174 jcc jlt,    175 jcc jge,   176 jcc jle,   177 jcc jgt,
340 jcc loopne, 341 jcc loope, 342 jcc loop,  343 jcc jcxz,

: jmp, ( special JMP NEAR )
  ?w  dup relative? if ( rel ) drop
    2 -  dup -200 200 within if  ( rel8 ) 353 b, b,  else
    ( rel16 ) 1 - 351 b, w,  then
  else  dup reg/mem? if ( r/m )  377 b, dup 040 or b, disp,
  else  abort" rel/reg/mem? "  then then ;

: call, ( special CALL NEAR )
  ?w  dup relative? if ( rel ) drop  3 -  350 b, w,
  else  dup reg/mem? if ( r/m )  377 b, 020 or b, disp,
  else  abort" rel/reg/mem? "  then then ;

: brf  ( far branch )  create , ;does:  ?w @ b, w, w, ;
( FIXME indirect far branches? 377 /3 CALL, /5 JMP )
232 brf callf,  352 brf jmpf,

( special immediate ) ( argument to AAM and AAD is usually ten )
: int,  315 b, b, ;   : aam,  324 b, b, ;   : aad,  325 b, b, ;
: #ret,  302 b, w, ;  : #retf,  312 b, w, ;

: nul  ( nullary )  create , ;does: ?w @ b, ;

047 nul daa,    057 nul das,   067 nul aaa,   077 nul aas,
220 nul nop,    230 nul cbw,   231 nul cwd,   233 nul wait,
234 nul pushf,  235 nul popf,  236 nul sahf,  237 nul lahf,
303 nul ret,    313 nul retf,  314 nul int3,  316 nul into,
317 nul iret,   327 nul xlat,  360 nul lock,  362 nul repne,
363 nul repe,   363 nul rep,   364 nul hlt,   365 nul cmc,
370 nul clc,    371 nul stc,   372 nul cli,   373 nul sti,
374 nul cld,    375 nul std,

: str  ( string )  create , ;does: @ w+ b,  .w ; 

244 str movs,   246 str cmps,  252 str stos,  254 str lods,
256 str scas,

dec

shim.ans

: oct  8 base ! ;
: dec  decimal  ;

: ;does:   postpone does>  ; immediate

: push  postpone >r ; immediate
: pop   postpone r> ; immediate
: tor   rot rot ;

: andif    postpone dup postpone if postpone drop ; immediate
: unless   postpone 0= postpone if ; immediate
: ?abort"  postpone abort" ; immediate
: abort"   postpone true postpone ?abort" ; immediate

: b!  swap 255 and swap c! ;
: b,  255 and c, ;
: w,  dup b,  8 rshift b, ;