/ JonesForth ARM64 / / based on Richard W.M. Jones' original x86 JonesForth / / In stack comments n, a, and x are used to mean: / / n | number / / a | address / / x | execution token / : MOD ÷MOD ↓ ; / nn→n modulo by dropping quotient from ÷MOD / : NEG 0 ↕ - ; / n→n negate / : CR 0A EMIT ; / Print newline / : SPACE 20 EMIT ; / Print space / : find WORD FIND ; / find next word in input / : create WORD CREATE 0 , ; / Create word header with next word as name, codeword pointer 0 / : ,LIT ' LIT , , ; / n→ Compile literal number / : LITERAL I ,LIT ; / n→ Compile literal number (immediate) / : >CFA 8+ 8+ ; / n→n Compute codeword address from dictionary pointer address / : >DFA >CFA 8+ ; / n→n Compute address of first word in definition from dictionary pointer address / : [COMP] I find >CFA , ; / Compile an immediate word / / Character constants / : '"' [ CHAR " ] LITERAL ; / →n '"' pushes 22 (ASCII ") to the stack / : '-' [ CHAR - ] LITERAL ; / →n '-' pushes 2D (ASCII -) to the stack / / Control structures / : { I ' BZ , H 0 , ; / { A } does A if top of stack (TOS) is true / : } I ↑ H ↕ - ↕ ! ; : | I ' BR , H 0 , ↕ ↑ H ↕ - ↕ ! ; / { A | B } does A if TOS true, B if false / : ( I H ; / ( A ∥ B ) does B while A gives true / : ∥ I ' BZ , H 0 , ; : ) I ' BR , ↕ H - , ↑ H ↕ - ↕ ! ; : ∥) I ' BNZ , H - , ; / ( A ∥) does A until false / : 1∥) I ' BR , H - , ; / ( A 1∥) does A indefinitely / : (( I ' n! , [COMP] ( ' n , [COMP] ∥ ; / n (( A )) does A n times / : )) I ' n- , [COMP] ) ; : ∇ I S { [COMP] ; | : } ; / ∇ starts and ends definitions / ∇ . ↑ 0≥ { U. | NEG U. '-' EMIT } ∇ / n→ Print signed number / ∇ ¯ I S { H 8- ↑ @ NEG ↕ ! | NEG } ∇ / n→n Compile time negate / ∇ SPACES ( ↑ ∥ SPACE 1- ) ↓ ∇ / n→ Print n spaces / ∇ .S D ( ↑ D0 < ∥ ↑ @ . CR 8+ ) ↓ ∇ / Print the stack / ∇ ⌈⌊ 2↑ > { ↕ } ∇ / nn→nn Sort top two elements of stack / ∇ ε ( ⌈⌊ ⊤ - ↑ ∥) ↓ ∇ / nn→n Euclid's algorithm for greatest common divisor / ∇ ? @ . ∇ / a→ Print contents of memory address / ∇ WITHIN -⌽ ⊤ ≤ { > | 2↓ 0 } ∇ / nnn→n Check if number lies in range / ∇ DEPTH D D0 ↕ - 8 ÷ ∇ / →n Current stack depth / ∇ CLEAR D0 D! ∇ / Clear stack / / Strings / ∇ H" H ( KEY ↑ '"' ≠ ∥ ⊤ C! 1+ ) ↓ 0 ⊤ ! H - H ↕ ∇ / Store a string Here / ∇ S" I ' LITS , H 0 , ( KEY ↑ '"' ≠ ∥ C, ) ↓ ↑ H ↕ - 8- ↕ ! 0 C, ALIGN ∇ / Compile a string in a word / ∇ ." I S { [COMP] S" ' TELL , | ( KEY ↑ '"' ≠ ∥ EMIT ) ↓ } ∇ / Print a string / / Constants and variables / ∇ CONST WORD CREATE DOCOL , ' LIT , , ' EXIT , ∇ ∇ ALLOT H + H! ∇ / n→ / ∇ CELLS 8 × ∇ / n→n / ∇ VAR H 1 CELLS ALLOT CONST ∇ / Values / ∇ VALUE WORD CREATE DOCOL , ' LIT , , ' EXIT , ∇ ∇ TO I find >DFA 8+ S { ' LIT , , ' ! , | ! } ∇ ∇ +TO I find >DFA 8+ S { ' LIT , , ' +! , | +! } ∇ / Dictionary / ∇ ID. @ 1 1⌽ ~ ∧ H ! H 8 TELL ∇ / a→ Print name at address a (masking immediate bit) / ∇ WORDS L ( ↑ 8+ ID. SPACE @ ↑ ∥) ↓ ∇ / Print all words in dictionary / ∇ FORGET find ↑ @ L! H! ∇ / forget all words after next word in input stream / ∇ 1DUMP ↑ U. SPACE @ 40⌽ U. ∇ / a→ / ∇ DUMP ( ↑ ∥ ↕ ↑ 1DUMP CR 8+ ↕ 1- ) 2↓ ∇ / an→ / ∇ INDATA? [ find EXIT ] LITERAL [ find MOD 40000 + ] LITERAL WITHIN ∇ / a→n Check if address is in data area / ∇ CEXIT [ find EXIT >CFA ] LITERAL ∇ / →a Codeword address of EXIT / ∇ SEE find >DFA ( ↑ @ CEXIT ≠ ∥ ↑ ↑ 1DUMP SPACE @ ↑ INDATA? { 8- ID. | . } CR 8+ ) ↓ ∇ / Decompile a word (try printing names of words, print literals) / / Execution tokens / ∇ ⊂ H DOCOL , ] ∇ / →x Start compiling anonymous word / ∇ ⊃ I [COMP] ; ∇ / Finish compiling anonymous word / ⊂ ⊃ ∇ ⊂⊃ LITERAL ∇ / →x Push execution token for anonymous word which does nothing / ∇ ['] I ' LIT , ∇ / Compile execution token of next word in input / / Combinators - see combinators.f / ∇ unit H ↕ DOCOL , ,LIT ' EXIT , ∇ / x→x / ∇ cat H -⌽ ↕ DOCOL , ,LIT ' ⍎ , ,LIT ' ⍎ , ' EXIT , ∇ / xx→x / ∇ cons H -⌽ ↕ DOCOL , ,LIT ,LIT ' ⍎ , ' EXIT , ∇ / xx→x / ∇ dip ↕ >R ⍎ R> ∇ ∇ sip ⊤ >R ⍎ R> ∇ / Assembler / ∇ ∆ WORD CREATE H 8+ , ∇ / Create header for assembly word; codeword points to cell following it / ∇ .dr B << ∨ 5 << ∨ ∇ / nnn→n build opcode for register data-processing instruction / ∇ .di 5 << ∨ 5 << ∨ ∇ / nnn→n build opcode for immediate data-processing instruction / ∇ .li 1FF ∧ 7 << ∨ 5 << ∨ ∇ / nnn→n build opcode for immediate load or store instruction / / Data processing instructions (register) nnn→n / ∇ add .dr 8B000000 ∨ ∇ ∇ sub .dr CB000000 ∨ ∇ ∇ and .dr 8A000000 ∨ ∇ ∇ orr .dr AA000000 ∨ ∇ / Data processing instructions (immediate) nnn→n / ∇ addi .di 91000000 ∨ ∇ ∇ subi .di D1000000 ∨ ∇ / Load and store instructions (immediate) nnn→n / ∇ ldr .li F8400000 ∨ ∇ ∇ str .li F8000000 ∨ ∇ / Set post- and pre- index flags for load and store instructions / ∇ post 400 ∨ ∇ ∇ pre C00 ∨ ∇ / n→n / ∇ pop 8 ldr post ∇ ∇ push 8 ¯ str pre ∇ / nn→n / ∇ .D 13 ∇ ∇ .R 14 ∇ ∇ .I 15 ∇ ∇ .J 16 ∇ / Register numbers for D,R,I,J pointers / ∇ NEXT .J .I 8 ldr post ,, 0 .J 0 ldr ,, D61F0000 ,, ALIGN ∇ / Code for NEXT (hex opcode is for the branch br x0) / / Example defining 7+ with the assembler / ∆ 7+ 0 .D pop ,, 0 0 7 addi ,, 0 .D push ,, NEXT / Defining words - see R.G. Loeliger's Threaded Interpretive Languages book / ∇ SCODE L >CFA ! ∇ / a→ Store address as codeword of latest word defined (used to set behaviour of word when run) / ∇ ⋄ I H 20 + ,LIT ' SCODE , ∇ / ⋄ compiles code to overwrite the latest word's codeword with the address following the word containing ⋄ / / Example defining words whose actions are defined with the assembler / ∇ CONST' create , ⋄ ∇ 0 .J 8 ldr ,, 0 .D push ,, NEXT ∇ 2CONST create , , ⋄ ∇ 0 .J 8 ldr ,, 1 .J 10 ldr ,, 0 .D push ,, 1 .D push ,, NEXT ∇ VAR' create 0 , ⋄ ∇ 0 .J 8 addi ,, 0 .D push ,, NEXT / ◁ and ▷ let you define the action of the defined words in Forth rather than assembler - see defining_words.f / ∇ ◁ create 0 , ∇ ∇ ▷ R> L >CFA 8+ ! ⋄ ∇ .I .R push ,, 0 .J 10 addi ,, 0 .D push ,, .I .J 8 ldr ,, NEXT / Example defining words with their actions specified in Forth (also see defining_words.f) / ∇ CONST'' ◁ , ▷ @ ∇ ∇ VAR'' ◁ , ▷ ∇ / λ allows us to name an execution token (see combinators.f) / ∇ λ ◁ , ▷ @ ⍎ ∇ / Exceptions / / Data stack restored after exception using a stack of stacks - see exceptions.f / VAR SS / Stack-stack pointer / D0 10 CELLS - CONST SS0 / Initial stack-stack pointer / SS0 SS ! / Initialize SS / ∇ SPUSH 10 CELLS SS -! DEPTH SS0 ! SS @ SS0 10 MOVE ∇ / Push current stack to stack-stack / ∇ SPOP D0 SS0 @ CELLS - D! SS0 SS @ 10 MOVE 10 CELLS SS +! ∇ / Pop stack from stack-stack / ∇ S↓ 10 CELLS SS +! ∇ / Drop top stack-stack stack / ∇ MARKER S↓ ∇ ∇ CATCH ' MARKER 8+ >R SPUSH ⍎ ∇ ∇ THROW ↑ { R ( ↑ R0 8- < ∥ ↑ @ ' MARKER 8+ = { 8+ R! >R SPOP ↓ R> EXIT } 8+ ) ↓ ." Uncaught throw" CR QUIT } ∇ ∇ ABORT 1 ¯ THROW ∇ ∇ TRACE R ( ↑ R0 8- < ∥ ↑ @ ↑ H ! U. CR 8+ ) ↓ ∇ / Print addresses currently on return stack (no attempt to decompile them) / / Delimited continuations - see continuations.f / ∇ RCOMP H DOCOL , >R ( 2↑ ≤ ∥ ↑ @ ,LIT ' >R , 8- ) 2↓ R> ' EXIT , ∇ / aa→x Compile word pushing addresses to return stack / ∇ ⟦ R ↑ ( ↑ R0 8- < ∥ ↑ @ ' MARKER 8+ = { ↑ 8+ R! 10 - CR RCOMP EXIT } 8+ ) ∇ / Start capturing a continuation / ∇ ⟧ ' MARKER 8+ >R ⍎ ∇ / Finish capturing a continuation / / C Strings / ∇ STRLEN ↑ ( ↑ C@ ∥ 1+ ) ↕ - ∇ / a→n Get length of null terminated string / / Environment / ∇ ARGC D0 @ ∇ ∇ ARGV 1+ CELLS D0 + @ ↑ STRLEN ∇ ∇ ENV ARGC 2 + CELLS D0 + ∇ / Syscalls / ∇ _EXIT 5D 2 SYS ∇ ∇ BYE 0 _EXIT ∇ ∇ ⍇ 3F 3 SYS ∇ / read / ∇ ⍈ 40 3 SYS ∇ / write / ∇ ⍐ 64 ¯ 38 3 SYS ∇ / open / ∇ ⍗ 39 1 SYS ∇ / close / ∇ UNAME A0 1 SYS ∇ ∇ OS H UNAME ↓ H 40 TELL ∇ ∇ HOSTNAME H UNAME ↓ H 41 + 40 TELL ∇ ." ⍋ JONESFORTH ARM64 ⍋" CR