\ 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