( 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.