F83 L&P 68000er ASSEMBLER  auf dem QL                           assembler: aus DDJ /1983 /Michael Perry                         0=    2=C|Z   4=C     6=Z     8=OV    A=N     C=N^V   E=Z|[N^V] T/F   HI/LS   CC/CS   NE/EQ   VC/VS   PL/MI   GE/LT   GT/LE           U<=     U<      0=      VS      0<      <       <=                                                                         word ####  D3^D7         move    363C^3E3C .. ####             .long       D3^D7 BP DI)  jmp/jsr 4EF6/4EB6 .. 38##^78##        --  word .long IP )+ D7 move 0 D7 BP DI) jmp     -- next        --  word .long  #### D3 move 0 D3 BP DI) jmp/jsr -- thread                                                                            ####        BP D)   jmp/jsr 4EEE/4EAE .. ####             .word   ##  D3^D7 BP DI)  jmp/jsr 4EF6/4EB6 .. 30##^70##        --  word .word IP )+ D7 move 0 D7 BP DI) jmp     -- next        --  word .word               #### BP D)  jmp/jsr -- thread                                                                      ( load                                                          )                                                                  decimal    marker noasm                                         get-order over swap 1+ set-order                                assembler definitions                                                                                                         ( ASSEMBLER ... )  2 24 thru  ( ... geladen. )                                                                                    decimal                                                         get-order ~swap drop 1- set-order                               definitions                                                                                                                                                                                                                                                                                                                                                                                  ( asm --------------------------------------------------------  )                                                               : OCTAL    8 base ! ;                                           : HEX     16 base ! ;           hex                                                                                             : >EXEC     create dup , cell+                                     DOES>    @ >codes @ + @ execute ;                            0  >exec >C@       >exec >@        >exec >C!       >exec >!        >exec >HERE     >exec >ALLOT    >exec >ALIGN                    >exec >C,       >exec >,        >exec >NEXT     drop                                                                         : W,    dup  $8 rshift >c, >c, ;                                : L,    dup $10 rshift  w,  w, ;                                : 2,    w, w, ;                                                 : ?,    if l, else w, then ( if w, then w,) ;                                                                                   ( asm --------------------------------------------------------  )                                                               : INLINE!   ( ad cfa --)      over 1- >c@                          0 do     over >c@ over >c!   1+ swap 1+ swap                    loop     1 cells - >next @ over >! >next ! drop ;                                                                            : W!        over $8 rshift over >c! 1+ >c, ;                    : ALTER     ( lbl cfa --)    2 + w! ;                           : CODE!-T   ( lbl cfa --)    $4EEE over w! alter ;              : NEST!-T   ( lbl cfa --)    $4EAE over w! alter ;                                                                              variable .SIZE                                                  variable SIZE                                                   create   EXTRA   3 cells allot  ( storage area)                                                                                                                                                 ( asm --------------------------------------------------------  )                                       octal                   : ~SWAP   swap ;                                                : ~AND    and ;                                                 : ~OR     or ;                                                  : ~U< u< ;                                                      : ~0= 0= ;                                                      : ~0< 0< ;                                                      : ~< < ;                                                        : ~> > ;                                                                                                                        : BYTE      ( --)   10000 size ! ;                              : WORD      ( --)   30100 size ! ;                              : LONG      ( --)   24600 size ! ;                              : .WORD     ( --)   30100 .size ! ;                             : .LONG     ( --)   24600 .size ! ;                             ( sizes                                                         )                                       octal                   : LONG?     ( -- f)              size @ 24600 = ;               : .LONG?    ( -- f)             .size @ 24600 = ;               : -SZ1      ( op -- op')        long? if 100 or then ;                                                                          : SZ        ( n --)                     create ,                   DOES>    @ size @ and or ;                                   00300 sz SZ3    00400 sz SZ4    30000 sz SZ300                                                                                  : .SZ       ( n --)                     create ,                   DOES>    @ .size @ and or ;                                  04000 .sz SZ40                                                                                                                  : RESET-ASM-VARS long .long extra 6 0 fill ;  reset-asm-vars                                                                    ( addr modes                                                    )                                                               : REGS   ( n --)            ( reg direct)                         10 0 do dup 1001 i um* drop or constant loop drop ;                                                                           0000 regs     D0  D1  D2  D3  D4  D5  D6  D7                    0110 regs     A0  A1  A2  A3  A4  A5  A6  A7                                                                                    A7 constant SP    A6 constant BP  ( rename...)                  A5 constant RP    A4 constant IP  ( ...forth)                   D7 constant W     D6 constant UP  ( ...registers)                                                                                                                                                                                                                                                                                                                                               ( addr modes                                                    )                                                               0770 constant #)     ( immediate ad)                            1771 constant L#)    ( imm long ad)                             2772 constant PCD)   ( pc displaced)                            3773 constant PCDI)  ( pc displaced indexed)                    4774 constant #      ( immediate data)                                                                                          : MODE      ( n --)                     create ,                   DOES>    @ swap 7007 and or ;                                0220 mode     )      ( ad reg indirect)                         0330 mode     )+     ( ad reg ind post-inc)                     0440 mode     -)     ( ad reg ind pre-dec)                      0550 mode     D)     ( ad reg ind displaced)                    0660 mode     DI)    ( ad reg ind displaced indexed)                                                                            ( reg assignments & fields                                      )                                                               : FIELD     ( n --)                     create ,                   DOES>    @ and ;               ( mask bit fields)                                                                            7000 field RD    0007 field RS    ( select reg source/dest)     0070 field MS    0077 field EAS   ( select source mode / EA)    0377 field LOW                    ( select low byte)                                                                            : DST   ( dn n -- n')   swap  rd or ;  ( calc... dest)          : SRC   ( ea n -- ea n') over eas or ; ( calc... source)        : DN?   ( ea -- ea f)   dup ms 0= ;    ( test: data reg direct) : MORE? ( ea -- f)      ms 0040 swap < ;                                                                                        : DOUBLE?   ( mode -- f)               ( 32 bits adr. required)             dup l#) = swap # = long? and or ;                   ( ext addressing                                                )                                                               : INDEX?    ( {n} mode -- {m} mode)                                dup >R   dup 0770 and A0 DI) ( 0660) =                                   swap         PCDI)  ( 3773) = or                      if        ( ireg)      dup rd  3 lshift                                   swap ms      if 100000 or then                                  sz40         swap ( disp) low or                      then R> ;                                                                                                                     : ,MORE     ( ea --)                                                        dup more?                 ( append extended)           if       index? double? ?,  else drop then ;                                                                                                                                                                                                                 ( ext adr extras                                                )                                                               : EXTRA?    ( {n} ea -- ea f)                                               dup >R    more?                                        if       R@ index? double?   extra cell+                                 swap  if ( 2!) ! 2 else ! 1 then                       else     0 then extra ! R> ;                                                                                                 : ,EXTRA    ( --)                                                           extra @ ?dup                                           if       extra cell+ swap 1 =                                      if    @ w, else ( 2@ 2,) @ l,                                   then  extra 3 cells 0 fill  then ;                                                                                                                                                                                                                        ( immediates & adress register specific                         )                                                               : IMM       ( n ea --)                  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     ( n ea --)                  create ,                   DOES>    @ sz3 2, ;                                                                                                          001074 immsr ANDI>SR   005074 immsr EORI>SR                     000074 immsr  ORI>SR                                                                                                            ( immediates & adress register specific                         )                                                               : IQ        ( n ea --)                  create ,                   DOES>    @ >R extra? eas                                                 ~swap rs 1000 um* drop or                                       R> or sz3 w, ,extra ;                                                                                               050000 iq ADDQ   050400 iq SUBQ                                                                                                 : IEAA      ( ea An --)                 create ,                   DOES>    @ dst src sz4 w, ,more ;                                                                                            150300 ieaa ADDA 130300 ieaa CMPA                               040700 ieaa LEA  110300 ieaa SUBA                                                                                                                                                               ( shift rot bit manipulation                                    )                                                               : IBIT      ( ea Dn | ea n # --)        create ,                   DOES>    @ >R size @ >R word                                             extra? R> size ! 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                                                                                                                                                                                                                                                                                                                                                                   ( shift rot bit manipulation                                    )                                                               : ISR       ( Dn Dn | n # Dn | ea --)   create ,                   DOES>    @ >R  dn?                                              if       ~swap dn?                                                 if    R> 40 or >R                                               else  drop ~swap  $9 lshift                                     then  rd ~swap rs or R> or 160000 or sz3 w,                  else     dup eas 300 or R@ 400 and or                                    R> 70 and  6 lshift 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                                       ( branch, loop, & set conditionals                              )                                                               : SETCLASS  ' ~swap 0 do i over execute loop drop ;                                                                             : IBRA      ( adr --)                                                       $8 lshift 060000 or create ,                          DOES>     @ ~swap >here 1+ 1+  - dup abs 200 <                            if low or w, else ~swap 2, then ;                                                                                   : IDBR      ( adr Dn --)                                                    $8 lshift 050310 or create ,                          DOES>     @ ~swap rs or w, >here - w, ;                                                                                       : ISET      ( ea --)                                                        $8 lshift 050300 or create ,                          DOES>     @ src w, ,more ;                                    ( branch, loop, & set conditionals                              )                                                               20 setclass ibra                                                   BRA  BSR  BHI  BLS  BCC  BCS  BNE  BEQ                          BVC  BVS  BPL  BMI  BGE  BLT  BGT  BLE                                                                                       20 setclass idbr                                                   DXIT DBRA DBHI DBLS DBCC DBCS DBNE DBEQ                         DBVC DBVS DBPL DBMI DBGE DBLT DBGT BGLE                                                                                      20 setclass iset                                                   SET  SNO  SHI  SLS  SCC  SCS  SNE  SEQ                          SVC  SVS  SPL  SMI  SGE  SLT  SGT  SLE                                                                                                                                                                                                                       ( moves                                                         )                                                               : MOVE      ( ea ea --)                                            extra? 7700 and src sz300 w, ,more ,extra ;                                                                                  : SWAP      ( Dn --)    rs 044100 or w, ;                       : MOVEQ     ( n Dn --)  rd ~swap low or 070000 or w, ;                                                                          : MOVE>USP  ( An --)    rs 047140 or w, ;                       : MOVE<USP  ( An --)    rs 047150 or w, ;                                                                                       ( W.xxx  EA  MOVEM> ===  EA  -)   ( D0 .. D7  A0 .. A7 )        (                   ===  EA else  ( A7 .. A0  D7 .. D0 )                                                                                                                                                                                                        ( moves                                                         )                                                               : MOVEM>    ( n ea --)                                             extra? eas 044200 or -sz1 w, w, ,extra ;                                                                                     : MOVEM<    ( n ea --)                                             extra? eas 046200 or -sz1 w, w, ,extra ;                                                                                     : MOVEP     ( Dn n{d} An | n{d} An Dn --)                          dn? if   rd ~swap rs ~or 410 or                                     else rs  rot  rd ~or 610 or then -sz1 2, ;                                                                               : EXG       ( Rn Rm --)                                           dn? if    ~swap dn? if       140500 else 140610 then >R             else  ~swap dn? if ~swap 140610 else 140510 then >R             then  rs dst R> or w, ;                                   ( odds and ends                                                 )                                                               : CMPM      ( An@+ Am@+ --) rd ~swap rs or 130410 or sz3 w, ;   : EXT       ( Dn --)    rs 044200 or -sz1 w, ;                  : STOP      ( n --)     047162 2, ;                             : TRAP      ( n --)     17 and 47100 or w, ;                    : LINK      ( n An --)  rs 047120 or 2, ;                       : UNLK      ( An --)    rs 047130 or w, ;                                                                                       : EOR    ( Dn ea --)  extra? eas dst sz3 130400 or w, ,extra ;  : CMP    ( ea Dn --)  130000 dst src sz3 w, ,more ;                                                                             : LMOVE                 7700 and ~swap eas or 20000 or w, ;                                           ( long reg direct move)                                                                                                                                   ( arihm & logic                                                 )                                                               : IDD       ( Dn Dm | An@- Am@- --)     create ,                   DOES>    @ dup 010000 and >R dst over rs or                              ~swap ms if 10 or then R> if sz3 then w, ;          140400 idd ABCD   100400 idd SBCD                               150400 idd ADDX   110400 idd SUBX                                                                                               : IDEA      ( ea Dn | Dn ea --)         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                                                                                                ( arithm & control                                              )                                                               : IEAD      ( ea Dn --)                 create ,                   DOES>    @ dst src w, ,more ;                                040600 iead CHK                                                 100300 iead DIVU   100700 iead DIVS                             140300 iead MULU   140700 iead MULS                                                                                             : IEA       ( ea --)                    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                                                                                                                  ( arithm & control                                              )                                                               : IEAS      ( ea --)                    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                                                                                                                                                                                                                                ( struct conditionals +/- 256 bytes                             )                                  hex                          62 constant U>  63 constant U<= 64 constant U>= 65 constant U<  66 constant 0<> 67 constant 0=  68 constant VC  69 constant VS  6A constant 0>= 6B constant 0<                                  6C constant >=  6D constant <   6E constant >   6E constant <=                                                                  : [DO      >here ~swap ;                                        : LOOP]    dbra ;                                               : HUH?     ~0= abort" unbalanced" ;                             : ?ABAL    dup huh? over >c@ ;                                  : +ABAL    1+ ;                                                 : -ABAL    1- ;                                                 : ABACKTO  ?abal huh? -abal  ~swap >here 1+ - >c, ;             : ALINKTO  ~swap >here over 1+ - ~swap >c! ;                    : AHALFGO  >here ~swap +abal 0 >c, ;                            ( next code label                                               )                                           hex                 : [?  ( AHEAD )   60 >c, ahalfgo ;                              : ?[  ( IF    )   1 xor >c,     ahalfgo ;                       : ]?  ( THEN  )   ?abal ~0= huh? -abal alinkto ;                : ][  ( ELSE  )   [? >R ~swap R> ]? ;                           : [[  ( BEGIN )   >here ~swap +abal ;                           : ?[[ ( WHILE )   >R ?abal drop R> ?[ >R ~swap R> ;             : ]]  ( AGAIN )   60 >c, abackto ;                              : ?]  ( UNTIL )   1 xor >c,     abackto ;                       : ]]? ( REPEAT)   ]]  ]? ;                                      : [[@    +abal >here 1+ 1+ ~swap 0 ;                            : !]]    ?abal drop -abal  ~swap   >here over - ~swap 1+ >c! ;                                                                  : NEXT   long .long     IP )+ W move  0 W BP DI) jmp                     0 >, ( debug) >here  >next dup @ >, ! ;