// JonesForth ARM64 (ARMv8 AArch64)
// Richard W.M. Jones' original x86 JonesForth available at http://git.annexia.org/?p=jonesforth.git
// Pointers
#define D x19 // Data stack pointer
#define R x20 // Return stack pointer
#define I x21 // Instruction pointer
#define J x22 // Codeword pointer
#define S x23 // State
#define H x24 // Here pointer
#define L x25 // Latest pointer
#define D0 x26 // Data stack top pointer
#define R0 x27 // Return stack top pointer
#define PDOC x28 // DOCOL pointer
#define PLIT x29 // LIT pointer
#define W x12 // Word register
#define F x13 // Find register
#define N x14 // Number register
#define B x15 // Buffer pointer
#define K x16 // Key pointer
#define E x17 // End pointer
#define OUTB x11 // Output buffer pointer
#define n x9 // Count register
#define m x10 // Count register
// Stack macros
.macro push s,x; str \x,[\s,-8]!; .endm // e.g. push D,x0 pushes x0 to data stack
.macro push2 s,x,y; stp \y,\x,[\s,-16]!; .endm // One instruction, two pushes!
.macro pop s,x; ldr \x,[\s],8; .endm // e.g. pop R,I pops instruction pointer from return stack
.macro pop2 s,x,y; ldp \x,\y,[\s],16; .endm // One instruction, two pops!
// Definition macros
.macro def x // Define assembly word
.data; .align 3
"l\x": .xword link; .set link, "l\x" // Dictionary pointer (to last word defined)
.ascii "\x"; .align 3 // 8-byte name
"\x": .xword "c\x" // Codeword - points to assembly code defined below
.text
"c\x": ; .endm // Assembly code follows
.macro defw x // Define Forth word
.data; .align 3
"l\x": .xword link; .set link, "l\x" // Dictionary pointer
.ascii "\x"; .align 3 // 8-byte name
"\x": .xword docol; .endm // Codeword - docol points to code which runs the Forth words to follow
.set link, 0 // link points to last defined word; it is updated by def and defw
// Forthisms
.macro NEXT; ldr J,[I],8; ldr x0,[J]; br x0; .endm // Run next word (ends assembly words)
docol: push R,I; add I,J,8; NEXT // Code to run a Forth word (the one found after J)
def EXIT; pop R,I; NEXT // Finish running a Forth word, run next word
def LIT; ldr x0,[I],8; push D,x0; NEXT // Push following literal number to stack and skip it
// Assembly functions
// Stack manipulation
def ↓; add D,D,8; NEXT; def ↑; ldr x0,[D]; push D,x0; NEXT
def 2↓; add D,D,16; NEXT; def 2↑; ldp x0,x1,[D]; push2 D,x1,x0; NEXT
def ⌽; pop2 D,x0,x1; pop D,x2; push2 D,x1,x0; push D,x2; NEXT; def -⌽; pop2 D,x0,x1; pop D,x2; push2 D,x0,x2; push D,x1; NEXT
def ↕; pop2 D,x0,x1; push2 D,x0,x1; NEXT; def ⊤; ldr x0,[D,8]; push D,x0; NEXT;
// Arithmetic
def +; pop2 D,x0,x1; add x0,x1,x0; push D,x0; NEXT; def -; pop2 D,x0,x1; sub x0,x1,x0; push D,x0; NEXT
def ×; pop2 D,x0,x1; mul x0,x1,x0; push D,x0; NEXT; def ÷; pop2 D,x0,x1; sdiv x0,x1,x0; push D,x0; NEXT
def ⌈; pop2 D,x0,x1; cmp x1,x0; csel x0,x1,x0,gt; push D,x0; NEXT; def ⌊; pop2 D,x0,x1; cmp x1,x0; csel x0,x1,x0,lt; push D,x0; NEXT
def 1+; pop D,x0; add x0,x0,1; push D,x0; NEXT; def 1-; pop D,x0; sub x0,x0,1; push D,x0; NEXT
def 8+; pop D,x0; add x0,x0,8; push D,x0; NEXT; def 8-; pop D,x0; sub x0,x0,8; push D,x0; NEXT
def ÷MOD; pop2 D x0,x1; sdiv x2,x1,x0; msub x1,x0,x2,x1; push2 D,x1,x2; NEXT
// Logic
def "="; pop2 D,x0,x1; cmp x1,x0; cset x0,eq; push D,x0; NEXT; def ≠; pop2 D,x0,x1; cmp x1,x0; cset x0,ne; push D,x0; NEXT
def <; pop2 D,x0,x1; cmp x1,x0; cset x0,lt; push D,x0; NEXT; def >; pop2 D,x0,x1; cmp x1,x0; cset x0,gt; push D,x0; NEXT
def ≤; pop2 D,x0,x1; cmp x1,x0; cset x0,le; push D,x0; NEXT; def ≥; pop2 D,x0,x1; cmp x1,x0; cset x0,ge; push D,x0; NEXT
def "0="; pop D,x0; cmp x0,0; cset x0,eq; push D,x0; NEXT; def 0≠; pop D,x0; cmp x0,0; cset x0,ne; push D,x0; NEXT
def 0<; pop D,x0; cmp x0,0; cset x0,lt; push D,x0; NEXT; def 0>; pop D,x0; cmp x0,0; cset x0,gt; push D,x0; NEXT
def 0≤; pop D,x0; cmp x0,0; cset x0,le; push D,x0; NEXT; def 0≥; pop D,x0; cmp x0,0; cset x0,ge; push D,x0; NEXT
def ∧; pop2 D,x0,x1; and x0,x1,x0; push D,x0; NEXT; def ∨; pop2 D,x0,x1; orr x0,x1,x0; push D,x0; NEXT
def ~; pop D,x0; mvn x0,x0; push D,x0; NEXT; def ⊕; pop2 D,x0,x1; eor x0,x1,x0; push D,x0; NEXT
// Bitwise operations
def 40⌽; pop D,x0; rev x0,x0; push D,x0; NEXT; def 20⌽; pop D,x0; rev32 x0,x0; push D,x0; NEXT
def 10⌽; pop D,x0; rev16 x0,x0; push D,x0; NEXT; def 1⌽; pop D,x0; rbit x0,x0; push D,x0; NEXT
def >>; pop2 D,x0,x1; lsr x0,x1,x0; push D,x0; NEXT; def <<; pop2 D,x0,x1; lsl x0,x1,x0; push D,x0; NEXT
def ⌽>; pop2 D,x0,x1; ror x0,x1,x0; push D,x0; NEXT
def CLZ; pop D,x0; clz x0,x0; push D,x0; NEXT
// Memory
def !; pop2 D,x0,x1; str x1,[x0]; NEXT; def @; pop D,x0; ldr x0,[x0]; push D,x0; NEXT
def +!; pop2 D,x0,x1; ldr x2,[x0]; add x1,x2,x1; str x1,[x0]; NEXT; def -!; pop2 D,x0,x1; ldr x2,[x0]; sub x1,x2,x1; str x1,[x0]; NEXT
def C!; pop2 D,x0,x1; strb w1,[x0]; NEXT; def C@; pop D,x0; ldrb w0,[x0]; push D,x0; NEXT
def MOVE; pop2 D,x0,x1; pop D,x2; 1:ldr x3,[x1],8; str x3,[x2],8; sub x0,x0,1; cbnz x0,1b; NEXT
def CMOVE; pop2 D,x0,x1; pop D,x2; 1:ldrb w3,[x1],1; strb w3,[x2],1; sub x0,x0,1; cbnz x0,1b; NEXT
// Return stack
def ">R"; pop D,x0; push R,x0; NEXT; def "R>"; pop R,x0; push D,x0; NEXT
def "R↓"; add R,R,8; NEXT; def "R↑"; ldr x0,[R]; push R,x0; NEXT
// Register values
def "D"; mov x0,D; push D,x0; NEXT; def "D!"; pop D,x0; mov D,x0; NEXT
def "R"; push D,R; NEXT; def "R!"; pop D,R; NEXT
def "H"; push D,H; NEXT; def "H!"; pop D,H; NEXT
def "L"; push D,L; NEXT; def "L!"; pop D,L; NEXT
def "S"; push D,S; NEXT; def "S!"; pop D,S; NEXT
def "D0"; push D,D0; NEXT
def "R0"; push D,R0; NEXT
def DOCOL; push D,PDOC; NEXT
def "n"; push D,n; NEXT; def "n!"; pop D,n; NEXT
def "n+"; add n,n,1; NEXT; def "n-"; sub n,n,1; NEXT
def "n0"; mov n,0; NEXT
def "m"; push D,m; NEXT; def "m!"; pop D,m; NEXT
def "m+"; add m,m,1; NEXT; def "m-"; sub m,m,1; NEXT
def "m0"; mov m,0; NEXT
def KEY; bl key; push D,x0; NEXT;
key: cmp K,E; b.ge fill; ldrb w0,[K],1; ret // Fill buffer if exhausted and read next character
fill: mov x0,0; mov x1,B; mov x2,4096; mov x8,63; svc 0 // stdin, buffer start, buffer size, read syscall
add E,B,x0; mov K,B // Update E, reset K
cbnz x0,key; mov x8,93; svc 0 // Exit 0 if no characters read
.bss
b: .space 4096 // Input buffer
outb: .space 16 // Output buffer
def EMIT; mov x0,1; mov x1,D; mov x2,1; mov x8,64; svc 0; add D,D,8; NEXT // Write top of stack to stdout
// The word macro loads next the next input word into W register
// It leaves N register ready to convert the word into a number (byte order ready to treat 42 as 00000042)
.macro word
mov N,0 // Zero number register
1: bl key; cmp w0,' '; ble 1b; // Skip leading whitespace
2: add N,x0,N,lsl 8; bl key; cmp w0,' '; bgt 2b // Add bytes until next whitespace
3: clz x0,N; and x0,x0,~7; lsl W,N,x0; rev W,W; .endm // Match byte arrangement of names loaded from memory in W
def WORD; word; NEXT
// Vector registers holding constants (for ASCII ←→ number conversion)
#define VC0A v8
#define VC0F v9
#define VC20 v10
#define VC30 v11
#define VC37 v12
#define VC41 v13
.macro number // characters → number
mov v2.2d[0],N; cmeq v0.8b,v2.8b,0; bsl v0.8b,VC30.8b,v2.8b // Fill null bytes with '0'
sub v1.8b,v0.8b,VC30.8b; sub v2.8b,v0.8b,VC37.8b // Calculate values from characters
cmge v3.8b,v0.8b,VC41.8b; bsl v3.8b,v2.8b,v1.8b // Conditionally select values from 0-9 or A-F
ushr v4.2d,v3.2d,4; add v3.8b,v3.8b,v4.8b; uzp1 v3.8b,v3.8b,v3.8b // Pack half bytes into bytes (01 0A → 1A)
mov w14,v3.s[1]; .endm // Store number in lower half of N
.macro unnumber // number → characters
orr x0,N,1; clz x0,x0; and x0,x0,~7; movn x1,0; lsl x0,x1,x0; mov v2.2d[0],x0; zip1 v2.16b,v2.16b,v2.16b
rev N,N; mov v0.2d[0],N
ushr v1.8b,v0.8b,4; zip1 v0.16b,v1.16b,v0.16b; and v0.16b,v0.16b,VC0F.16b
cmge v1.16b,v0.16b,VC0A.16b; bsl v1.16b,VC37.16b,VC30.16b; add v1.16b,v0.16b,v1.16b
bsl v2.16b,v1.16b,VC20.16b; st1 {v2.16b},[OUTB]; .endm
def NUMBER; number; push D,N; NEXT
def U.; pop D,N; unnumber // Print number on top of stack
mov x0,1; mov x1,OUTB; mov x2,16; mov x8,64; svc 0
NEXT
.set FIMMED, 0x80 // Immediate flag (stored in top bit of last byte of a name)
.macro find // Search dictionary for word in W
mov F,L // Start searching at latest word defined
1: cbz F,2f // Stop if end of dictionary reached
ldr x0,[F,8]; bic x0,x0,FIMMED<<56 // Load name and zero immediate bit
cmp x0,W; beq 2f // Stop if word matches
ldr F,[F]; b 1b // Otherwise loop
2: ; .endm
def FIND; find; push D,F; NEXT
def MINTERP // Minimal interpreter - no compiling (not used below)
word; find; cbz F,mnum // Search for word; if not found convert it to a number
add J,F,16; ldr x0,[J]; br x0 // If word found, get its codeword and execute
mnum: number; push D,N; NEXT
defw QUIT; .xword "R0","R!",INTERP,BR,-16 // Top loop - Reset return stack, interpret, repeat
def ALIGN; add H,H,7; and H,H,~7; NEXT // Round H up to next word boundary
def CREATE; stp L,W,[H],16; sub L,H,16; NEXT // Store link pointer and name Here, updating Here and Latest
def ","; pop D,x0; str x0,[H],8; NEXT // Store word at H
def ",,"; pop D,x0; str w0,[H],4; NEXT // Store half word at H
def "C,"; pop D,x0; strb w0,[H],1; NEXT // Store byte at H
def "[\x0\x0\x0\x0\x0\x0\x80"; mov S,0; NEXT // [ starts compiling (defined with immediate flag)
def "]"; mov S,1; NEXT // ] Stops compiling
// : creates a Forth word header (like defw) and starts compiling
defw ":"; .xword ALIGN,WORD,CREATE,LIT,docol,",","]",EXIT
// ; appends EXIT and stops compiling (immediate)
defw ";\x0\x0\x0\x0\x0\x0\x80"; .xword LIT,EXIT,",","[\x0\x0\x0\x0\x0\x0\x80",EXIT
// I sets immediate flag of latest word defined (I is itself immediate)
def "I\x0\x0\x0\x0\x0\x0\x80"; ldr x0,[L,8]; eor x0,x0,FIMMED<<56; str x0,[L,8]; NEXT
def "'"; ldr x0,[I],8; push D,x0; NEXT // ' pushes next word to data stack and skips it
def BR; ldr x0,[I]; add I,x0,I; NEXT // Unconditional branch
def BZ; pop D,x0; cbz x0,cBR; add I,I,8; NEXT // Branch if zero
def BNZ; pop D,x0; cbnz x0,cBR; add I,I,8; NEXT // Branch if non-zero
def LITS; ldr x0,[I],8; push2 D,I,x0; add I,I,x0; add I,I,8; and I,I,~7; NEXT // Push string literal address+length to stack
def TELL; mov x0,1; pop2 D,x2,x1; mov x8,64; svc 0; NEXT // Print string
def INTERP
word; find; cbz F,num // Search for word; if not found, it is a number
add J,F,16; cbz S,ex // Get codeword pointer; if not compiling, execute word
ldr x0,[J,-8]; tbnz x0,63,ex // Check if word is immediate; if so execute it
str J,[H],8; NEXT // Else just compile word
num: number; cbnz S,lit; push D,N; NEXT // Convert to number; if compiling, compile literal, else push to stack
lit: stp PLIT,N,[H],16; NEXT // Compile two words LIT N
ex: ldr x0,[J]; br x0 // Get codeword and execute it
def CHAR; word; and x0,W,0xFF; push D,x0; NEXT // Push first character of next input word
def ⍎; pop D,J; ldr x0,[J]; br x0 // Execute (use top of stack as a codeword pointer)
def "/\x0\x0\x0\x0\x0\x0\x80"; skip: bl key; cmp x0,'/'; bne skip; NEXT // Use / for comments, e.g. / comment /
def SYS // n SYS performs syscall with n arguments
pop2 D,x9,x8; ldp x0,x1,[D]; ldp x2,x3,[D,16]; ldp x4,x5,[D,32]
svc 0; add D,D,x9,lsl 3; push D,x0; NEXT
.text
.globl _start
_start: mov D,sp // Initialize Data stack pointer
adr R,Rtop; // Initialize Return stack pointer
adr I,first // Initialize Instruction pointer
mov S,0 // Initialize State
adr H,Dstart; adr L,lSYS // Initialize Here and Latest pointers
adr B,b; mov K,B; mov E,B // Initialize Buffer, Key, End pointers
adr OUTB,outb // Initialize output buffer pointer
mov D0,D; mov R0,R // Initialize stack top pointers
mov n,0; // Initialize count register
adr PLIT,LIT; adr PDOC,docol // Initialize LIT and DOCOL pointers
movi VC0A.16b,10; movi VC0F.16b,0x0F // Initialize constant vector registers
movi VC20.16b,32; movi VC30.16b,'0'
movi VC37.16b,55; movi VC41.16b,65
NEXT // Start interpreter
.data
first: .xword QUIT
.bss
.align 3; Dstart: .space 262144; Rtop: // Space for data area (pointed to by H) and return stack