home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / 99asm.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  17.3 KB  |  997 lines
  1. \    9900 assembler
  2. \
  3. \    syntax:
  4. \
  5. \    <opcode> <operand> [ , <operand> ]
  6. \    <opcode> knows how many operands to expect, and
  7. \    the instruction is assembled as soon as the last
  8. \    operand is executed.
  9. \
  10. \    Assembler syntax:
  11. \
  12. \    reg     = R 0..15
  13. \    idx     = *R 0..15
  14. \    addr    = <addr> @>
  15. \    idx+    = *R+ 0..15
  16. \    idx+addr= <addr> @>(R) 0..15
  17. \    imm/cnt    = 0..ffff #
  18. \
  19. \    If fat-ass defined:    
  20. \        R0...R15, *R0...*R15, *R0+...*R15+, @>(R0)..@>(R15)
  21. \
  22. \    Jump targets and labels:
  23. \        jmp 3 $f    jmp 3 $b    \ forward, backward
  24. \    3 $:                        \ definition
  25. \
  26. \    <opcode>              ( op@ arg )
  27. \    <first operand>     ( op'@ arg reg/addr/imm )    
  28. \    <second operand>    ( op''@ arg reg/addr/imm )
  29. \
  30.  
  31.  
  32. [IFUNDEF] >cross
  33. : T ; immediate
  34. : H ; immediate
  35. [THEN]
  36. hex
  37.  
  38. \ only forth also definitions
  39. \    base address of image -- here for non-cross, 0 for cross
  40.  
  41. only forth also definitions
  42. vocabulary assembler 
  43. variable tbase 
  44.  
  45. : >assembler
  46.     also assembler definitions previous
  47. ; immediate
  48.  
  49. : <A> previous forth also assembler ; immediate
  50.  
  51. \ only forth also definitions
  52. cr order cr
  53. >assembler also assembler
  54.  
  55. \    Define FAT-ASS to get *R5+ as well as 5 *R+ 
  56. 1 constant fat-ass
  57.  
  58. : >4u.     ( # -- printed )
  59.     [char] > emit s>d <# # # # # #> type
  60. ;
  61.  
  62. : >1u.
  63.     [char] > emit s>d <# # #> type
  64. ;
  65.  
  66. : >2u.
  67.     [char] > emit s>d <# # # #> type
  68. ;
  69.  
  70. : R.
  71.     [char] R emit base @ $A base ! swap s>d <# #S #> type base !
  72. ;
  73.  
  74. : 2.
  75.     s>d <# # # #> type
  76. ;
  77.  
  78. \    operand types: the arg word says
  79. \    what we expect for this opcode.
  80. \    low byte has two of the (... values in its nybbles
  81. \    (>1 shift to the first one, >2 to the second)
  82. \    the high nybble tells which args we've gotten.
  83.  
  84. 1    constant (G        \ general
  85. 2    constant (4        \ 4-bit field
  86. 2    constant (C        \ register or count
  87. 2     constant (R        \ alias
  88. 3    constant (16    \ data (whole word)
  89. 3    constant (D        \ data (whole word)
  90. 4    constant (8        \ 8-bit field
  91. 4    constant (B        \ bit field (8 bits)
  92. 5    constant (J        \ jump (8 bits)
  93. 6    constant (I        \ immediate
  94. 7    constant (S        \ register at bit 6
  95. F    constant (#        \ type mask
  96.  
  97. 0    constant >1        \ shift to arg 1
  98. 4    constant >2        \ shift to arg 2
  99.  
  100. 8000 constant    1)    \ got arg 1
  101. 4000 constant    2)    \ got arg 2
  102.  
  103. variable InstGoing    \ true if incomplete opcode
  104. order
  105. InstGoing    off
  106.  
  107. : InstGoing?
  108.     InstGoing @ 0= if
  109.         cr ." Too many arguments"
  110.         1 throw
  111.     then
  112. ;
  113.  
  114. : asmerror"
  115.     ['] cr , postpone (.") ," ['] cr ,
  116. ; immediate
  117.  
  118. \    opcode types
  119.  
  120. : .argdesc    ( typ -- )
  121.     dup (G = if ." general" else
  122.     dup (C = if ." register/count" else
  123.     dup (D = if ." data" else
  124.     dup (B = if ." bit count" else
  125.     dup (J = if ." jump" else
  126.     dup (I = if ." immediate" else
  127.     dup (S = if ." register" else
  128.     dup 0 = if ." end of inst" else        \ error code
  129.                 ." ???arg = " dup .
  130.     then then then then then then then then
  131.     drop
  132. ;
  133.  
  134. \ 0 [if]
  135. : .inst ( op@ arg -- )
  136.     ." -- "
  137.     drop T here <A> swap ?do
  138.         i T @ <A> ." >" . 
  139.         T cell <A>        \ !!! tcell
  140.     +loop
  141. ;
  142. \ [then]
  143.  
  144. order
  145. : >op)    ( arg -- typ' )
  146.     dup 2) and if drop 0 else
  147.     dup 1) and if >2 rshift (# and else
  148.     >1 rshift (# and then then
  149. ;
  150.  
  151. : >end? ( op@ arg -- op@ arg | )
  152.     dup 2) and if
  153.         true                \ got two args, quit
  154.     else dup 1) and if
  155.         dup >2 rshift (# and 0=    \ if non-zero, want second arg
  156.     else
  157.         dup (# >2 lshift (# or and 0=    \ want any args?
  158.     then then
  159.     if 2drop \ .inst 
  160.         InstGoing off 
  161.     then
  162. ;
  163.  
  164. 0 [if]
  165. : <<)    ( arg typ' -- arg' shiftcnt )
  166.     over 1) and if        \ ( arg typ' arg&1 )
  167.         dup (G = if         \ ( arg t/f )
  168.             drop
  169.             2) or 6     \ ( arg' shiftcnt )
  170.         else dup (D = if
  171.             drop
  172.             2) or 16    \ i.e., a whole new word
  173.         else (R = if
  174.             2) or 4
  175.         else
  176.             2) or 4 
  177.         then then then
  178.     else
  179.         dup (J = if 
  180.             drop
  181.             1) or -1 
  182.         else (D = if
  183.             1) or 16
  184.         else
  185.             1) or 0 
  186.         then then
  187.     then
  188. ;
  189.  
  190. : op)    ( arg typ -- arg' shift 1 | arg 0 )
  191.     swap                \ ( typ arg )
  192.  
  193.     dup >op)            \ ( typ arg typ' )
  194.     >r                     \ save typ' ( R: arg typ' )
  195.  
  196.     swap r@                \ ( arg typ typ' )
  197.  
  198.     \ (G matches (G or (C
  199.     2dup                \ ( arg typ typ' typ typ' )
  200.     (G = swap (C = and    \ ( arg typ typ' typ'==(G&&typ==(C )
  201.     >r
  202.     \ (D matches (D or (I
  203.     2dup                \ ( arg typ typ' typ typ' )
  204.     (D = swap (I = and    \ ( arg typ typ' typ'==(D&&typ==(I )
  205.     >r
  206.     \ (I matches anything
  207.     over (I =
  208.     >r
  209.     = 
  210.     r> r> r> or or or
  211.  
  212.     \  ( arg t/f )
  213.     0= if
  214.         ." wanted " r> .argdesc cr
  215.         
  216.         InstGoing off
  217.         0                \ error
  218.     else
  219.         r>                 \ ( arg typ' )
  220.         <<)                \ ( arg' shf )
  221.         1                \ success
  222.     then
  223. ;
  224.  
  225. [else]
  226. : <<)    ( arg typ' -- arg' shiftcnt )
  227.     over 1) and if        \ ( arg typ' arg&1 )
  228.         case
  229. \        dup (G = if         \ ( arg t/f )
  230.         (G of
  231. \            drop
  232.             2) or 6     \ ( arg' shiftcnt )
  233.         endof
  234. \        else dup (D = if
  235.         (D of
  236. \            drop
  237.             2) or 16    \ i.e., a whole new word
  238.         endof
  239. \        else dup (R = if
  240.         (R of
  241. \            drop
  242.             2) or 4
  243.         endof
  244. \        else (S = if
  245.         (S of
  246.             2) or 6
  247.         endof
  248.         
  249.             2) or 4 
  250. \        then then then then
  251.         endcase
  252.     else
  253.         dup (J = if 
  254.             drop
  255.             1) or -1 
  256.         else (D = if
  257.             1) or 16
  258.         else
  259.             1) or 0 
  260.         then then
  261.     then
  262. ;
  263.  
  264. : op)    ( arg typ -- arg' shift 1 | arg 0 )
  265.     dup >r                \ save orig typ
  266.     swap                \ ( typ arg )
  267.  
  268.     dup >op)            \ ( typ arg typ' )
  269.     >r                     \ save typ' ( R: arg typ' )
  270.  
  271.     swap r@                \ ( arg typ typ' )
  272.  
  273.     \ (G matches (G or (C or (S
  274.     2dup                \ ( arg typ typ' typ typ' )
  275.     (G = swap (C = and    \ ( arg typ typ' typ'==(G&&typ==(C )
  276.     >r
  277.     2dup                \ ( arg typ typ' typ typ' )
  278.     (S = swap (C = and    \ ( arg typ typ' typ'==(G&&typ==(C )
  279.     >r
  280.     \ (D matches (D or (I
  281.     2dup                \ ( arg typ typ' typ typ' )
  282.     (D = swap (I = and    \ ( arg typ typ' typ'==(D&&typ==(I )
  283.     >r
  284.     \ (I matches anything
  285.     over (I =
  286.     >r
  287.     = 
  288.     r> or
  289.     r> or
  290.     r> or
  291.     r> or
  292.  
  293.     \  ( arg t/f )
  294.     0= if
  295.         ." wanted " rdrop r> .argdesc cr
  296.         
  297.         InstGoing off
  298.         0                \ error
  299.     else
  300.         r> rdrop        \ ( arg typ' )
  301.         <<)                \ ( arg' shf )
  302.         1                \ success
  303.     then
  304. ;
  305.  
  306. [endif]
  307.  
  308.     
  309. \    set bits in instruction and tell if done
  310. \    -1 on stack is flag that new args aren't needed
  311. \    (don't need to test explicitly, since new inst will drop it,
  312. \    and new op will match (1 and (2 and error out).
  313. order cr
  314. : >op!    ( op@ arg' bits -- op@ arg' | )
  315.     2 pick T @ <A> or         \ set bits ( op@ arg' bits )
  316.     2 pick T ! <A>
  317.     >end? 
  318. ;
  319. order
  320.  
  321. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  322.  
  323.  
  324. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  325.  
  326. : Register?
  327.     dup f invert and if
  328.         ." suspicious register R" dup . cr
  329.     then
  330. ;
  331.  
  332. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  333.  
  334. \ >assembler also asm-hidden
  335.  
  336. : R    ( op@ arg reg# -- op@ arg )
  337.     InstGoing? 
  338.     Register?
  339.     >r
  340.     (C op)                \ ( op@ arg' shift 1 | opc arg 0 )
  341.     if
  342.         r>                \ ( op@ arg' shift reg# )
  343.         swap lshift        \ ( op@ arg' regmask )
  344.         >op!            \ ( op@ arg' | )
  345.     else
  346.         rdrop
  347.     then
  348. ;
  349. cr ." R:" order cr
  350.  
  351. : R: ( num -- )
  352.     create 
  353.         ,
  354.     does>
  355.         @ R 
  356. ;
  357.  
  358. [IFDEF] FAT-ASS
  359. 0 R: R0        1 R: R1     2 R: R2        3 R: R3    
  360. 4 R: R4        5 R: R5        6 R: R6        7 R: R7
  361. 8 R: R8        9 R: R9        $A R: R10    $B R: R11
  362. $C R: R12    $D R: R13    $E R: R14    $F R: R15
  363. [THEN]
  364.  
  365. \ \\\\\\\\\\\\\\
  366.  
  367. : *R ( op@ arg reg# -- op@ arg )
  368.     InstGoing?
  369.     Register?
  370.     >r
  371.     (G op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  372.     if
  373.         r>                \ ( op@ arg' shift reg# )
  374.         10 or            \ add *Rx mask
  375.         swap lshift        \ ( op@ arg' regmask )
  376.         >op!            \ ( op@' arg' | )
  377.     else
  378.         rdrop
  379.     then
  380. ;
  381.  
  382. : *R: ( num -- )
  383.     create 
  384.         ,
  385.     does>
  386.         @ *R
  387. ;
  388.  
  389. [IFDEF] FAT-ASS
  390. 0 *R: *R0        1 *R: *R1         2 *R: *R2        3 *R: *R3    
  391. 4 *R: *R4        5 *R: *R5        6 *R: *R6        7 *R: *R7
  392. 8 *R: *R8        9 *R: *R9        $A *R: *R10        $B *R: *R11
  393. $C *R: *R12        $D *R: *R13        $E *R: *R14        $F *R: *R15
  394. [THEN]
  395.  
  396. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  397.  
  398. : *R+ ( op@ arg reg# -- op@ arg )
  399.     InstGoing?
  400.     Register?
  401.     >r
  402.     (G op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  403.     if
  404.         r>                \ ( op@ arg' shift reg# )
  405.         30 or            \ add *Rx+ mask
  406.         swap lshift        \ ( op@ arg' regmask )
  407.         >op!            \ ( op@' arg' | )
  408.     else
  409.         rdrop
  410.     then
  411. ;
  412.  
  413. : *R+: ( num -- )
  414.     create 
  415.         ,
  416.     does>
  417.         @ *R+
  418. ;
  419.  
  420. [IFDEF] FAT-ASS
  421. 0 *R+: *R0+        1 *R+: *R1+         2 *R+: *R2+        3 *R+: *R3+
  422. 4 *R+: *R4+        5 *R+: *R5+        6 *R+: *R6+        7 *R+: *R7+
  423. 8 *R+: *R8+        9 *R+: *R9+        $A *R+: *R10+    $B *R+: *R11+
  424. $C *R+: *R12+    $D *R+: *R13+    $E *R+: *R14+    $F *R+: *R15+
  425. [THEN]
  426.  
  427. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  428.  
  429. : @>(R) ( op@ arg addr reg# -- op@ arg )
  430.     InstGoing?
  431.     Register?
  432.     2>r                    \ hide reg# and addr#
  433.     (G op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  434.     if
  435.         r>                \ ( op@ arg' shift reg# )
  436.         20 or            \ add *Rx+ mask
  437.         swap lshift        \ ( op@ arg' regmask )
  438.         r> T A, <A>        \ add address
  439.         >op!            \ ( op@' arg' | )
  440.     else
  441.         2rdrop
  442.     then
  443. ;
  444.  
  445. : @>(R): ( num -- )
  446.     create 
  447.         ,
  448.     does>
  449.         @ @>(R)
  450. ;
  451.  
  452. [IFDEF] FAT-ASS
  453. 0 @>(R): @>(R0)        1 @>(R): @>(R1)         2 @>(R): @>(R2)        3 @>(R): @>(R3)
  454. 4 @>(R): @>(R4)        5 @>(R): @>(R5)        6 @>(R): @>(R6)        7 @>(R): @>(R7)
  455. 8 @>(R): @>(R8)        9 @>(R): @>(R9)        $A @>(R): @>(R10)    $B @>(R): @>(R11)
  456. $C @>(R): @>(R12)    $D @>(R): @>(R13)    $E @>(R): @>(R14)    $F @>(R): @>(R15)
  457. [THEN]
  458.  
  459.  
  460.  
  461. : @>     ( op@ arg addr reg# -- op@ arg )
  462.     InstGoing?
  463.     >r                    \ hide addr#
  464.     (G op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  465.     if
  466.         20                 \ add @>xxxx mask
  467.         swap lshift        \ ( op@ arg' regmask )
  468.         r> T A, <A>            \ add address
  469.         >op!            \ ( op@' arg' | )
  470.     else
  471.         rdrop
  472.     then
  473. ;
  474.  
  475. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  476.  
  477. : #     ( op@ arg num -- op@ arg )
  478.     InstGoing?
  479.     >r                    \ hide num
  480.     (I op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  481.     if
  482.         r> swap         \ ( op@ arg' data shift )
  483.         dup 16 = if
  484.             drop T , <A> 0    \ compile new word
  485.         else
  486.             lshift        \ ( op@ arg' data )
  487.         then
  488.         >op!            \ ( op@' arg' | )
  489.     else
  490.         rdrop
  491.     then
  492. ;
  493.  
  494. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  495.  
  496. : $+    ( op@ arg offset -- op@ arg )
  497.     InstGoing?
  498.  
  499.     >r                    \ hide num
  500.     (J op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  501.     if
  502.         r> swap         \ ( op@ arg' data shift )
  503.         drop
  504.         2/ 1-            \ calc offset
  505.         dup -81 80 within
  506.         0= if
  507.             ." warning: jump out of range = " dup . cr
  508.         then
  509.         ff and
  510.         >op!            \ ( op@' arg' | )
  511.     else
  512.         rdrop
  513.     then
  514.  
  515. ;
  516.  
  517. : $        ( op@ arg addr -- op@ arg )
  518.     InstGoing?
  519.  
  520.     >r                    \ hide num
  521.     (J op)                \ ( op@ arg' shift 1 | op@ arg 0 )
  522.     if
  523.         r> swap         \ ( op@ arg' data shift )
  524.         drop
  525.         T here <A> 2dup 2>r -
  526.         2/                 \ calc offset
  527.         dup -81 80 within
  528.         0= if
  529.             2r>
  530.             ." warning: jump from " 2 - . ." out of range to " . cr
  531.         else
  532.             2rdrop
  533.         then
  534.         ff and
  535.         >op!            \ ( op@' arg' | )
  536.     else
  537.         rdrop
  538.     then
  539.  
  540. ;
  541.  
  542. \    values are relative to tbase
  543. \    <reschain> <addr>
  544. \    reschain==ffff if no unresolved references
  545. \    else reschain points to jump instruction chain
  546. \    addr holds value of label; may be valid even if reschain <> ffff
  547. \    (i.e., when redefining a label); ffff if not defined
  548. \
  549.  
  550. create #Labels    10 2* cells allot
  551.  
  552. : #>Label    ( num -- laddr )
  553.     dup 0>= over 10 < and if
  554.         2* cells #Labels +
  555.     else
  556.         abort" label number out of range (0-9): " .
  557.         #Labels
  558.     then
  559. ;
  560.  
  561. : Label>#    ( laddr -- num )
  562.     #Labels - 2 cells /
  563. ;
  564.  
  565. : clear-labels
  566.     #Labels 10 0 do 
  567.         ffff over ! ffff over cell+ ! 2 cells +
  568.     loop
  569.     drop
  570. ;
  571.  
  572. \    is the label unresolved?
  573. \
  574. : $>fwd? ( label -- t/f )
  575.     @ ffff <>
  576. ;
  577.  
  578.  
  579. \    add reference to label by making
  580. \    list through the offsets of other jumps:
  581. \
  582. \    >xxxx jmp 1 $f    --> jmp $
  583. \    ...
  584. \    >yyyy jne 1 $f    --> jmp >xxxx
  585. \    ...
  586. \    $f must call $ to fixup the jump.
  587. \
  588. : $>ref ( label addr -- paddr )
  589.     over @                \ label addr paddr
  590.     dup ffff = if drop T here <A> 2 - then    \ undefined jmp
  591.     -rot swap !        \ paddr
  592. ;
  593.  
  594. \    reference a label forward
  595. \    jmp 3 $f
  596. \
  597. : $f    ( op@ arg num -- )
  598.     #>Label            \ get addr
  599.     T here <A> 2 - $>ref    \ add reference
  600.     $                \ "jump" to previous ref
  601. ;
  602.  
  603. \    resolve reference to label
  604. \    undefined labels --> 0
  605. : $>res ( label -- resaddr )
  606.     cell+ @ dup ffff = if
  607.         ." error: label not defined yet" cr
  608.     then
  609. ;
  610.  
  611. \    reference a label backward
  612. \    jmp 3 $b
  613. : $b    ( op@ arg num -- )
  614.     #>Label             \ get addr
  615.     $>res            \ resolve (or error)
  616.     tbase @ + $        \ jump
  617. ;
  618.  
  619. \    define label
  620. \    for all previous references, fix them up
  621. \    and store new address at label
  622. \
  623. : $>fixup ( raddr opc taddr -- )
  624.     rot    dup >r        \ ( opc taddr raddr )
  625.     - 2 - 2/        \ ( opc jmpoffs )
  626.     swap FF00 
  627.     and or            \ ( opc' )
  628.     r> T ! <A>
  629. ;
  630.  
  631. : op>joffs ( opc -- jump-offset )
  632.     ff and dup 80 >= if ff invert or then 2* 2 +
  633. ;
  634.  
  635. : $>resolve ( label taddr -- )
  636.     over @             \ ( label taddr raddr )
  637.     swap >r
  638.     begin            \ ( label raddr )
  639.         dup            \ save raddr
  640.         T @ <A>
  641.         
  642.         2dup r@ $>fixup
  643.         op>joffs    \ ( label raddr joffs )
  644.         swap over + swap
  645.         0=
  646.     until
  647.     rdrop 2drop
  648. ;
  649.  
  650.  
  651. : $>set ( label taddr -- )
  652.     over Label># ." Label " . ." = @" dup >4u. cr
  653.     over ffff swap !        \ not unresolved
  654.     swap cell+ !            \ save new addr
  655. ;
  656.  
  657. : $>def    ( label addr -- )
  658.     over $>fwd? if
  659.         2dup $>resolve
  660.     \    else
  661.     \     label redefined
  662.     then
  663.     $>set
  664. ;
  665.  
  666. \    define a label
  667. \    3 $:
  668. : $:    ( num -- )
  669.     #>Label            \ get addr
  670.     T here <A> $>def        \ define
  671. ;
  672.  
  673.  
  674. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  675.  
  676. \    Instruction formats.
  677.  
  678. : inst:        ( opc arg1 arg2 -- )
  679.     create
  680.         >2 lshift or , ,    
  681.     does>
  682.  
  683.         \ see if inst was finished
  684.         InstGoing @ if
  685.             asmerror" Previous instruction not finished!"
  686.             nip nip
  687.         then
  688.         InstGoing on
  689.         T here <A>
  690.         \ read opcode and write to memory
  691.         swap dup cell + @ T , <A>
  692.         \ read argflags
  693.         @
  694.         \ leaves ( op@ flags )
  695.         >end?
  696. ;
  697.  
  698. : DATA
  699.     t , <A>
  700. ;
  701.  
  702. \ cr cr cr order cr cr cr 
  703.  
  704. 0000    0    0    inst:    (DATA)
  705. 0200    (R    (D    inst:    LI
  706. 0220    (R    (D    inst:    AI
  707. 0240    (R    (D    inst:    ANDI
  708. 0260    (R    (D    inst:    ORI
  709. 0280    (R    (D    inst:    CI
  710. 02A0    (R    0    inst:    STWP
  711. 02C0    (R    0    inst:    STST
  712. 02E0    (D    0    inst:    LWPI
  713.  
  714. 0300    (D    0    inst:    LIMI
  715. 0340    0    0    inst:    IDLE
  716. 0360    0    0    inst:    RSET
  717. 0380    0    0    inst:    RTWP
  718. 03A0    0    0    inst:    CKON
  719. 03C0    0    0    inst:    CKOF
  720. 03E0    0    0    inst:    LREX
  721.  
  722. 0400    (G    0    inst:    BLWP
  723. 0440    (G    0    inst:    B
  724. 0480    (G    0    inst:    X
  725. 04C0    (G    0    inst:    CLR
  726. 0500    (G    0    inst:    NEG
  727. 0540    (G    0    inst:    INV
  728. 0580    (G    0    inst:    INC
  729. 05C0    (G    0    inst:    INCT
  730. 0600    (G    0    inst:    DEC
  731. 0640    (G    0    inst:    DECT
  732. 0680    (G    0    inst:    BL
  733. 06C0    (G    0    inst:    SWPB
  734. 0700    (G    0    inst:    SETO
  735. 0740    (G    0    inst:    ABS
  736.  
  737. 0800    (R    (C    inst:    SRA
  738. 0900    (R    (C    inst:    SRL
  739. 0A00    (R    (C    inst:    SLA
  740. 0B00    (R    (C    inst:    SRC
  741.  
  742. 0C00    (C    0    inst:    DSR            \ v9t9
  743. 0D40    0    0    inst:    KYSL        \ v9t9
  744. 0DC0    (R    0    inst:    EMITCHAR    \ v9t9
  745. 0DE0    0    0    inst:    DBG            \ v9t9
  746. 0DE1    0    0    inst:    -DBG        \ v9t9
  747.  
  748. 1000    (J    0    inst:    JMP
  749. 1100    (J    0    inst:    JLT
  750. 1200    (J    0    inst:    JLE
  751. 1300    (J    0    inst:    JEQ
  752. 1400    (J    0    inst:    JHE
  753. 1500    (J    0    inst:    JGT
  754. 1600    (J    0    inst:    JNE
  755. 1700    (J    0    inst:    JNC
  756. 1800    (J    0    inst:    JOC
  757. 1900    (J    0    inst:    JNO
  758. 1A00    (J    0    inst:    JL
  759. 1B00    (J    0    inst:    JH
  760. 1C00    (J    0    inst:    JOP
  761.  
  762. 1D00    (B    0    inst:    SBO
  763. 1E00    (B    0    inst:    SBZ
  764. 1F00    (B    0    inst:    TB
  765.  
  766. 2000    (G    (S    inst:    COC        \ not (R
  767. 2400    (G    (S    inst:    CZC        \ not (R
  768. 2800    (G    (S    inst:    XOR        \ not (R
  769. 2C00    (G    (S    inst:    XOP
  770.  
  771. 3000    (G    (C    inst:    LDCR
  772. 3400    (G    (C    inst:    STCR
  773. 3800    (G    (S    inst:    MPY
  774. 3C00    (G    (S    inst:    DIV
  775.  
  776. 4000    (G    (G    inst:    SZC
  777. 5000    (G    (G    inst:    SZCB
  778. 6000    (G    (G    inst:    S
  779. 7000    (G    (G    inst:    SB
  780. 8000    (G    (G    inst:    C
  781. 9000    (G    (G    inst:    CB
  782. A000    (G    (G    inst:    A
  783. B000    (G    (G    inst:    AB
  784. C000     (G    (G    inst:    MOV    
  785. D000     (G    (G    inst:    MOVB
  786. E000     (G    (G    inst:    SOC
  787. F000     (G    (G    inst:    SOCB
  788.  
  789.  
  790. \    Disassembler
  791.  
  792. \ >assembler-hidden
  793.  
  794. create opcode-table
  795.     ' (DATA) , ' LI , ' AI , ' ANDI , ' ORI , ' CI , ' STWP , ' STST , ' LWPI ,
  796.     ' LIMI , ' IDLE , ' RSET , ' RTWP , ' CKON , ' CKOF , ' LREX ,
  797.     ' BLWP , ' B , ' X , ' CLR , ' NEG , ' INV , ' INC , ' INCT , 
  798.     ' DEC , ' DECT , ' BL , ' SWPB , ' SETO , ' ABS ,
  799.     ' SRA , ' SRL , ' SLA , ' SRC , ' DSR , ' KYSL , ' EMITCHAR , ' DBG , ' -DBG ,
  800.     ' JMP , ' JLT , ' JLE , ' JEQ , ' JHE , ' JGT , ' JNE , ' JNC ,
  801.     ' JOC , ' JNO , ' JL , ' JH , ' JOP , ' SBO , ' SBZ , ' TB ,
  802.     ' COC , ' CZC , ' XOR , ' XOP , ' LDCR , ' STCR , ' MPY , ' DIV ,
  803.     ' SZC , ' SZCB , ' S , ' SB , ' C , ' CB , 
  804.     ' A , ' AB , ' MOV , ' MOVB , ' SOC , ' SOCB ,
  805.     0 ,
  806.  
  807. : inst>info    ( xt -- flags opc )
  808.     >body dup @ swap cell + @
  809. ;
  810.  
  811. : inst>op    ( xt -- opc )
  812.     inst>info nip
  813. ;
  814. : inst>args    ( xt -- flags )
  815.     inst>info drop
  816. ;
  817.  
  818. : instlookup ( opc -- xt )
  819.     >r
  820.     opcode-table cell+        \ skip (DATA)
  821.     begin
  822.         dup @                \ ( opc ptr xt )
  823.         dup if
  824.             inst>op            \ ( opc ptr opc' )
  825.             r@ U<=
  826.         else
  827.             0 nip
  828.         then
  829.     while
  830.         cell+
  831.     repeat
  832.  
  833.     \ here, ptr points to opcode past the one we want.
  834.     cell -
  835.      @
  836.  
  837.     rdrop
  838. ;
  839.  
  840.  
  841. : op-show-(G ( addr opc arg# typ -- addr )
  842.     <<) nip rshift
  843.     dup 30 and        
  844.     swap F and
  845.     over 0 = if R. else
  846.     over 10 = if [char] * emit R. else
  847.     over 20 = if 
  848.         [char] @ emit      \ ( addr typ reg )
  849.         2>r 2 + dup T @ <A> >4u. 2r>
  850.         ?dup if [char] ( emit R. [char] ) emit then
  851.     else
  852.         [char] * emit R. [char] + emit
  853.     then then then
  854.     drop
  855. ;
  856.  
  857. : op-show-(4  ( addr opc arg# typ -- addr )
  858.     over >r <<) nip rshift F and 
  859.     r> 0= if R. else >1u. then
  860. ;
  861. : op-show-(8  ( addr opc arg# typ -- addr )
  862.     2drop FF and >2u.
  863. ;
  864. : op-show-(16  ( addr opc arg# typ -- addr )
  865.     2drop drop 2 + dup T @ <A> >4u.
  866. ;
  867. : op-show-(J ( addr opc arg# typ -- addr )
  868.     2drop FF and
  869.     dup 80 u>= if ff invert or then
  870.     1 lshift over + 2 +
  871.     >4u.
  872. ;
  873.  
  874.  
  875. : op-show    ( addr typ opc arg# -- addr )
  876.     2 pick >r
  877.     r@ (G = if rot op-show-(G else
  878.     r@ (4 = if rot op-show-(4 else
  879.     r@ (16 = if rot op-show-(16 else
  880.     r@ (8 = if rot op-show-(8 else
  881.     r@ (J = if rot op-show-(J else
  882.     r@ (S = if rot op-show-(4 else
  883.     r@ (I = if rot op-show-(16 else drop ." [???op=" . ." |typ=" . 
  884.     then then then then then then then
  885.     rdrop
  886. ;
  887.  
  888. : instdis ( addr opc -- addr )
  889.     dup >r
  890.     instlookup
  891.  
  892.     \ get name
  893.     dup >head name>string
  894.     2dup
  895.     type
  896.     nip negate 6 + spaces  
  897.  
  898.     inst>args >r
  899.     r@ >1 rshift (# and dup
  900.     if 2r@ drop 0 op-show
  901.         r@ >2 rshift (# and  dup
  902.         if [char] , emit 
  903.             2r@ drop 1) op-show else
  904.             drop then
  905.     else drop then
  906.  
  907.     2rdrop
  908. ;
  909.  
  910. 8 constant per-line
  911.  
  912. [IFUNDEF] >target
  913. \ only forth also definitions
  914. [ELSE]
  915. >target
  916. [THEN]
  917.  
  918. : dis ( addr cnt -- )
  919.     over + swap ?do
  920.         i >4u.        \ print address
  921.         [char] = emit
  922.         i T @ <A>
  923.         dup >4u.    \ print opcode
  924.         20 emit
  925.         i swap instdis 
  926.         cr
  927.         i - 2 +        \ add #cells read
  928.     +loop
  929. ;
  930.  
  931.  
  932. : tdump ( addr cnt -- )
  933.     dup 0< if exit then
  934.     over + swap ?do
  935.         i >4u. $20 emit [char] = emit $20 emit
  936.         i' i per-line + min dup i ?do 
  937.             i  T c@ <A> 2. $20 emit
  938.         loop    
  939.         i - 
  940.         dup
  941.             per-line swap - 0 ?do ."    " loop
  942.         dup
  943.             0 ?do j i +  T c@ <A> dup $20 $7f within 0= 
  944.                 if drop [char] . then emit 
  945.             loop
  946.         cr
  947.     +loop
  948. ;
  949.  
  950.  
  951.  
  952. \    syntactical sugar for assembler
  953.  
  954. \ >assembler-hidden  also asm-hidden
  955.  
  956. >assembler
  957.  
  958. get-order
  959. [IFUNDEF] >cross
  960. [ELSE]
  961. only forth also cross
  962. : [  postpone [ ;
  963. : ]  postpone ] ;
  964.  
  965. [THEN]
  966. order cr cr
  967. set-order
  968.  
  969. : ,     ( opc arg -- opc arg )
  970.     InstGoing @ if
  971.         dup 1) and 0= if
  972. \        ." no operand or unresolved operand preceding comma"
  973.             InstGoing off
  974.             2drop
  975.         then
  976.     else
  977.         ,
  978.     then
  979. ;
  980.  
  981. [IFDEF] >cross
  982. 0 tbase !
  983. [ELSE]
  984. T here <A> tbase !
  985. [THEN]
  986.  
  987. clear-labels
  988.  
  989. \ >root
  990.  
  991. [IFDEF] >cross
  992. >cross
  993. [THEN]
  994.  
  995.  
  996.  
  997.