1 files changed, 308 insertions, 0 deletions
diff --git a/test/asm68k.4th b/test/asm68k.4th
new file mode 100644
index 0000000000000..a549d69c17c6d
--- /dev/null
+++ b/test/asm68k.4th
@@ -0,0 +1,308 @@
+HEX
+4e71 constant nop
+
+\ w, ( WORD compile )
+: w, ( d16 -- )  dup 100 / c, c, ;
+
+: OCTAL 8 BASE ! ;
+
+
+\ FORTH ASSEMBLER ....
+
+ALSO FORTH
+VOCABULARY ASSEMBLER IMMEDIATE
+ASSEMBLER DEFINITIONS
+
+: END-CODE ALIGN CURRENT @ CONTEXT ! ;
+: *SWAP SWAP ;
+: ?, IF w, THEN w, ;
+
+\ SIZES
+
+OCTAL
+VARIABLE SIZE
+: BYTE 10000 SIZE ! ;
+: WORD 30100 SIZE ! ;
+: LONG 24600 SIZE ! ;
+: SZ CREATE , DOES> @ SIZE @ AND OR ;
+
+00300 SZ SZ3
+00400 SZ SZ4
+04000 SZ SZ40
+30000 SZ SZ300
+
+: LONG? SIZE @ 24600 = ;
+: -SZ1 LONG? IF 100 OR THEN ;
+
+\ ADDRESSING MODES 
+
+: REGS 10 0 DO DUP 1001 I * OR CONSTANT LOOP DROP ;
+: MODE CREATE , DOES> @ SWAP 7007 AND OR ;
+
+0000 REGS D0 D1 D2 D3 D4 D5 D6 D7
+0110 REGS A0 A1 A2 A3 A4 A5 A6 A7
+
+0220 MODE )
+0330 MODE )+
+0440 MODE -)
+0550 MODE D)
+0660 MODE DI)
+0770 CONSTANT #)
+1771 CONSTANT L#)
+2772 CONSTANT PCD)
+3773 CONSTANT PCDI)
+4774 CONSTANT #
+
+\ FIELDS AND REGISTER ASSIGNMENTS
+
+: FIELD CREATE , DOES> @ AND ;
+
+7000 FIELD RD
+0007 FIELD RS
+0070 FIELD MS
+0077 FIELD EAS
+0377 FIELD LOW
+
+: DN? DUP MS 0 = ;
+: SRC OVER EAS OR ;
+: DST SWAP RD OR ;
+
+A7 CONSTANT SP
+A6 CONSTANT RP
+A5 CONSTANT IP
+
+: ?MODE 0 = ABORT" BAD MODE" ;
+: ??Dn DN? ?MODE ;
+: ??An DUP MS 1 = ?MODE ;
+: ??JMP DUP MS DUP 2 = SWAP 4 > OR OVER 74 = NOT AND ?MODE ;
+
+\ EXTENDED ADDRESSING
+
+: DOUBLE? DUP L#) = SWAP # = LONG? AND OR ;
+: INDEX? 
+  DUP >R DUP 0770 AND A0 DI) = SWAP PCDI) = OR
+  IF DUP RD 10 * SWAP MS IF 100000 OR THEN
+     SZ40 SWAP LOW OR
+  THEN R> ;
+: MORE? DUP MS 0040 > ;
+: ,MORE MORE? IF INDEX? DOUBLE? ?, ELSE DROP THEN ;
+
+\ EXTENDED ADDRESSING EXTRAS
+
+CREATE EXTRA HERE 10 ALLOT 10 ERASE
+
+: EXTRA? MORE?
+  IF >R R@ INDEX? DOUBLE? EXTRA 1 + SWAP
+     IF 2! 2 ELSE ! 1 THEN EXTRA C! R>
+  ELSE 0 EXTRA ! THEN ;
+: ,EXTRA EXTRA C@ ?DUP
+  IF EXTRA 1 + SWAP 1 =
+     IF @ w, ELSE 2@ , THEN EXTRA 10 ERASE
+  THEN ;
+
+\ IMMEDIATE & ADDRESS REGISTER SPECIFIC INSTRUCTIONS
+
+: IMM CREATE , DOES> @ >R EXTRA? EAS R> OR SZ3 w, LONG? ?, ,EXTRA ;
+0000 IMM ORI
+1000 IMM ANDI
+2000 IMM SUBI
+3000 IMM ADDI
+5000 IMM EORI
+6000 IMM CMPI
+
+: IMMSR CREATE , DOES> @ SZ3 , ;
+001074 IMMSR ANDI>SR
+005074 IMMSR EORI>SR
+000074 IMMSR ORI>SR
+
+: IQ CREATE , DOES> @ >R EXTRA? EAS SWAP RS 1000 * OR R> OR SZ3 w, ,EXTRA ;
+050000 IQ ADDQ
+050400 IQ SUBQ
+
+: IEAA CREATE , DOES> @ DST SRC SZ4 w, ,MORE ;
+150300 IEAA ADDA
+130300 IEAA CMPA
+040700 IEAA LEA
+110300 IEAA SUBA
+
+\ SHIFTS, ROTATES, & BIT MANIPULATION
+: ISR CREATE , DOES> @ >R DN?
+  IF SWAP DN? IF R> 40 OR >R ELSE DROP SWAP 1000 * THEN
+     RD SWAP RS OR R> OR 160000 OR SZ3 w,
+  ELSE DUP EAS 300 OR R@ 400 AND OR R> 70 AND 100 * OR
+     160000 OR w, ,MORE
+  THEN ;
+400 ISR ASL
+000 ISR ASR
+410 ISR LSL
+010 ISR LSR
+420 ISR ROXL
+020 ISR ROXR
+430 ISR ROL
+030 ISR ROR
+
+: IBIT CREATE , DOES> @ >R EXTRA? DN?
+  IF RD SRC 400 ELSE DROP DUP EAS 4000 THEN
+  OR R> OR w, ,EXTRA ,MORE ;
+000 IBIT BTST
+100 IBIT BCHG
+200 IBIT BCLR
+300 IBIT BSET
+
+\ BRANCH, LOOP, & SET CONDITIONALS
+
+: SETCLASS ' SWAP 0 DO I OVER EXECUTE LOOP DROP ;
+: SETCLAS2 ' ROT ROT DO I OVER EXECUTE LOOP DROP ;
+: IBRA 400 * 060000 OR CREATE ,
+  DOES> @ SWAP HERE 2 + - DUP ABS 200 < 
+  IF LOW OR w, ELSE SWAP , THEN ;
+: IDBR 400 * 050310 OR CREATE ,
+  DOES> @ SWAP RS OR w, HERE - , ;
+: ISET 400 * 050300 OR CREATE ,
+  DOES> @ SRC w, ,MORE ;
+
+20 SETCLASS IBRA BRA BSR BHI BLS BCC BCS BNE BEQ BVC BVS BPL BMI BGE BLT BGT BLE 
+
+10 SETCLASS IDBR DXIT DBRA DBHI DBLS DBCC DBCS DBNE DBEQ 
+
+20 10 SETCLAS2 IDBR DBVC DBVS DBPL DBMI DBGE DBLT DBGT DBLE
+
+20 SETCLASS ISET SET SNO SHI SLS SCC SCS SNE SEQ SVC SVS SPL SMI SGE SLT SGT SLE
+
+\ MOVES
+
+: MOVE EXTRA? 7700 AND SRC SZ300 w, ,MORE ,EXTRA ;
+                                                                   
+: MOVEQ RD SWAP LOW OR 070000 OR w, ;
+                                                                     
+: MOVE>USP RS 047140 OR w, ;
+: MOVE<USP RS 047150 OR w, ;
+: MOVEM> EXTRA? EAS 044200 OR -SZ1 w, w, ,EXTRA ;
+: MOVEM< EXTRA? EAS 046200 OR -SZ1 w, w, ,EXTRA ;
+: MOVEP DN? IF RD SWAP RS OR 410 OR
+            ELSE RS ROT RD OR 610 OR
+            THEN -SZ1 , ;
+: LMOVE 7700 AND SWAP EAS OR 20000 OR w, ;
+
+\ ODDS AND ENDS 
+
+: CMPM RD SWAP RS OR 130410 OR SZ3 w, ;
+: EXG
+  DN? IF SWAP DN? IF 140500 ELSE 140610 THEN >R
+      ELSE SWAP DN? IF 140610 ELSE 140510 THEN >R SWAP
+      THEN RS DST R> OR w, ;
+: EXT RS 044200 OR -SZ1 w, ;
+: SWAP RS 044100 OR w, ;
+: STOP 47162 , ;
+: TRAP 17 AND 47100 OR w, ;
+: LINK RS 047120 OR , ;
+: UNLK RS 047130 OR w, ;
+
+\ ARITHMETIC & LOGIC
+
+: EOR EXTRA? EAS DST SZ3 130400 OR w, ,EXTRA ;
+
+: IDD CREATE , 
+  DOES> @ DST OVER RS OR *SWAP MS IF 10 OR THEN w, ; 
+
+140400 IDD ABCD
+100400 IDD SBCD
+150300 IDD ADDX
+110400 IDD SUBX
+
+: IDEA CREATE , 
+  DOES> @ >R DN?
+  IF RD SRC R> OR SZ3 w, ,MORE
+  ELSE EXTRA? EAS DST 400 OR R> OR SZ3 w, ,EXTRA THEN ;
+
+150000 IDEA ADD
+110000 IDEA SUB
+140000 IDEA AND
+100000 IDEA OR
+
+: IEAD CREATE , DOES> @ DST SRC w, ,MORE ;
+
+040600 IEAD CHK
+100300 IEAD DIVU
+100700 IEAD DIVS
+140300 IEAD MULU
+140700 IEAD MULS
+
+: CMP 130000 DST SRC SZ3 w, ,MORE ;
+
+\ ARITHMETIC & CONTROL
+
+
+: IEA CREATE , DOES> @ SRC w, ,MORE ;
+
+047200 IEA JSR
+047300 IEA JMP
+042300 IEA MOVE>CCR
+040300 IEA MOVE<SR
+043300 IEA MOVE>SR
+044000 IEA NBCD
+044100 IEA PEA
+045300 IEA TAS
+
+: IEAS CREATE , DOES> @ SRC SZ3 w, ,MORE ;
+
+041000 IEAS CLR
+043000 IEAS NOT
+042000 IEAS NEG
+040000 IEAS NEGX
+045000 IEAS TST
+
+: ICON CREATE , DOES> @ w, ;
+
+47160 ICON RESET
+47161 ICON NOP
+47163 ICON RTE
+47165 ICON RTS
+47166 ICON TRAPV
+47167 ICON RTR
+
+\ STRUCTURED CONDITIONALS ( +/- 256 BYTES )
+
+: THEN HERE OVER 2 + - *SWAP 1 + C! ;
+: ENDIF THEN ;
+: IF w, HERE 2 - ;
+
+HEX
+
+: ELSE 6000 IF *SWAP THEN ;
+: BEGIN HERE ;
+: UNTIL , HERE - HERE 1 - C! ;
+: AGAIN 6000 UNTIL ;
+: WHILE IF ;
+: REPEAT *SWAP AGAIN THEN ;
+: DO HERE *SWAP ;
+: LOOP DBRA ;
+
+6600 CONSTANT 0=
+6700 CONSTANT 0<>
+6A00 CONSTANT 0<
+6B00 CONSTANT 0>=
+6C00 CONSTANT <
+6D00 CONSTANT >=
+6E00 CONSTANT <=
+6F00 CONSTANT >
+
+DECIMAL
+
+: NEXT 
+  A5 )+ A0 LMOVE
+  A0 ) JMP ;
+
+FORTH DEFINITIONS
+
+: LABEL CREATE [COMPILE] ASSEMBLER ASSEMBLER WORD ;
+: CODE LABEL HERE CELL- CELL- CELL- CP ! ;
+
+
+
+
+--openmail-part-01d4752f-00000002--
+
+--openmail-part-01d4752f-00000001--
+
+