\ asm68k v1.21 98.7.20 9:05 pm NAB
\ Ported to Quartus 0.3.0ß.
.( Loading asm68k v1.21...)

wordlist constant asmlist
: ASSEMBLER
  get-order nip
  asmlist swap set-order ;

variable codedepth
: CODE
  :  get-order  depth codedepth !
  also assembler postpone [ ;

also assembler definitions
: END-CODE
  depth codedepth @ <>
  -22 and throw
  ] set-order  postpone ;  ; immediate

: FORTH  forth ;

: 2,  cs, cs, ;
: ?,  if cs, then cs, ;

: define:  \ shorthand
  s" create , does> @" evaluate ; immediate

variable post
: postfix  0 post ! ; postfix
: prefix true post ! ;
: fix  post @ if 
    source >in @  2dup -  >r nip + r>
    evaluate  postpone \  then ;

: instr:
  s" create , does> @ >r fix r>"
  evaluate ; immediate

8 base ! \ Octal
variable size
: .b  10000 size ! ;
: .w  30100 size ! ; .w
: .l  24600 size ! ;

: sz  define: 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  define: 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 )  \ adr reg indirect
0330 mode )+  \ adr reg ind post-incr
0440 mode -)  \ adr reg ind pre-decr
0550 mode D)  \ adr reg ind displaced
0660 mode DI)  \ adr reg ind disp idx
0770 constant #)  \ imm address
1771 constant L#)  \ imm long addr
2772 constant PCD)  \ PC relative disp
3773 constant PCDI)  \ PC rel disp idx
4774 constant #  \ immediate data

\ Fields and register assignments:
: field  define: and ;
7000 field rd
0007 field rs
0070 field ms
0077 field eas
0377 field low

: dn? ( ea -- ea flag )  dup ms 0= ;
: src ( ea ins -- ea ins' )  over  eas or ;
: dst ( ea ins -- ea ins' )  swap  rd or ;

\ Quartus registers:
A2 constant CS
A4 constant SP
A5 constant DS
A7 constant RP
D7 constant TOS

\ Extended addressing:
: double? ( mode -- flag )
  dup  L#)  =  swap # = long?  and  or ;
: index? ( [n] mode -- [a] mode )
  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? ( ea -- flag )  dup ms 0040 > ;
: ,more ( ea -- )  more?  if  index?
  double?  ?,  else  drop  then ;

\ Extended addressing extras:
create extra 0 , 0 , 0 ,
: extra? ( [n] mode -- mode )  more?
  if  dup >r index?  double?  extra cell+ swap
    if  2! 2  else  ! 1 then  extra !  r>
  else  0 extra !
  then ;
: ,extra ( -- )  extra @  ?dup
  if  extra cell+ swap 1 =
    if  @ cs,  else  2@  2,  then
    extra 3 cells 0 fill
  then ;

\ Immediates & adr reg specific:
: imm  instr:  >r extra?
  eas r> or sz3 cs, long? ?,  ,extra ;
( n ea )
0000 imm ORI
1000 imm ANDI
2000 imm SUBI
3000 imm ADDI
5000 imm EORI
6000 imm CMPI

: immsr  instr: sz3 2, ;
( n )
001074 immsr ANDI>SR
005074 immsr EORI>SR
000074 immsr ORI>SR

: iq  instr:  >r extra?
  eas swap rs 1000 * or
  r> or  sz3  cs, ,extra ;
( n ea )
050000 iq ADDQ
050400 iq SUBQ

: ieaa  instr: dst src sz4 cs, ,more ;
( ea An )
150300 ieaa ADDA
130300 ieaa CMPA
040700 ieaa LEA
110300 ieaa SUBA

\ Shifts, rotates, bit ops:
: isr  instr: >r dn?
  if  swap dn? if  r> 40 or >r
    else  drop swap 1000 *  then
    rd swap rs or
    r> or 160000 or sz3 cs,
  else  dup eas 300 or r@ 400 and or
    r> 70 and 100 * or 160000 or
    cs, ,more
  then ;
( Dm Dn ) ( m # Dn ) ( ea )
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  instr: >r extra?
  dn? if  rd src 400
  else  drop dup eas 4000  then
  or  r> or  cs, ,extra ,more ;
( ea Dn ) ( ea n # )
000 ibit BTST
100 ibit BCHG
200 ibit BCLR
300 ibit BSET

include asm68k.part2
only definitions
.( done.) cr