--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/examples_forth/asm09.4	Mon Jul 23 16:07:12 2018 +0900
@@ -0,0 +1,335 @@
+\ 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.