\ 6809 assembler

BASE @ HEX

: DEFER CREATE 0 , DOES> @ EXECUTE ;
: IS ' >BODY ! ;

VOCABULARY ASSEMBLER
ASSEMBLER ALSO DEFINITIONS

' C! DEFER VC! IS VC! \ Vectorize the important words so we can cross
' C@ DEFER VC@ IS VC@ \ assemble and self-assemble using the same code.
' !  DEFER V!  IS V!
' @  DEFER V@  IS V@
' C, DEFER C, IS C,
' ,  DEFER ,  IS ,
' HERE DEFER HERE IS HERE
' ALLOT DEFER ALLOT IS ALLOT

VARIABLE VDP
: VHERE ( --- addr)
  VDP @ ;
: VALLOT VDP +! ;
: VC, ( c --- )
  VHERE VC! 1 VALLOT ;
: V, ( n ---)
  VHERE V! 2 VALLOT ;
: ORG VDP ! ;

: <MARK ( --- addr )
  HERE ;
: <RESOLVE ( addr ---)
  HERE 1+ - C, ;
: >MARK ( --- addr )
  HERE 0 C, ;
: >RESOLVE ( addr --- )
  HERE OVER 1+ - SWAP VC! ;

VARIABLE ?PREBYTE VARIABLE PREBYTE \ Byte $10 or $11 before opcode
VARIABLE ?OPCODE  VARIABLE OPCODE  \ Opcode byte
VARIABLE ?POSTBYTE VARIABLE POSTBYTE \ Byte after opcode indicating mode.
VARIABLE ?OPERAND  \ Address or data after instruction.
VARIABLE MODE \ True is direct addressing false is other.
VARIABLE DPAGE \ Direct page address.
: SETDP ( n ---) \ Set direct page.
  100 * DPAGE ! ;
0 SETDP

: NOINSTR \ Reset all the instruction flags so there will be no instruction.
  ?PREBYTE OFF ?OPCODE OFF ?POSTBYTE OFF ?OPERAND OFF MODE OFF ;
: A; \ Assemble current instruction and reset instruction flags.
  MODE @  IF \ direct addresiing?
   DUP DPAGE @ - 0FF U> IF \ Is address 16 bits?
    2 ?OPERAND ! \ Indicate 16 bits address.
    OPCODE @ 0F0 AND 0= \ Change opcode byte.
     IF 70 OPCODE +!
     ELSE 20 OPCODE +!
     THEN
   ELSE 1 ?OPERAND ! \ Indicate 8 bis address.
   THEN
  THEN
  ?PREBYTE @ IF PREBYTE @ C, THEN
  ?OPCODE @ IF OPCODE @ C, THEN
  ?POSTBYTE @ IF POSTBYTE @ C, THEN
  ?OPERAND @ IF
   CASE ?OPERAND @
    1 OF C, ENDOF            \ 8 bits data/address.
    2 OF , ENDOF             \ 16 bits data/address.
    3 OF HERE 1+ - C, ENDOF  \ 8 bits relative address.
    4 OF HERE 2 + - , ENDOF   \ 16 bits realtive address.
   ENDCASE
  THEN NOINSTR ;


: LABEL A; HERE CONSTANT ;


HEX
: flag10 \ Indicate that next instruction has prebyte $10
  ?PREBYTE ON 10 PREBYTE ! ;
: flag11 \ Indicate that next instruction has prebyte $11
  ?PREBYTE ON 11 PREBYTE ! ;

: # \ Signal immediate mode.
  MODE OFF -10 OPCODE +! ;

: USE-POSTBYTE \ Signal that postbyte must be used.
  MODE OFF
  ?POSTBYTE ON
  OPCODE @ 0F0 AND 0= IF
   60 OPCODE +!
  ELSE
   OPCODE @ 80 AND IF
    10 OPCODE +!
   THEN
  THEN ;

: [] \ Signal indirect mode.
  MODE @ IF \ Indirect addressing with 16-bits addres, no postbyte made yet.
   USE-POSTBYTE
   9F POSTBYTE !   \ Make postbyte.
   2 ?OPERAND !     \ Indicate 16-bits address.
  ELSE
   POSTBYTE @ 80 AND 0= IF \ 5-bits address format already assembled?
    POSTBYTE @ 1F AND DUP 10 AND 0<> 0E0 AND OR
    1 ?OPERAND !            \ Signal operand.
    POSTBYTE @ 60 AND 98 OR POSTBYTE ! \ Change postbyte.
   ELSE
    POSTBYTE @ 10 OR POSTBYTE ! \ Indicate indirect addressing.
   THEN
  THEN ;

: ,R \ Modes with a constant offset from a register.
  CREATE C,
  DOES> USE-POSTBYTE
        C@ POSTBYTE ! \ Make register field in postbyte.
        DUP 0= IF
         84 POSTBYTE +! DROP \ Zero offset.
         ?OPERAND OFF
        ELSE
         DUP -10 >= OVER 0F <= AND IF \ 5-bit offset.
          1F AND POSTBYTE +!
          ?OPERAND OFF
         ELSE
          DUP 80 + 100 U< IF \ 8-bit offset.
           88 POSTBYTE +!
           1 ?OPERAND !
          ELSE
           89 POSTBYTE +!    \ 16-bit offset.
           2 ?OPERAND !
          THEN
         THEN
        THEN ;
00 ,R ,X
20 ,R ,Y
40 ,R ,U
60 ,R ,S

: AMODE \ addressing modes with no operands.
  CREATE C,
  DOES> USE-POSTBYTE
        C@ POSTBYTE !
        ?OPERAND OFF ;
080 AMODE ,X+   081 AMODE ,X++ 082 AMODE ,-X   083 AMODE ,--X
085 AMODE B,X   086 AMODE A,X  08B AMODE D,X
0A0 AMODE ,Y+   0A1 AMODE ,Y++ 0A2 AMODE ,-Y   0A3 AMODE ,--Y
0A5 AMODE B,Y   0A6 AMODE A,Y  0AB AMODE D,Y
0C0 AMODE ,U+   0C1 AMODE ,U++ 0C2 AMODE ,-U   0C3 AMODE ,--U
0C5 AMODE B,U   0C6 AMODE A,U  0CB AMODE D,U
0E0 AMODE ,S+   0E1 AMODE ,S++ 0E2 AMODE ,-S   0E3 AMODE ,--S
0E5 AMODE B,S   0E6 AMODE A,S  0EB AMODE D,S

: ,PCR \ Signal program counter relative.
  USE-POSTBYTE
  DUP
  HERE ?PREBYTE @ - 3 + - \ Subtract address after instruction
  80 + 100 U< IF \ 8-bits offset good?
   3 ?OPERAND !
   8C POSTBYTE !
  ELSE
   4 ?OPERAND !
   8D POSTBYTE !
  THEN ;

: USE-OPCODE ( c ---)
  ?OPCODE ON
  OPCODE ! ;

: IN1 \ Simple instructions with one byte opcode
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE ;
12 IN1 NOP    13 IN1 SYNC
19 IN1 DAA    1D IN1 SEX
39 IN1 RTS    3A IN1 ABX
3B IN1 RTI    3D IN1 MUL
3F IN1 SWI    : SWI2 SWI flag10 ; : SWI3 SWI flag11 ;
40 IN1 NEGA   50 IN1 NEGB
43 IN1 COMA   53 IN1 COMB
44 IN1 LSRA   54 IN1 LSRB
46 IN1 RORA   56 IN1 RORB
47 IN1 ASRA   57 IN1 ASRB
48 IN1 ASLA   58 IN1 ASLB
48 IN1 LSLA   58 IN1 LSLB
49 IN1 ROLA   59 IN1 ROLB
4A IN1 DECA   5A IN1 DECB
4C IN1 INCA   5C IN1 INCB
4D IN1 TSTA   5D IN1 TSTB
4F IN1 CLRA   5F IN1 CLRB
\ Though not no-operand instructions the LEA instructions
\ are treated correctly as the postbyte is added by the mode words.
30 IN1 LEAX   31 IN1 LEAY
32 IN1 LEAS   33 IN1 LEAU
: DEX LEAX -1 ,X ; : INX LEAX 1 ,X ;
: DES LEAS -1 ,S ; : INS LEAS 1 ,S ;
: DEY LEAY -1 ,Y ; : INY LEAY 1 ,Y ;

: BR-8 \ relative branches with 8-bit offset
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE 3 ?OPERAND ! ;
  20 BR-8 BRA   21 BR-8 BRN
  22 BR-8 BHI   23 BR-8 BLS
  24 BR-8 BCC   25 BR-8 BCS
  24 BR-8 BHS   25 BR-8 BLO
  26 BR-8 BNE   27 BR-8 BEQ
  28 BR-8 BVC   29 BR-8 BVS
  2A BR-8 BPL   2B BR-8 BMI
  2C BR-8 BGE   2D BR-8 BLT
  2E BR-8 BGT   2F BR-8 BLE
  8D BR-8 BSR

: LBRA
  A; 16 USE-OPCODE 4 ?OPERAND ! ;
: LBSR
  A; 17 USE-OPCODE 4 ?OPERAND ! ;

: BR16 \ Relative branches with 16-bit offset.
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE flag10 4 ?OPERAND ! ;
                  21 BR16 LBRN
  22 BR16 LBHI   23 BR16 LBLS
  24 BR16 LBCC   25 BR16 LBCS
  24 BR16 LBHS   25 BR16 LBLO
  26 BR16 LBNE   27 BR16 LBEQ
  28 BR16 LBVC   29 BR16 LBVS
  2A BR16 LBPL   2B BR16 LBMI
  2C BR16 LBGE   2D BR16 LBLT
  2E BR16 LBGT   2F BR16 LBLE

: IN2 \ Instructions with one immediate data byte.
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE 1 ?OPERAND ! ;
1A IN2 ORCC  1C IN2 ANDCC  3C IN2 CWAI
: CLC ANDCC 0FE ; : SEC ORCC 01 ;
: CLF ANDCC 0BF ; : SEF ORCC 40 ;
: CLI ANDCC 0EF ; : SEI ORCC 10 ;
: CLIF ANDCC 0AF ; : SEIF ORCC 50 ;
: CLV ANDCC 0FD ; : SEV ORCC 02 ;
: % ( --- n) \ Interpret next word as a binary number.
  BASE @ 2 BASE ! BL WORD NUMBER? drop DROP SWAP BASE ! ;

: REG \ Registers as used in PUSH PULL TFR and EXG instructions.
  CREATE C, C,
  DOES> ?OPERAND @ IF \ Is a PUSH/PULL instruction meant?
         1+ C@ OR
        ELSE
         C@ POSTBYTE +! \ It's a TFR,EXG instruction.
        THEN ;
06 00 REG D,  06 00 REG D
10 10 REG X,  10 01 REG X
20 20 REG Y,  20 02 REG Y
40 30 REG U,  40 03 REG U
40 40 REG S,  40 04 REG S
80 50 REG PC, 80 05 REG PC
02 80 REG A,  02 08 REG A
04 90 REG B,  04 09 REG B
01 A0 REG CC, 01 0A REG CC
08 B0 REG DP, 08 0B REG DP

: EXG A; 1E USE-OPCODE ?POSTBYTE ON 0 POSTBYTE ! ;
: TFR A; 1F USE-OPCODE ?POSTBYTE ON 0 POSTBYTE ! ;
: STK \ Stack instructions.
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE
        1 ?OPERAND ! 0 ;
34 STK PSHS  35 STK PULS
36 STK PSHU  37 STK PULU

: OP-8 \ Instructions with 8-bits data.
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE
        MODE ON
        1 ?OPERAND ! ;
00 OP-8 NEG  03 OP-8 COM
04 OP-8 LSR  06 OP-8 ROR
07 OP-8 ASR  08 OP-8 ASL
08 OP-8 LSL  09 OP-8 ROL
0A OP-8 DEC  0C OP-8 INC
0D OP-8 TST  0E OP-8 JMP
0F OP-8 CLR
90 OP-8 SUBA 0D0 OP-8 SUBB
91 OP-8 CMPA 0D1 OP-8 CMPB
92 OP-8 SBCA 0D2 OP-8 SBCB
94 OP-8 ANDA 0D4 OP-8 ANDB
95 OP-8 BITA 0D5 OP-8 BITB
96 OP-8 LDA  0D6 OP-8 LDB
97 OP-8 STA  0D7 OP-8 STB
98 OP-8 EORA 0D8 OP-8 EORB
99 OP-8 ADCA 0D9 OP-8 ADCB
9A OP-8 ORA  0DA OP-8 ORB
9B OP-8 ADDA 0DB OP-8 ADDB
9D OP-8 JSR

: OP16 \ Instructions with 16-bits daia.
  CREATE C,
  DOES> >R A; R> C@ USE-OPCODE
        MODE ON
        2 ?OPERAND ! ;
93 OP16 SUBD  0D3 OP16 ADDD
9C OP16 CMPX  0DC OP16 LDD  0DD OP16 STD
9E OP16 LDX   0DE OP16 LDU
9F OP16 STX   0DF OP16 STU
: CMPD SUBD flag10 ; : CMPY CMPX flag10 ;
: LDY  LDX  flag10 ; : STY  STX  flag10 ;
: LDS  LDU  flag10 ; : STS  STU  flag10 ;
: CMPU SUBD flag11 ; : CMPS CMPX flag11 ;

\ Structured assembler constructs.
: IF >R A; R> C, >MARK ;
: THEN A; >RESOLVE ;
: ELSE A; 20 C, >MARK SWAP >RESOLVE ;
: BEGIN A; <MARK ;
: UNTIL >R A; R> C, <RESOLVE ;
: WHILE >R A; R> C, >MARK ;
: REPEAT A; 20 C, SWAP <RESOLVE >RESOLVE ;
: AGAIN 20 UNTIL ;
22 CONSTANT U<= 23 CONSTANT U>
24 CONSTANT U<  25 CONSTANT U>=
26 CONSTANT 0=  27 CONSTANT 0<>
28 CONSTANT VS  29 CONSTANT VC
2A CONSTANT 0<  2B CONSTANT 0>=
2C CONSTANT <   2D CONSTANT >=
2E CONSTANT <=  2F CONSTANT >

: ENDASM \ End assembly.
  A; PREVIOUS ;
FORTH DEFINITIONS
: ASSEMBLE \ Start assembly.
  ALSO ASSEMBLER NOINSTR ;

: CODE CREATE -3 ALLOT ASSEMBLE ;
: END-CODE [ ASSEMBLER ] ENDASM [ FORTH ] ;

PREVIOUS FORTH DEFINITIONS

BASE ! \ Restore the original base.
