\ ARM Disassembler.
\
\ This program is distributed under the terms of the 'MIT license'. The text
\ of this licence follows...
\
\ Copyright (c) 2005 J.D.Medhurst (a.k.a. Tixy)
\
\ Permission is hereby granted, free of charge, to any person obtaining a copy
\ of this software and associated documentation files (the "Software"), to deal
\ in the Software without restriction, including without limitation the rights
\ to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
\ copies of the Software, and to permit persons to whom the Software is
\ furnished to do so, subject to the following conditions:
\
\ The above copyright notice and this permission notice shall be included in
\ all copies or substantial portions of the Software.
\
\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
\ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
\ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
\ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
\ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
\ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
\ THE SOFTWARE.
\
\
\ ----------------------------------------------------------------------------
\ 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.
\
\
\ ----------------------------------------------------------------------------
\ CHANGES
\
\ 2006-11-09
\     Fixed some ANS Forth Standard compliancey issues.
\     * Made all hex values use upper-case letters.


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
	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.
	['] EXTRA-MEM-INDEX. MEM-OPERANDS.
;

: SWAP-OP   ( x -- x )   \ Decode SWAP instruction
	00000F00 SBZ
	S" swp" S.BL.CC.
	BIT22? IF [CHAR] b C.BL. THEN
	TAB. REG12. REG0. [. REG16. ].
;

: STREX-OP   ( x -- x )   \ Decode SWAP instruction
	00000F00 SBO
	S" strex" S.BL.CC.
	TAB. REG12. REG0. [. REG16. ].
;

: LDREX-OP   ( x -- x )   \ Decode SWAP instruction
	00000F0F SBO
	S" ldrex" S.BL.CC.
	TAB. REG12. [. REG16. ].
;

: MULTI-MODE.   ( x -- x )   \ Output LDM/STM address mode
	DUP 17 RSHIFT 3 AND SELECT" 2daiadbib" S.BL.
;

: MULTI-OP   ( x -- x )   \ Decode LDM and STM instructions
	BIT20? ?SELECT" stmldm" S.BL.CC.
	MULTI-MODE.
	TAB. REG16. !.
	[CHAR] { C.BL.
	10 0
	DO
		1 I LSHIFT OVER AND
		IF I REG. THEN
	LOOP
	[CHAR] } C.BL.
	BIT22? IF [CHAR] ^ C. THEN
;

: RFE-OP   ( x -- x )   \ Decode RFE instruction
	0000F0FF SBZ
	S" rfe" S.BL.
	MULTI-MODE.
	TAB. REG16. !.
;

: SRS-OP   ( x -- x )   \ Decode SRS instruction
	0000F0E0 SBZ
	S" srs" S.BL.
	MULTI-MODE.
	TAB. DUP 1F AND #. !.
;

\ ----------------------------------------------------------------------------
\ Branch instructions...

: BRANCH-OP   ( a-addr x -- a-addr x )   \ Decode B,BL and BLX(1) instructions
	2DUP 8 LSHIFT 6 ARSHIFT + 8 + >R
	DUP F0000000 U<
	IF
		DUP 01000000 AND ?SELECT" b bl" S.BL.CC.
	ELSE
		\ blx instruction...
		DUP 17 RSHIFT 2 AND R> + >R   \ add in the half-word bit to target
		S" blx" S.BL.
	THEN
	TAB. R> U#.
;

: BX-OP   ( x -- x )   \ Decode BX instruction (register form)
	000FFF00 SBO
	DUP 4 RSHIFT 3 AND SELECT" 3   bx bxjblx" S.BL.CC.
	TAB. REG0.
;

: SWI-OP   ( x -- x )   \ Decode SWI instructions
	S" swi" S.BL.CC. TAB.   DUP 00FFFFFF AND #. ;

\ ----------------------------------------------------------------------------
\ Decode MRS and MSR instructions...

: PSR.   ( x -- x )
	BIT22? ?SELECT" cpsrspsr" S.
;

: MRS-OP   ( x -- x )   \ Decode MRS instruction
	000F0000 SBO 00000FFF SBZ
	S" mrs" S.BL.CC.
	TAB. REG12. PSR.
;

: MSR-OP   ( x -- x )
	0000F000 SBO
	S" msr" S.BL.CC.
	TAB. PSR. [CHAR] _ C.BL.
	000F0000 2DUP AND 0= ?UNPREDICTABLE   \ treat no flags as unpredictable
	DUP 10 RSHIFT FLAGS." cxsf" BL.
;

: MSR-IMM-OP   ( x -- x)   \ Decode MSR immediate instruction
	MSR-OP IMMEDIATE. ;

: MSR-REG-OP   ( x -- x)   \ Decode MSR immediate instruction
	00000F00 SBZ   MSR-OP REG0. ;

\ ----------------------------------------------------------------------------
\ Coprocessor instructions...

: 0-15.   ( x -- )   \ Output bottom 4 bits of x as decimal number
	0F AND SELECT" 20 1 2 3 4 5 6 7 8 9 101112131415" S.BL.
;

: CREG.   ( x -- )   \ Output coprocessor register given by bottom 4 bits of x
	[CHAR] c C. 0-15. ;

: CP.   ( x -- x )   \ Output coprocessor number in op-code x
	[CHAR] p C.   DUP 8 RSHIFT 0-15. ;

: COP.   ( x c-addr u - u )   \ Output coprocessor op name and condition code
	S.
	DUP 1C RSHIFT 0F =
	IF [CHAR] 2 C.BL.   \ Append '2' for condition code = 0F
	ELSE BL. CC.
	THEN
;

: CO-MEM-OP   ( x -- x )   \ Decode LDC and STC instructions
	BIT20? ?SELECT" stcldc" COP.
	BIT22? IF [CHAR] l C.BL. THEN
	TAB. CP.
	DUP 0C RSHIFT CREG.
	[. REG16.
	DUP 0FF AND 2 LSHIFT
	OVER 01000000 AND
	IF
		INDEX#. ]. !.
	ELSE
		].
		OVER 00200000 AND
		IF
			INDEX#.
		ELSE
			[CHAR] { C.BL.
			2 ARSHIFT #.
			[CHAR] } C.BL.
			DUP 00800000 AND 0= IF UNDEFINED-OP THEN
		THEN
	THEN
;

: CO-OPERANDS.   ( x -- x )   \ Output final coprocessor instruction arguments
	DUP 10 RSHIFT CREG.
	DUP CREG.
	DUP 5 RSHIFT 7 AND #.
;

: CDP-OP   ( x -- x )   \ Decode CDP instruction
	S" cdp" COP.
	TAB. CP.
	DUP 14 RSHIFT 0F AND #.
	DUP 0C RSHIFT CREG.
	CO-OPERANDS.
;

: CO-REG-OP   ( x -- x )   \ Decode MRC and MCR instructions
	BIT20? ?SELECT" mcrmrc" COP.
	TAB. CP.
	DUP 15 RSHIFT 7 AND #.
	REG12.
	CO-OPERANDS.
;

: CO-REG2-OP   ( x -- x )   \ Decode MRRC and MCRR instructions
	BIT20? ?SELECT" mcrrmrrc" COP.
	TAB. CP.
	DUP 4 RSHIFT 0F AND #.
	REG12. REG16.
	DUP CREG.
;

\ ----------------------------------------------------------------------------
\ Miscelaneous instructions...

: CLZ-OP   ( x -- x )   \ Decode CLZ instruction
	000F0F00 SBO
	S" clz" S.BL.CC. TAB. REG12. REG0. ;

: BKPT-OP   ( x -- x )   \ Decode BKPT instruction
	F0000000 2DUP AND E0000000 <> ?UNPREDICTABLE
	DUP 0000000F AND
	OVER 000FFF00 AND
	4 RSHIFT OR
	S" bkpt" S.BL. TAB. #. ;

: CPSI-OP   ( x -- x )   \ Decode CPS instruction
	0000FE00 SBZ
	DUP 00040000 AND ?SELECT" cpsiecpsid" S. TAB.
	1C0 2DUP AND 0= ?UNPREDICTABLE   \ treat no flags changed as unpredictable
	DUP 6 RSHIFT FLAGS." fia" BL.
	DUP 1F AND
	OVER 00020000 AND
	IF #.
	ELSE 1 ?UNPREDICTABLE   \ mode SBZ if not changing it
	THEN
;

: CPS-OP   ( x -- x )   \ Decode CPS instruction
	0004FFC0 SBZ 00020000 SBO
	S" cps" S. TAB.
	DUP 1F AND #.
;

: SETEND-OP   ( x -- x )   \ Decode SETEND instruction
	0000FC0F SBZ
	S" setend" S. TAB.
	DUP 00000200 AND ?SELECT" lebe" S.
;

\ ----------------------------------------------------------------------------
\ Media instructions

SARRAY PAS1
	," "  ," s"  ," q"   ," sh"
	," "  ," u"  ," uq"  ," uh"

SARRAY PAS2
   ," add16"  ," addsubx"  ," subaddx"  ," sub16"
   ," add8"   ," "         ," "         ," sub8"

: PARALLEL-ADD-SUB-OP   ( x -- x )   \ Decode parallel add/sub instructions
	00000F00 SBO
	DUP 14 RSHIFT 7 AND PAS1 -UNDEFINED S.
	DUP 5 RSHIFT 7 AND PAS2 -UNDEFINED S.BL.CC.
	TAB. REG12. REG16. REG0.
;

: PACK-HALFWORD-OP   ( x -- x )   \ Decode PKHBT and PKHTB instruction
	DUP 40 AND ?SELECT" pkhbtpkhtb" S.BL.CC.
	TAB. REG12. REG16. REG0. SHIFT#.
;

: WORD-SATURATE-OP   ( x -- x )   \ Decode SSAT and USAT instruction
	BIT22? ?SELECT" ssatusat" S.BL.CC.
	TAB. REG12. DUP 10 RSHIFT 1F AND #. REG0. SHIFT#.
;

: HALF-WORD-SATURATE-OP   ( x -- x )   \ Decode SSAT16 and USAT16 instructions
	00000F00 SBO
	BIT22? ?SELECT" ssat16usat16" S.BL.CC.
	TAB. REG12. DUP 10 RSHIFT F AND #. REG0.
;

: SEL-OP   ( x -- x)   \ Decode SEL instruction
	00000F00 SBO
	S" sel" S.BL.CC.
	TAB. REG12. REG16. REG0.
;

: EXTEND-OP   ( x -- x )   \ Decode extend instructions
	00000300 SBZ
	DUP 10 RSHIFT F AND F <> >R   \ flag true if extend with add
	BIT22? ?SELECT" sxtuxt" S.
	R@ IF [CHAR] a C. THEN
	DUP 14 RSHIFT 3 AND SELECT" 3b16   b  h  " -UNDEFINED S.BL.CC.
	TAB. REG12. R> IF REG16. THEN REG0.
	DUP C00 AND IF SHIFT#. THEN
;

: REV-OP.   ( x c-addr u -- x )
	S.BL.CC.
	000F0F00 SBO
	TAB. REG12. REG0.
;

: REV-OP   ( x -- x )   \ Decode extend instructions
	S" rev" REV-OP. ;

: REV16-OP   ( x -- x )   \ Decode extend instructions
	S" rev16" REV-OP. ;

: REVH-OP   ( x -- x )   \ Decode extend instructions
	S" revsh" REV-OP. ;

: USAD8-OP   ( x -- x )   \ Decode USDA instruction
	S" usad8" S.BL.CC. TAB. REG16. REG0. REG8. ;

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

\ ----------------------------------------------------------------------------
\ Top level functions...

: PATTERN   ( "name<space>" -- )   \ Define a list of patterns to match
	CREATE
	DOES>   ( x -- x )   \ Find match for x in list of patterns
	BEGIN
		2DUP @ AND
		OVER CELL+ @ <>
	WHILE
		CELL+ CELL+ CELL+
	REPEAT
	CELL+ CELL+ @ EXECUTE
;

PATTERN PATTERN-0E000090-00000090   ( x -- x )
	\ Multiplies and extra load/store instructions...
	0FE000F0 , 00000090 , ' MUL-OP ,
	0FE000F0 , 00200090 , ' MLA-OP ,
	0FF000F0 , 00400090 , ' UMAAL-OP ,
	0F8000F0 , 00800090 , ' LONG-MUL-OP ,
	0FB000F0 , 01000090 , ' SWAP-OP ,
	0FF000F0 , 01800090 , ' STREX-OP ,
	0FF000F0 , 01900090 , ' LDREX-OP ,
	000000F0 , 00000090 , ' UNDEFINED-OP ,
	01200000 , 00200000 , ' UNDEFINED-OP , 	\ post index without writeback
	00100040 , 00000040 , ' DOUBLE-MEM-OP ,
	0 , 0 , ' EXTRA-MEM-OP ,

PATTERN MISCELANEOUS-OP   ( x -- x )
	\ Miscelaneous instructions...
	FFF90020 , F1080000 , ' CPSI-OP ,
	FFF90020 , F1000000 , ' CPS-OP ,
	FFFFFDFF , F1010000 , ' SETEND-OP ,
	0FB000F0 , 01000000 , ' MRS-OP ,
	0FF000C0 , 01200000 , ' BX-OP ,
	0FF000F0 , 01600010 , ' CLZ-OP ,
	0F9000F0 , 01000050 , ' QADD/SUB-OP ,
	0FF000F0 , 01200070 , ' BKPT-OP ,
	0FF00090 , 01000080 , ' SMLAXY-OP ,
	0FF000B0 , 01200080 , ' SMLAWY-OP ,
	0FF000B0 , 012000A0 , ' SMULWY-OP ,
	0FF00090 , 01400080 , ' SMLALXY-OP ,
	0FF00090 , 01600080 , ' SMULXY-OP ,
	0 , 0 , ' UNDEFINED-OP ,

PATTERN MEDIA-OP   ( x -- x )
	\ Media instructions...
	0F800010 , 06000010 , ' PARALLEL-ADD-SUB-OP ,
	0FF00030 , 06800010 , ' PACK-HALFWORD-OP ,
	0FA00030 , 06A00010 , ' WORD-SATURATE-OP ,
	0FF000F0 , 06B00030 , ' REV-OP ,
	0FF000F0 , 06B000B0 , ' REV16-OP ,
	0FF000F0 , 06F000B0 , ' REVH-OP ,
	0FB000F0 , 06A00030 , ' HALF-WORD-SATURATE-OP ,
	0FF000F0 , 068000B0 , ' SEL-OP ,
	0F8000F0 , 06800070 , ' EXTEND-OP ,
	0FF0F090 , 0700F010 , ' DUAL-MUL-OP ,
	0FF00090 , 07000010 , ' DUAL-MULA-OP ,
	0FF0F0D0 , 0750F010 , ' MOST-SIG-MUL-OP ,
	0FF000D0 , 07500010 , ' MOST-SIG-MULA-OP ,
	0FF000D0 , 075000D0 , ' MOST-SIG-MULA-OP ,
	0FF00090 , 07400010 , ' LONG-DUAL-MULA-OP ,
	0FF0F0F0 , 0780F010 , ' USAD8-OP ,
	0FF000F0 , 07800010 , ' USADA8-OP ,
	0 , 0 , ' UNDEFINED-OP ,

PATTERN (disasm-op)   ( a-addr x -- a-addr x )
	\ Decode op-code x with origin a-addr
	0E000090 , 00000090 , ' PATTERN-0E000090-00000090 ,
	0FB00000 , 03200000 , ' MSR-IMM-OP ,
	0FB000F0 , 01200000 , ' MSR-REG-OP ,
	0F900000 , 01000000 , ' MISCELANEOUS-OP ,
	0DA00000 , 01A00000 , ' MOV-OP ,
	0D900000 , 01000000 , ' UNDEFINED-OP , \ CMP/TST without S flag
	0D900000 , 01100000 , ' CMP-TST-OP ,
	0C000000 , 00000000 , ' DATA-OP ,

	0E000010 , 06000010 , ' MEDIA-OP ,
	FD70F000 , F550F000 , ' PLD-OP ,
	0C000000 , 04000000 , ' MEM-OP ,

	FE500F00 , F8100A00 , ' RFE-OP ,
	FE5F0F00 , F84D0A00 , ' SRS-OP ,
	0E000000 , 08000000 , ' MULTI-OP ,
	0E000000 , 0A000000 , ' BRANCH-OP ,

	0FE00000 , 0C400000 , ' CO-REG2-OP ,
	0E000000 , 0C000000 , ' CO-MEM-OP ,
	0F000010 , 0E000000 , ' CDP-OP ,
	0F000010 , 0E000010 , ' CO-REG-OP ,
	0F000000 , 0F000000 , ' SWI-OP ,

: BEGIN-DISASM   ( -- )   \ Initialise disassembler state
	0 BUFFER C!
	FALSE UNDEFINED !
	FALSE UNPREDICTABLE !
;

: END-DISASM   ( -- c-addr u )   \ Return text for disassembly of instruction
	BUFFER COUNT -TRAILING
;

: DISASM-OP   ( a-addr x -- a-addr x )
	BUFFER C@ >R
	(disasm-op) 2DROP
	UNDEFINED @
	IF
		R> BUFFER C! S" UNDEFINED" S.
		EXIT
	THEN
	R> DROP
	UNPREDICTABLE @
	IF TAB. S" \ UNPREDICTABLE" S. THEN
;

: H32.   ( x -- )   \ Output x as a 32 bit hexadecimal value
	BASE @ >R
	HEX 0 <# # # # # # # # # #> S.BL.
	R> BASE ! ;

\ ----------------------------------------------------------------------------
\ Public words for producing disassembly

PREVIOUS DEFINITIONS ALSO ARM-DISASSEMBLER

: ARM-DISASM-OP   ( a-addr x -- c-addr u )   \ Disassemble a single opcode
	\ Disassemble op-code x with origin a-addr
	BEGIN-DISASM
	DISASM-OP
	END-DISASM
;

: ARM-DISASM ( a-addr u -- )   \ Disassemble memory
	\ Disassemble instructions a-addr thru a-addr+u-1
	OVER + SWAP
 	BEGIN
		2DUP U>
	WHILE
		BEGIN-DISASM
		DUP H32. BL.
		DUP @ H32. BL.
		DUP DUP @ DISASM-OP
		END-DISASM
		TYPE CR
		CELL+
	REPEAT
	2DROP
;

\ ----------------------------------------------------------------------------

PREVIOUS DEFINITIONS

DECIMAL