arm-disasm.f

这个是关于G.726算法的源程序

\ ARM Disassembler.
\
\ This code has been placed in the Public Domain by J.D.Medhurst (aka Tixy).
\
\
\ ----------------------------------------------------------------------------
\ REQUIREMENTS and DEPENDECIES
\
\ This code requires ANS wordsets: CORE, CORE-EXT, SEARCH-ORDER and
\ SEARCH-ORDER-EXT. It also uses the non-standard word VOCABULARY.
\
\ The code is dependent on the size of a CELL being at least 32 bits.
\
\
\ ----------------------------------------------------------------------------
\ USAGE
\
\ Two words are provided to produce a disassembly, ARM-DISASM and
\ ARM-DISASM-OP.


HEX

\ ----------------------------------------------------------------------------
\ Place disassembler in its own vocabulary

VOCABULARY ARM-DISASSEMBLER

ALSO ARM-DISASSEMBLER DEFINITIONS

\ ----------------------------------------------------------------------------
\ Helpers words...

: RROTATE   ( x1 u -- x2 )   \ rotate the bits of x1 right by u bits
	1F AND
	2DUP RSHIFT
	ROT ROT 20 SWAP - LSHIFT
	OR
;

: ARSHIFT   ( x1 u -- x2 )   \ shift x1 right by u bits, propagating the sign
	OVER 0<
	IF
		TRUE OVER RSHIFT INVERT
		>R RSHIFT R> OR
		EXIT
	THEN
	RSHIFT
;

\ ----------------------------------------------------------------------------
\ Variables which indicate validity of instruction being disassembled

VARIABLE UNDEFINED       \ Set TRUE if instruction is undefined
VARIABLE UNPREDICTABLE   \ Mask of bits which make instruction unpredictable

: UNDEFINED-OP   ( -- )
	TRUE UNDEFINED ! ;

: ?UNPREDICTABLE   ( x flags -- )
	IF UNPREDICTABLE @ OR UNPREDICTABLE ! EXIT
	THEN DROP
;

: -UNDEFINED   ( x -- x )   \ Set undefined instruction if x is zero
	DUP 0= IF UNDEFINED-OP THEN ;

: SBO   ( x1 x2 -- x1 )   \ All bits set in x2 should be one in x1
	2DUP AND OVER <> ?UNPREDICTABLE ;

: SBZ   ( x1 x2 -- x1 )   \ All bits set in x2 should be zero in x1
	2DUP AND ?UNPREDICTABLE ;

\ ----------------------------------------------------------------------------
\ Text output
\
\ Disassembled code is stored as a counted string at BUFFER

CREATE BUFFER   81 CHARS ALLOT   \ room for 128 characters

: OUT   ( -- c-addr )   \ Address to store next output char at
	BUFFER COUNT CHARS + ;

: +OUT   ( n -- )   \ Advance OUT by n chars
	CHARS BUFFER C@ +  BUFFER C! ;

: C.   ( char -- )   \ Append a char to disassembled text
	OUT C!  1 +OUT ;

: S.   ( c-addr u -- )   \ Append a string to disassembled text
	OUT SWAP  DUP +OUT  CHARS MOVE ;

: BL.   ( -- )   \ Append a space
	BL C. ;

: C.BL.   ( char -- )   \ Append char then a space
	C. BL. ;

: S.BL.   ( c-addr u -- )   \ Append string then a space
	S. BL. ;

: NUM.   ( n flag -- )   \ Append n
	DUP >R 0< IF NEGATE THEN 0
	<# #S R> SIGN #>
	OVER C@ [CHAR] 9 U>   \ number starts with letter?
	OVER 8 < AND          \ and less that 8 chars long?
	IF [CHAR] 0 C. THEN   \ ... If so, add '0' prefix
	S.BL.
;

: TAB.   ( -- )   \ Append spaces to make number of chars a multiple of 8
	BUFFER  BEGIN  BL.  DUP C@ 7 AND 0=  UNTIL  DROP ;

\ ----------------------------------------------------------------------------
\ Text output for parts of disassembled instruction

: -TRAILING   ( c-addr u1 -- c-addr u2 )   \ Remove a single trailing space
	BEGIN
		DUP
	WHILE
		1-
		2DUP CHARS +
		C@ BL =
	WHILE
	REPEAT
	1+
	THEN
;

: (select")   ( u1 c-addr1 -- c-addr2 u2 )
	CHAR+  COUNT [CHAR] 0 - >R  SWAP R@ *  CHARS +  R>
	-TRAILING DUP 0= IF UNDEFINED-OP THEN
;

: SELECT"   ( Compilation: "ccc<quote>" -- ) ( Run-time: u1  -- c-addr u2 )
	\ Treat "ccc" as an array of strings, the size of each string is the
	\ given by the first ascii character in "ccc". From this array, return
	\ the element given by u1, (removing a trailing space if present).
	POSTPONE C"  POSTPONE (select")
; IMMEDIATE

: (?select")   ( x c-addr1 -- c-addr2 u )
	COUNT 2/ >R  SWAP 0<>  R@ AND CHARS +  R> -TRAILING ;

: ?SELECT"   ( Compilation: "ccc<quote>" -- ) ( Run-time: x -- c-addr2 u )
	\ Treat "ccc" as two strings of equal length. If x is false, return
	\ the first string, otherwise return the second. Any trailing space
	\ is removed.
	POSTPONE C"  POSTPONE (?select")
; IMMEDIATE

: SARRAY   ( "name<space>" -- )   \ Create array of counted strings
	CREATE
	DOES>   ( n - c-addr u )
	BEGIN
		OVER
	WHILE
		COUNT CHARS +
		SWAP 1- SWAP
	REPEAT
	SWAP DROP
	COUNT
;

: ,"   ( "ccc<quote>" -- )   \ Compile a counted string
	[CHAR] " PARSE
	DUP C,
	HERE SWAP DUP ALLOT CHARS MOVE
;

: (flags.")   ( x c-addr -- )
	COUNT CHARS OVER + SWAP
	DO DUP 1 AND IF I C@ C. THEN 2/ LOOP
	DROP
;

: FLAGS."   ( Compilation: "ccc<quote>" -- ) ( Run-time: x -- )
	\ Output characters from "ccc" if corresponding bit is set in x
	POSTPONE C"  POSTPONE (flags.") ; IMMEDIATE

: REG.   ( u -- )   \ Output name for ARM register given by bottom 4 bits of u
	0F AND SELECT" 3r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10r11r12r13lr pc " S.BL. ;

: REG0.   ( x -- x )   \ Output name of ARM register given by bits 0-3 of x
	DUP REG. ;

: REG8.   ( x -- x )   \ Output name of ARM register given by bits 8-11 of x
	DUP 8 RSHIFT REG. ;

: REG12.   ( x -- x )   \ Output name of ARM register given by bits 12-15 of x
	DUP 0C RSHIFT REG. ;

: REG16.   ( x -- x )   \ Output name of ARM register given by bits 16-23 of x
	DUP 10 RSHIFT REG. ;

: #.   ( n -- )   \ Output n as an assembler immediate argument "nnn # "
	S>D NUM.  [CHAR] # C.BL. ;

: U#.   ( n -- )   \ Output n as an assembler immediate argument "nnn # "
	0 NUM.  [CHAR] # C.BL. ;

: ?-.   ( x -- x )   \ Output a '-' if the U bit is clear in op-code x
	DUP 00800000 AND 0=  IF [CHAR] - C. THEN ;

: INDEX#.   ( x n -- x )   \ Output n as an immediate operand, if not zero
	?DUP IF OVER 00800000 AND 0= IF NEGATE THEN #. THEN ;

: [.   ( -- )   \ Output a [ char
	[CHAR] [ C.BL. ;

: ].   ( -- )   \ Output a ] char
	[CHAR] ] C.BL. ;

: CC.   ( x -- x)   \ Output condition code mnemonic for op-code x
	DUP 1C RSHIFT
	DUP 0E <
	IF
		SELECT" 2eqnecsccmiplvsvchilsgeltgtle" S.BL.
	ELSE
		0F = IF UNDEFINED-OP THEN
	THEN
;

: S.BL.CC.   ( x c-addr u -- x )   \ Output string followed by condition code
	S.BL. CC. ;

: IMMEDIATE.   ( x -- x )   \ Output data processing instruction immediate arg
	DUP 0FF AND  OVER F00 AND  7 RSHIFT  RROTATE  #. ;

: SHIFT.   ( x -- x )   \ Output mnemonic for shift operand in op-code x
	DUP 5 RSHIFT 3 AND SELECT" 3lsllsrasrror" S.BL. ;

: SHIFT#.   ( x -- x )   \ Output mnemonic for immediate shift operand
	DUP FE0 AND
	DUP 0= IF DROP EXIT THEN   \ asl 0 # is ignored
	060 =
	IF   \ ror 0 # is an rrx...
		S" rrx" S.BL.
	ELSE
		SHIFT.
		DUP 7 RSHIFT 1F AND   \ immediate shift value
		OVER 60 AND
		IF
			 DUP 0=
			 IF DROP 20 THEN   \ convert shift 0 into 32 for lsr and asr
		THEN
		#.
	THEN
;

: RM-SHIFT.   ( x -- x )   \ Output register and shift operands in bits 0-11
	REG0.
	DUP 10 AND
	IF	 \ shift by register...
		SHIFT. REG8.
	ELSE   \ shift by constant...
		SHIFT#.
	THEN
;

: BIT20?   ( x1 -- x1 x2 )   \ Return bit 20 of x1
	DUP 00100000 AND ;

: BIT22?   ( x1 -- x1 x2 )   \ Return bit 22 of x1
	DUP 00400000 AND ;

\ ----------------------------------------------------------------------------
\ Data processing instructions...

: DATA-OP.   ( x -- x )
	DUP 15 RSHIFT 0F AND 
	SELECT" 3andeorsubrsbaddadcsbcrsctstteqcmpcmnorrmovbicmvn"
	S.BL.CC.
;

: SFLAG.   ( x -- x )   \ Output and 's' char if S bit is set in op-code x
	BIT20? IF [CHAR] s C.BL. THEN ;

: DATA-OPERANDS.   ( x -- x )
	DUP 02000000 AND
	IF
		IMMEDIATE.
	ELSE
		RM-SHIFT.
	THEN
;

: MOV-OP    ( x -- x )   \ Decode MOV and MVN instructions
	000F0000 SBZ
	DATA-OP. SFLAG. TAB. REG12. DATA-OPERANDS.
;

: CMP-TST-OP    ( x -- x )   \ Decode CMP, CMN, TEQ and TST instructions
	0000F000 SBZ
	DATA-OP. TAB. REG16. DATA-OPERANDS.
;

: DATA-OP   ( x -- x )   \ Decode data processing instructions
	DATA-OP. SFLAG. TAB. REG12. REG16. DATA-OPERANDS. ;

: QADD/SUB-OP   ( x -- x)   \ Decode QADD, QDADD, QSUB and QDSUB intructions
	00000F00 SBZ
	DUP 15 RSHIFT 3 AND SELECT" 5qadd qsub qdaddqdsub" S.BL.CC.
	TAB. REG12. REG0. REG16.
;

\ ----------------------------------------------------------------------------
\ Decode Multiply instructions...

: MUL-OP    ( x -- x )    \ Decode MUL and MLA instructions
	0000F000 SBZ
	S" mul" S.BL.CC. SFLAG.
	TAB. REG16. REG0. REG8.
;

: MLA-OP   ( x -- x )   \ Decode MUL and MLA instructions
	S" mla" S.BL.CC. SFLAG.
	TAB. REG16. REG0. REG8. REG12.
;

: LONG-MUL-OP   ( x -- x )   \ Decode UMULL, UMLAL, SMULL & SMLAL instructions
	DUP 15 RSHIFT 3 AND SELECT" 5umullumlalsmullsmlal" S.BL.CC. SFLAG.
	TAB. REG12. REG16. REG0. REG8.
;

: B/T.   ( x1 x2  -- x1 )
	OVER AND IF [CHAR] t ELSE [CHAR] b THEN C. ;

: SMUL-OPERANDS   ( x -- x )
	40 B/T. BL. CC.
	TAB. REG16. REG0. REG8.
;

: SMLAXY-OP   ( x -- x )   \ Decode SMLA instruction
	S" smla" S. 20 B/T. SMUL-OPERANDS REG12. ;

: SMLAWY-OP   ( x -- x )   \ Decode SMLA instruction
	S" smlaw" S. SMUL-OPERANDS REG12. ;

: SMULXY-OP   ( x -- x )   \ Decode SMLA instruction
	0000F000 SBZ
	S" smul" S. 20 B/T. SMUL-OPERANDS
;

: SMULWY-OP   ( x -- x )   \ Decode SMLA instruction
	0000F000 SBZ
	S" smulw" S. SMUL-OPERANDS
;

: SMLALXY-OP   ( x -- x )   \ Decode SMLAL instruction
	S" smlal" S. 20 B/T. 40 B/T. BL. CC.
	TAB. REG12. REG16. REG0. REG8.
;

: UMAAL-OP   ( x -- x )   \ Decode UMAAL-OP instruction
	S" umaal" S.BL.CC.
	TAB. REG12. REG16. REG0. REG8.
;

: DUAL-MUL-OP   ( x -- x )   \ Decode dual multiply instruction
	DUP 5 RSHIFT 3 AND SELECT" 6smuad smuadxsmusd smusdx" S.BL.CC.
	TAB. REG16. REG0. REG8.
;

: DUAL-MULA-OP   ( x -- x )   \ Decode dual multiply accumulate instruction
	DUP 5 RSHIFT 3 AND SELECT" 6smlad smladxsmlsd smlsdx" S.BL.CC.
	TAB. REG16. REG0. REG8. REG12.
;

: MOST-SIG-MULA-OP   ( x -- x )   \ Decode most significaant multiply accumulate instruction
	DUP 5 RSHIFT 3 AND SELECT" 6smmla smmlarsmmls smmlsr" S.BL.CC.
	TAB. REG16. REG0. REG8. REG12.
;

: MOST-SIG-MUL-OP   ( x -- x )   \ Decode most significaant multiply instruction
	DUP 20 AND ?SELECT" smmul smmulr" S.BL.CC.
	TAB. REG16. REG0. REG8.
;

: LONG-DUAL-MULA-OP   ( x -- x )   \ Decode long dual multiply accumulate instruction
	DUP 5 RSHIFT 3 AND SELECT" 7smlald smlaldxsmlsld smlsldx" S.BL.CC.
	TAB. REG12. REG16. REG0. REG8. 
;

\ ----------------------------------------------------------------------------
\ Decode load/store instructions...

: MEM-OP.   ( x -- )   \ Output LDR op if x is true, STR if false
	?SELECT" strldr" S.BL.CC. ;

: !.   ( x -- x )   \ Output a ! character if op-code x contains a set W bit
	DUP 00200000 AND IF [CHAR] ! C.BL. THEN ;

: MEM-OPERANDS.   ( x xt - x )   \ Output operands for memory op
	\ xt outputs the index
	>R TAB. REG12. [. REG16. R>
	OVER 01000000 AND \ pre/post index selection
	IF
		EXECUTE ]. !.
	ELSE
		]. EXECUTE
	THEN
;

: MEM-INDEX.   ( x -- x )   \ Output address index for load/stores
	DUP 02000000 AND
	IF
		?-. RM-SHIFT.
	ELSE
		DUP 0FFF AND INDEX#.
	THEN
;

: MEM-OP   ( x -- x )   \ Decode LDR and STR (word and unsigned byte forms)
	BIT20? MEM-OP.
	FALSE
	OVER 00400000 AND IF [CHAR] b C. DROP TRUE THEN
	OVER 01200000 AND 00200000 = IF [CHAR] t C. DROP TRUE THEN
	IF BL. THEN
	['] MEM-INDEX. MEM-OPERANDS.
;

: PLD-OP   ( x -- x)   \ Decode PLD instructions
	S" pld" S. TAB. [. REG16. MEM-INDEX. ]. ;

: EXTRA-MEM-INDEX.   ( x -- x )   \ Output address index for extra load/stores
	BIT22?
	IF
		DUP 4 RSHIFT F0 AND 
		OVER 0F AND OR
		INDEX#.
	ELSE
		00000F00 SBZ
		?-. REG0.
	THEN
;

: EXTRA-MEM-OP   ( x -- x )   \ Decode LDR & STR (half word, and signed forms)
	BIT20? MEM-OP.
	DUP 5 RSHIFT 3 AND SELECT" 2sbh sbsh" S.BL.
	['] EXTRA-MEM-INDEX. MEM-OPERANDS.
;

: DOUBLE-MEM-OP   ( x -- x )   \ Decode LDRD and STRD
	DUP INVERT 20 AND MEM-OP.
	[CHAR] d C.BL.