home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / disassem.seq < prev    next >
Text File  |  1988-09-20  |  16KB  |  502 lines
  1. \ DISASSEM.SEQ  A disassembler for the 8086             by Charles Curley
  2.  
  3. FORTH DEFINITIONS
  4. DECIMAL
  5. WARNING OFF
  6.  
  7. VOCABULARY DISASSEMBLER
  8.  
  9. \ : EXEC  2* R> + PERFORM   ;
  10.  
  11. CODE 2/S     \ n ct --- n' | shift n right ct times
  12.         POP CX
  13.         POP AX
  14.         SHR AX, CL
  15.         1PUSH
  16.         END-CODE
  17.  
  18. CODE 2*S     \ n ct --- n' | shift n left ct times
  19.         POP CX
  20.         POP AX
  21.         SHL AX, CL
  22.         1PUSH
  23.         END-CODE
  24.  
  25. : STOP[  ?CSP REVEAL  [COMPILE] [ ; IMMEDIATE
  26.  
  27. CODE SEXT    \ n --- n' | sign extend lower half of n to upper
  28.         POP AX
  29.         CBW
  30.         1PUSH
  31.         END-CODE
  32.  
  33. : C?  C@ . ;
  34.  
  35. : COL   #OUT @  - SPACES ;   \ n ---  | go to column n
  36.  
  37. VARIABLE RELOC  0 ,  ?CS: 0 RELOC 2! \ keeps relocation factor
  38. : (T@)   RELOC 2@ ROT +  @L ; \ in first word, seg in 2nd. You
  39.                               \ dump/dis any segment w/ any
  40. : (TC@)  RELOC 2@ ROT + C@L ; \ relocation you want by setting
  41.                               \ RELOC  correctly.
  42. : SETSEG   RELOC 2+ ! ;       : HOMESEG   ?CS: SETSEG ;
  43.  
  44. : SEG?  RELOC 2+ @ U. ;
  45.  
  46. DEFER T@                       DEFER TC@
  47. : MEMORY    ['] (TC@) IS TC@       ['] (T@) IS T@ ;   MEMORY
  48.  
  49. : DUMPBOOT   MEMORY  HOMESEG  [ ' BOOT >BODY @ , ] ;
  50. ' DUMPBOOT  IS BOOT
  51.  
  52. VARIABLE CP                 DISASSEMBLER DEFINITIONS
  53. VARIABLE SAVEBASE        BASE @ SAVEBASE !
  54.  
  55. CODE CP@
  56.         MOV AX, CP
  57.         1PUSH
  58.         END-CODE
  59.  
  60. : OOPS   CR CR .S  SAVEBASE @ BASE !
  61.   BELL EMIT  TRUE ABORT"  OOPS!"  STOP[
  62.  
  63. : NEXTB  CP@ TC@    CP INCR ;
  64.  
  65. : NEXTW  CP@ T@   2 CP +! ;
  66.  
  67. : .MOI       \  ---  | have the current word print out its name.
  68.   LAST @ [COMPILE] LITERAL  COMPILE .ID ;   IMMEDIATE
  69.  
  70. VARIABLE OPS \ operand count
  71. VARIABLE IM  \ 2nd operand extension flag/ct
  72.  
  73. : ?DISP      \ op ext --- op ext | does MOD operand have a disp?
  74.   DUP 6 2/S  DUP 3 =  OVER 0=  OR
  75.   0= IF  IM !  ELSE
  76.      0= IF DUP 7 AND 6 = IF 2 IM ! THEN  THEN  THEN ;
  77.  
  78. : .SELF      \  --  | create a word which prints its name
  79.   CREATE  LAST @ ,  DOES> @ .ID ;  \ the ultimate in self-doc!
  80.  
  81. .SELF AL        .SELF AX        .SELF [BX+SI]   .SELF ES
  82. .SELF CL        .SELF CX        .SELF [BX+DI]   .SELF CS
  83. .SELF DL        .SELF DX        .SELF [BP+SI]   .SELF SS
  84. .SELF BL        .SELF BX        .SELF [BP+DI]   .SELF DS
  85. .SELF AH        .SELF SP        .SELF [SI]      .SELF #
  86. .SELF CH        .SELF BP        .SELF [DI]      .SELF #)
  87. .SELF DH        .SELF SI        .SELF [BP]      .SELF S#)
  88. .SELF BH        .SELF DI        .SELF [BX]
  89. .SELF RP        .SELF [RP]      \ RETURN STACK POINTER
  90. .SELF IP        .SELF [IP]      \ INTERPRETER POINTER
  91. .SELF W         .SELF [W]       \ WORKING REGISTER
  92.  
  93. 6 CONSTANT SYMBOLCT              CREATE SYMBOLS  ASSEMBLER
  94. >NEXT ,  >NEXT 1- ,  >NEXT 2- ,  >NEXT 3 - ,  ' BRANCH >BODY ,
  95. ' (LOOP) 5 + ,
  96. DISASSEMBLER
  97. .SELF NEXT      .SELF 1PUSH     .SELF 2PUSH     .SELF 3PUSH
  98. .SELF BRAN1     .SELF PLOOP
  99.  
  100. : ?SYMBOL    \ a -- a n | if n = -1 then no symbol, else index
  101.   TRUE  RELOC 2+ @  ?CS: = IF \ iff in code segment.
  102.     SYMBOLCT 0 DO OVER I 2* SYMBOLS + @ =
  103.       IF DROP I LEAVE THEN LOOP THEN ;
  104.  
  105. : .SYMBOL    \ a ---  | print symbol name else value
  106.   ?SYMBOL  DUP 0< IF DROP U.  EXIT THEN  SWAP U. EXEC:
  107.   NEXT 1PUSH  2PUSH  3PUSH  BRAN1  PLOOP  STOP[
  108. FORTH DEFINITIONS
  109. VARIABLE SYMBOLIC  SYMBOLIC ON
  110.  
  111. DISASSEMBLER DEFINITIONS
  112. : SYMBOL  CREATE  ' >NAME ,  ' >NAME ,
  113.   DOES> SYMBOLIC @ IF 2+ THEN @ .ID ;
  114.  
  115. SYMBOL BX BX W   SYMBOL [BX] [BX] [W]
  116. SYMBOL SI SI IP  SYMBOL [SI] [SI] [IP]
  117. SYMBOL BP BP RP  SYMBOL [BP] [BP] [RP]
  118.  
  119. : .16REG     \ r# ---  | register printed out
  120.   7 AND  EXEC:  AX CX DX BX  SP BP SI DI  STOP[
  121.  
  122. : .8REG      \ r# ---  | register printed out
  123.   7 AND  EXEC:  AL CL DL BL  AH CH DH BH  STOP[
  124.  
  125. : .SEG       \ s# ---  | register printed out
  126.   3 2/S 3 AND  EXEC:  ES CS SS DS   STOP[
  127.  
  128. : 0DISP      \  ---  | do if displacement is 0
  129.   ." 0 "  ;
  130.  
  131. : BDISP      \  ---  | do if displacement is byte
  132.   CP@  IM @ +  TC@ SEXT U.  OPS INCR  IM OFF ;
  133.  
  134. : WDISP      \  ---  | do if displacement is word
  135.   CP@  IM @ +  T@  U.  2 OPS +!  IM OFF ;
  136.  
  137. : (.R/M)     \ op ext ---  | print a register
  138.   SWAP 1 AND  IF .16REG ELSE .8REG THEN  IM OFF ;
  139.  
  140. : .R/M       \ op ext --- op ext | print r/m as register
  141.   2DUP        (.R/M) ;
  142.  
  143. : .REG       \ op ext --- op ext | print reg as register
  144.   2DUP  3 2/S (.R/M) ;
  145.  
  146. : .DISP      \ op ext --- op ext | print displacement
  147.   DUP 6 2/S  3 AND  EXEC:  0DISP BDISP WDISP .R/M STOP[
  148.  
  149. : BIMM       \  ---  | do if immed. value is byte
  150.   CP@  IM @ +  TC@      .  1 OPS +!  IM OFF ;
  151.  
  152. HEX
  153. : .MREG     \ op ext --- op ext | register(s) printed out + disp
  154.   DUP C7 AND 6 = IF  WDISP #)  ELSE
  155.   DUP C0 AND C0 - IF  .DISP
  156.   DUP  7 AND EXEC:  [BX+SI]  [BX+DI]  [BP+SI]  [BP+DI]
  157.                    [SI]     [DI]     [BP]     [BX]
  158.   ELSE .R/M  IM OFF  THEN  THEN ;
  159.  
  160. DECIMAL                         .SELF BYTE        .SELF WORD
  161. : .SIZE      \ op ---  | decodes for size
  162.   1 AND  EXEC:  BYTE  WORD   STOP[
  163.  
  164. CREATE SEGTB  ASCII E C, ASCII C C,  ASCII S C,  ASCII D C,
  165.  
  166. : SEG:       \ op ---  | print segment overrides
  167.   3 2/S 3 AND SEGTB + C@ EMIT  ." S:" ;
  168.  
  169. : POP,       \ op ---  | print pops
  170.   DUP 8 = IF OOPS THEN  .SEG  .MOI ;
  171.  
  172. : PUSH,      \ op ---  | print pushes
  173.   .SEG  .MOI ;
  174.  
  175. : P/P        \ op --- | pushes or pops
  176.   DUP 1 AND  EXEC:  PUSH, POP,  STOP[
  177.  
  178. .SELF DAA,      .SELF DAS,      .SELF AAA,      .SELF AAS,
  179.  
  180. : ADJUSTS    \ op ---  | the adjusts
  181.   3 2/S  3 AND  EXEC:  DAA,  DAS,  AAA,  AAS,  STOP[
  182.  
  183. : P/SEG      \ op ---  | push or seg overrides
  184.   DUP 5 2/S  1 AND EXEC:  P/P SEG:      STOP[
  185.  
  186. : P/ADJ      \ op ---  | pop or adjusts
  187.   DUP 5 2/S  1 AND EXEC:  P/P ADJUSTS  STOP[
  188.  
  189. : 0GP        \ op --- op | opcode decoded & printed
  190.   DUP 4 AND IF  DUP 1 AND
  191.             IF WDISP ELSE BIMM THEN  #
  192.             1 AND IF AX ELSE AL THEN  ELSE
  193.   NEXTB  OVER 2 AND
  194.          IF  .MREG .REG  ELSE  ?DISP .REG .MREG
  195.   THEN  2DROP THEN  ;
  196.  
  197. .SELF ADD,      .SELF ADC,      .SELF AND,      .SELF XOR,
  198. .SELF OR,       .SELF SBB,      .SELF SUB,      .SELF CMP,
  199.  
  200. : 0GROUP     \ op ---  | select 0 group to print
  201.   DUP 0GP 3 2/S 7 AND  EXEC:
  202.   ADD,  OR,   ADC,  SBB,  AND,  SUB,  XOR,  CMP,  STOP[
  203.  
  204. : LOWS       \ op ---  |  0-3f opcodes printed out
  205.   DUP        7 AND  EXEC:
  206.   0GROUP  0GROUP  0GROUP  0GROUP
  207.   0GROUP  0GROUP  P/SEG   P/ADJ  STOP[
  208.  
  209. : .REGGP     \ op ---  | register group defining word
  210.   CREATE  LAST @ ,    DOES>  @ SWAP  .16REG  .ID ;
  211.  
  212. .REGGP INC,     .REGGP DEC,     .REGGP PUSH,    .REGGP POP,
  213.  
  214. : POP,       \ op ---  | handle illegal opcode for cs pop
  215.   DUP 56 AND 8 = IF ." illegal," DROP  ELSE  POP,  THEN ;
  216.  
  217. : REGS       \ op ---  | 40-5f opcodes printed out
  218.   DUP 3 2/S 3 AND EXEC:  INC, DEC, PUSH, POP,   STOP[
  219. .SELF O,        .SELF NO,       .SELF B/NAE,    .SELF NB/AE,
  220. .SELF E/Z,      .SELF NE/NZ,    .SELF BE/NA,    .SELF NBE/A,
  221. .SELF S,        .SELF NS,       .SELF P/PE,     .SELF NP/PO,
  222. .SELF L/NGE,    .SELF NL/GE,    .SELF LE/NG,    .SELF NLE/JG,
  223.  
  224. : .BRANCH    \ op ---  | branch printed out w/ dest.
  225.   NEXTB SEXT  CP @ + .SYMBOL  ASCII J EMIT   15 AND EXEC:
  226.   O,    NO,   B/NAE, NB/AE, E/Z,   NE/NZ, BE/NA, NBE/A,
  227.   S,    NS,   P/PE,  NP/PO, L/NGE, NL/GE, LE/NG, NLE/JG,
  228.                   STOP[
  229.  
  230. : MEDS       \ op ---  | 40-7f opcodes printed out
  231.   DUP 4 2/S  3 AND EXEC:
  232.   REGS  REGS  OOPS .BRANCH  STOP[
  233.  
  234. : 80/81      \ op ---  | secondary at 80 or 81
  235.   NEXTB  ?DISP OVER 1 AND  IF WDISP ELSE BIMM THEN  # .MREG
  236.   SWAP .SIZE  3 2/S 7 AND  EXEC:
  237.   ADD, OR,  ADC, SBB, AND, SUB, XOR, CMP,   STOP[
  238.  
  239. : 83S        \ op ---  | secondary at 83
  240.   NEXTB  ?DISP BIMM #  .MREG
  241.   SWAP .SIZE  3 2/S 7 AND  EXEC:
  242.   ADD, OR,  ADC, SBB, AND, SUB, XOR, CMP,   STOP[
  243.  
  244. : 1GP        \ op ---  | r/m reg opcodes
  245.   CREATE  LAST @ ,  DOES> @ >R  NEXTB  ?DISP .REG .MREG  2DROP
  246.   R> .ID ;
  247.  
  248. 1GP TEST,       1GP XCHG,       .SELF LEA,      .SELF MOV,
  249.  
  250. : MOVRM/REG  NEXTB  ?DISP .REG .MREG  2DROP  MOV, ; \ 88-89
  251.  
  252. : MOVD       NEXTB        .MREG .REG  2DROP  MOV, ; \ 8A-8B
  253.  
  254. HEX
  255. : MOVS>M     \ op ---  | display instructions  8C-8E
  256.   NEXTB  OVER 8D = IF  .MREG .REG  LEA,  ELSE
  257.     OVER 8F = IF  .MREG  [ ' POP, >NAME ] LITERAL .ID  ELSE
  258.     SWAP 1 OR SWAP  \ 16 bit moves only, folks!
  259.     OVER 2 AND IF  .MREG DUP .SEG  ELSE
  260.    ( ?DISP) DUP .SEG .MREG  THEN MOV, THEN THEN  2DROP ;
  261.  
  262. : 8MOVS      \ op ---  | display instructions  80-8F
  263.   DUP 2/ 7 AND EXEC:  80/81 83S TEST, XCHG,
  264.                      MOVRM/REG  MOVD  MOVS>M  MOVS>M  STOP[
  265.  
  266. DECIMAL
  267.  
  268. .SELF XCHG,     .SELF CBW,      .SELF CWD,      .SELF CALL,
  269. .SELF WAIT,     .SELF PUSHF,    .SELF POPF,     .SELF SAHF,
  270. .SELF LAHF,
  271.  
  272. : INTER      \ ---  | decode interseg jmp or call
  273.   NEXTW .SYMBOL ." : " NEXTW U. ;
  274.  
  275. : CALLINTER  \ ---  | decode interseg call
  276.   INTER  CALL, ;
  277.  
  278. : 9HIS       \ op ---  | 98-9F decodes
  279.   7 AND EXEC:
  280.   CBW,  CWD,  CALLINTER WAIT,  PUSHF,  POPF, SAHF, LAHF,  STOP[
  281.  
  282. : XCHGA      \ op ---  | 98-9F decodes
  283.   AX .16REG  XCHG, ;
  284.  
  285. : 90S        \ op ---  | 90-9F decodes
  286.   DUP 3 2/S 1 AND EXEC:  XCHGA  9HIS  STOP[
  287.  
  288. .SELF MOVS,     .SELF CMPS,
  289.  
  290. : MOVS       \ op ---  | A4-A5 decodes
  291.   .SIZE  MOVS, ;
  292.  
  293. : CMPS       \ op ---  | A6-A7 decodes
  294.   .SIZE  CMPS, ;
  295.  
  296. : .AL/AX     \ op ---  | decodes for size
  297.   1 AND  EXEC:  AL AX STOP[
  298.  
  299. : MOVS/ACC   \ op ---  | A0-A3 decodes
  300.   DUP 2 AND IF  .AL/AX  WDISP #)  ELSE
  301.       WDISP #)  .AL/AX  THEN MOV, ;
  302.  
  303. .SELF TEST,     .SELF STOS,     .SELF LODS,     .SELF SCAS,
  304.  
  305. : .TEST      \ op ---  | A8-A9 decodes
  306.   DUP 1 AND IF WDISP ELSE BIMM THEN #  .AL/AX TEST, ;
  307.  
  308. : STOS   ( op --- )  .SIZE  STOS, ;
  309. : LODS   ( op --- )  .SIZE  LODS, ;
  310. : SCAS   ( op --- )  .SIZE  SCAS, ;
  311.  
  312. : A0S        \ op ---  | A0-AF decodes
  313.   DUP 2/ 7 AND EXEC:
  314.   MOVS/ACC MOVS/ACC  MOVS       CMPS
  315.   .TEST    STOS      LODS       SCAS       STOP[
  316.  
  317. : MOVS/IMM   \ op ---  | B0-BF decodes
  318.   DUP 8 AND IF  WDISP # .16REG  ELSE  BIMM # .8REG  THEN
  319.   MOV, ;
  320.  
  321. : HMEDS      \ op ---  | op codes 80 - C0 displayed
  322.   DUP 4 2/S  3 AND EXEC:  8MOVS  90S A0S MOVS/IMM   STOP[
  323.  
  324. .SELF LES,      .SELF LDS,      .SELF INTO,     .SELF IRET,
  325.  
  326. : LES/LDS    \ op ---  | les/lds instruction  C4-C5
  327.   NEXTB .MREG  .REG  DROP 1 AND EXEC: LES, LDS, STOP[
  328.  
  329. : RET,       \ op ---  | return instruction  C2-C3, CA-CB
  330.   DUP 1 AND 0= IF WDISP ."  SP+" THEN
  331.   8 AND IF ."  FAR"  THEN  .MOI ;
  332.  
  333. : MOV#R/M    \ op ---  | return instruction  C2-C3, CA-CB
  334.   NEXTB  ?DISP  OVER 1 AND  IF  WDISP  ELSE  BIMM  THEN #
  335.   .MREG OVER .SIZE MOV, 2DROP ;
  336.  
  337. : INT,       \ op ---  | int instruction  CC-CD
  338.   1 AND IF NEXTB ELSE 3 THEN U.  .MOI ;
  339.  
  340. : INTO/IRET  \ op ---  | int & iret instructions  CE-CF
  341.   1 AND EXEC:  INTO, IRET, STOP[
  342.  
  343. : C0S        \ op ---  | display instructions  C0-CF
  344.   DUP 2/ 7 AND EXEC:
  345.   OOPS RET, LES/LDS  MOV#R/M  OOPS RET, INT,  INTO/IRET  STOP[
  346.  
  347. : AAS        \ op ---  | does anybody actually use these things?
  348.   CREATE  LAST @ ,  DOES>  @ .ID  NEXTB 2DROP ;
  349.  
  350. AAS AAM,        AAS AAD,
  351.  
  352. .SELF ROL,      .SELF ROR,      .SELF RCL,      .SELF RCR,
  353. .SELF SHL/SAL,  .SELF SHR,      .SELF SAR,
  354.  
  355. : SHIFTS     \ op ---  | secondary instructions d0-d3
  356.   DUP 2 AND IF CL THEN
  357.   NEXTB  .MREG NIP  3 2/S 7 AND EXEC:
  358.   ROL,  ROR,  RCL,  RCR,  SHL/SAL, SHR,  OOPS  SAR,  STOP[
  359.  
  360. : XLAT,   DROP .MOI ;
  361.  
  362. : ESC,       \ op ext --- op ext | esc instructions d8-DF
  363.      2DUP .MREG  3 2/S 7 AND U.  7 AND U.  .MOI ;
  364.  
  365. DEFER ESCCODE   ' ESC, IS ESCCODE
  366.  
  367. : D0S        \ op ---  | display instructions  D0-DF
  368.   DUP 8 AND  IF  NEXTB ESCCODE 2DROP EXIT  THEN
  369.   DUP 7 AND EXEC:
  370.   SHIFTS SHIFTS SHIFTS SHIFTS  AAM, AAD, OOPS XLAT, STOP[
  371.  
  372. comment:
  373. : ESC,       \ op ---  | esc instructions d8-DF
  374.   NEXTB .MREG  3 2/S 7 AND U.  7 AND U.  .MOI ;
  375.  
  376. : D0S        \ op ---  | display instructions  D0-DF
  377.   DUP 8 AND IF ESC, EXIT THEN
  378.   DUP 7 AND EXEC:
  379.   SHIFTS SHIFTS SHIFTS SHIFTS  AAM, AAD, OOPS XLAT, STOP[
  380. comment;
  381.  
  382. .SELF LOOPE/Z   .SELF LOOP,     .SELF JCXZ,     .SELF LOOPNE/NZ,
  383.  
  384. : LOOPS      \ op ---  | display instructions  E0-E3
  385.   NEXTB SEXT  CP @ + .SYMBOL  3 AND EXEC:
  386.   LOOPNE/NZ,  LOOPE/Z  LOOP,  JCXZ,  STOP[
  387.  
  388. .SELF IN,       .SELF OUT,      .SELF JMP,
  389.  
  390. : IN/OUT     \ op ---  | display instructions  E4-E6,EC-EF
  391.   DUP 8 AND IF
  392.        DUP 2 AND  IF  .AL/AX DX  OUT, ELSE
  393.                       DX .AL/AX  IN,  THEN  ELSE
  394.        DUP 2 AND  IF  .AL/AX BIMM # OUT, ELSE
  395.                       BIMM # .AL/AX IN,  THEN  THEN ;
  396.  
  397. : CALL       \ op ---  | display instructions  E7-EB
  398.   DUP 2 AND IF  DUP 1 AND IF  NEXTB SEXT  CP @ + .SYMBOL \ short
  399.         ELSE  INTER  THEN  ELSE  NEXTW CP @ + .SYMBOL THEN
  400.   3 AND EXEC: CALL, JMP,  JMP,  JMP, STOP[
  401.  
  402. : E0S        \ op ---  | display instructions  E0-EF
  403.   DUP 2 2/S  3 AND  EXEC:  LOOPS  IN/OUT CALL  IN/OUT STOP[
  404.  
  405. : FTEST      \ op ---  | display instructions  F6,7:0
  406.   ?DISP OVER 1 AND IF WDISP ELSE BIMM THEN #
  407.   .MREG DROP  .SIZE  TEST, ;
  408.  
  409. .SELF NOT,      .SELF NEG,      .SELF MUL,      .SELF IMUL,
  410. .SELF DIV,      .SELF IDIV,     .SELF REP/NZ,   .SELF REPZ,
  411. .SELF LOCK,     .SELF HLT,      .SELF CMC,      .SELF CLC,
  412. .SELF STC,      .SELF CLI,      .SELF STI,      .SELF CLD,
  413. .SELF STD,      .SELF INC,      .SELF DEC,      .SELF PUSH,
  414.  
  415. : MUL/DIV    \ op ext ---  | secondary instructions F6,7:4-7
  416.   .MREG  AX OVER 1 AND IF DX THEN  NIP
  417.   3 2/S 3 AND EXEC: MUL, IMUL, DIV, IDIV, STOP[
  418.  
  419. : NOT/NEG    \ op ext ---  | secondary instructions F6,7:2,3
  420.   .MREG SWAP .SIZE  3 2/S 1 AND EXEC: NOT, NEG, STOP[
  421.  
  422. : F6-F7S     \ op ---  | display instructions  F6,7
  423.   NEXTB  DUP 3 2/S  7 AND EXEC:
  424.   FTEST OOPS NOT/NEG NOT/NEG
  425.   MUL/DIV MUL/DIV MUL/DIV MUL/DIV  STOP[
  426.  
  427. : FES        \ op ---  | display instructions  FE
  428.   NEXTB .MREG BYTE NIP 1 AND EXEC: INC, DEC, STOP[
  429.  
  430. : FCALL/JMP  \ op ext ---  | display call instructions  FF
  431.   .MREG  3 2/S DUP 1 AND IF  S#) ." FAR "  ELSE  #)  THEN  NIP
  432.   2/ 1 AND EXEC: JMP, CALL,  STOP[
  433.  
  434. : FPUSH      \ op ext ---  | display push instructions  FF
  435.   DUP 4 AND IF .MREG  2DROP PUSH, EXIT THEN OOPS ;
  436.  
  437. : FINC       \ op ext ---  | display inc/dec instructions  FF
  438.   .MREG  NIP 3 2/S 1 AND EXEC: INC, DEC, STOP[
  439.  
  440. : FFS        \ op ---  | display instructions  FF
  441.   NEXTB DUP 4 2/S 3 AND EXEC:
  442.   FINC  FCALL/JMP FCALL/JMP  FPUSH   STOP[
  443.  
  444. : F0S        \ op ---  | display instructions  F0-FF
  445.   DUP 15 AND  DUP 7 AND 6 < IF NIP  THEN  EXEC:
  446.   LOCK,  OOPS   REP/NZ, REPZ,  HLT, CMC, F6-F7S  F6-F7S
  447.   CLC, STC, CLI, STI, CLD, STD,  FES  FFS                STOP[
  448.  
  449. : HIGHS   \ op -- | op codes C0 - FF displayed
  450.   DUP 4 2/S  3 AND EXEC: C0S D0S E0S F0S STOP[
  451.  
  452. : (INST)  \ op ---  | highest level vector table
  453.   255 AND  DUP 6 2/S EXEC: LOWS  MEDS  HMEDS  HIGHS  STOP[
  454.  
  455. .SELF ESC_TO_EXIT
  456.  
  457. FORTH DEFINITIONS
  458. : INST  \  ---  | display opcode at ip, advancing as needed
  459.   [ DISASSEMBLER ]
  460.   CP@ 6 U.R  CP@ TC@ 3 .R 2 SPACES
  461.   NEXTB (INST)  OPS @ CP +!  OPS OFF  IM OFF ;
  462.  
  463. : (DUMP) \  addr ct ---  | dump as pointed to by reloc
  464.   SPACE  BOUNDS DO  I TC@ 0 <# # # bl HOLD #> TYPE LOOP ;
  465.  
  466. : LASCI   \  addr ct ---  | asci type as pointed to by reloc
  467.   SPACE  BOUNDS DO  I TC@  127 AND  DUP
  468.     32 ASCII ~ BETWEEN 0= IF DROP ASCII . THEN  EMIT  LOOP ;
  469.  
  470. \ comment:
  471.  
  472. : HEAD  \ addr --- | headder for dump display
  473.   16 0 DO I OVER + 15 AND 3 .R LOOP DROP ;
  474.  
  475.   \ N. B: Not responsible for negative counts! -- the MGT.
  476. : DUMP   \  addr ct ---  | dump as pointed to by reloc
  477.   OVER CR 6 SPACES HEAD  BEGIN  DUP  WHILE  CR OVER 5 U.R
  478.      2DUP 16 MIN >R  R@ 2DUP (DUMP)  54 COL LASCI
  479.      R@ R> NEGATE D+  KEY? IF DROP 0 THEN  REPEAT 2DROP ;
  480.  
  481. \ comment;
  482.  
  483. : DISASSEM   \  addr --- | disassemble until esc key
  484.   [ DISASSEMBLER ]
  485.   2 COL ESC_TO_EXIT  CP !  BASE @ SAVEBASE !  HEX
  486.   BEGIN  CP @ >R
  487.     CR INST  R> CP @ OVER - 2DUP  35 COL (DUMP)
  488.     55 COL LASCI  ?STACK  KEY  CONTROL [ = UNTIL
  489.   SAVEBASE @ BASE ! ;
  490.  
  491. : DIS:  HOMESEG   RELOC OFF  ' DISASSEM ;
  492.  
  493. : SEE    \ cfa ---   | disassemble if unknown or code
  494.   ' DUP @REL>ABS [ HIDDEN ] DEFINITION-CLASS
  495.   MAX-CLASSES = IF  DUP @ DOES?  NIP  IF  (SEE)
  496.            ELSE  HOMESEG ( @ ) DISASSEM  THEN
  497.       ELSE  (SEE)  THEN ;
  498.  
  499. : UN:  SEE ;    \ made with the un: nut, of course
  500.  
  501.  
  502.