\ ARM Assembler.
\
\ 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
\
\ All assembler words are in the vocabulary ARM-ASSEMBLER. Before use
\ this must be added to the search order, with:
\
\     ALSO ARM-ASSEMBLER
\
\ Before performing any assembly CODE-BEGIN must be executed, this takes as
\ a parameter the target address for which code will be compiled for.
\ When all code has been assembled, CODE-END must be executed to ensure that
\ the final instruction is assembled correctly.
\
\ Because many ARM instructions also share names with standard Forth words
\ there may be problems when intermingling Forth and ARM code. To resolve this
\ the word [[ is provided which adds the FORTH wordlist to the beginning of
\ the search order, the word ]] reverts this change. E.g.
\
\     mov r0 [[ SOME-VARIABLE @ FF AND ]] #
\
\ This is analogous to escaping from compilation mode with the Forth [ ]
\ words.
\
\
\ ----------------------------------------------------------------------------
\ ASSEMBLER SYNTAX
\
\ The assembler syntax attempts to follow that defined by ARM but changes have
\ made to enable it to work under the Forth interpreter. These changes are
\ detailed below.
\
\ 1. Operands are separated by whitespace rather than commas. E.g.
\
\        ADD  R0,R1,R2
\
\    is written as
\
\        ADD  R0 R1 R2
\
\ 2. Non alpha-numeric symbols must be surrounded by whitespace. E.g.
\
\        LDR  R0,[R1]
\        LDM  R0!,{R2,R3}
\
\    is written as
\
\        LDR  R0 [ R1 ]
\        LDM  R0 ! { R2 R3 }
\
\ 3. Condition code mnemonics must be surrounded by whitespace. E.g.
\
\        MOVEQ  R0,R1
\
\    is written as
\
\        MOV EQ  R0 R1
\
\    This may also mean that an instruction names get split. E.g.
\
\        LDREQBT  R0,[R1]
\        MOVEQS   R2,R0
\
\    is written as
\
\        LDR EQ BT  R0 [ R1 ]
\        MOV EQ S   R2 R0
\
\ 4. All numeric constants are postfixed by a #, (which actually just takes a
\    value from the stack). E.g.
\
\        MOV  R0,#123
\
\    is written as
\
\        MOV  R0 123 #
\
\    A # is also used for numeric values which don't normally have a # prefix
\    in ARM syntax. E.g.
\
\        MCR  P15,1,R2,C3,C4,5
\
\    is written as
\
\        MCR  P15 1 # R2 C3 C4 5 #
\
\ 5. The PSR fields in the MSR instruction must have whitespace before them.
\    E.g.
\
\        MSR  CPSR_CF,R0
\
\    is written as
\
\        MSR  CPSR_ CF R0
\
\    The words CPSR_ and SPSR_ are parsing words.
\
\
\ Other Notes:
\
\ The load an store instructions can take numeric constants as their
\ addressing mode and the assembler converts these into pc relative
\ addressing. E.g.
\
\     LDR R0 12345678 #
\
\ is converted to the form
\
\     LDR R0 [ PC <offset> # ]
\
\ The pseudo instruction ADR does a similar thing to generate ADD or SUB
\ instructions which give a pc relative address. E.g.
\
\     ADR R0 12345678 #
\
\ is converted to the form
\
\     ADD R0 PC <offset> #
\
\
\ LABELS
\
\ The assembler supports labels. There are 3 words which support this:
\
\    L: name
\        Define label 'name' whose value is the current code address.
\
\    L= name
\        Define label 'name' and assign its value from the top of the stack.
\
\    L# name
\        Use the value of label 'name' in an instruction as though it were a
\        numeric constant.
\
\    Examples:
\        CHAR " L= terminator
\        L: scan-loop
\        	 ldr b  r0 [ r1 ] 1 #
\        	 cmp    r0 L# terminator
\        	 bl ne  L# scan-loop
\
\            ldr    r0 L# default
\            mov    pc lr
\        L: default
\            dcd 12345678 #
\
\
\ PORTING
\
\ The internal words CODE-HERE CODE-HERE! and CODE, are used for storing
\ assembled code into memory. This implementation uses the Forth dictionary
\ but these words can be modified to use some other location.
\
\ CODE, will also need porting if this code is run on a Forth system where
\ a cell isn't 32 bits.
\
\
\ Code follows... 


HEX

\ ----------------------------------------------------------------------------
\ Place assembler in its own vocabulary.
\ Internal implementation words go into a separate PRIVATE-WORDLIST

VOCABULARY ARM-ASSEMBLER      ALSO ARM-ASSEMBLER DEFINITIONS
VOCABULARY PRIVATE-WORDLIST   ALSO PRIVATE-WORDLIST DEFINITIONS

ALSO FORTH   \ Make sure FORTH words are found first

: PRIVATE   ( -- )   \ Make new words go into private wordlist
	ALSO PRIVATE-WORDLIST DEFINITIONS PREVIOUS ;

: PUBLIC   ( -- )   \ Make new words go into public wordlist
	ALSO ARM-ASSEMBLER DEFINITIONS PREVIOUS ;

: PUBLIC:   ( "<spaces>name" -- )   \ Define word in public wordlist
	PUBLIC : PRIVATE ;

: PUBLIC-CREATE   ( "<spaces>name" -- )   \ CREATE in public wordlist
	PUBLIC CREATE PRIVATE ;

\ ----------------------------------------------------------------------------
\ 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
;

\ ----------------------------------------------------------------------------
\ Words governing where assembled code gets placed.  ( PORTING )

: CODE-HERE   ( -- a-addr )   \ Return address where code will be assembled to
	HERE ;

: CODE-HERE!   ( a-addr -- )   \ Set address where code will be assembled to
	HERE - ALLOT ;

: CODE,   ( x -- )   \ Store 32 bit x at assembly address, and step to next
	, ; 

\ ----------------------------------------------------------------------------
\ Variables

VARIABLE OP-VALUE     \ bits for op-code being constructed
VARIABLE OP-MASK      \ mask of bits currently stored in OP-VALUE
VARIABLE OP-DEFAULT   \ mask of bits in OP-VALUE which have default values
VARIABLE SHIFT-FLAG   \ set by shift operands
VARIABLE ]-FLAG       \ set true by ]
VARIABLE {-FLAG       \ set true by {
VARIABLE REGISTER-LOCATION   \ 0 to 4 bytes giving location to store registers
VARIABLE '#           \ vector for #
VARIABLE 'RM          \ vector called when Rm register is encountered
VARIABLE CODE-ORIGIN  \ address at which OP-VALUE is assembled for

\ ----------------------------------------------------------------------------
\ Words controlling immediate operands

PUBLIC: #   ( x -- )   \ ARM Assembler, immediate operand suffix
	'# @ EXECUTE ;

: UNEXPECTED-#   ( -- )
	TRUE ABORT" ARM Assembler: Unexpected #" ;

: RESET-#   ( -- )   \ Clear behaviour of immediate operand
	['] UNEXPECTED-# '# ! ;

: INVALID#   ( -- )
	TRUE ABORT" ARM Assembler: Invalid immediate operand" ;

: CHECK#   ( u1 u2 -- u1 )   \ Check u1 <= u2
	OVER U< IF INVALID# THEN ;

\ ----------------------------------------------------------------------------
\ Words for initialising op-code generation

: DEFAULT-RM   ( x1 x2 x3 -- x1 x2 )   \ Default action when RM register used
	DROP ;   \ Do nothing

: OP-RESET   ( -- )   \ Reset assembler state
	0 OP-VALUE !
	0 OP-MASK !
	F0000000 OP-DEFAULT !
	0 SHIFT-FLAG !
	0 ]-FLAG !
	0 {-FLAG !
	FFFFFFFF REGISTER-LOCATION !
	RESET-#
	['] DEFAULT-RM 'RM !
;

: ?INVALID   ( x -- )   \ If x not zero, then instruction is invalid
	ABORT" ARM Assembler: Invalid instruction form"
;

: OP-BUILD   ( x1 x2 -- )   \ Set opcode bits masked by x2 to values in x1
	OP-MASK @
	2DUP AND ?INVALID
	OVER OR OP-MASK !
	INVERT OP-VALUE @ AND OR OP-VALUE !
;

: OP-END   ( -- )   \ End of instruction assembly
	OP-MASK @
	IF
		OP-MASK @ OP-DEFAULT @ OR
		FFFFFFFF XOR ?INVALID   \ check all bits are accounted for
		OP-VALUE @ CODE,
		4 CODE-ORIGIN +!
		0 OP-MASK !
	THEN
;

: OP-INIT   ( x1 x2 x3 -- )   \ Initialise the assembler of new instruction
	OP-RESET
	REGISTER-LOCATION !
	OP-MASK !
	OP-VALUE !
;

: OP-BEGIN   ( x1 x2 x3 -- )    \ Start assembly of a new instruction
	OP-END OP-INIT ;

: DO-INSTRUCTION   ( a-addr -- )   \ Common behaviour of INSTRUCTION words
	\ Fetch 3 words from a-addr and call OP-BEGIN
	DUP @
	SWAP CELL+ DUP @
	SWAP CELL+ @
	OP-BEGIN
;

: INSTRUCTION   ( "<spaces>name" -- )   \ Create instruction
	PUBLIC-CREATE
	DOES>  ( -- )
	DO-INSTRUCTION
;

: INSTRUCTION#   ( "<spaces>name" -- )   \ Instruction with immediate operand
	PUBLIC-CREATE
	DOES>  ( -- )
	DUP DO-INSTRUCTION
	CELL+ CELL+ CELL+
	@ '# !
;

: INSTRUCTIOND   ( "<spaces>name" -- )   \ Instruction with default ops mask
	PUBLIC-CREATE
	DOES>  ( -- )
	DUP DO-INSTRUCTION
	CELL+ CELL+ CELL+
	@ OP-DEFAULT !
;

: INSTRUCTIOND#   ( "<spaces>name" -- )   \ Instr. with default and immediate
	PUBLIC-CREATE
	DOES>  ( -- )
	DUP DO-INSTRUCTION
	CELL+ CELL+ CELL+
	DUP @ '# !
	CELL+ @ OP-DEFAULT !
;

\ ----------------------------------------------------------------------------
\ Flags parsing

: LOWER-CASE   ( c1 -- c2 )   \ Covert ASCII character to lower-case
	DUP [CHAR] A - 1A U< 20 AND +
;

: FLAG   ( c c-addr -- )   \ Process a single parsed flag character
	BEGIN
		2DUP C@ <>
	WHILE
		DUP C@ 0= ?INVALID
		CHAR+ CHAR+
	REPEAT
	1 SWAP CHAR+ C@ LSHIFT
	DUP OP-BUILD
	DROP
;

: FLAGS   ( -- )   \ Create flags parsing word
	CREATE
	DOES>   ( "<spaces>ccc" -- )
	>R
	\ set flags in OP-VALUE for each flag char present in "ccc"...
	BL WORD COUNT
	BEGIN
		DUP
	WHILE
		OVER C@ LOWER-CASE R@ FLAG
		1- SWAP CHAR+ SWAP
	REPEAT
	2DROP
	\ now set OP-MASK for each flag bit...
	0 R>
	BEGIN
		DUP C@
	WHILE
		CHAR+
		>R 1 R@ C@ LSHIFT OR
		R> CHAR+
	REPEAT
	DROP
	OP-MASK @ OR OP-MASK !
;

\ ----------------------------------------------------------------------------
\ Labels
\
\ Structure of object is
\   CELL    REF-LINK   \ link to list of unresolved references
\   CELL    VALUE      \ value for label
\   STRING  NAME       \ name of label as a counted string

: LABEL>REF-LINK   ( a-addr1 -- a-addr2 )
	;

: LABEL>VALUE   ( a-addr1 -- a-addr2 )
	CELL+ ;

: LABEL>NAME   ( a-addr -- c-addr )
	CELL+ CELL+ ;

0F CONSTANT MAX-LABEL-NAME-SIZE   \ Max significant length for label name

2 CELLS  MAX-LABEL-NAME-SIZE 1+ CHARS +   ALIGNED
CONSTANT LABEL-SIZE   \ Size of label object

10 CONSTANT #LABELS   \ Max number of labels
CREATE LABELS   #LABELS LABEL-SIZE * ALLOT
HERE CONSTANT LABELS-END

: ALLOC-LABEL   ( -- a-addr )   \ Allocate a new label object
	LABELS
	BEGIN
		DUP LABEL>NAME C@