mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-14 16:29:26 +00:00
837 lines
16 KiB
Forth
837 lines
16 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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|