forth.asm

; ---------------------------------------------------------------------------
; forth.asm -- a small Forth interpreter for Linux/amd64, pure NASM assembly.
;
; Based on a classic indirect-threaded model.
;
; registers:
;   rsi = Forth instruction pointer (points into a thread: a list of "xt"s)
;   rbp = data (parameter) stack pointer, grows down
;   rsp = the native CPU stack, reused as the Forth return stack
;
; A dictionary entry ("word") looks like:
;   dq  link           -> previous dictionary entry (0 = end of list)
;   db  immediate      -> 0 or 1
;   db  namelen
;   db  name[namelen]
;   dq  codeword        -> address to jump to when this word runs
;   ... parameter field (only for colon definitions / variables)
;
; An "xt" (execution token) is the address of a word's codeword field.
; NEXT fetches the next xt from the current thread, then jumps to the
; address stored there:
;
;   NEXT:  lodsq        ; rax = xt = [rsi], rsi += 8
;          jmp [rax]     ; jump to *xt (rax itself is left = xt)
;
; For primitives (defcode) the codeword points directly at the hand-written
; machine code that implements the word, which ends by running NEXT again.
; For colon definitions the codeword is DOCOL, which pushes the caller's
; rsi (return address) on the return stack and starts executing the new
; word's own thread -- EXIT pops rsi back off to resume the caller.
;
; Build:
;   nasm -f elf64 forth.asm -o forth.o
;   ld -o forth forth.o
;
; Run:
;   echo ": square dup * ; 5 square ." | ./forth
; ---------------------------------------------------------------------------

BITS 64

%define RETURN_STACK_CELLS 8192
%define LOOP_STACK_FRAMES 4096


%macro push_ds 1
    sub rbp, 8
    cmp rbp, data_stack
    jae %%ok
    jmp data_stack_overflow_error
%%ok:
    mov [rbp], %1
%endmacro

%macro pop_ds 1
    cmp rbp, data_stack_top
    jb %%ok
    jmp data_stack_underflow_error
%%ok:
    mov %1, [rbp]
    add rbp, 8
%endmacro

; Guards words that peek at the stack (DUP, OVER, 2DUP, ...) without going
; through pop_ds -- verifies at least %1 items are present before reading.
%macro check_ds_depth 1
    lea rax, [rbp+(%1-1)*8]
    cmp rax, data_stack_top
    jb %%ok
    jmp data_stack_underflow_error
%%ok:
%endmacro

; Guards compile-only words (IF, DO, LOOP, ...): they work by *compiling*
; helper code into the dictionary rather than doing anything themselves, so
; using them outside a colon definition would silently corrupt HERE and
; leave garbage for words like I to read. Bail out to a clean error instead.
%macro check_compiling 0
    mov rax, [var_STATE]
    test rax, rax
    jz compile_only_error
%endmacro

%macro NEXT 0
    lodsq
    jmp [rax]
%endmacro

; Dictionary-building macro. Chains every word together at assemble time
; via the text macro LINK, which always holds the label of the previously
; defined word (or the literal 0 for the very first one).
%define LINK 0

%macro defcode 3
    section .data
    align 8
name_%1:
    dq LINK
%define LINK name_%1
    db %3
    %strlen %%L %2
    db %%L
    db %2
name_%1_CFA:
    dq code_%1
    section .text
code_%1:
%endmacro

; Entry point

section .text
global _start

_start:
    cld
    mov rbp, data_stack_top
    ; Use our own return stack instead of the one the OS gave this process,
    ; pre-filled everywhere with QUIT_thread. rsp normally holds real return
    ; addresses pushed by DOCOL/(DO), but a stray EXIT (popping deeper than
    ; anything legitimately pushed) will pop one of these sentinels instead
    ; of garbage, harmlessly resuming the interpreter rather than crashing.
    ; rsp starts in the middle of the buffer so there is headroom both for
    ; genuine call/loop nesting (below) and for repeated stray pops (above).
    mov rdi, return_stack
    mov rax, QUIT_thread
    mov rcx, RETURN_STACK_CELLS
    rep stosq
    mov rsp, return_stack + (RETURN_STACK_CELLS/2)*8
    mov rsi, QUIT_thread
    NEXT

; DOCOL: codeword for every colon definition. rax = xt of the word being
; entered (NEXT leaves it there); the parameter field starts right after
; the codeword, i.e. at rax+8.
DOCOL:
    cmp rsp, return_stack + 128
    ja .ok
    jmp return_stack_overflow_error
.ok:
    push rsi
    lea rsi, [rax+8]
    NEXT

; DOVAR: codeword for VARIABLE words -- just pushes the address of the
; single storage cell that follows the codeword.
DOVAR:
    lea rbx, [rax+8]
    push_ds rbx
    NEXT

; DOCON: codeword for CONSTANT words -- pushes the value stored in the
; single cell that follows the codeword (not its address, unlike DOVAR).
DOCON:
    mov rbx, [rax+8]
    push_ds rbx
    NEXT


; Core VM primitives: EXIT, LIT, BRANCH, 0BRANCH
defcode EXIT, "EXIT", 0
    pop rsi
    NEXT

defcode LIT, "LIT", 0
    lodsq
    push_ds rax
    NEXT

defcode BRANCH, "BRANCH", 0
    mov rsi, [rsi]
    NEXT

defcode ZBRANCH, "0BRANCH", 0
    pop_ds rax
    test rax, rax
    jnz .no_branch
    mov rsi, [rsi]
    NEXT
.no_branch:
    add rsi, 8
    NEXT

; Data stack primitives
defcode DUP, "DUP", 0
    check_ds_depth 1
    mov rax, [rbp]
    push_ds rax
    NEXT

defcode DROP, "DROP", 0
    pop_ds rax
    NEXT

defcode SWAP, "SWAP", 0
    pop_ds rax
    pop_ds rbx
    push_ds rax
    push_ds rbx
    NEXT

defcode OVER, "OVER", 0
    check_ds_depth 2
    mov rax, [rbp+8]
    push_ds rax
    NEXT

defcode ROT, "ROT", 0
    pop_ds rax          ; c
    pop_ds rbx          ; b
    pop_ds rcx          ; a
    push_ds rbx         ; b
    push_ds rax         ; c
    push_ds rcx         ; a
    NEXT

defcode DOTS, ".S", 0
    mov r12, rbp
.loop:
    cmp r12, data_stack_top
    jae .done
    mov rax, [r12]
    call print_num
    call print_space
    add r12, 8
    jmp .loop
.done:
    NEXT

defcode QDUP, "?DUP", 0
    check_ds_depth 1
    mov rax, [rbp]
    test rax, rax
    jz .done
    push_ds rax
.done:
    NEXT

defcode DEPTH, "DEPTH", 0
    mov rax, data_stack_top
    sub rax, rbp
    shr rax, 3
    push_ds rax
    NEXT

; ( xu ... x1 x0 u -- xu ... x1 x0 xu ) -- u=0 picks the current top (same
; as DUP), u=1 the item below it, and so on.
defcode PICK, "PICK", 0
    pop_ds rax               ; u
    lea rbx, [rbp+rax*8]
    cmp rbx, data_stack_top
    jb .ok
    jmp data_stack_underflow_error
.ok:
    mov rax, [rbx]
    push_ds rax
    NEXT


; Arithmetic
defcode ADD, "+", 0
    pop_ds rax
    pop_ds rbx
    add rax, rbx
    push_ds rax
    NEXT

defcode SUB, "-", 0
    pop_ds rax          ; b
    pop_ds rbx          ; a
    sub rbx, rax
    push_ds rbx
    NEXT

defcode MUL, "*", 0
    pop_ds rax
    pop_ds rbx
    imul rax, rbx
    push_ds rax
    NEXT

defcode DIV, "/", 0
    pop_ds rax          ; divisor
    pop_ds rbx          ; dividend
    mov r8, rax
    mov rax, rbx
    cqo
    idiv r8
    push_ds rax
    NEXT

defcode MOD, "MOD", 0
    pop_ds rax          ; divisor
    pop_ds rbx          ; dividend
    mov r8, rax
    mov rax, rbx
    cqo
    idiv r8
    push_ds rdx
    NEXT



; Comparisons (true = -1, false = 0) and bitwise logic

defcode EQ, "=", 0
    pop_ds rax
    pop_ds rbx
    cmp rbx, rax
    mov rax, 0
    jne .no
    mov rax, -1
.no:
    push_ds rax
    NEXT

defcode LT, "<", 0
    pop_ds rax
    pop_ds rbx
    cmp rbx, rax
    mov rax, 0
    jge .no
    mov rax, -1
.no:
    push_ds rax
    NEXT

defcode GT, ">", 0
    pop_ds rax
    pop_ds rbx
    cmp rbx, rax
    mov rax, 0
    jle .no
    mov rax, -1
.no:
    push_ds rax
    NEXT

defcode ZEQ, "0=", 0
    pop_ds rax
    cmp rax, 0
    mov rax, 0
    jne .no
    mov rax, -1
.no:
    push_ds rax
    NEXT

defcode ZLT, "0<", 0
    pop_ds rax
    cmp rax, 0
    mov rax, 0
    jge .no
    mov rax, -1
.no:
    push_ds rax
    NEXT

defcode LAND, "AND", 0
    pop_ds rax
    pop_ds rbx
    and rax, rbx
    push_ds rax
    NEXT

defcode LOR, "OR", 0
    pop_ds rax
    pop_ds rbx
    or rax, rbx
    push_ds rax
    NEXT

defcode LINVERT, "INVERT", 0
    pop_ds rax
    not rax
    push_ds rax
    NEXT


; Memory

defcode STORE, "!", 0
    pop_ds rax          ; addr
    pop_ds rbx          ; value
    mov [rax], rbx
    NEXT

defcode FETCH, "@", 0
    pop_ds rax          ; addr
    mov rbx, [rax]
    push_ds rbx
    NEXT


; I/O

defcode DOT, ".", 0
    pop_ds rax
    call print_num
    call print_space
    NEXT

defcode EMIT, "EMIT", 0
    pop_ds rax
    mov [charbuf], al
    push rsi
    mov rax, 1
    mov rdi, 1
    lea rsi, [charbuf]
    mov rdx, 1
    syscall
    pop rsi
    NEXT

defcode CR, "CR", 0
    mov byte [charbuf], 10
    push rsi
    mov rax, 1
    mov rdi, 1
    lea rsi, [charbuf]
    mov rdx, 1
    syscall
    pop rsi
    NEXT

defcode KEY, "KEY", 0
    call read_char
    push_ds rax
    NEXT

defcode BYE, "BYE", 0
    mov rax, 60
    xor rdi, rdi
    syscall



; Compiling words: : ; IMMEDIATE VARIABLE

defcode COLON, ":", 0
    call word_
    test rax, rax
    jz .done                ; EOF right after ':' -- nothing to do
    mov r8, [var_HERE]
    mov r9, [var_LATEST]
    mov [var_SAVED_LATEST], r9   ; so an error mid-definition can unlink this word
    mov [r8], r9
    mov byte [r8+8], 0
    mov [r8+9], cl
    lea r10, [r8+10]
    xor r11, r11
.copy:
    cmp r11, rcx
    jge .nameend
    mov al, [rdi+r11]
    mov [r10+r11], al
    inc r11
    jmp .copy
.nameend:
    lea r10, [r10+rcx]       ; codeword field address
    mov qword [r10], DOCOL
    lea r11, [r10+8]         ; start of parameter field
    mov [var_LATEST], r8
    mov [var_HERE], r11
    mov qword [var_STATE], 1
.done:
    NEXT

defcode SEMICOLON, ";", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_EXIT_CFA
    add r11, 8
    mov [var_HERE], r11
    mov qword [var_STATE], 0
    NEXT

; IMMEDIATE must itself be immediate: the standard idiom is to write it
; *inside* a definition, right after the name (": foo IMMEDIATE ... ;"),
; so it needs to run the moment it's encountered while compiling -- to
; flag the word currently being built -- rather than get compiled into
; that word's body and mis-flag whatever LATEST happens to be much later,
; at run time.
defcode IMMEDIATE, "IMMEDIATE", 1
    mov r8, [var_LATEST]
    mov byte [r8+8], 1
    NEXT

defcode VARIABLE, "VARIABLE", 0
    call word_
    test rax, rax
    jz .done
    mov r8, [var_HERE]
    mov r9, [var_LATEST]
    mov [r8], r9
    mov byte [r8+8], 0
    mov [r8+9], cl
    lea r10, [r8+10]
    xor r11, r11
.copy:
    cmp r11, rcx
    jge .nameend
    mov al, [rdi+r11]
    mov [r10+r11], al
    inc r11
    jmp .copy
.nameend:
    lea r10, [r10+rcx]
    mov qword [r10], DOVAR
    lea r14, [r10+8]         ; the variable's one storage cell
    mov qword [r14], 0
    mov [var_LATEST], r8
    lea r15, [r14+8]
    mov [var_HERE], r15
.done:
    NEXT


defcode WORDS, "WORDS", 0
    ; r8 = current dictionary entry
    mov r8, [var_LATEST]

.loop:
    test r8, r8
    jz .done

    ; Dictionary layout:
    ;   [r8+0]  = link
    ;   [r8+8]  = immediate flag
    ;   [r8+9]  = name length
    ;   [r8+10] = name

    movzx r9d, byte [r8+9]
    lea r10, [r8+10]

    ; write(1, name, length)
    push rsi
    mov rax, 1
    mov rdi, 1
    mov rsi, r10
    mov rdx, r9
    syscall
    pop rsi

    ; Space after the word name.
    call print_space

    ; Follow the dictionary link.
    mov r8, [r8]
    jmp .loop

.done:
    ; Finish with a newline.
    push rsi
    mov byte [charbuf], 10
    mov rax, 1
    mov rdi, 1
    lea rsi, [charbuf]
    mov rdx, 1
    syscall
    pop rsi

    NEXT


; Control structures. These are IMMEDIATE: the interpreter always runs them
; right away (even while compiling), so they execute natively during
; compilation and use the data stack to remember addresses that need
; back-patching -- the standard technique for threaded Forths.

defcode IF, "IF", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_ZBRANCH_CFA
    add r11, 8
    push_ds r11              ; remember placeholder cell address
    add r11, 8
    mov [var_HERE], r11
    NEXT

defcode ELSE, "ELSE", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_BRANCH_CFA
    lea r12, [r11+8]          ; ELSE's own placeholder cell
    lea r13, [r11+16]         ; start of the else-part
    mov [var_HERE], r13
    pop_ds rax                ; IF's placeholder cell address
    mov [rax], r13
    push_ds r12
    NEXT

defcode THEN, "THEN", 1
    check_compiling
    pop_ds rax
    mov r10, [var_HERE]
    mov [rax], r10
    NEXT

defcode BEGIN, "BEGIN", 1
    check_compiling
    mov r10, [var_HERE]
    push_ds r10
    NEXT

defcode UNTIL, "UNTIL", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_ZBRANCH_CFA
    add r11, 8
    pop_ds rax
    mov [r11], rax
    add r11, 8
    mov [var_HERE], r11
    NEXT

defcode DO, "DO", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_PAREN_DO_CFA
    add r11, 8
    mov [var_HERE], r11
    push_ds r11              ; loop-start address
    NEXT

defcode LOOP, "LOOP", 1
    check_compiling
    mov r11, [var_HERE]
    mov qword [r11], name_PAREN_LOOP_CFA
    add r11, 8
    mov qword [r11], name_ZBRANCH_CFA
    add r11, 8
    pop_ds rax                ; loop-start address (from DO)
    mov [r11], rax
    add r11, 8
    mov [var_HERE], r11
    NEXT

; (DO) and (LOOP) push the loop limit/index onto their own dedicated loop-
; control stack (loop_stack/var_LOOP_SP) rather than the call/return stack.
; Keeping it separate from rsp -- which DOCOL/EXIT touch on every call --
; means a helper word invoked from inside the loop body doesn't disturb it:
; I and J read whichever loop is dynamically innermost/next-outer at the
; moment they run, regardless of how many word calls deep they're called
; from. Each frame is 2 cells: [rcx] = index, [rcx+8] = limit.
defcode PAREN_DO, "(DO)", 0
    pop_ds rax                ; index
    pop_ds rbx                ; limit
    mov rcx, [var_LOOP_SP]
    sub rcx, 16
    cmp rcx, loop_stack
    jae .ok
    jmp loop_stack_overflow_error
.ok:
    mov [rcx], rax
    mov [rcx+8], rbx
    mov [var_LOOP_SP], rcx
    NEXT

defcode PAREN_LOOP, "(LOOP)", 0
    mov rcx, [var_LOOP_SP]
    mov rax, [rcx]             ; index
    mov rbx, [rcx+8]           ; limit
    inc rax
    cmp rax, rbx
    jge .finished
    mov [rcx], rax
    xor rax, rax
    push_ds rax               ; not finished -> 0BRANCH branches back
    NEXT
.finished:
    add qword [var_LOOP_SP], 16
    mov rax, 1
    push_ds rax                ; finished -> 0BRANCH falls through
    NEXT

defcode I, "I", 0
    mov rax, [var_LOOP_SP]
    cmp rax, loop_stack_top
    jb .ok
    jmp loop_stack_underflow_error
.ok:
    mov rax, [rax]
    push_ds rax
    NEXT

; J reads the next loop out from I -- the enclosing loop's index when used
; inside a nested DO...LOOP (directly, or through any number of calls).
defcode J, "J", 0
    mov rax, [var_LOOP_SP]
    add rax, 16
    cmp rax, loop_stack_top
    jb .ok
    jmp loop_stack_underflow_error
.ok:
    mov rax, [rax]
    push_ds rax
    NEXT

; Explicit return-stack access, for stashing values across calls that would
; otherwise be in the data stack's way. Shares the same physical stack as
; DOCOL/EXIT (DO/LOOP's index/limit pairs live on their own loop_stack, see
; below), so it's on the caller to keep >R/R> balanced within a definition
; -- an unbalanced >R left on the stack across EXIT will confuse whatever
; the caller does with its own return address next.
defcode TOR, ">R", 0
    cmp rsp, return_stack + 128
    ja .ok
    jmp return_stack_overflow_error
.ok:
    pop_ds rax
    push rax
    NEXT

defcode FROMR, "R>", 0
    pop rax
    push_ds rax
    NEXT

defcode RFETCH, "R@", 0
    mov rax, [rsp]
    push_ds rax
    NEXT


; String literals. ." and S" are IMMEDIATE: the text between them and the
; closing '"' is read directly off the input stream (not tokenized by
; word_, since it may contain spaces), right when the word is encountered
; -- whether interpreting or compiling. While interpreting, the text is
; just used right away; while compiling, it is embedded straight into the
; definition's thread (a length cell followed by the raw bytes) after a
; runtime word that knows how to skip back over its own inline data.

defcode DOTQUOTE, '."', 1
    call read_string_lit        ; rcx = length, bytes copied into strbuf
    mov r10, [var_STATE]
    test r10, r10
    jnz .compile
    push rsi
    mov rdx, rcx
    mov rax, 1
    mov rdi, 1
    lea rsi, [strbuf]
    syscall
    pop rsi
    NEXT
.compile:
    mov r11, [var_HERE]
    mov qword [r11], name_PAREN_DOTQUOTE_CFA
    add r11, 8
    mov [r11], rcx
    add r11, 8
    xor r9, r9
.copyloop:
    cmp r9, rcx
    jge .copydone
    mov al, [strbuf+r9]
    mov [r11+r9], al
    inc r9
    jmp .copyloop
.copydone:
    add r11, rcx
    mov [var_HERE], r11
    NEXT

; Runtime companion to ." when compiled: rsi points at the length cell
; that was embedded right after this word's own xt, followed immediately
; by the raw string bytes.
defcode PAREN_DOTQUOTE, '(."', 0
    mov rbx, [rsi]              ; length (rbx survives the syscall below)
    lea rax, [rsi+8]            ; string bytes
    push rsi
    mov rdx, rbx
    mov rsi, rax
    mov rax, 1
    mov rdi, 1
    syscall
    pop rsi
    lea rax, [rbx+8]
    add rsi, rax
    NEXT

defcode SQUOTE, 'S"', 1
    call read_string_lit
    mov r10, [var_STATE]
    test r10, r10
    jnz .compile
    lea rax, [strbuf]
    push_ds rax
    push_ds rcx
    NEXT
.compile:
    mov r11, [var_HERE]
    mov qword [r11], name_PAREN_SQUOTE_CFA
    add r11, 8
    mov [r11], rcx
    add r11, 8
    xor r9, r9
.copyloop:
    cmp r9, rcx
    jge .copydone
    mov al, [strbuf+r9]
    mov [r11+r9], al
    inc r9
    jmp .copyloop
.copydone:
    add r11, rcx
    mov [var_HERE], r11
    NEXT

; Runtime companion to S" when compiled: pushes (addr len) of the inline
; string data, same layout as (.").
defcode PAREN_SQUOTE, '(S"', 0
    mov rbx, [rsi]
    lea rax, [rsi+8]
    push_ds rax
    push_ds rbx
    lea rax, [rbx+8]
    add rsi, rax
    NEXT

defcode TYPE, "TYPE", 0
    pop_ds rcx                  ; len
    pop_ds rax                  ; addr
    push rsi
    mov rdx, rcx
    mov rsi, rax
    mov rax, 1
    mov rdi, 1
    syscall
    pop rsi
    NEXT


; A few more common primitives.

defcode NEGATE, "NEGATE", 0
    pop_ds rax
    neg rax
    push_ds rax
    NEXT

defcode INCR, "1+", 0
    pop_ds rax
    inc rax
    push_ds rax
    NEXT

defcode DECR, "1-", 0
    pop_ds rax
    dec rax
    push_ds rax
    NEXT

defcode ABS, "ABS", 0
    pop_ds rax
    test rax, rax
    jns .positive
    neg rax
.positive:
    push_ds rax
    NEXT

defcode MIN, "MIN", 0
    pop_ds rax                  ; b
    pop_ds rbx                  ; a
    cmp rax, rbx
    jl .done                    ; b < a -> keep b
    mov rax, rbx
.done:
    push_ds rax
    NEXT

defcode MAX, "MAX", 0
    pop_ds rax                  ; b
    pop_ds rbx                  ; a
    cmp rax, rbx
    jg .done                    ; b > a -> keep b
    mov rax, rbx
.done:
    push_ds rax
    NEXT

defcode TWODUP, "2DUP", 0
    check_ds_depth 2
    mov rax, [rbp]               ; b
    mov rbx, [rbp+8]              ; a
    push_ds rbx
    push_ds rax
    NEXT

defcode TWODROP, "2DROP", 0
    pop_ds rax
    pop_ds rax
    NEXT

; CONSTANT: "value CONSTANT name" reads the name off the input stream (like
; VARIABLE) and defines a word that pushes the value back whenever it runs.
defcode CONSTANT, "CONSTANT", 0
    call word_               ; NB: word_ uses rbx as scratch, so read the
    test rax, rax             ; name before popping the value into rbx
    jz .done
    pop_ds rbx
    mov r8, [var_HERE]
    mov r9, [var_LATEST]
    mov [r8], r9
    mov byte [r8+8], 0
    mov [r8+9], cl
    lea r10, [r8+10]
    xor r11, r11
.copy:
    cmp r11, rcx
    jge .nameend
    mov al, [rdi+r11]
    mov [r10+r11], al
    inc r11
    jmp .copy
.nameend:
    lea r10, [r10+rcx]
    mov qword [r10], DOCON
    lea r14, [r10+8]
    mov [r14], rbx
    mov [var_LATEST], r8
    lea r15, [r14+8]
    mov [var_HERE], r15
.done:
    NEXT


; INTERPRET: the outer interpreter loop's body. Reads one word, looks it
; up, and either compiles or executes it (numbers get pushed or compiled
; as a LIT). Runs forever as part of QUIT_thread.

defcode INTERPRET, "INTERPRET", 0
    call word_
    test rax, rax
    jz .eof
    call find_
    test rax, rax
    jz .maybe_number
    mov r8, rax
    movzx r9d, byte [r8+8]     ; immediate flag
    movzx ecx, byte [r8+9]
    lea rax, [r8+10+rcx]        ; rax = xt (codeword field address)
    mov r10, [var_STATE]
    test r10, r10
    jz .execute
    test r9, r9
    jnz .execute
    mov r11, [var_HERE]
    mov [r11], rax
    add r11, 8
    mov [var_HERE], r11
    NEXT
.execute:
    jmp [rax]                   ; tail into the word; NEXT happens inside it
.maybe_number:
    call number_
    test rdx, rdx
    jnz .error
    mov r10, [var_STATE]
    test r10, r10
    jnz .compile_lit
    push_ds rax
    NEXT
.compile_lit:
    mov r11, [var_HERE]
    mov qword [r11], name_LIT_CFA
    add r11, 8
    mov [r11], rax
    add r11, 8
    mov [var_HERE], r11
    NEXT
.error:
    push rsi
    mov r13, rdi
    mov r14, rcx
    mov rax, 1
    mov rdi, 2
    mov rsi, r13
    mov rdx, r14
    syscall
    mov rax, 1
    mov rdi, 2
    lea rsi, [errmsg]
    mov rdx, errmsg_len
    syscall
    pop rsi
    ; An unknown word or bad number mid-definition means the definition is
    ; broken beyond repair (whatever was compiled so far isn't terminated
    ; by EXIT). Unlink it -- as if ':' had never been typed -- rather than
    ; leaving a half-built, uncallable word sitting in the dictionary and
    ; silently staying in compile mode for everything typed afterward.
    mov r10, [var_STATE]
    test r10, r10
    jz .error_done
    mov r11, [var_SAVED_LATEST]
    mov [var_LATEST], r11
    mov qword [var_STATE], 0
.error_done:
    NEXT
.eof:
    mov rax, 60
    xor rdi, rdi
    syscall

; Reached via check_compiling: rdi/rcx still hold the offending word's text
; and length (untouched since word_/find_ returned them), so this reports
; it the same way INTERPRET's unknown-word error does.
compile_only_error:
    push rsi
    mov r13, rdi
    mov r14, rcx
    mov rax, 1
    mov rdi, 2
    mov rsi, r13
    mov rdx, r14
    syscall
    mov rax, 1
    mov rdi, 2
    lea rsi, [compile_only_msg]
    mov rdx, compile_only_msg_len
    syscall
    pop rsi
    NEXT

; Reached when a push would run the data stack into its own base (runaway
; computation, e.g. deep non-tail recursion piling up intermediate values)
; or when DOCOL would push the return stack past its low-water mark
; (runaway/too-deep recursion). Neither is recoverable in place -- both
; stacks may hold a long, meaningless chain of partial results -- so this
; reports the error and resets to a fresh top-level prompt, like ABORT.
data_stack_overflow_error:
    mov rax, 1
    mov rdi, 2
    lea rsi, [dstackerr_msg]
    mov rdx, dstackerr_msg_len
    syscall
    jmp abort_reset

data_stack_underflow_error:
    mov rax, 1
    mov rdi, 2
    lea rsi, [dstackuerr_msg]
    mov rdx, dstackuerr_msg_len
    syscall
    jmp abort_reset

return_stack_overflow_error:
    mov rax, 1
    mov rdi, 2
    lea rsi, [rstackerr_msg]
    mov rdx, rstackerr_msg_len
    syscall
    jmp abort_reset

loop_stack_overflow_error:
    mov rax, 1
    mov rdi, 2
    lea rsi, [lstackoerr_msg]
    mov rdx, lstackoerr_msg_len
    syscall
    jmp abort_reset

loop_stack_underflow_error:
    mov rax, 1
    mov rdi, 2
    lea rsi, [lstackuerr_msg]
    mov rdx, lstackuerr_msg_len
    syscall
    jmp abort_reset

abort_reset:
    mov r10, [var_STATE]
    test r10, r10
    jz .no_unlink
    mov r11, [var_SAVED_LATEST]
    mov [var_LATEST], r11
.no_unlink:
    mov rbp, data_stack_top
    mov rsp, return_stack + (RETURN_STACK_CELLS/2)*8
    mov qword [var_LOOP_SP], loop_stack_top
    mov qword [var_STATE], 0
    mov rsi, QUIT_thread
    NEXT


;  helpers

; read_char: returns AL = next input byte in rax, or rax = -1 on EOF.
; Serves bytes out of the rodata `prelude_src` string first (see below),
; then transparently falls through to stdin once it's exhausted -- callers
; can't tell the difference, so the prelude is just "typed" ahead of stdin.
read_char:
    mov rax, [prelude_pos]
    cmp rax, prelude_len
    jae .from_stdin
    mov r8, prelude_src
    add r8, rax
    movzx eax, byte [r8]
    inc qword [prelude_pos]
    ret
.from_stdin:
    mov rax, [inbuf_pos]
    cmp rax, [inbuf_len]
    jb .have
    push rsi
    mov rax, 0
    mov rdi, 0
    mov rsi, inbuf
    mov rdx, 4096
    syscall
    pop rsi
    cmp rax, 0
    jle .eof
    mov [inbuf_len], rax
    mov qword [inbuf_pos], 0
.have:
    mov rax, [inbuf_pos]
    mov r8, inbuf
    add r8, rax
    movzx eax, byte [r8]
    inc qword [inbuf_pos]
    ret
.eof:
    mov rax, -1
    ret

; word_: skips whitespace, reads the next word into wordbuf.
; Returns: rax = 0 on EOF (no word), else rax = 1, rdi = wordbuf, rcx = length.
word_:
.skip:
    call read_char
    cmp rax, -1
    je .eof
    cmp al, ' '
    je .skip
    cmp al, 9
    je .skip
    cmp al, 10
    je .skip
    cmp al, 13
    je .skip
    cmp al, 0x5c              ; '\' -- line comment, runs to end of line
    jne .notcomment
.eatline:
    call read_char
    cmp rax, -1
    je .eof
    cmp al, 10
    je .skip
    jmp .eatline
.notcomment:
    xor rbx, rbx
.collect:
    mov [wordbuf+rbx], al
    inc rbx
    cmp rbx, 31
    jae .done
    call read_char
    cmp rax, -1
    je .done
    cmp al, ' '
    je .done
    cmp al, 9
    je .done
    cmp al, 10
    je .done
    cmp al, 13
    je .done
    jmp .collect
.done:
    mov rdi, wordbuf
    mov rcx, rbx
    mov rax, 1
    ret
.eof:
    xor rax, rax
    ret

; read_string_lit: reads raw characters (no tokenizing) into strbuf until
; a '"' or EOF is hit. Used by ." and S" to read their text directly off
; the input stream. Returns: rcx = length of the string collected.
read_string_lit:
    xor rbx, rbx
.loop:
    call read_char
    cmp rax, -1
    je .done
    cmp al, '"'
    je .done
    cmp rbx, 255
    jae .done
    mov [strbuf+rbx], al
    inc rbx
    jmp .loop
.done:
    mov rcx, rbx
    ret

; find_: rdi = addr, rcx = len -> rax = dictionary header address, or 0.
; Name comparison is case-insensitive.
find_:
    mov r8, [var_LATEST]
.loop:
    test r8, r8
    jz .notfound
    movzx r9d, byte [r8+9]
    cmp r9, rcx
    jne .next
    lea r10, [r8+10]
    xor r11, r11
.cmp:
    cmp r11, rcx
    je .match
    mov al, [rdi+r11]
    mov dl, [r10+r11]
    cmp al, 'A'
    jb .noconv1
    cmp al, 'Z'
    ja .noconv1
    or al, 0x20
.noconv1:
    cmp dl, 'A'
    jb .noconv2
    cmp dl, 'Z'
    ja .noconv2
    or dl, 0x20
.noconv2:
    cmp al, dl
    jne .next
    inc r11
    jmp .cmp
.match:
    mov rax, r8
    ret
.next:
    mov r8, [r8]
    jmp .loop
.notfound:
    xor rax, rax
    ret

; number_: rdi = addr, rcx = len -> rax = value, rdx = 0 if fully valid
; (nonzero = number of trailing characters that failed to parse).
; Also recognizes the 'x' character-literal form (a quote, any one byte,
; a quote) and returns that byte's value, e.g. '(' -> 40.
number_:
    cmp rcx, 3
    jne .not_char_lit
    cmp byte [rdi], 0x27      ; '\''
    jne .not_char_lit
    cmp byte [rdi+2], 0x27
    jne .not_char_lit
    movzx rax, byte [rdi+1]
    xor rdx, rdx
    ret
.not_char_lit:
    test rcx, rcx
    jz .error_empty
    xor r8, r8               ; sign flag
    xor r9, r9               ; index
    mov al, [rdi]
    cmp al, '-'
    jne .digits
    mov r8, 1
    mov r9, 1
    cmp rcx, 1
    je .error_signonly
.digits:
    xor rax, rax
.loop:
    cmp r9, rcx
    jae .done
    movzx r10d, byte [rdi+r9]
    cmp r10, '0'
    jb .bad
    cmp r10, '9'
    ja .bad
    sub r10, '0'
    imul rax, rax, 10
    add rax, r10
    inc r9
    jmp .loop
.bad:
    mov rdx, rcx
    sub rdx, r9
    jmp .apply_sign
.done:
    xor rdx, rdx
.apply_sign:
    test r8, r8
    jz .positive
    neg rax
.positive:
    ret
.error_empty:
    xor rax, rax
    mov rdx, 1
    ret
.error_signonly:
    xor rax, rax
    mov rdx, 1
    ret

; print_num: rax = signed number to print (decimal, no trailing space).
print_num:
    push rsi
    push rbx
    push rcx
    push rdx
    push r12
    push r13
    push r8
    mov rbx, rax
    xor r12, r12
    lea r13, [numbuf+23]
    xor r8, r8
    test rbx, rbx
    jns .conv
    mov r8, 1
    neg rbx
.conv:
    mov rax, rbx
.divloop:
    xor rdx, rdx
    mov rcx, 10
    div rcx
    add dl, '0'
    dec r13
    mov [r13], dl
    inc r12
    test rax, rax
    jnz .divloop
    test r8, r8
    jz .print
    dec r13
    mov byte [r13], '-'
    inc r12
.print:
    mov rax, 1
    mov rdi, 1
    mov rsi, r13
    mov rdx, r12
    syscall
    pop r8
    pop r13
    pop r12
    pop rdx
    pop rcx
    pop rbx
    pop rsi
    ret

; print_space: print a space character
print_space:
    push rsi
    push rdi
    push rax
    push rdx
    push r12
    mov rax, 1
    mov rdi, 1
    lea rsi, [space_char]
    mov rdx, 1
    syscall
    pop r12
    pop rdx
    pop rax
    pop rdi
    pop rsi
    ret





section .data
align 8
var_STATE:  dq 0
var_HERE:   dq user_dict
var_LATEST: dq LINK
var_SAVED_LATEST: dq 0
var_LOOP_SP: dq loop_stack_top

align 8
QUIT_thread:
    dq name_INTERPRET_CFA
    dq name_BRANCH_CFA
    dq QUIT_thread

section .rodata

space_char: db ' '
errmsg:     db " ?", 10
errmsg_len equ $-errmsg

compile_only_msg: db " compile-only, use it inside a colon definition", 10
compile_only_msg_len equ $-compile_only_msg

dstackerr_msg: db "data stack overflow -- aborting to top level", 10
dstackerr_msg_len equ $-dstackerr_msg

dstackuerr_msg: db "data stack underflow -- aborting to top level", 10
dstackuerr_msg_len equ $-dstackuerr_msg

rstackerr_msg: db "return stack overflow (recursion too deep?) -- aborting to top level", 10
rstackerr_msg_len equ $-rstackerr_msg

lstackoerr_msg: db "loop stack overflow (DO nested too deeply) -- aborting to top level", 10
lstackoerr_msg_len equ $-lstackoerr_msg

lstackuerr_msg: db "I/J used outside a DO...LOOP -- aborting to top level", 10
lstackuerr_msg_len equ $-lstackuerr_msg

; Words defined here are compiled before the first byte of stdin is ever
; read (see read_char)
prelude_src:
incbin "forth.inline"
prelude_len equ $-prelude_src

section .bss
align 8
data_stack: resb 8192
data_stack_top:

align 8
return_stack: resb RETURN_STACK_CELLS*8
return_stack_top:

align 8
loop_stack: resb LOOP_STACK_FRAMES*16
loop_stack_top:

align 8
user_dict: resb 65536

align 8
inbuf:     resb 4096
inbuf_len: resq 1
inbuf_pos: resq 1

prelude_pos: resq 1

wordbuf: resb 32
charbuf: resb 1
numbuf:  resb 24
strbuf:  resb 256