VolksForth/sources/msdos/disasm.fth
2020-07-20 23:47:02 +02:00

749 lines
46 KiB
Forth

\ *** Block No. 0 Hexblock 0
\
\ *** Block No. 1 Hexblock 1
\ A disassembler for the 8086 by Charles Curley cas 10nov05
\ adapted to volksFORTH-83 by B. Molte
| : internal 1 ?head ! ;
| : external ?head off ;
onlyFORTH forth DEFINITIONS DECIMAL
VOCABULARY DISAM DISAM also DEFINITIONS
2 capacity 1- thru
onlyforth
cr .( Use DIS <name> to disassemble word. )
cr .( ESC will stop the output. )
\ *** Block No. 2 Hexblock 2
\ cas 10nov05
internal
: [and] and ; \ the forth and
: [or] or ;
: mask ( n maskb -- n n' ) over and ;
5 constant 5 \ save some space
6 constant 6
7 constant 7
8 constant 8
\ *** Block No. 3 Hexblock 3
\
internal
: EXEC [and] 2* R> + PERFORM ;
: STOP[
0 ?pairs [compile] [ reveal ; immediate restrict
code shift> \ n ct --- n' | shift n right ct times
D C mov D pop D C* shr next end-code
\ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ;
code SEXT \ n --- n' | sign extend lower half of n to upper
D A mov cbw A D mov next end-code
\ : hsext $FF and dup $80 and IF $FF00 or THEN ;
\ *** Block No. 4 Hexblock 4
\
external
VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor
internal
VARIABLE CP
VARIABLE OPS \ operand count
: cp@ cp @ ;
: C? C@ . ;
: (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You
\ dump/dis any segment w/ any
: (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting
\ RELOC correctly.
: SETSEG RELOC 2+ ! ;
\ *** Block No. 5 Hexblock 5
\
external
DEFER T@ DEFER TC@
: HOMESEG ds@ SETSEG ; HOMESEG
: SEG? RELOC 2+ @ 4 U.r ;
: .seg:off seg? ." :" cp@ 4 u.r 2 spaces ;
: MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY
\ *** Block No. 6 Hexblock 6
\
internal
: oops ." ??? " ;
: OOPS0 oops ;
: OOPS1 oops drop ;
: OOPS2 oops 2drop ;
\ *** Block No. 7 Hexblock 7
\
: NEXTB CP@ TC@ 1 CP +! ;
: NEXTW CP@ T@ 2 CP +! ;
: .myself \ --- | have the current word print out its name.
LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE
\ *** Block No. 8 Hexblock 8
\
internal
VARIABLE IM \ 2nd operand extension flag/ct
: ?DISP \ op ext --- op ext | does MOD operand have a disp?
DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then
0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ;
: .SELF \ -- | create a word which prints its name
CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc!
\ *** Block No. 9 Hexblock 9
\ register byte/word
internal
create wreg-tab ," ACDRSUIW"
create breg-tab ," A-C-D-R-A+C+D+R+"
: .16REG \ r# --- | register printed out
7 and wreg-tab 1+ + c@ emit space ;
: .8REG \ r# --- | register printed out
7 and 2* breg-tab 1+ + 2 type space ;
: .A 0 .16reg ; : .A- 0 .8reg ;
: .D 2 .16reg ;
\ *** Block No. 10 Hexblock A
\ indizierte/indirekte Adressierung cas 10nov05
internal
: ?d DUP 6 shift> 3 [and] 1 3 uwithin ;
: .D) ( disp_flag ext -- op ) \ indirect
?d IF ." D" THEN ." ) " ; \ with/without Displacement
: .I) ( disp_flag ext -- op ) \ indexted indirect
?d IF ." D" THEN ." I) " ; \ with/without Displacement
\ *** Block No. 11 Hexblock B
\ indexed/indirect addressing cas 10nov05
internal
: I) 6 .16reg .D) ;
: W) 7 .16reg .D) ;
: R) 3 .16reg .D) ;
: S) 4 .16reg .D) ;
: U) 5 .16reg .D) ;
: U+W) 5 .16reg 7 .16reg .I) ;
: R+I) 3 .16reg 6 .16reg .I) ;
: U+I) 5 .16reg 6 .16reg .I) ;
: R+W) 3 .16reg 7 .16reg .I) ;
: .# ." # " ;
\ *** Block No. 12 Hexblock C
\
internal
: (.R/M) \ op ext --- | print a register
IM OFF SWAP 1 [and] IF .16REG exit then .8REG ;
: .R/M \ op ext --- op ext | print r/m as register
2DUP (.R/M) ;
: .REG \ op ext --- op ext | print reg as register
2DUP 3 shift> (.R/M) ;
\ *** Block No. 13 Hexblock D
\
internal
CREATE SEGTB ," ECSD"
: (.seg ( n -- )
3 shift> 3 and segtb + 1+ c@ emit ;
: .SEG \ s# --- | register printed out
(.seg ." : " ;
: SEG: \ op --- | print segment overrides
(.seg ." S:" ;
\ *** Block No. 14 Hexblock E
\
internal
: disp@ ( ops-cnt -- )
ops +! CP@ IM @ + IM off ." $" ;
: BDISP \ --- | do if displacement is byte
1 disp@ TC@ sext U. ;
: WDisp \ --- | do if displacement is word
2 disp@ T@ U. ;
: .DISP \ op ext --- op ext | print displacement
DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[
: BIMM \ --- | do if immed. value is byte
1 disp@ TC@ . ;
\ *** Block No. 15 Hexblock F
\
internal
: .MREG \ op ext --- op ext | register(s) printed out + disp
$C7 mask 6 = IF WDISP ." ) " exit then
$C0 mask $C0 - 0= IF .R/M exit THEN
.DISP DUP 7 exec
R+I) R+W) U+I) U+W) \ I) oder DI)
I) W) U) R) \ ) oder D)
;
\ *** Block No. 16 Hexblock 10
\
internal
: .SIZE \ op --- | decodes for size; WORD is default
1 [and] 0= IF ." BYTE " THEN ;
create adj-tab ," DAADASAAAAASAAMAAD"
: .adj-tab 3 * adj-tab 1+ + 3 type space ;
: ADJUSTS \ op --- | the adjusts
3 shift> 3 [and] .adj-tab ;
: .AAM 4 .adj-tab nextb 2drop ;
: .AAD 5 .adj-tab nextb 2drop ;
\ *** Block No. 17 Hexblock 11
\
internal
: .POP \ op --- | print pops
DUP 8 = IF OOPS1 THEN .SEG ." POP " ;
: .PUSH \ op --- | print pushes
.SEG ." PUSH " ;
: P/P \ op --- | pushes or pops
1 mask IF .pop ELSE .push THEN ;
\ *** Block No. 18 Hexblock 12
\
internal
: P/SEG \ op --- | push or seg overrides
DUP 5 shift> 1 exec P/P SEG: STOP[
: P/ADJ \ op --- | pop or adjusts
DUP 5 shift> 1 exec P/P ADJUSTS STOP[
: 0GP \ op --- op | opcode decoded & printed
4 mask IF 1 mask
IF WDISP ELSE BIMM THEN .#
1 [and] IF .A ELSE .A- THEN ELSE
NEXTB OVER 2 [and]
IF .MREG .REG ELSE ?DISP .REG .MREG
THEN 2DROP THEN ;
\ *** Block No. 19 Hexblock 13
\
external
.SELF ADD .SELF ADC .SELF AND .SELF XOR
.SELF OR .SELF SBB .SELF SUB .SELF CMP
internal
: 0GROUP \ op --- | select 0 group to print
DUP 0GP 3 shift> 7 EXEC
ADD OR ADC SBB AND SUB XOR CMP STOP[
: LOWS \ op --- | 0-3f opcodes printed out
DUP 7 EXEC
0GROUP 0GROUP 0GROUP 0GROUP
0GROUP 0GROUP P/SEG P/ADJ STOP[
\ *** Block No. 20 Hexblock 14
\
internal
: .REGGP \ op --- | register group defining word
CREATE LAST @ , DOES> @ SWAP .16REG .name ;
external
.REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP
: POPs \ op --- | handle illegal opcode for cs pop
$38 mask 8 = IF ." illegal" DROP ELSE POP THEN ;
: REGS \ op --- | 40-5f opcodes printed out
DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[
\ *** Block No. 21 Hexblock 15
\ conditional branches
create branch-tab
," O NO B NB E NE BE NBES NS P NP L GE LE NLE"
: .BRANCH \ op --- | branch printed out w/ dest.
NEXTB SEXT CP@ + u. ASCII J EMIT
&15 [and] 3 * branch-tab 1+ + 3 type ;
\ *** Block No. 22 Hexblock 16
\
\\
\ *** Block No. 23 Hexblock 17
\
internal
: MEDS \ op --- | 40-7f opcodes printed out
DUP 4 shift> 3 exec
REGS REGS OOPS1 .BRANCH STOP[
: 80/81 \ op --- | secondary at 80 or 81
NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG
SWAP .SIZE 3 shift> 7 EXEC
ADD OR ADC SBB AND SUB XOR CMP STOP[
\ *** Block No. 24 Hexblock 18
\
internal
: 83S \ op --- | secondary at 83
NEXTB ?DISP BIMM .# .MREG
SWAP .SIZE 3 shift> 7 EXEC
ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[
: 1GP \ op --- | r/m reg opcodes
CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP
R> .name ;
external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal
: MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89
: MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B
\ *** Block No. 25 Hexblock 19
\
internal
: MOVS>M \ op --- | display instructions 8C-8E
NEXTB OVER $8D = IF .MREG .REG LEA ELSE
OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE
SWAP 1 [or] SWAP \ 16 bit moves only, folks!
OVER 2 [and] IF .MREG DUP .SEG ELSE
DUP .SEG .MREG THEN MOV THEN THEN 2DROP ;
: 8MOVS \ op --- | display instructions 80-8F
DUP 2/ 7 exec
80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[
\ *** Block No. 26 Hexblock 1A
\
external
.SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP
.SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF
internal
: INTER \ --- | decode interseg jmp or call
NEXTW 4 u.r ." :" NEXTW U. ;
: CALLINTER \ --- | decode interseg call
INTER CALL ;
: 9HIS \ op --- | 98-9F decodes
7 exec
CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[
\ *** Block No. 27 Hexblock 1B
\
internal
: XCHGA \ op --- | 98-9F decodes
dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ;
: 90S \ op --- | 90-9F decodes
DUP 3 shift> 1 exec XCHGA 9HIS STOP[
: MOVSs \ op --- | A4-A5 decodes
.SIZE ." MOVS " ;
: CMPSs \ op --- | A6-A7 decodes
.SIZE ." CMPS " ;
\ *** Block No. 28 Hexblock 1C
\
internal
: .AL/AX \ op --- | decodes for size
1 EXEC .A- .A STOP[
: MOVS/ACC \ op --- | A0-A3 decodes
2 mask
IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ;
create ss-tab ," TESTSTOSLODSSCAS"
: .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ;
: .TEST \ op --- | A8-A9 decodes
1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ;
\ *** Block No. 29 Hexblock 1D
\
internal
: STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS
: LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS
: SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS
: A0S \ op --- | A0-AF decodes
DUP 2/ 7 exec
MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[
: MOVS/IMM \ op --- | B0-BF decodes
8 mask
IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ;
: HMEDS \ op --- | op codes 80 - C0 displayed
DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[
\ *** Block No. 30 Hexblock 1E
\
external
.SELF LES .SELF LDS .SELF INTO .SELF IRET
internal
: LES/LDS \ op --- | les/lds instruction C4-C5
NEXTB .MREG .REG DROP 1 exec LES LDS STOP[
external
: RET \ op --- | return instruction C2-C3, CA-CB
1 mask 0= IF WDISP ." SP+" THEN
8 [and] IF ." FAR " THEN .myself ;
internal
: MOV#R/M \ op --- | return instruction C2-C3, CA-CB
NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .#
.MREG MOV 2DROP ;
\ *** Block No. 31 Hexblock 1F
\
external
: INT \ op --- | int instruction CC-CD
1 [and] IF NEXTB ELSE 3 THEN U. .myself ;
internal
: INTO/IRET \ op --- | int & iret instructions CE-CF
1 exec INTO IRET STOP[
: C0S \ op --- | display instructions C0-CF
DUP 2/ 7 exec
OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[
\ *** Block No. 32 Hexblock 20
\
external
.SELF ROL .SELF ROR .SELF RCL .SELF RCR
.SELF SHL/SAL .SELF SHR .SELF SAR
internal
: SHIFTS \ op --- | secondary instructions d0-d3
2 mask IF 0 .8reg ( C-) THEN
NEXTB .MREG NIP 3 shift> 7 exec
ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[
: XLAT DROP ." XLAT " ;
: ESC \ op --- | esc instructions d8-DF
NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ;
\ *** Block No. 33 Hexblock 21
\
internal
: D0S \ op --- | display instructions D0-DF
8 mask IF ESC EXIT THEN
DUP 7 exec
SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[
external
.SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ
internal
: LOOPS \ op --- | display instructions E0-E3
NEXTB SEXT CP@ + u. 3 exec
LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[
external .SELF IN .SELF OUT .SELF JMP
\ *** Block No. 34 Hexblock 22
\
internal
: IN/OUT \ op --- | display instructions E4-E6,EC-EF
8 mask
IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN
ELSE 2 mask
IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN
THEN ;
\ *** Block No. 35 Hexblock 23
\
internal
: CALLs \ op --- | display instructions E7-EB
2 mask IF 1 mask IF NEXTB SEXT CP@ + u.
ELSE INTER THEN
ELSE NEXTW CP@ + u. THEN
3 exec CALL JMP JMP JMP STOP[
: E0S \ op --- | display instructions E0-EF
DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[
: FTEST \ op --- | display instructions F6,7:0
?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .#
.MREG DROP .SIZE 0 .ss-tab ; \ TEST
\ *** Block No. 36 Hexblock 24
\
external
.SELF NOT .SELF NEG .SELF MUL .SELF IMUL
.SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ
.SELF LOCK .SELF HLT .SELF CMC .SELF CLC
.SELF STC .SELF CLI .SELF STI .SELF CLD
.SELF STD .SELF INC .SELF DEC .SELF PUSH
internal
: MUL/DIV \ op ext --- | secondary instructions F6,7:4-7
.MREG .A OVER 1 [and] IF .D THEN NIP
3 shift> 3 exec MUL IMUL DIV IDIV STOP[
\ *** Block No. 37 Hexblock 25
\
internal
: NOT/NEG \ op ext --- | secondary instructions F6,7:2,3
.MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[
: F6-F7S \ op --- | display instructions F6,7
NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG
MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[
: FES \ op --- | display instructions FE
NEXTB .MREG ." BYTE " NIP 3 shift>
3 exec INC DEC oops oops STOP[
: FCALL/JMP \ op ext --- | display call instructions FF
.MREG 3 shift> 1 mask IF ." FAR " THEN
NIP 2/ 1 exec JMP CALL STOP[
\ *** Block No. 38 Hexblock 26
\
internal
: FPUSH \ op ext --- | display push instructions FF
dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht!
4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ;
: FINC \ op ext --- | display inc/dec instructions FF
.MREG NIP 3 shift> 1 exec INC DEC STOP[
: FFS \ op --- | display instructions FF
NEXTB DUP 4 shift> 3 exec
FINC FCALL/JMP FCALL/JMP FPUSH STOP[
\ *** Block No. 39 Hexblock 27
\
internal
: F0S \ op --- | display instructions F0-FF
&15 mask 7 mask 6 < IF NIP THEN -1 exec
LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S
CLC STC CLI STI CLD STD FES FFS STOP[
: HIGHS \ op -- | op codes C0 - FF displayed
DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[
: (INST) \ op --- | highest level vector table
&255 [and] DUP 6 shift>
-1 exec LOWS MEDS HMEDS HIGHS STOP[
\ *** Block No. 40 Hexblock 28
\
internal
: INST \ --- | display opcode at ip, advancing as needed
[ disam ] .seg:off
NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ;
: (DUMP) \ addr ct --- | dump as pointed to by reloc
[ forth ] BOUNDS ?do I TC@ u. LOOP ;
\ *** Block No. 41 Hexblock 29
\
internal
: steps?
1+ dup &10 mod 0= IF key #esc = exit THEN 0 ;
create next-code assembler next forth
: ?next ( steps-count -- steps-count )
cp@ 2@ next-code 2@ D=
IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U.
cp@ 6 + cp ! \ 4 bytes code, 2 byte link
drop 9 \ forces stop at steps?
THEN ;
\ *** Block No. 42 Hexblock 2A
\ ks 28 feb 89
forth definitions
external
: DISASM \ addr --- | disassemble until esc key
[ disam ] CP ! base [ forth ] push hex 0
BEGIN CP@ >R
CR INST R> CP@ OVER - &35 tab (DUMP)
?next ?stack steps?
UNTIL drop ;
: dis ( <name> -- ) ' @ disasm ;
\ *** Block No. 43 Hexblock 2B