( Creative Commons Attribution-Noncommercial 2.5 License

SP!
HEX 

: XCOMP ; // A MARKER
// HOST CONSTANTS FOR TARGET COMPILATION.


: 'IMMEDIATE	// unlike IMMEDIATE  - This finds a word and smudges it.
	' LFA>FFA F_IMMD OVER C@ OR SWAP C!
;

: PATCHDP 10 + DP @ SWAP ! ;
: PATCHCONTEXT 18 + CONTEXT @ SWAP ! ;
: OLD' ' ;

// VARIABLE DSTACK MEMTOP 400 - DSTACK !
// MEMTOP 100 - CONSTANT RSTACK
80 CONSTANT TIBSIZE 
80 CONSTANT TOBSIZE
80 CONSTANT PADSIZE

10 CONSTANT   Mode_USR
11 CONSTANT   Mode_FIQ
12 CONSTANT   Mode_IRQ
13 CONSTANT   Mode_SVC
17 CONSTANT   Mode_ABT
1B CONSTANT   Mode_UND
1F CONSTANT   Mode_SYS

80 CONSTANT   I_Bit // when I bit is set, IRQ is disabled */
40 CONSTANT   F_Bit // when F bit is set, FIQ is disabled */
00100000 CONSTANT   FLASHBASE
00200000 CONSTANT   RAMBASE
00210000 CONSTANT   Top_Stack
00000004 CONSTANT   UND_Stack_Size
00000100 CONSTANT   SVC_Stack_Size
00000004 CONSTANT   ABT_Stack_Size
00000004 CONSTANT   FIQ_Stack_Size
00000100 CONSTANT   IRQ_Stack_Size
00000100 CONSTANT   USR_Stack_Size
Top_Stack 
UND_Stack_Size -
SVC_Stack_Size -
ABT_Stack_Size -
FIQ_Stack_Size -
IRQ_Stack_Size -
CONSTANT RSTACK

// 1 15 LSHIFT CONSTANT   PA21_RXD1
// 1 16 LSHIFT CONSTANT   PA22_TXD1

// IO Controller definitions
FFFFFF00 	CONSTANT EFC_BASE   	//  .equ    EFC_BASE,       0xFFFFFF00  /* EFC Base Address */
60 			CONSTANT EFC_FMR   		//   .equ    EFC_FMR,        0x60        /* EFC_FMR Offset */
1			CONSTANT EFC_SETUP
00320100   	CONSTANT EFC_FMR_Val   
1 			CONSTANT PMC_SETUP      
00000601 	CONSTANT PMC_MOR_Val
00481C0E 	CONSTANT PMC_PLLR_Val

00000007 	CONSTANT PMC_MCKR_Val 

// Watchdog Timer WDT definitions
FFFFFD40	CONSTANT WDT_BASE				// WDT Base Address */
04    		CONSTANT WDT_MR      			// WDT_MR Offset */
1    		CONSTANT WDT_SETUP      
00008000    CONSTANT WDT_MR_Val
// Power Mangement Controller PMC definitions
FFFFFC00   	CONSTANT  PMC_BASE   	// PMC Base Address */
20    		CONSTANT  PMC_MOR   	// PMC_MOR Offset */
24   	 	CONSTANT  PMC_MCFR   	// PMC_MCFR Offset */
2C   	 	CONSTANT  PMC_PLLR   	// PMC_PLLR Offset */
30    		CONSTANT  PMC_MCKR   	// PMC_MCKR Offset */
68    		CONSTANT  PMC_SR   		// PMC_SR Offset */
1    		CONSTANT  PMC_MOSCEN   		//  1<<0      /* Main Oscillator Enable */
1 1 LSHIFT 	CONSTANT  PMC_OSCBYPASS   	//  1<<1      /* Main Oscillator Bypass */
FF 8 LSHIFT CONSTANT  PMC_OSCOUNT   	//  0xFF<<8   /* Main OScillator Start-up Time */
FF    		CONSTANT  PMC_DIV   		//  0xFF<<0   /* PLL Divider */
3F 8 LSHIFT	CONSTANT  PMC_PLLCOUNT   	//  0x3F<<8   /* PLL Lock Counter */
3  E LSHIFT	CONSTANT  PMC_OUT   		//	0x03<<14  /* PLL Clock Frequency Range */
7FF 10 LSHIFT CONSTANT  PMC_MUL   		//  0x7FF<<16 /* PLL Multiplier */
3 1C LSHIFT	CONSTANT  PMC_USBDIV   		//  0x03<<28  /* USB Clock Divider */
3   		CONSTANT  PMC_CSS    		//  3<<0      /* Clock Source Selection */
7 2  LSHIFT	CONSTANT  PMC_PRES   		//  7<<2      /* Prescaler Selection */
1  			CONSTANT  PMC_MOSCS  		//  1<<0      /* Main Oscillator Stable */
1 2  LSHIFT	CONSTANT  PMC_LOCK 			//  1<<2      /* PLL Lock Status */

FFFFFF00  CONSTANT  MC_BASE			// * MC Base Address */
: RUNARM
 	' LFA>CA 2 ALIGN 1 - EXECUTE
;

: 'SMUDGE // ADDR -- ; Leave addr of smudged char on stack
	' 6 + DUP DUP C@ 80 OR SWAP C!
;
.S
// VARIABLES FOR PATCHING FORWARD REFERENCES 
VARIABLE ADDR[LIT]
VARIABLE ADDR[LOOP]
VARIABLE ADDR[DO]
VARIABLE ADDR[VAR]
VARIABLE ADDR[CON]
VARIABLE ADDR[IF]
VARIABLE ADDR[."]
VARIABLE ADDRDSTACK
VARIABLE ADDRRSTACK
: HOST! ! ;

: ." ( Compile print string.
	22 WORD
	C@ IF
		ADDR[."] @ 2 ALIGN BRLNK (  Make a call to  [."] 
		PAD C@ 1 +
		0
		BEGIN				( CNTDWN INDEX --
			DUP PAD + C@ 	( Get byte from PAD )
			C,				( CNTDWN INDEX --
			1 + SWAP
			1 - SWAP
		OVER 0=	UNTIL
		DROP DROP
		2 ALIGNDP
	THEN
;

: DO 
	ADDR[DO] @
	BRLNK		// Make a call to [DO]
;

: LOOP 
	ADDR[LOOP] @
	BRLNK		// Make a call to [LOOP]
;

: VARIABLE
	CREATE
	{ LR } PUSH
	ADDR[VAR] @
	BRLNK		// Make a call to [VAR] 
	0 , 			// Rerserve storage space 
;

: CONSTANT
	CREATE
	{ LR } PUSH
	ADDR[CON] @
	BRLNK		// Make a call to [CON] 
	, 			// Store CONSTANT value from top
;

: UNSMUDGE' 
	DUP C@ 7F AND SWAP C!
;

// : AGAIN AGAIN, ;

// IMMEDIATE AGAIN

: PATCH			( Insert a branch too HERE at address @ top
	HERE SWAP 	( Save DP for later
	DP !		( Move dp to patch address
	SWAP BR		( Apply the patch
	DP !		( Restore dp )
;

: IF // -- ADDR ; 
	ADDR[IF] @ BRLNK // At compile time compiler a call to [IF]
	HERE 									// Save here for ELSE or THEN to patch.
	0 ,
;

: ELSE 
	HERE
	0 ,	( Reserve space and clear it.	
	SWAP HERE SWAP PATCH
;

: THEN
	HERE SWAP PATCH
;

: UNTIL 
	ADDR[IF] @ BRLNK
	BR
;

'IMMEDIATE UNTIL

: WHILE
	IF	// While does the same as IF - note IF isn't immediate yet.
;

: REPEAT
	SWAP	( GET "BEGIN" ADDRESS TO TOP
	BR		( MAKE A BRANCH TO IT
	HERE SWAP
	PATCH	( PATCH THE BRANCH AT "wHILE" TO HERE
;
: EXIT
{ PC } POP
;

'IMMEDIATE EXIT
'IMMEDIATE ."
'IMMEDIATE IF
'IMMEDIATE ELSE
'IMMEDIATE THEN
'IMMEDIATE WHILE
'IMMEDIATE REPEAT
'IMMEDIATE DO
'IMMEDIATE LOOP

: LITERAL
	[ 'SMUDGE LITERAL ] 
	ADDR[LIT] @
	BRLNK		// Make a call to [LIT] 
	, 			// Store literal value from top
;

UNSMUDGE'

// These are the XCOMP words for colon defs. From this point on we can't do host/thumb mode : defs.
'SMUDGE IF
'SMUDGE ELSE
'SMUDGE THEN
'SMUDGE WHILE
'SMUDGE REPEAT
'SMUDGE ."

: ]
	1  MODE ! ( Set mode to compile )
	BEGIN 
	MODE @ 1 =
	WHILE
		BEGIN
			20 WORD	C@
		0= WHILE
			 GETLINE
			 CR
		REPEAT
		FIND
		DUP IF ( NOT ZERO 
			DUP 4 + C@ ( GET flags
			F_IMMD AND ( Check immediate flag )
			IF 
				LFA>CA EXECUTE
			ELSE 
				LFA>CA 2 ALIGN BRLNK
			THEN
		ELSE 
			DROP NUMBER	LITERAL // Don't use this till [lit] is defined.
		THEN 
	REPEAT
;

UNSMUDGE'
UNSMUDGE'
UNSMUDGE'
UNSMUDGE'
UNSMUDGE'
UNSMUDGE'

 : :
 	CREATE
 	{ LR }	PUSH
 	]
 ;	


 ALIAS OLD; ;
 ALIAS OLD: :
 ALIAS OLDLIT LITERAL
 ALIAS OLDLFA>CA LFA>CA
'IMMEDIATE OLD;

// UNLOCKALL

( Next compile XKERN.for )

// MIRROR64K

CREATE ARM 
E59FF018 ,	// VECTORS
E59FF018 ,
E59FF018 ,
E59FF018 ,
E59FF018 ,
E59FF018 ,
E59FF018 ,
E59FF018 ,
20 ALLOT // JUMP TABLE

CODE [CON]		// Like [lit] except we pop the PC 
	4 # RSEC [!] RDSP STR, 	
	RTOP RSEC MOV,							
	LR RTOP LDR,
	{ PC } POP
END-CODE
' [CON] LFA>CA 2 ALIGN ADDR[CON] !

// These are target constants they can NOT! be used by the host!!

FFFFF400	CONSTANT PIO_PER 	// (PIOA - PIO Enable Register
FFFFF410	CONSTANT PIO_OER 	// (PIOA - Output Enable Register
FFFFF434	CONSTANT PIO_CODR	// (PIOA - Clear Output Data Register
FFFFF430	CONSTANT PIO_SODR	// (PIOA - Set Output Data Register

1 8 LSHIFT	CONSTANT LEDBIT

FFFC4000 	CONSTANT BASE_US1 	
4			CONSTANT US_MR
14			CONSTANT US_CSR
1C  		CONSTANT US_THR  
18			CONSTANT US_RHR
20			CONSTANT US_BRGR
1 1 LSHIFT	CONSTANT US_TXRDY    //     0x1 <<  1 // DBGU TXRDY Interrup
1 			CONSTANT US_RXRDY    //  

4 CONSTANT BPW

1	CONSTANT F_IMMD		( immediate flag )
2	CONSTANT F_OFFS		( offset compilation flag ie dA non-zero )
4	CONSTANT F_REMT		( remote flag ie headerless code or alias )
8	CONSTANT F_SMUD		( smudge flag )
10	CONSTANT F_VOCB  	( vocab flag )
20 	CONSTANT F_THUMB 


CODE [VAR]		// Like [CON] except we return the address
	4 # RSEC [!] RDSP STR, 	
	RTOP RSEC MOV,							
	LR RTOP MOV,
	{ PC } POP
END-CODE
' [VAR] LFA>CA 2 ALIGN ADDR[VAR] !

// Target variables - not for host!! 
VARIABLE *ABORT

VARIABLE DSTACK 
-4 ALLOT HERE ADDRDSTACK ! 20C000 ,
VARIABLE RSTACK
-4 ALLOT HERE ADDRRSTACK ! 20D000 ,

VARIABLE DP	// The target dictionary pointer.
VARIABLE CONTEXT //  points to most recent words header
VARIABLE VOCLINK
VARIABLE LATEST
VARIABLE MODE
VARIABLE >IN	// input charactor pointer
VARIABLE OUT>	// output charactor pointer
VARIABLE BASE
VARIABLE TIB	// input buffer
TIBSIZE ALLOT
VARIABLE TOB	// output buffer
TOBSIZE ALLOT
VARIABLE PAD	// scratch pad 
PADSIZE ALLOT

// Note we the host can no longer use the host vsersions of these.
80 CONSTANT TIBSIZE 
80 CONSTANT TOBSIZE
80 CONSTANT PADSIZE

CODE [IF]
	0 # RTOP CMP,	// Test top for zero ie false.
	NE 4 # LR ADD,	// If cc are set to NE skip over the branch 
	RSEC RTOP MOV,	// drop top.	
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,	
END-CODE
' [IF] LFA>CA 2 ALIGN ADDR[IF] !

(  loop runtime code )
CODE [LOOP]             ( R = loopaddr limit count LR = return  )
	{ R0 R1 R2 } [U] LDM,  // NO [!]
	1 # R0 ADD,
	R1 R0 CMP,
	LT IF,					( if limit not reached )
		{ R0 } STM,			// NO [P] OR [!]
		R2 PC MOV,
	THEN,
	0C # SP ADD,			// DROP 3 ITEMS FROM STACKBPW ,X LDY,
	LR PC MOV,
END-CODE
' [LOOP] LFA>CA 2 ALIGN ADDR[LOOP] !

CODE [DO]            	( D = limit count -- mt LR = Loopaddr )
	{ LR } 		PUSH
	{ RSEC } 	PUSH
	{ RTOP } 	PUSH
	{ RTOP RSEC } [!] [P] RDSP LDM, // Load both top and next 
	LR PC MOV,
END-CODE                ( R = loopaddr limit count -- )
' [DO] LFA>CA 2 ALIGN ADDR[DO] !

CODE [LIT]		// get the word at LR to top and advance LR.
	4 # RSEC [!] RDSP STR, 			// str 	r5,[r7]
	RTOP RSEC MOV,						//	mov 	r5,r6		
	4 # [!] LR RTOP LDR,
	LR PC MOV,							//	mov 	pc,lr
END-CODE

' [LIT] LFA>CA 2 ALIGN ADDR[LIT] !

CODE RESET
// Setup EFC
	LR R4 MOV, 
	EFC_BASE # R0 MOV,      //    LDR     R0, =EFC_BASE
	EFC_FMR_Val # R1 MOV,  	//    LDR     R1, =EFC_FMR_Val
	R1 EFC_FMR # [P] R0 STR,  	//    STR     R1, [R0, #EFC_FMR]

// Setup WDT
    WDT_BASE # R0 MOV,      //    LDR     R0, =WDT_BASE
    WDT_MR_Val # R1 MOV,    //    LDR     R1, =WDT_MR_Val
    R1 WDT_MR #  [P] R0 STR,   	//    STR     R1, [R0, #WDT_MR]

// Setup PMC

	PMC_BASE # R0 MOV,     //    LDR     R0, =PMC_BASE

//  Setup Main Oscillator
   PMC_MOR_Val # R1 MOV,    		//  LDR     R1, =PMC_MOR_Val
   R1 PMC_MOR # R0 [P] STR,      	//  STR     R1, [R0, #PMC_MOR]

//  Wait until Main Oscillator is stablilized

	BEGIN,
		PMC_SR # R0	[P] R2 LDR, 			// LDR     R2, [R0, #PMC_SR]
        PMC_MOSCS # R2 R2 [S] AND,  // ANDS    R2, R2, #PMC_MOSCS
    NE UNTIL, 							// BEQ     MOSCS_Loop

//  Setup the PLL

    PMC_PLLR_Val # R1 MOV,      //        LDR     R1, =PMC_PLLR_Val
    R1 PMC_PLLR # [P] R0 STR,        //        STR     R1, [R0, #PMC_PLLR]

//  Wait until PLL is stabilized
	BEGIN, 
		PMC_SR # R0 [P] R2 LDR,    			//  LDR     R2, [R0, #PMC_SR]
		PMC_LOCK # R2 R2 [S] AND,     	//            ANDS    R2, R2, #PMC_LOCK
    NE UNTIL,		//          BEQ     PLL_Loop

//  Select Clock
    PMC_MCKR_Val # R1 MOV,      	//            LDR     R1, =PMC_MCKR_Val
    R1 PMC_MCKR # [P] R0 STR,     		//            STR     R1, [R0, #PMC_MCKR]

// Setup Stack for each mode

    210000 # R0 MOV,        // LDR     R0, =Top_Stack
	FFFFF240 # R1 MOV,		// ADDR OF ID 
	27090540 # R2 MOV,		// CODE FOR SAM7-64
	R1 R1 LDR,				// get sam7 id word.
	R1 R2 CMP,				// Is it sam7-64 //
	EQ IF,
		204000 # R0 MOV,         //   LDR     R0, =Top_Stack
	THEN,
//  Enter Undefined Instruction Mode and set its Stack Pointer
    Mode_UND I_Bit F_Bit OR OR # _C CPSR MSR,        	//    MSR     CPSR_c, #Mode_UND|I_Bit|F_Bit
    R0 SP MOV,							        		//    MOV     SP, R0
    UND_Stack_Size # R0 R0 SUB,				        	//    SUB     R0, R0, #UND_Stack_Size

//  Enter Abort Mode and set its Stack Pointer
    Mode_ABT I_Bit F_Bit OR OR # _C CPSR MSR,           //    MSR     CPSR_c, #Mode_ABT|I_Bit|F_Bit
    R0 SP MOV,							        		//    MOV     SP, R0
    ABT_Stack_Size # R0 R0 SUB,				        	//    SUB     R0, R0, #ABT_Stack_Size

//  Enter FIQ Mode and set its Stack Pointer
    Mode_FIQ I_Bit F_Bit OR OR # _C CPSR MSR,           //   MSR     CPSR_c, #Mode_FIQ|I_Bit|F_Bit
    R0 SP MOV,							        		//   MOV     SP, R0
    FIQ_Stack_Size # R0 R0 SUB,				        	//   SUB     R0, R0, #FIQ_Stack_Size

//  Enter IRQ Mode and set its Stack Pointer
    Mode_IRQ I_Bit F_Bit OR OR # _C CPSR MSR,           //   MSR     CPSR_c, #Mode_IRQ|I_Bit|F_Bit
    R0 SP MOV,							        		//    MOV     SP, R0
    IRQ_Stack_Size # R0 R0 SUB,				        	//    SUB     R0, R0, #IRQ_Stack_Size

//  Enter Supervisor Mode and set its Stack Pointer
    Mode_SVC I_Bit F_Bit OR OR # _C CPSR MSR,           //    MSR     CPSR_c, #Mode_SVC|I_Bit|F_Bit
    R0 SP MOV,							        		//    MOV     SP, R0
    SVC_Stack_Size # R0 R0 SUB,				        	//    SUB     R0, R0, #SVC_Stack_Size

//  Enter User Mode and set its Stack Pointer
    Mode_USR # _C CPSR MSR,           					//    MSR     CPSR_c, #Mode_USR
    R0 SP MOV,	
    USR_Stack_Size # R0 R0 SUB,				        	//    SUB     R0, R0, #SVC_Stack_Size

	R0 RDSP MOV,										// DATA STACK

	MC_BASE	# R0 MOV,	
	1 #	R1 MOV,     
	R1 R0 STR,   						        		//    MOV     SP, R0
	R4 PC MOV,
END-CODE

CODE RP!	// Must be called from the top level.
	ADDRRSTACK @ # R0 MOV, // patched after relocation.
	R0 SP LDR,
	LR PC MOV,
END-CODE

CODE LR@	// Must be called from the top level.
	4 # RSEC RDSP [!] STR, 
	LR RTOP MOV,
	LR PC MOV,
END-CODE

CODE RP@	// Must be called from the top level.
	4 # RSEC RDSP [!] STR, 
	SP RTOP MOV,
	LR PC MOV,
END-CODE

CODE SP! 
	ADDRDSTACK @ # R0 MOV, // patched after relocation.
	R0 RDSP LDR,
	LR PC MOV,
END-CODE

CODE SP@
	4 # RSEC RDSP [!] STR, 
	RTOP RSEC MOV,		
	RDSP RTOP MOV,
	LR PC MOV,		
END-CODE

CODE 0	// Push 0 - Saved 208 bytes.
	RSEC 4 # RDSP [!] STR, 
	RTOP RSEC MOV,
	00 # RTOP MOV,		// Use 00 not 0 to avoid recursion.
	LR PC MOV,		
END-CODE

CODE 1	// Push 1 - Saved 60 bytes.
	RSEC 4 # RDSP [!] STR, 
	RTOP RSEC MOV,
	01 # RTOP MOV,		// Use 01 not 1 to avoid recursion.
	LR PC MOV,		
END-CODE

CODE 2	// Push 2 - Saved 64 bytes.
	RSEC 4 # RDSP [!] STR, 
	RTOP RSEC MOV,
	02 # RTOP MOV,		// Use 02 not 2 to avoid recursion.
	LR PC MOV,		
END-CODE

CODE 4	// Push 4 - Saved 44 bytes.
	RSEC 04 # RDSP [!] STR, // Use 04 not 4 to avoid recursion.
	RTOP RSEC MOV,
	04 # RTOP MOV,		// Use 04 not 4 to avoid recursion.
	LR PC MOV,		
END-CODE

CODE 8	// Push 8 - Saved 44 bytes.
	RSEC 4 # RDSP [!] STR, 
	RTOP RSEC MOV,
	08 # RTOP MOV,		// Use 08 not 8 to avoid recursion.
	LR PC MOV,		
END-CODE

CODE DUP	// duplicate top.
	4 # RSEC RDSP [!] STR, 
	RTOP RSEC MOV,		
	LR PC MOV,		
END-CODE

CODE DROP	
	RSEC RTOP MOV,	// drop top.	
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,		
END-CODE

CODE SWAPDROP	// drop next
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,		
END-CODE

CODE SWAP
	RTOP R0 MOV,
	RSEC RTOP MOV,
	R0 RSEC MOV,
	LR PC MOV,		
END-CODE

CODE OVER	
	4 # RSEC RDSP [!] STR, 		// push next
	RTOP RSEC MOV,					// mov top to next
	-4 # RDSP [P] RTOP LDR, 		// load the orginal next from stack to top - no [!]
	LR PC MOV,		
END-CODE

CODE ROT	
	-4 # RDSP [P] R0 LDR,		// Get 3'rd item
	-4 # RSEC RDSP [P] STR, 	// overwrite top of deep stack with next
	RTOP RSEC MOV,		// mov top to next
	R0 RTOP MOV, 	// load the orginal 3'RD from stack to top - no [!]
	LR PC MOV,		
END-CODE

CODE PICK	
	1 # RTOP [S] SUB, // Adjust to skip NEXT	
	EQ IF, // 1 PICK is a special case 
		RTOP RSEC MOV,					// mov top to next
		LR PC MOV,	
	ELSE,
		2 # LSL RTOP RDSP RTOP [P] LDR, 		// load from deep stack to top - no [!]
	THEN,
	LR PC MOV,		
END-CODE

CODE 0=
	0 # RTOP CMP,
	EQ IF,
		0 # RTOP MVN,
	ELSE,
		0 # RTOP MOV,
	THEN,
	LR PC MOV,
END-CODE

CODE = 
	RTOP RSEC RTOP [S] SUB,
	EQ IF,
		0 # RTOP MVN,
	ELSE,
		0 # RTOP MOV,
	THEN,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE < 
	RTOP RSEC RTOP [S] SUB,
	LT IF,
		0 # RTOP MVN,
	ELSE,
		0 # RTOP MOV,
	THEN,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE > 
	RTOP RSEC RTOP [S] SUB,
	GT IF,
		0 # RTOP MVN,
	ELSE,
		0 # RTOP MOV,
	THEN,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE - 
	RTOP RSEC RTOP SUB,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE + 
	RTOP RSEC RTOP ADD,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE 1+ 
	1 # RTOP ADD,
	LR PC MOV,
END-CODE

CODE 1- 
	1 # RTOP SUB,
	LR PC MOV,
END-CODE

CODE AND 
	RSEC RTOP RTOP AND,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE
 
CODE OR 
	RSEC RTOP RTOP ORR,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE XOR 
	RSEC RTOP RTOP EOR,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE *
	RSEC RTOP RTOP MUL,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE	

CODE LSHIFT
	RTOP LSL RSEC RTOP MOV,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE	

CODE RSHIFT
	RTOP LSR RSEC RTOP MOV,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE	

CODE 2* 
	RTOP 1 # LSL RTOP MOV,
	LR PC MOV,
END-CODE

CODE 2/ 
	RTOP 1 # LSR RTOP MOV,
	LR PC MOV,
END-CODE

CODE NEGATE 
	0 # RTOP RTOP RSB,
	LR PC MOV,
END-CODE

CODE INVERT 
	RTOP RTOP MVN,
	LR PC MOV,
END-CODE

CODE !
	RSEC RTOP STR,
	{ RTOP RSEC } [!] [P] RDSP LDM, // Load both top and next 
	LR PC MOV,
END-CODE

CODE C!
	RSEC RTOP STRB,
	{ RTOP RSEC } [!] [P] RDSP LDM, // Load both top and next 
	LR PC MOV,
END-CODE

CODE @
	RTOP RTOP LDR,
	LR PC MOV,
END-CODE

CODE C@
	RTOP RTOP LDRB,
	LR PC MOV,
END-CODE

CODE >R								// Move top the Rstack
	{ RTOP } PUSH
	RSEC RTOP MOV,
	-4 # RDSP [P] [!] RSEC LDR,
	LR PC MOV,
END-CODE

CODE R>								// Move Top of Rstack to Dstack
	4 # RSEC RDSP [!] STR, 
	RTOP RSEC MOV,	
	{ RTOP } POP
	LR PC MOV,
END-CODE

CODE I								// COPY Top of Rstack to Dstack
	4 # RSEC RDSP [!] STR, 
	RTOP RSEC MOV,	
	{ RTOP } [U]  LDM, // NO [!]
	LR PC MOV,
END-CODE

CODE EXECUTE
	RTOP R0 MOV,
	RSEC RTOP MOV,	// drop top.	
	-4 # RDSP [P] [!] RSEC LDR,
	R0 PC MOV,	
END-CODE

CODE U/MOD	( A B --> A umod B, A/B )
	RSEC R0 MOV,
	RTOP R2 MOV,
	1 # R3	MOV,			//  MOV      R3,#1     ;set bit 0 in R3, which will be shifted left then right
	1 # LSR RSEC RSEC MOV,
	BEGIN,					// .start
		RSEC R2 CMP,			// CMP      R2,R1
		1 # LSR RSEC RSEC LS MOV,	//	MOVLS    
		1 # LSL RTOP RTOP LS MOV,	//	MOVLS    R2,R2,LSL#1
		1 # LSL R3 R3 LS MOV,		//	MOVLS    R3,R3,LSL#1
	HI UNTIL,					// BLS      start
	R0 RSEC MOV,
	0 # R0	MOV,			//	MOV      R0,#0     ;clear R0 to accumulate result
	BEGIN,						// .next
		RTOP RSEC CMP,				// CMP       R1,R2      	;carry set if R1>R2 (don't ask why)
		RTOP RSEC RSEC CS SUB,		// SUBCS     R1,R1,R2   	;subtract R2 from R1 if this would give a positive answer
		R3 R0 R0 CS ADD,			// ADDCS     R0,R0,R3   	;and add the current bit in R3 to the accumulating answer in R0
		1 # LSR R3 R3 [S] MOV,		// MOVS      R3,R3,LSR#1     ;Shift R3 right into carry flag
		1 # LSR RTOP RTOP  CC MOV,	// MOVCC     R2,R2,LSR#1     ;and if bit 0 of R3 was zero, also shift R2 right
	CS UNTIL,						//	BCC      next ;If carry not clear, R3 has shifted back to where it started, and we can end
	R0 RTOP MOV,			
	LR PC MOV,
END-CODE

: / 							// Make number positive before sending to u/mod then adjust sign of result. 
	DUP 0 < IF
		NEGATE 1 >R 
	ELSE
		0 >R
	THEN
	SWAP
	DUP 0 < IF
		NEGATE R> 1 XOR >R 
	THEN
	SWAP
	U/MOD
	SWAPDROP
	R> IF NEGATE THEN	// Get sign flag from R and adjust result as needed.
; 
	
: U/ U/MOD SWAPDROP ;
: UMOD U/MOD DROP ;

: ALIGN 			// Align address on stack 
	1 				( Build mask etc. -- N 1
	BEGIN
		SWAP 2 *
		SWAP 1 -
		DUP 
	0=	UNTIL
	DROP 		// ADDR MASK -- 
	SWAP OVER 1 - +	// MASK {ADDR+MASK-1} -- 
	SWAP NEGATE AND 
;

: ,	
	DP @ 2 ALIGN SWAP  //  AHERE VAL --
	OVER			 // AHERE VAL AHERE --
	! 4 + DP !
;

: C,	
	DP @ SWAP OVER C! 1 + DP !
;

: +!
	SWAP OVER @ //  VAR NUM *VAR
	+ SWAP ! 
;
: C+!
	SWAP OVER C@ //  VAR NUM *VAR
	+ SWAP C! 
;

: -!
	SWAP OVER @ //  VAR NUM *VAR
	SWAP - SWAP ! 
;

: SOUT 
	BEGIN
		BASE_US1 US_CSR + @
		US_TXRDY AND 
	UNTIL
	BASE_US1 US_THR + C!
;

: SIN 
	BEGIN
		BASE_US1 US_CSR + @
		US_RXRDY AND 
	UNTIL
	BASE_US1 US_RHR + C@
;
: EMIT SOUT ;

CODE [."]

	LR R0 MOV,				// We need to work on the LR address
	1 # R0 R1 [!] LDRB,		// Get the string count
	BEGIN,
		1 # R1 [S] SUB,
	PL WHILE,
		4 # RSEC RDSP [!] STR, 	// Push datastack down to make room for char
		RTOP RSEC MOV,	
		1 # R0 RTOP [!] LDRB,		// Get the CHAR
		CALL EMIT					// emit - this drops the char from top.
	REPEAT,
	3 # R0 ADD,
	3 # R1 MVN,
	R1 R0 R0 AND,
	R0 PC MOV,
END-CODE

' [."] LFA>CA  ADDR[."] HOST! // NO 2 ALIGN - this is done by ."

: SPACE 20 EMIT ;
: SPACES DUP 0 > IF 0 DO SPACE LOOP ELSE DROP THEN ;

: CR
	D SOUT
	A SOUT
;

: DELAY
	10000 
	BEGIN
		1 -  
	DUP 0= UNTIL
	DROP
;

: LEDON
	LEDBIT PIO_CODR !
;

: LEDOFF 
	LEDBIT PIO_SODR !
;

: FLASHLED
 	LEDON	
	DELAY
	LEDOFF
	DELAY
;

: ABS	( N - U ) DUP 0 < IF NEGATE THEN ;

: HOLD	( ..# X N - ..# X)
	SWAP >R SWAP 1 + R>
;

: DIGIT	 ( N - N)
	DUP 9 > IF 7 + THEN 30 + // 30 HEX 
;

: <#	 ( N - ..* N)
	-1 SWAP
;

: #>	 ( ..# N)
	DROP -1 DO 
	EMIT LOOP ;

: #		 ( ..# N - ..# N)
	BASE @ U/MOD SWAP 
	DIGIT HOLD ;

: #S	 ( ..# N - ..# 0)
	BEGIN
		# DUP
	0= UNTIL
;

: SIGN	( ..# N N - ..# N )	0 < IF 2D HOLD THEN ;

: (.)	 ( N - ..# N)

	DUP >R ABS <# #S R> SIGN
;

// FORTH DEFINITIONS

: . ( N)
	(.) #> SPACE
;

: U.R	( U N) >R <# #S OVER R> SWAP - SPACES #> ;

: U.	( U) 0 U.R SPACE ;

: U?	( A) @ U. ;
: ?	( A) @ . ;
: DEPTH
	SP@ DSTACK @ - 4 / 1 -                  ( bpw / ? )
;

: .S
	DEPTH 		( depth --- )
	CR 
	." DATA STACK -- "
	DUP 0 < IF ." UNDERFLOWED!! " 7 EMIT
	ELSE
		BEGIN 		( depth --- )
			DUP      ( depth depth --- )
		WHILE       ( depth ---
			DUP 1+ PICK U. ( depth data -- )
			1-      ( depth-1 --- )
		REPEAT
		DROP
		." [TOS] " 
    THEN
CR
;

: NOT 0= ; // Make this an alias?? Not before the reloction or you have to patch it again.

: >TIB		// CHAR -- ; Save char to TIB
	TIB >IN @ + C! 	1 >IN +!	// -- save the char
;
: CHK>IN 	// RANGE CHECK >IN
	>IN @ TIBSIZE <
;
: DEC>IN	// -- dec >in
	1 >IN -!
;

: DECIMAL A BASE ! ;

: HEX 10 BASE ! ;

: GETLINE
	0 >IN !	// use >IN for overflow checking
	BEGIN					//  -- 
		SIN					// CHAR -- 
		DUP D = NOT			// CHAR FLAG -- ; True if not CR
		CHK>IN    			// CHAR FLAG FLAG -- ;True if no TIB overflow
		AND					// CHAR FLAG -- True if both tests above are true.
	WHILE					// CHAR -- 
		DUP 8 = 			// CHAR FLAG -- Was  char a backspace
		IF DROP				// -- yes drop the char
			>IN @			// @>IN  -- are there any chars in the buffer
			IF 				// -- yes
				DEC>IN		// -- dec >in
			THEN			// -- 
		ELSE				// CHAR -- not a BS
			DUP 9 = 		// CHAR -- is it a tab
			IF					
				DROP 20 	// SPACE  -- convert tab to space
			THEN
			>TIB 			// -- save char
		THEN
	REPEAT
	DROP D >TIB				// -- save a CR char
	0 >IN !
;

: TIB>
	TIB >IN @ + C@
	1 >IN +!
;

: WORD // delim -- pad
	0 PAD C!					// delim -- Zero pad count
	PAD 						// delim pad  --
	BEGIN						// Skip leading delim
		OVER TIB> =				// delim pad flag -- true if char = delim
		CHK>IN 	AND				// delim pad flag  flag  -- true if >IN not overflowed and previous test is true
	NOT UNTIL					// loop back until either test = false
	DEC>IN						// delim pad -- step >in back one char
	BEGIN						// scan to delim or control char
		1 +						// delim pad+  --
		OVER TIB> SWAP OVER = NOT	// delim pad+ char flag -- true if char is not a delimiter
		OVER 1F > AND			// delim pad+ char flag -- true if  char is not delim and not a control char such as CR or null
		CHK>IN AND				// delim pad+ char flag -- true if if both tests are true and >in hasn't overflowed.
	WHILE						// while all three tests are true do the while part.
		OVER C!					// delim pad+ -- 
		1 PAD C+!				// delim pad+ -- Inc cnt
	REPEAT
	ROT = NOT IF DEC>IN THEN 	// Pad+ - If char is not delim then step back one   
	DROP						// -- drop pad+ 
	PAD
;

: TYPE							// addr -- 
	DUP C@						// addr cnt -- GET COUNT
	BEGIN
		DUP
	WHILE						// while cnt not zero
		1 - 					// addr cnt-1 -- 
		SWAP 1 + DUP C@ EMIT	// cnt-1 addr+1 -- 
		SWAP					// addr+1 cnt-1 -- 
	REPEAT
	DROP DROP
;

: BPW+ BPW + ;
: ID	( LFA --> )
	BPW+						( FFA --> )
	DUP C@ 
	F_REMT AND
		IF ." ^ "
		ELSE
			DUP C@ F_SMUD AND
				IF ." * "
				ELSE
				DUP C@ F_VOCB AND
					IF ." V "
					ELSE 2 SPACES
					THEN
				THEN
		THEN
	1+ DUP C@ 						( NFA COUNT --> )
	DUP 8 > IF DROP 8 THEN			( ONLY DO 8 CHARs )
	SWAP 1+ OVER					( COUNT NFA+1 COUNT --> )
		0 DO
			DUP I + C@  EMIT
		LOOP
	DROP SPACE						( COUNT --> )
	DUP 9 < IF
		8 SWAP - SPACES
	ELSE
	DROP
	THEN
;

: VLIST
		CR
//		VP @ BPW+ @ @
	CONTEXT @ 
		 ( FIRST LFA --> )
		0 SWAP							( CNT LFA	--> )
		BEGIN
			DUP
// 0= NOT
//			KEYHIT IF
//				KEY 1B = IF
//					DROP FALSE
//					ELSE
//					KEY DROP
//				THEN
//			THEN
		WHILE
			DUP 4 U.R SPACE DUP ID	( CNT LFA --> )
			SWAP 1+						( LFA CNT++ --> )
				DUP 4 = IF				( LFA CNT FLAG --> )
					CR DROP 0			( LFA 0 --> )
				THEN
				SWAP					( CNT LFA --> )
			@							( CNT NEXTLINK --> )
		REPEAT
		DROP
		DROP
		CR
;


: CRASH

//	R> R> 2- TYPE CR
//	BLK@ IF						( if source was disk )
//		." Abort in File - "
//		BLK@ [ BUFFSIZE E + ] LITERAL +
//		TYPE  ."  at line "
//		BASE @ >R DECIMAL
//		BLK@ B + U?  ( @ U. )
//		R> BASE ! CR
//	THEN
//	CNT @ 0 DO TIB I + C@ EMIT LOOP CR
//	>IN @ PAD C@ - 1- SPACES PAD C@ 0 DO ." ^" LOOP CR
." ???" 7 EMIT CR
	*ABORT @ EXECUTE
;

: -DIGIT	 ( ASCII - N )
	DUP 39 >
		IF
			DUP 40 >
			IF 7 -
			ELSE CRASH
			THEN
		THEN
	30 - DUP
	BASE @ < OVER 0 < NOT AND
	NOT IF CRASH
	THEN
;

: 10*+	 ( U ASCII - U)
	-DIGIT				( CONVERT ASCII TO NUMBER )
	SWAP				( BRING SUM TO TOP )
	BASE @ * +			( * SUM BY BASE AND ADD NUMBER )
;

// HEADS
// FORTH DEFINITIONS

: NUMBER	( - N )
	PAD DUP
	1+ C@							( A 1ST --> GET FIRST CHAR )
	DUP 2D	=						( IS IT - )
		IF
			SWAP 0					( SIGN A SUM --> )
		ELSE
			>R 0 SWAP R> -DIGIT		( 0 A SUM --> )
		THEN

	SWAP DUP C@ 1- >R				( SGN SUM A --> REMAINING COUNT TO R )
	1+								( SGN SUM A --> ADDRESS OF NEXT CHAR )
		BEGIN
			I						( GET CNT FROM R )
		WHILE
			1+ SWAP OVER C@			( SGN A++ SUM ASCII --> )
			10*+ SWAP				( SGN SUM A -- )
			R> 1- >R				( SGN SUM A -- DEC CNT )
		REPEAT
	R> DROP							( DROP CNT )
	DROP SWAP						( SUM SGN --> TRASH A GET SIGN )
	IF								( SIGNED )
		0 SWAP -					( -SUM --> )
	THEN
;

: FIND						// -- false/addr
	CONTEXT 
//	@				//  get the link to vocab onto top.
	BEGIN 
		@ 					// LFA -- @ it to get the address of the first word
	DUP WHILE				// LFA -- check for zero - ie end of list
		DUP 5 +	DUP C@			// LFA DICSTRADDR DScnt -- advance to dict word Cstring and get count byte
		PAD C@ 				// LFA DICSTRADDR DScnt PadCnt -- now compare PAD cnt with word cnt.
		= IF 				// LFA DICSTRADDR -- Size matches compare string	
			PAD DUP C@		// LFA DICSTRADDR PAD PADCNT -- Get pad and cnt  - NB it would be quicker to pick pad from the stack.
			BEGIN
				DUP 0= IF 	// LFA DICSTRADDR PAD PADCNT -- We have a match, quitely slip away with the loot, no-one will notice.
					DROP DROP DROP
					EXIT
				THEN
				1- 					// LFA DICSTRADDR PAD PADCNT -- Dec counter 
				ROT 1+				// LFA PAD PADCNT DICSTRADDR+ -- dic word pointer to top and inced.
				ROT 1+				// LFA PADCNT DICSTRADDR+ PAD+ -- pad pointer to top and inced.
				OVER C@ OVER C@	= 	// LFA PADCNT DICSTRADDR+ PAD+ flag -- compare two chars
				>R ROT R>			// LFA  DICSTRADDR+ PAD+ PADCNT flag -- temp move flag to R so we can bring CNT up again.
			NOT UNTIL				// LFA  DICSTRADDR+ PAD+ PADCNT -- if equal go around the loop.
			DROP DROP DROP			// LFA  -- words didn't match try next one.
		ELSE DROP
		THEN						// LFA -- No match try again
	REPEAT							// FALSE --
;	

: INIT 
	SP!
	HEX
;

: LFA>CA // CFA -- CA ; Make code address from link address
	4 + // REMEMBER FLAG ADDR
	DUP 1 + DUP C@ + 1+ 2 ALIGN
	SWAP 
	C@ F_REMT AND	// Is remote flag set
		IF 
			@		// get remote address
		THEN
;


: '
	20 WORD C@
	IF FIND
		DUP 0= IF CRASH THEN
	ELSE CRASH
	THEN
;

: HERE DP @ ;

: -BR							// CODE -- ; a simple version of BR24
	SWAP
	HERE 8 + - 2/ 2/		// CODE SHIFTADDR --
	FFFFFF AND +
	,							// MT -- 
;

: BRLNK EB000000 -BR	;			// CODE ADDR -- To be superseded by version with CCs .

: CALL 
	' LFA>CA BRLNK
;
: BR EA000000  -BR	;				// CODE ADDR--
: GOTO 
	' LFA>CA BR
;

: LFA>FFA // Convert the link address to flag address
	4 + 
;

: LITERAL
	[ OLD' [LIT] OLDLFA>CA OLDLIT ] BRLNK		( Make a call to [LIT] 
	, 			( Store literal value from top
;

: ALIGNDP
	HERE SWAP ALIGN DP !
;

: CREATE // A new version of create which has more flag options.
	2 ALIGNDP HERE 
	DUP LATEST !
	CONTEXT @ , 				( Store link 
	CONTEXT !
	0 C, 						( Store flags )
	20 WORD						( parse name of word to create -- PAD
	DUP C@ 1+					( Get length Add 1 for cnt byte
	BEGIN						( LFA PAD CNT
		SWAP DUP C@ C, 			( Store char to dic.
		1+ SWAP 1-				( Inc pad swap to get cnt
		DUP 
	0= 	UNTIL
	DROP DROP
;

: ABORT
	RP!
	INIT	
( [ OLD' ABORT OLDLIT LFA>CA ] *ABORT !	// Patch *ABORT to allow forward references to ABORT.
." EMFORTH for the SAM7 ARM micro controller" CR
." E.Matejowsky 2007" CR

	BEGIN					// begin interpreter loop 
	CR 3E EMIT SPACE		// send prompt
	GETLINE					// get a line for input stream
	CR						// send a return to the terminal. 
	BEGIN 					// begin parse loop 
		20 WORD C@			// parse a string delimited by a space
	WHILE					// if a string was found continue, if not go to past the repeat. 
		FIND				// looks for the word in the dictionary
		DUP IF				// dup the address and goto "else" if it was zero ie not found.
			LFA>CA EXECUTE 	// the word exists, convert the link address to the code address and execute it.  
		ELSE 
			DROP NUMBER		// the word was not found, drop the address and convert the string to number.
		THEN
	REPEAT 					// repeat the parse loop 
	AGAIN					// execute the interpret loop again.
;

: // 0 WORD DROP ;

: ]
	1  MODE ! 			( Set mode to compile )
	BEGIN 				( begin compile loop )
	MODE  @ 1 =			( check we are still in compile mode )
	WHILE				
		BEGIN			
			20 WORD	C@	( try to parse a word
		0= WHILE		( if 0 no word parsed so get a new line 
			 GETLINE
			 CR
		REPEAT			( repeat until a word is parsed )
		FIND			( look for the word in the dictionary )
		DUP IF 			( in not zero we found one 
			DUP 4 + C@ 	( GET flags
			F_IMMD AND 	( Check immediate flag )
			IF 
				LFA>CA EXECUTE	( it was immediate so execute it. )
			ELSE 
				LFA>CA BRLNK	( it wasn't immediate so compile a call to it.
			THEN
		ELSE 
			DROP				( word not in dictionary )
			NUMBER LITERAL		( convert string to number and compile a literal )
		THEN 
	REPEAT						( repeat until the mode is not compile )
;

: [
	0 MODE ! ( Set mode to interp )
;
: LRPUSH E92D4000 , ;
: PCPOP E8BD8000 , ;
: ;
	0  MODE  ! ( Set mode to interp )
	PCPOP
OLD;

OLD: :
	CREATE
	LRPUSH 
	]
OLD;	

'IMMEDIATE ;
'IMMEDIATE [
'IMMEDIATE //
OLD' CONTEXT PATCHCONTEXT 
OLD' DP PATCHDP

( MIRROR64K ( next compile extras )

ABORT

0 ' ARM !

' ABORT LFA>CA *ABORT ! // Patch abort address

: VARIABLE
	CREATE
	LRPUSH
	[ ' [VAR] LFA>CA LITERAL ]
	BRLNK		// Make a call to [VAR] 
	0 , 		// Reserve storage space 
;

: CONSTANT
	CREATE
	LRPUSH
	[ ' [CON] LFA>CA LITERAL ]
	BRLNK		// Make a call to [CON] 
	, 			// Store CONSTANT value from top
;

: IMMEDIATE	// unlike thumb version - This is ANS93 style - can only change the most recently defined header.
	LATEST @ LFA>FFA F_IMMD OVER C@ OR SWAP C!
;

: ( 29 WORD DROP ; IMMEDIATE

: ALIAS		// Make alias to an existing word.
	2 ALIGNDP HERE CREATE 4 + DUP C@ F_REMT OR SWAP C! // Set remote bit.
	' LFA>CA ,
;

: PATCH			( Insert a branch too *NXT at address @ top
	HERE SWAP 	( Save DP for later
	DP !		( Move dp to patch address
	SWAP BR		( Apply the patch
	DP !		( Restore dp 
;

: ELSE 
	HERE
	0 ,	( Reserve space and clear it.	
	SWAP HERE SWAP PATCH
; IMMEDIATE

: THEN
	HERE SWAP PATCH
; IMMEDIATE


: REPEAT
	SWAP	( GET "BEGIN" ADDRESS TO TOP
	BR		( MAKE A BRANCH TO IT
	HERE SWAP
	PATCH	( PATCH THE BRANCH AT "WHILE" TO HERE
; IMMEDIATE

: EXIT
	PCPOP
; IMMEDIATE

: BEGIN 
	HERE
; IMMEDIATE

: DO 
	[ ' [DO] LFA>CA LITERAL ]
	BRLNK		// Make a call to [DO]
; IMMEDIATE


: LOOP
	[ ' [LOOP] LFA>CA LITERAL ]
	BRLNK		// Make a call to [LOOP]
; IMMEDIATE

: IF // -- ADDR ; 
	[ ' [IF] LFA>CA LITERAL ] BRLNK // At compile time compiler a call to [IF]
	HERE 									// Save here for ELSE or THEN to patch.
	0 ,
; IMMEDIATE

: ERASE // START LEN --
	0 DO
		0 OVER I + C!
	LOOP
	DROP
;

: CMOVE // SRC DST LEN --
	0 DO  // SRC DST --
		OVER I + C@ OVER I + C!
	LOOP
	DROP DROP
;

200000 CONSTANT RAM 

' ARM LFA>CA RAM - CONSTANT OFFSET

// RAM OFFSET ERASE


: PATCHIT
	CONTEXT OFFSET - // CONTEXT- CONTEXT- -- PATCH MOVED CONTEXT 
	BEGIN
	DUP @ 
	0 >
	IF 							// IF DOES THE SAME AS WHILE;	THREAD --
		DUP @ OFFSET - 			// LINKAD LINK- 
		DUP ROT !
	REPEAT	
	DROP
;

' ARM LFA>CA // REMEMBER THIS 
0 ' [CON] !		// Make this the first {lowest} Word in the dictionary.

 RAM OFFSET .S CMOVE

PATCHIT

 ' ABORT LFA>CA OFFSET - EXECUTE
 ' ABORT LFA>CA  *ABORT ! // Patch abort address
 ' PATCHIT DUP DP ! @ CONTEXT !
 
 ' [CON] LFA>CA ' CONSTANT LFA>CA 10 + !
 ' [VAR] LFA>CA ' VARIABLE LFA>CA 10 + !
 ' [LIT] LFA>CA ' LITERAL LFA>CA 8 + !
 ' [DO] LFA>CA ' DO LFA>CA 8 + !
 ' [LOOP] LFA>CA ' LOOP LFA>CA 8 + !
 ' [IF] LFA>CA ' IF LFA>CA 8 + !
 RSTACK ' RP! LFA>CA C + !
 DSTACK ' SP! LFA>CA C + !

 HERE 1000 ERASE


: UNTIL 
	[ ' [IF] LFA>CA LITERAL ] BRLNK
	BR
; IMMEDIATE

// If alias is used before the relocation then it points to the old copy.
ALIAS WHILE	IF	// While does the same as IF
IMMEDIATE
 
FFFFFC10 CONSTANT PMC_PCER // (PMC) Peripheral Clock Enable Register
2 CONSTANT ID_PIOA     // Parallel IO Controller bit
6 CONSTANT ID_US0      // USART 0
7 CONSTANT ID_US1      // USART 0
 // ========== Register definition for usart peripheral ==========


1 2 LSHIFT CONSTANT US_RSTRX // (DBGU) Reset Receiver
1 3 LSHIFT CONSTANT US_RSTTX // (DBGU) Reset Transmitter
1 4 LSHIFT CONSTANT US_RXEN  // (DBGU) Receiver Enable
1 5 LSHIFT CONSTANT US_RXDIS // (DBGU) Receiver Disable
1 6 LSHIFT CONSTANT US_TXEN  // (DBGU) Transmitter Enable
1 7 LSHIFT CONSTANT US_TXDIS // (DBGU) Transmitter Disable
1 8 LSHIFT CONSTANT RSTSTA   // (DBGU) Reset Status Bits

// ========== Register definition for PIOA peripheral ==========
FFFFF404 CONSTANT PIOA_PDR   // (PIOA) PIO Disable Register
DECIMAL
1 21 LSHIFT CONSTANT PA21_RXD1 
1 22 LSHIFT CONSTANT PA22_TXD1 

0 CONSTANT US_USMODE_NORMAL  // (USART) Normal
0 4 LSHIFT  CONSTANT US_CLKS_CLOCK    // (USART) Clock
0 12 LSHIFT CONSTANT US_NBSTOP_1_BIT  // (USART) 1 stop bit
4 9 LSHIFT  CONSTANT US_PAR_NONE      // (DBGU) No Parity
3 6 LSHIFT  CONSTANT US_CHRL_8_BITS   // (USART) Character Length: 8 bit
HEX

FFFFFD00  	CONSTANT base_RSTC		
8	  		CONSTANT RSTC_MR 		
1  			CONSTANT RSTC_URSTEN

VARIABLE INIDATA // Data to initialize uart etc
INIDATA DP !


//   Enable RxD0 Pin  Enable TxD0 Pin */
PIOA_PDR , PA21_RXD1 PA22_TXD1 OR ,
// set up usart 1
// Reset Receiver Reset Transmitter  Receiver Disable  Transmitter Disable 
BASE_US1 , US_RSTRX US_RSTTX US_RXDIS US_TXDIS OR OR OR , // same as US_CR 

// Normal Mode Clock = MCK No Parity 1 Stop Bit 
BASE_US1 US_MR + , US_USMODE_NORMAL US_CLKS_CLOCK US_CHRL_8_BITS US_PAR_NONE US_NBSTOP_1_BIT OR OR OR OR ,

//  Baud Rate Divisor 38.4Kbd with 48mhz clock = 78 
BASE_US1 US_BRGR + , DECIMAL 78 HEX ,

//  Receiver Enable  Transmitter Enable  
BASE_US1 , US_RXEN US_TXEN OR ,

//  p_pPMC->PMC_PCER = 1 << AT91C_ID_PIOA;
PMC_PCER , 1 ID_PIOA LSHIFT 1 ID_US0 LSHIFT 1 ID_US1 LSHIFT OR OR ,

//  p_pPio->PIO_PER = BIT8;    //Enable PA8 for led
PIO_PER	,	1 8	LSHIFT ,

//  p_pPio->PIO_OER = BIT8;    //Configure in Output
PIO_OER , 1 8	LSHIFT ,
						

// *AT91C_RSTC_RMR = 0xA5000000|AT91C_RSTC_URSTEN ;
base_RSTC RSTC_MR + , A5000000 RSTC_URSTEN OR ,
0 ,

: INITPORTS
	INIDATA
	BEGIN
		DUP @ // While not pointing to a zero
	WHILE
		 DUP 4 + @ 		// PTR, DATA -- 
		 OVER @			// PTR, DATA STOREADDR -- 
			! 
		 8 + 
	REPEAT
	DROP
;

// reset vector points here. Probably running in flash with nothing initialized yet.
CREATE COLD // Use create instead of : to avoid stack push before ram is up.
 ] RESET // intialize arm memory controls, clock etc.

 
	INITPORTS	// bring up coms and io ports.
	4 0 DO LEDON DELAY LEDOFF DELAY LOOP // show some life.
	LR@
	RAM <
	IF
		100000 200000 DP @ 200000 - CMOVE 
	THEN
 RP@ RSTACK FFFF AND !	// Clear the high bits so we write to ram not flash
 SP@ DSTACK FFFF AND ! // reset main pointers.
	
	*ABORT @ EXECUTE // run forth 
 [ // no need for ; because abort never returns here.


' COLD LFA>CA 100000 - 200020 !
' COLD LFA>CA 100000 - 200024 !
' COLD LFA>CA 100000 - 200028 !
' COLD LFA>CA 100000 - 20002C !
' COLD LFA>CA 100000 - 200030 !
' COLD LFA>CA 100000 - 200034 !
' COLD LFA>CA 100000 - 200038 !
' COLD LFA>CA 100000 - 20003C !

: SDASC
	OVER OVER SWAP
	OVER OVER -
	IF SPACE
		DO
			I C@
			DUP 20 < OVER 7A > OR
				IF DROP 2E THEN
					EMIT
		LOOP
	ELSE
		DROP DROP
THEN
;

: DUMP
		DEPTH 2 < IF
// ABORT" Not enough items on stack "
//		." Not enough items on stack " 
		CRASH
 THEN
		OVER SWAP				( ADDR ADDR CNT )
		0 DO					( LOOP LEN TIMES )
			I 0F AND NOT
				IF
					SDASC
					CR DUP
					4 U.R
					SWAP DROP DUP
//					KEYHIT IF
//						KEY 1B = IF
//							LEAVE
//						ELSE
//							KEY DROP
//						THEN
//					THEN
				THEN
			DUP C@ 2 U.R
			1+
		LOOP
		SDASC
		DROP DROP
		CR
;

( SAM7 FLASH PROGRAMMING COMMANDS.

01 CONSTANT WP 			( Write page
02 CONSTANT SLB  		( Set Lock Bit 
03 CONSTANT WPL 		(  Write Page and Lock 
04 CONSTANT CLB 		(  Clear Lock Bit 
08 CONSTANT EA 			(  Erase all 
0B CONSTANT SGPB 		(  Set General-purpose NVM Bit
0D CONSTANT CGPB 		(  Clear General-purpose NVM Bit 
0F CONSTANT SSB 		(  Set Security Bit 

( Embedded Flash Controller EFCS User Interface

60 CONSTANT 	MC_FMR	( MC Flash Mode Register
64 CONSTANT 	MC_FCR 	( MC Flash Command Register Write-only 
68 CONSTANT 	MC_FSR 	( MC Flash Status Register

FFFFFF00 CONSTANT MCBASE	( Memory Controller MC User Interface

5A 18 LSHIFT CONSTANT FLASHKEY ( The shifted 24 places (18 hex

30 CONSTANT CPUMHZ ( CPU clock speed )

: READFSTAT 
	[ MCBASE MC_FSR + LITERAL ]
	@
;

: READFMODE 
	[ MCBASE MC_FMR + LITERAL ]
	@
;

: WAITFREADY
	BEGIN
		READFSTAT 1 AND ( WAIT FOR READY )
	UNTIL
;

: CLEARLOCK ( PAGENUM -- MT )
[	CPUMHZ 10 LSHIFT CPUMHZ F LSHIFT + ( = MHZ *1.5 LSFT DEC'16 
	100 + LITERAL ( ADD 1 WAIT STATE
]

	[ MCBASE MC_FMR + LITERAL ]
	!
	8 LSHIFT  ( SHIFT PAGE NUMBER AND BUILD COMMAND)
	[ FLASHKEY CLB + LITERAL ]
	+
	[ MCBASE MC_FCR + LITERAL ]
	!
	WAITFREADY
;

: SETLOCK ( PAGENUM -- MT )
[	CPUMHZ 10 LSHIFT CPUMHZ F LSHIFT + ( = MHZ *1.5 LSFT DEC'16 
	100 + LITERAL ( ADD 1 WAIT STATE
]

	[ MCBASE MC_FMR + LITERAL ]
	!
	8 LSHIFT  ( SHIFT PAGE NUMBER AND BUILD COMMAND)
	[ FLASHKEY SLB + LITERAL ]
	+
	[ MCBASE MC_FCR + LITERAL ]
	!
	WAITFREADY
;

: UNLOCKALL
	0
	BEGIN
	
		DUP 
		6 LSHIFT	( * H'40 {DEC 64} 64 Pages per sector )		
		CLEARLOCK
		1 + DUP
	10 > UNTIL
	DROP
;

: LOCKALL
	0
	BEGIN
	
		DUP 
		6 LSHIFT	( * H'40 {DEC 64} 64 Pages per sector )		
		SETLOCK
		1 + DUP
	10 > UNTIL
	DROP
;

: LOCK64K
	0
	BEGIN
		DUP 
		6 LSHIFT	( * H'40 {DEC 64} 64 Pages per sector )		
		SETLOCK
		1 + DUP
	4 = UNTIL
	DROP
;

: DELAY 
	0 10000 RSHIFT DROP
;
VARIABLE USER

: MIRRORPAGE ( PAGENUM OFFSET -- MT
USER !		( Save offset 
[	CPUMHZ 10 LSHIFT ( = MHZ  LSFT DEC'16 
	100 + LITERAL ( ADD 1 WAIT STATE
]
	[ MCBASE MC_FMR + LITERAL ]
	!
	
	DUP						( COPY PAGE NUMBER
	8 LSHIFT 				( PAGE NUM TO BYTE ADDRESS
	
	BEGIN
		DUP	 200000 + @			( FETCH FROM RAM WORD ADDRESS 
		OVER 100000 + USER @ + !			( STORE TO FLASH {BUFFER} WORD ADDRESS  
		4 + 
		DUP FF AND
	0= UNTIL
	DROP 
		8 LSHIFT USER @ + ( SHIFT PAGE NUMBER AND BUILD COMMAND)
	[ FLASHKEY WP + LITERAL ]
	+
	[ MCBASE MC_FCR + LITERAL ] 
	!
	WAITFREADY
;

: MIRROR64K
	0
	BEGIN
		DUP	
		0 MIRRORPAGE
		1 + 
		DUP 
	FF > UNTIL
	DROP
;

: MIRROR64KOFFSET
	0
	BEGIN
		DUP	
		10000 MIRRORPAGE
		1 + 
		DUP 
	FF > UNTIL
	DROP
;

: RS READFSTAT U. ;

SP! HEX
: EXTRAS ; // Place marker.
: ." ( Compile print string.
	22 WORD
	C@ IF
		[ ' [."] LFA>CA LITERAL ] BRLNK (  Make a call to  [."] 
		PAD C@ 1 +
		0
		BEGIN				( CNTDWN INDEX --
			DUP PAD + C@ 	( Get byte from PAD )
			C,				( CNTDWN INDEX --
			1 + SWAP
			1 - SWAP
		OVER 0=	UNTIL
		DROP DROP
		2 ALIGNDP
	THEN
;
IMMEDIATE

: ALLOT // N -- mt ; Allot N bytes in the dictionary.
	HERE + 2 ALIGN DP !
;

: ASM ; // Just a place marker 



// the arm can't load load immediate values so we need a way to generate
// lookup table (usually PC referenced. I will us another data stack for 
// storing the value and ldr addresses for later patching - the AUX stack.
( In future stacks may be objects or >BUILDS DOES> constructs

100 CONSTANT AUXSIZE // the size of the aux stack in words.
VARIABLE AUX // reserve space for the stack.
AUXSIZE 2 LSHIFT ALLOT // Reserve space - it will be size+1 
VARIABLE AUXSP // The stack pointer

: @OR @ OR ;
: OR! 		// NUM ADDR --
	SWAP OVER // ADDR NUM ADDR
	@OR SWAP !
	
;

: AUX!							// Reset the pointer
	AUX AUXSP !
;
AUX!

: >AUX							// Push a value from Top to aux stack.
	AUXSP @ !
	AUXSP @ [ AUX AUXSIZE 2 LSHIFT + LITERAL ]	
	< IF 
		BPW AUXSP +! 
	ELSE 
		." Aux stack overflow" CR
	THEN
;

: AUX>							// Push a value from aux stack to Top.
	AUXSP @ AUX 
	> IF 
		BPW AUXSP -! 
	ELSE 
		." Aux stack underflow" CR
	THEN
	AUXSP @ @	
;

: AUXDEPTH // -- N ; Aux stack depth in words.
	AUXSP @ AUX - 2 RSHIFT
;
( a register list stack. Could be a byte stack.
10 CONSTANT REGSSIZE // the size of the aux stack in words.
VARIABLE REGS // reserve space for the stack.
REGSSIZE 2 LSHIFT ALLOT // Reserve space - it will be size+1 
VARIABLE REGSSP // The stack pointer

: REGS!							// Reset the pointer
	REGS REGSSP !
;
REGS!

: >REGS							// Push a value from Top to aux stack.
	REGSSP @ !
	REGSSP @ [ REGS REGSSIZE 2 LSHIFT + LITERAL ]	
	< IF 
		BPW REGSSP +! 
	ELSE 
		." Reg stack overflow" CR
	THEN
;

: REGS>							// Push a value from aux stack to Top.
	REGSSP @ REGS 
	> IF 
		BPW REGSSP -! 
	ELSE 
		." Reg stack underflow" CR
	THEN
	REGSSP @ @	
;

: REGSDEPTH // -- N ; Aux stack depth in words.
	REGSSP @ REGS - 2 RSHIFT
;

VARIABLE REGMASK	( A place to build regist list field for LDM etc.
VARIABLE CODEBITS
VARIABLE IMMVAL
VARIABLE IMMSHT
VARIABLE CFLAGS
1 CONSTANT SFLAG
2 CONSTANT IMMDFLAG
4 CONSTANT SBZFLAG
: R0	( FOR ASM )
	0 >REGS
;

: R1	( FOR ASM )
	1 >REGS
;
: R2	( FOR ASM )
	2 >REGS
;
: R3	( FOR ASM )
	3 >REGS
;
: R4	( FOR ASM )
	4 >REGS
;
: R5	( FOR ASM )
	5 >REGS
;
: R6	( FOR ASM )
	6 >REGS
;
: R7	( FOR ASM )
	7 >REGS
;
: R8	( FOR ASM )
	8 >REGS
;
: R9	( FOR ASM )
	9 >REGS
;
: R10	( FOR ASM )
	0A >REGS
;
: R11	( FOR ASM )
	0B >REGS
;
: R12	( FOR ASM )
	0C >REGS
;
: R13	( FOR ASM )
	0D >REGS
;
: R14	( FOR ASM )
	0E >REGS
;
: R15	( FOR ASM )
	0F >REGS
;

: SP R13 ;
: LR R14 ;
: PC R15 ;

: REGS>MASK
	0 REGMASK !
	BEGIN
		REGSDEPTH
	WHILE
		REGMASK @
		1
		REGS>
		LSHIFT
		+ REGMASK ! ( Should be "OR" but we don't have it)
	REPEAT
;


: [P] // Set the P bit in PUxWL type codes.
	1000000 CODEBITS OR!
;

: [U] // Set the 	U bit in PUxWL type codes.
	800000 CODEBITS OR!
;
// Note that there are 2 type of "S" flag sometime is means "status" sometimes "sign"
// the former changes position eg bit 22 is LDM and bit 20 in data processing inst.
: [S] // Set the S bit in PUxWL type codes.
	SFLAG CFLAGS OR!
;

: [!] // Set the W bit in PUxWL type codes.
	200000 CODEBITS OR!
;

VARIABLE CCODES // condition codes
: CCODES! CCODES ! ;
: EQ 
	0 CCODES!
;

: NE 
	10000000 CCODES!
;

: CS 
	20000000 CCODES!
;

: HS 
	20000000 CCODES!
;

: LO 
	30000000 CCODES!
;

: CC 
	30000000 CCODES!
;

: MI 
	40000000 CCODES!
;

: PL 
	50000000 CCODES!
;

: VS 
	60000000 CCODES!
;

: VC 
	70000000 CCODES!
;

: HI 
	80000000 CCODES!
;

: LS 
	90000000 CCODES!
;

: GE 
	A0000000 CCODES!
;

: LT 
	B0000000 CCODES!
;

: GT 
	C0000000 CCODES!
;

: LE 
	D0000000 CCODES!
;

: AL 
	E0000000 CCODES!
;

: NV 
	F0000000 CCODES!
;

: { // clear register list for { reglist } type syntax
	REGS! AL
	0 CODEBITS 	!
	0 IMMVAL	!
	0 IMMSHT 	!
	0 CFLAGS 	!
;

: } // Make mask for { reglist } type syntax
	REGS>MASK
;

: PUxWL // Make code for instructions multiple load/store 
	REGSDEPTH 0= IF SP THEN // If no reg on stack assume SP
	REGS> 10 LSHIFT + // fill in reg field.
	CODEBITS @ +
	CFLAGS @ SFLAG AND IF 400000 CODEBITS OR! THEN
	CCODES @ +
	REGMASK @ + 
	,
	{	// Clear for next instruction.
;

: LDM,	// Load multiple
	8100000 PUxWL
;

: STM,	// Store multiple
	8000000 PUxWL
;

: PUSH 
	[P] [!] STM,
;

: POP 
	[U] [!] LDM,
;


: LFA>FFA // Convert the link address to flag address
	4 + 
;

1	CONSTANT F_IMMD		( immediate flag )
2	CONSTANT F_OFFS		( offset compilation flag ie dA non-zero )
4	CONSTANT F_REMT		( remote flag ie headerless code or alias )
8	CONSTANT F_SMUD		( smudge flag )
10	CONSTANT F_VOCB  	( vocab flag )
20 	CONSTANT F_THUMB 

100 CONSTANT COMPFLAG

F_SMUD CONSTANT F_XCOMP

: NATIVE 0 MODE ! ;

: XCOMPMODE F_XCOMP MODE ! ;

' CREATE LFA>CA // Remember CA of existing CREATE

: CREATE // A new version of create which has more flag options.
	2 ALIGNDP HERE LFA>FFA // remember FFA - at compile time not meta complile time.
	[ BRLNK ] // Make a call to the old version of CREATE 
	MODE C@ SWAP C! // Overwrite the flags
	2 ALIGNDP
;

: CODE CREATE { AUX! ;

: END-CODE 
	BEGIN
		AUXDEPTH
	WHILE
		AUX> 	
		AUX>					// NUM *INST 		-- Get address of inst to patch.
		DUP	HERE SWAP 8 + -	FFF AND	// NUM *INST OFFS 	-- Make rel offset
		OVER @OR				// NUM *INST MERG 	-- Merge with instruction
		SWAP !					// NUM
		,
	REPEAT
;



: BR24 // Make code for instructions such as BR,BL
	CODEBITS @ +
	CCODES @ +
	SWAP HERE 8 + - 2 RSHIFT
	FFFFFF AND +
	,
	{	// Clear for next instruction.
;

: BR 
	A000000 BR24
;

: BRLNK 
	B000000 BR24
;

: NEGATE 
	0 SWAP -
;

: ALIGN 			// Align address on stack - use ALIGN, to align DP
	1 				( Build mask etc. -- N 1
	BEGIN
		SWAP 2*
		SWAP 1 -
		DUP 
	0=	UNTIL
	DROP 		// ADDR MASK -- 
	SWAP OVER 1 - +	// MASK {ADDR+MASK-1} -- 
	SWAP NEGATE AND 
;

: GOTO 
	' LFA>CA 2 ALIGN BR
;

: CALL 
	' LFA>CA 2 ALIGN BRLNK
;

: BRDR 				// get base and dest regs from stack to mask
	0 REGMASK !
	REGSDEPTH IF	
		REGS>		// Get dst
	ELSE 
		0 ." No regs???" CR // error 
	THEN
	REGSDEPTH IF	
		REGS>		// get base
	ELSE
		DUP			// no base - make same as dest
	THEN			// dest base -- 
	CODEBITS @ // Is it a load or a store 
	[ 1 14 LSHIFT LITERAL ] AND
	IF SWAP THEN
	0C LSHIFT REGMASK OR!
	10 LSHIFT REGMASK OR!
	REGSDEPTH IF	// If there is a register left it must be for offset
		REGS>		// get offset reg
		REGMASK OR!
		2000000 CODEBITS OR!
		IMMSHT @ CODEBITS OR!
	ELSE 			// Might need offset12 or offset8
		IMMVAL @ IF 
			IMMVAL @ DUP
			0 < IF
				NEGATE
			ELSE
				[U]
			THEN
			CODEBITS @ 2000000 AND IF // if zero it's a 8 bit offset 
				FF AND DUP
				F AND SWAP
				F0 AND 4 LSHIFT +
			ELSE
				FFF AND
			THEN
			CODEBITS OR!
		THEN
	THEN
;	

: # 
	IMMVAL !
	IMMDFLAG CFLAGS OR!
;

: MAKESFT
	CFLAGS @ IMMDFLAG AND 
	IF
		IMMVAL @ 1F AND 7 LSHIFT + IMMSHT !
		CFLAGS @ IMMDFLAG - CFLAGS !
		0 IMMVAL !		
	ELSE
		10 + IMMSHT !
		REGS>
		8 LSHIFT
		CODEBITS OR!


	THEN
	
;

: LSL 
	0 MAKESFT 
;

: LSR 
	[ 1 5 LSHIFT LITERAL ] 
	MAKESFT
;

: ASR 
	[ 2 5 LSHIFT  LITERAL ]
	MAKESFT
;

: ROR 
	[ 3 5 LSHIFT  LITERAL ] 
	MAKESFT
;

: RRX // NB. the previous 4 words assume a value on the data stack, rxx doesn't
	[ 3 5 LSHIFT LITERAL ]  IMMSHT !
;

: LDSTWB 			// Make code for instructions such as load/store 
	CODEBITS OR!
	BRDR
	CODEBITS @ 
	CCODES @OR
	REGMASK @OR
	IMMSHT @OR
	,
	{				// Clear for next instruction.
;

// UBYTE AND WORD
: STR,
	4000000 LDSTWB
;

: LDR,
	4100000 LDSTWB
;

: STRB,
	4400000 LDSTWB
;

: LDRB,
	4500000 LDSTWB
;

// SBYTE AND HWORD

: STRSB,
	D0 LDSTWB
;

: LDRSB,
	1000D0 LDSTWB
;
: STRSH,
	F0 LDSTWB
;

: LDRSH,
	1000F0 LDSTWB
;
: STRH,
	B0 LDSTWB
;

: LDRH,
	1000B0 LDSTWB
;

: SHIFTOP // Work out shift field and status bit 
	CFLAGS @ SFLAG AND IF
	[ 1 14 LSHIFT LITERAL ] OR
	THEN
	CFLAGS @ IMMDFLAG AND 
	IF								// The immediate flag is set - try to make a immd shift.
		IMMVAL @ 0					// VAL SFT -- ; get the immediate value 
		0 USER !					// flag as not done
		BEGIN	
			USER @ 0=
		WHILE						// VAL SFT
			DUP C <
			IF 
				SWAP DUP FFFFFF00 AND 0= 		// 
				IF 
					1 USER !		// -- SFT VAL ; Still swapped
				ELSE
					DUP 1 AND 0= IF
						2 RSHIFT
						SWAP 1 +
					ELSE
						2 USER !
					THEN
				THEN
			ELSE					// 
				3 USER !
			THEN
		REPEAT						// val sht -- or -- sht val ; 
		USER @ 1 = IF
			SWAP
			10 SWAP - F AND
			8 LSHIFT +
			2000000 OR			
			CODEBITS OR!
			1						// TRUE --
		ELSE
			DROP DROP 0				// FALSE -- 
		THEN
	ELSE		// Not immediate mode.
	1
	THEN	
;

:	MOVINST	
	CODEBITS @OR
	IMMSHT @OR
	REGS> C LSHIFT OR
	REGSDEPTH IF
		REGS> 
	ELSE
		2000000
	THEN
	OR
	,	
	{				// Clear for next instruction.
;

: ERROR ." range error " CR ;

: MOV,	
[ D 15 LSHIFT LITERAL ]
	CCODES @ +

	SHIFTOP
	IF MOVINST
	ELSE
		DROP
		HERE >AUX
		IMMVAL @ >AUX
		0 IMMVAL !
		REGS> PC >REGS [U] [P] LDR,
	THEN
;

: MVN,	
[ F 15 LSHIFT LITERAL ]
	CCODES @ +

    SHIFTOP 
	IF MOVINST
	ELSE DROP ERROR
	THEN
;

: CHKSBZ CFLAGS @ SBZFLAG AND ;

 : COMP	
	CFLAGS @ SFLAG AND IF 100000 OR THEN
	CCODES @ +
    SHIFTOP 
	IF 
		CODEBITS @OR

		REGS> 
		REGSDEPTH IF 
			REGS>
		ELSE
			CHKSBZ
			IF 0 SWAP		// The RD field for this instruction should be zeroed.
			ELSE DUP
			THEN
		THEN
 		
		CHKSBZ		// If sbz bit clear shift to RD position
			IF	
				CFLAGS @ IMMDFLAG AND NOT IF SWAP THEN	
				10 LSHIFT
			
			ELSE
				10 LSHIFT
				SWAP	
				C LSHIFT
			THEN 
		OR OR
		REGSDEPTH IF
			REGS> OR
		THEN
	,	
	ELSE
		DROP ERROR
	THEN
	{				// Clear for next instruction.
;

: [SBZ] // Set the "SHOULD BE ZERO" flag.
	SBZFLAG CFLAGS OR!
;

: AND, [ 0 15 LSHIFT LITERAL ]  COMP ;
: EOR, [ 1 15 LSHIFT LITERAL ]  COMP ;
: SUB, [ 2 15 LSHIFT LITERAL ]  COMP ;
: RSB, [ 3 15 LSHIFT LITERAL ]  COMP ;
: ADD, [ 4 15 LSHIFT LITERAL ]  COMP ;
: ADC, [ 5 15 LSHIFT LITERAL ]  COMP ;
: SBC, [ 6 15 LSHIFT LITERAL ]  COMP ;
: RSC, [ 7 15 LSHIFT LITERAL ]  COMP ;
: TST, [ 8 15 LSHIFT LITERAL ] [S] [SBZ] COMP ;
: TEQ, [ 9 15 LSHIFT LITERAL ] [S] [SBZ] COMP ;
: CMP, [ A 15 LSHIFT LITERAL ] [S] [SBZ] COMP ;
: CMN, [ B 15 LSHIFT LITERAL ] [S] [SBZ] COMP ;
: ORR, [ C 15 LSHIFT LITERAL ]  COMP ;
: BIC, [ E 15 LSHIFT LITERAL ]  COMP ;

: CLZ,
	016F0F10
	CCODES @ +
	REGS> C LSHIFT OR
	REGS> OR
	,
	{
;

: MUL,
	90
	CCODES @ +
	REGS> 				// Get RD
	REGSDEPTH 2 < IF  	// if less than 2 regs on stack dup 
		DUP
	ELSE 
		REGS>
	THEN
	8 LSHIFT
	SWAP 10 LSHIFT OR OR	// Add RS
	REGS> OR			// Add RM
	,
	{
;

: .I HERE 4 - ? ;

: BEGIN,
	HERE
;

: FLIPCC
	CCODES @ 10000000 XOR CCODES!
;

: UNTIL, 
	FLIPCC BR
;

: AGAIN, NV UNTIL, ;

: IF,
	HERE // Remember here
	DUP FLIPCC BR // Make dummy branch to be patched later.
;

: THEN, 						// addr -- ; top has address to be patched
	DUP 						// ADDR ADDR -- DUP PATCH ADDRESS
	 8 + HERE SWAP - 2 RSHIFT	// ADDR OFFSET -- 
	FFFFFF AND 					// ADDR OFFSET24 -- 
	OVER @ FF000000 AND + 
	SWAP !
;

: ELSE,			// Else is like a "then" with an uncoditional branch left for patching.

	HERE 
	DUP BR // The default is "AL" 
	SWAP THEN, 	
;

: WHILE,
	IF,			// While is like IF,
;

: REPEAT,		// Baddr WADDR -- ; address of begin and while on top.
	SWAP BR		// Make a branch back to BEGIN
	THEN,		// Use "then" to patch forward
;

: SPSR	( FOR ASM )
	10 >REGS
;

: CPSR	( FOR ASM )
	11 >REGS
;

: MRS, 
	010F0000
	CCODES @OR
	REGS> 
	C LSHIFT OR
	REGS>
	10 = IF 400000 OR THEN	// SPSR OR CPSR
	,
	{				// Clear for next instruction.
;

: _C 10000 CODEBITS OR! ;
: _X 20000 CODEBITS OR! ;
: _S 40000 CODEBITS OR! ;
: _F 80000 CODEBITS OR! ;

: MSR, 
	0120F000
	CCODES @OR
	REGS>
	10 = IF 400000 OR THEN	// SPSR OR CPSR
	    SHIFTOP 
	IF 
		REGSDEPTH IF REGS> OR THEN
		CODEBITS @OR
		,
	ELSE ERROR
	THEN
	{
;
: RDSP R7 ;
: RTOP R6 ;
: RSEC R5 ;

ALIAS AGAIN AGAIN,
IMMEDIATE
: FORGET ( FORGET WORDS FROM NAME ON,  )
	' DUP DP ! @ CONTEXT !
;


// Type MIRROR64K to save image to flash, may need UNLOCKALL first.

