forth

forth.asm (28675B)

---

 ; An in-progress Forth compiler and tutorial for UEFI x86_64 systems.
 ;
 ; Written By Christian Ermann
 ;
 
 format pe64 dll efi
 entry main
 
 section '.text' code executable readable
 
 include 'efi.asm'
 
 ;------------------------------------------------------------------------------
 ;
 ; Foreword
 ;
 ; I am writing this as an alternative to the "jonesforth" implementation of
 ; the Forth language for learning how to write a Forth. I'm attempting to
 ; design my Forth in such a way that a user can interact with the system as
 ; soon as possible, and further progress is broken into incremental steps. My
 ; hope is that this also makes it easier to port to different architectures by
 ; providing natural checkpoints to verify functionality as more features are
 ; added.
 ;
 ;------------------------------------------------------------------------------
 ;
 ; Table of Contents
 ; 1. The Basic Structure of Forth
 ; 2. Executing this Program
 ; 3. Hello, World!
 ; 4. Reading Words
 ; 5. Printing Numbers
 ;
 ;------------------------------------------------------------------------------
 ;
 ; Section 1: Basic Structure
 ;
 ; In this section, we'll learn how to represent words in the Forth language in
 ; memory, and how to execute those words to do meaningful work.
 ;
 ; The Dictionary
 ;
 ; All words in Forth are stored in a dictionary, just like in English or in
 ; French. Each entry in a Forth dictionary stores a reference to the previous
 ; word (known as the link pointer), some flags to denote special properties of
 ; certain words, the length of the word's name, the name of the word, and
 ; finally the definition of the word. For memory alignment, there may be some
 ; padding placed inbetween
 ; the name of the word and its definition. The memory layout of an entry for
 ; soupforth can be seen below:
 ;
 ;     Dictionary Entry
 ;     +-------------------------------+ <
 ;     | link pointer | 8 bytes        | | Header
 ;     +-------------------------------+ |
 ;     | flags        | 1 byte         | |
 ;     +-------------------------------+ |
 ;     | length       | 1 byte         | |
 ;     +-------------------------------+ |
 ;     | name         | upto 255 bytes | |
 ;     +-------------------------------+ |
 ;     | padding      | upto 7 bytes   | |
 ;     +-------------------------------+ <
 ;     | definition   |                |
 ;     +-------------------------------+
 ;
 ; All the words we define can be split into two main categories: primitive
 ; words and Forth words. The terminology can be a bit confusing, as all the
 ; words we define are part of our Forth, but what these terms actually compare
 ; is the implementation of the words. Primitive words are implemented directly
 ; in assembly, while Forth words are implemented in Forth itself.
 ;
 ; This distinction is mostly hidden from users of the language, however, the
 ; choices you make affect the speed and portability of the implementation. As
 ; the number of primitive words increases, so does the speed of the Forth
 ; implementation. However, the fewer primitive words there are, the easier the
 ; Forth is to port to new architectures.
 ;
 ; As implementers, we do need to be aware of the differences. For example, the
 ; "definition" field, left blank in the diagram above, differs slightly between
 ; primitive words and Forth words. Definitions always start with a codeword and
 ; end with some sort of "return" statement, but the details of these codewords
 ; and "return" tatements differ between the two types of words.
 ;
 ; For primitive words, the codeword is the address of the assembly code that
 ; implements the word. The return statement is called `NEXT` and takes care of
 ; loading and jumping to the address of the **next** word.
 ;
 ; As we execute words, we'll use the RAX register to store the address of the
 ; word that we're currently executing and we'll use the RSI register to store
 ; the address of the next word we need to execute.
 ;
 ; This leads us to a fairly straightforward definition of a macro for NEXT:
 
 macro NEXT
 {
     lodsq           ; 1. Load value at address RSI into RAX
     jmp qword [rax] ; 2. Jump to address in RAX
 }
 
 ; For Forth words, the codeword is called DOCOL, short for "DO COLON", as Forth
 ; definitions are started with a ":". DOCOL takes care of storing the address
 ; of the next word we need to execute, and starting execution of the current
 ; word. The return statement is called EXIT and loads the address of the next
 ; word that DOCOL stored earlier and calls NEXT.
 ;
 ; In order to store and load addresses of words, Forth uses what's known as the
 ; return stack. It's called the return stack as it stores the addresses we
 ; **return** to at the end of a definition. We'll use the RBP register as our
 ; return stack pointer.
 
 macro push_rs reg
 ; Push the value of `reg` onto the return stack.
 ;
 {
     lea rbp, [rbp - 8] ; 1. Move the return stack pointer down 1 address.
     mov [rbp], reg     ; 2. Push the word address onto the stack.
 }
 
 macro pop_rs reg
 ; Pop the top value of the return stack into `reg`.
 ;
 {
     mov reg, [rbp]     ; 1. Pop a word address off of the stack.
     lea rbp, [rbp + 8] ; 2. Move the return stack pointer up 1 address.
 }
 
 DOCOL:
 ; Start execution of a Forth word.
 ;
     push_rs rsi        ; 1. Save the next word's address onto the return stack.
     lea rsi, [rax + 8] ; 2. Load the address of the first data word into RSI.
     NEXT               ; 3. Execute the word pointed to by RSI.
 
 ; As EXIT is included in the definition of every Forth word, it has to have an
 ; entry in the dictionary. EXIT will be the first primitive word we define.
 ;
 ; Let's revisit what the memory layout of our entry will look like before we
 ; start defining anything:
 ;
 ;   Memory layout of EXIT
 ;
 ;   section '.rodata'
 ;   +-------------------------------+ <- name_EXIT
 ;   | link pointer | 8 bytes        |
 ;   +-------------------------------+
 ;   | flags        | 1 byte         |
 ;   +-------------------------------+
 ;   | length       | 1 byte         |
 ;   +-------------------------------+
 ;   | name         | upto 255 bytes |
 ;   +-------------------------------+
 ;   | padding      | upto 7 bytes   |
 ;   +-------------------------------+ <- EXIT
 ;   | code_EXIT    | 8 bytes        |
 ;   +-------------------------------+
 ;
 ;   section '.text'
 ;   +-------------+ <- code_EXIT
 ;   | pop_rs rsi  |
 ;   | NEXT        |
 ;   +-------------+
 ;
 ; Some notes about the labels:
 ; 1. name_EXIT is the label for the start of the dictionary entry.
 ; 2. EXIT is the label for the location of the codeword.
 ; 3. code_EXIT is the label of the assembly code implementing EXIT.
 ;
 ; We'll need to re-create this memory structure for every primitive word we
 ; define so it's worthwhile to write a `defcode` macro that does it for you:
 
 macro defcode name, name_length, flags, label_
 ; Define a primitive word.
 ;
 {
 section '.rodata' data readable
     align 8
 name_#label_:
     dq link               ; 1. Set the link pointer.
     link equ name_#label_ ; 2. Update `link`.
     db flags              ; 3. Set the flags.
     db name_length        ; 4. Set the name length.
     db name               ; 5. Set the name.
 
     align 8               ; 6. Add any padding we may need.
 label_:
     dq code_#label_       ; 7. Set the codeword.
 section '.text' code readable executable
     align 1
 code_#label_:             ; 8. This is where our assembly code will go.
 }
 
 macro defword name, name_length, flags, label_
 ; Define a forth word.
 ;
 {
 section '.rodata' data readable
     align 8
 name_#label_:
     dq link
     link equ name_#label_
     db flags
     db name_length
     db name
 
     align 8
 label_:
     dq DOCOL
 }
 
 ; You'll have noticed that the macro expects the `link` variable to hold the
 ; address of the previous word. As EXIT is our first word, we'll need to
 ; initialize `link` to 0. The `defcode` macro will take care of updating `link`
 ; for us as we define new words.
 ;
 ; After we set `link`, we can finally define our first primitive word:
 
 link dq 0
 
 defcode "EXIT", 4, 0, EXIT
 ; Return from a Forth word.
 ;
     pop_rs rsi ; 1. Load the next word's address back into RSI.
     NEXT       ; 2. Execute word pointed to by RSI.
 
 ; It will be awhile before we get a chance to actually use EXIT, but it gives
 ; us a taste of where we're heading.
 ;
 ;------------------------------------------------------------------------------
 ;
 ; Section 2 - Executing this Program
 ;
 ; In this section, we'll build some infrastructure to enable us to run small
 ; demos at the end of each section without having to re-write any code.
 ;
 ; The Entry Point
 ;
 ; At the beginning of this file, we defined the entry point to be `main`. That
 ; means we need to define what `main` is before we can run anything. I decided
 ; that `main` should do 4 things:
 ;
 ; 1. Initialize the UEFI interface.
 ; 2. Clear the screen, so we have a blank canvas.
 ; 3. Store the version string for this Forth onto the stack.
 ; 4. Start the execution of Forth code.
 ;
 ; These first two steps are handled by function calls provided by the UEFI
 ; interface.
 ;
 ; The version string, and its length, arae defined in the `data` section at the
 ; bottom of this file.
 ;
 ; If you remember from the previous section, we can use the macro NEXT to start
 ; the execution of a primitive word. The only thing NEXT expects is for the RSI
 ; register to contain the address of a primitive word.
 ;
 ; If we pass an address corresponding to a sequence of words,
 ;
 ; We'll use the variable `program` to store the address of the w
 ;
 
 postpone {
 section '.text' code executable readable
 main:
     cld
     call sys_initialize
     call sys_clear_screen
     initialize_stack
     mov rbp, return_stack_top
     mov rsi, program
     NEXT
 }
 
 macro set_program init_stack_macro, program_label {
     macro initialize_stack \{ init_stack_macro \}
     program equ program_label
 }
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 3 - Hello, World!
 ;
 ; In this section, we'll define a few more primitive words and print a message
 ; to screen using them.
 ;
 ; Basic Output
 ;
 ; There are two main words for printing to the screen in Forth: EMIT and TYPE.
 ; EMIT **emits** a single character to the screen, while TYPE outputs an entire
 ; string to the screen. Unlike many other languages at the time, Forth does not
 ; use null-terminated strings. Instead, the address and length of a string are
 ; expected to travel as a pair.
 ;
 ; The implementations of these words are fairly simple, as I've defined the
 ; `sys_print_string` function as part of the EFI abstraction and it does most
 ; of the work for us.
 ;
 
 defcode "EMIT", 4, 0, EMIT
 ; Print a character. 
 ;
 ; The character is temporarily stored in the `.char_buffer` local variable.
 ; `.char_buffer` is defined as a 1-byte variable in the data section at the
 ; bottom of this file.
 ;
     pop rax
     mov [.char_buffer], al
     mov rcx, .char_buffer
     mov rdx, 1
     call sys_print_string
     NEXT
 
 defcode "TYPE", 4, 0, TYPE
 ; Print an ASCII string.
 ;
     pop rdx
     pop rcx
     call sys_print_string
     NEXT
 
 section '.rodata' data readable
 
 macro initialize_stack_s3 {
     push version_string
     push version_string.length
 }
 
 program_s3:
     dq TYPE
 
 set_program initialize_stack_s3, program_s3
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 4 - Reading Words
 ;
 ; In this section, we'll define words for processing user input and even build
 ; a simple interpreter. At this point, the interpreter will only be able to
 ; execute words that we've already defined. We'll need to do a bit more work
 ; before we can start defining new words in the interpreter.
 ;
 
 defcode "KEY", 3, 0, KEY
 ; Read a character.
 ;
     call _KEY
     push rax
     NEXT
 
 _KEY:
     cmp [input_buffer], 0
     jne .buffer
 
 .stdin:
     call sys_read_char
     ret
 
 .buffer:
     cmp [input_buffer.len], 0
     je .buffer_empty
     mov rax, [input_buffer]
     movzx rax, byte [rax]
     inc [input_buffer]
     dec [input_buffer.len]
     ret
 
 .buffer_empty:
     mov [input_buffer], 0
     jmp .stdin
 
 
 defcode "WORD", 4, 0, WORD_
 ; Read a word.
 ;
 ; A word is considered to be a group of ASCII characters surrounded by white
 ; space.
 ;
 ; WORD is implemented using a pattern that we'll use a lot: We'll define
 ; a label '_WORD' that holds most of the implementation, aside from stack
 ; manipulation. This lets us easily re-use the implementation in other
 ; primitive words, we just have to make sure we're not overwriting important
 ; registers when we do this.
 ;
     call _WORD
     push rdi   ; word name address
     push rcx   ; word name length
     NEXT
 
 _WORD:
 ; Read a word.
 ;
 ; Returns:
 ;   RDI: word name address
 ;   RCX: word name length
 ;
 
 .skip_whitespace:
 ; Read characters until we reach one that isn't white space.
 ;
 ; After a non-whitespace character is found, RDI is used to hold the address
 ; of the next character to be stored.
 ;
     call _KEY
     cmp al, ' '
     je .skip_whitespace
     cmp al, 0xA
     je .skip_whitespace
     cmp al, 0xD
     je .skip_whitespace
     mov rdi, .buffer
 
 .store_char:
 ; Store a character into the buffer.
 ;
 ; There are some assembly instructions such as 'stos', 'lods', etc. that
 ; perform string operations for us. These instructions require us to use
 ; registers in specific ways, so it's always a good idea to double check what
 ; an instruction does.
 ;
 ; In this instance, 'stosb' stores the byte in AL at address RDI, then
 ; increments RDI to point at the next byte in the buffer.
 ;
     stosb
 
 .next_char:
 ; Keep processing characters until we find the end of the word.
 ;
     call _KEY
     cmp al, ' '
     je .end
     cmp al, 0xA
     je .end
     cmp al, 0xD
     jne .store_char
 
 .end:
 ; Return buffer address in RDI and length in RCX.
 ;
     mov rcx, .buffer
     sub rdi, rcx
     xchg rdi, rcx
     ret
 
 
 
 defcode "FIND", 4, 0, FIND
 ; Find a word in the dictionary.
 ;
 ; We search the dictionary starting from the end (the newest words) and move
 ; towards the beginning (the oldest words).
 ;
     pop rcx    ; word name length
     pop rdi    ; word name address
     call _FIND
     push rdx   ; word address
     NEXT
 
 _FIND:
 ; Find a word in the dictionary.
 ;
 ; Args:
 ;   RDI: word name address
 ;   RCX: word name length
 ;
 ; Returns:
 ;   RDX: word address
 ;
     mov rdx, [latest]
     jmp .check_out_of_words
 
 .next_word:
 ; Move to the next word in the dictionary.
 ;
     mov rdx, [rdx]
 
 .check_out_of_words:
 ; Are we at the beginning of the dictionary?
 ;
     test rdx, rdx
     je .end
 
 .check_hidden:
 ; Is the word we're looking at hidden?
 ;
     movzx rax, byte [rdx + 8] ; al = word flags
     test al, FLAG_HIDDEN
     jne .next_word
 
 .check_length:
 ; Is the word we're looking at the right length?
 ;
     movzx rax, byte [rdx + 9] ; al = word name length
     cmp cl, al
     jne .next_word
 
 .check_names:
 ; Do the words actually match?
 ;
 ; We use the 'cmpsb' instruction to compare the names of the words which is
 ; another of the special string instructions mentioned earlier. 'cmpsb'
 ; compares the strings referenced by RDI and RSI for up to RCX characters.
 ;
 ; The 'repe' prefix causes 'cmpsb' to be called repeatedly until RCX is 0 or a
 ; difference between the strings is found.
 ;
 ; This means that RSI, RDI, and RCX will all be modified. Since we need the
 ; original values of these registers after the loop, we have to make sure to
 ; save them to the stack, and then restore them afterwards.
 ;
     push rsi
     push rdi
     push rcx
 
     lea rsi, [rdx + 10] ; rsi = word name address of current entry
     repe cmpsb
 
     pop rcx
     pop rdi
     pop rsi
 
     jne .next_word
 
 .end:
     ret
 
 
 defcode ">CFA", 4, 0, TO_CFA
 ; Convert the address of a word into it's code field address.
 ;
 ; The code field address, or CFA, is the memory address of the code that
 ; actually implements this word.
 ;
     pop rdx
     call _TO_CFA
     push rdx
     NEXT
 
 _TO_CFA:
 ; Convert the address of a word into it's code field address.
 ;
 ; The implementation of this word uses a common method for aligning an address
 ; to the nearest 8-byte boundary. First, we add 8-1=7 to our address. This
 ; ensures we're within the 8-byte region we want to end up in. Next we flip all
 ; the bits for 7, then do a bit-by-bit AND with the current address to drop
 ; down to the actual 8-byte boundary. It's weird the first time you see it, so
 ; it can be useful to work it out on paper.
 ;
 ; Args:
 ;   RDX: word address
 ;
 ; Returns:
 ;   RDX: word CFA
 ;
     movzx rax, byte [rdx + 9]    ; al = name length
     lea rdx, [rdx + 10 + rax + 7] ; rdx > link, flags, length, and name
     and rdx, 0xFFFFFFFFFFFFFFF8  ; rdx = code field address
     ret
 
 
 defcode ">NUMBER", 7, 0, TO_NUMBER
 ; Convert a string into a number.
 ;
 ; The digits permitted in the string depend on the value of the `base` variable
 ; defined at the bottom of this file.
 ;
     pop rcx         ; string length
     pop rdi         ; string address
     call _TO_NUMBER
     push rbx        ; parsed number
     push rcx        ; # of unparsed characters (0 => no error)
     NEXT
 
 _TO_NUMBER:
 ; Convert a string into a number.
 ;
 ; The number is initialized as 0 and is parsed incrementally. As the string is
 ; parsed from left to right, the existing number must be multipled by the
 ; value of `base` before adding each new digit. We use the R8 register as a
 ; sign flag, where 0 means positive and 1 means negative.
 ;
 ; Args:
 ;   RDI: string address
 ;   RCX: string length
 ;
 ; Returns:
 ;   RBX: parsed number
 ;   RCX: # of unparsed characters (0 => no error)
 ;
     xor rax, rax
     xor rbx, rbx
     xor r8, r8
     push rsi
     mov rsi, rdi
 
 .check_empty_string:
 ; Is the string empty?
 ;
 ; If so, we can't do any parsing and should give up. Otherwise, we initialize
 ; RDX to hold the value of `base` and we start reading characters into RAX.
 ;
     test rcx, rcx
     jz .handle_empty_string
 
     movzx rdx, byte [BASE]
     lodsb
 
 .check_sign:
 ; Does the string begin with '-'?
 ;
     cmp al, '-'
     jnz .to_numeric_value
     inc r8
     dec rcx
     lodsb
 
 .check_negative_empty_string:
 ; Is '-' the only character in the string?
 ;
 ; If so, we return the number 0 with 1 unparsed character.
 ;
     test rcx, rcx
     jnz .to_numeric_value
 
     mov rcx, 1
     pop rsi
     ret
 
 .next_char:
 ; Start parsing the next character. 
 ;
 ; We also have to multiply the number by 'base' to make room for the next
 ; digit.
 ;
     imul rbx, rdx
     lodsb
 
 .to_numeric_value:
 ; Convert an ASCII character to its numeric value.
 ;
 ; The characters '0'-'9' are represented by the ASCII codes 48-57, so we can
 ; convert them to the right value by subtracting 48. If the value is below 0
 ; at that point, an invalid character was passed, and we should stop parsing.
 ; If it's below 10, we're good to start comparing to the value of 'base'. For
 ; values greater than 10, the only valid characters are 'A'-'F' which are 
 ; represented by the ASCII codes 65-70. Since we've already substracted 48,
 ; we need to subtract 7 to line each character up with the value they
 ; represent (A=10, ..., F=15). If the value is below 10, then we should stop
 ; parsing as an invalid character was passed. Otherwise, we're good to start
 ; comparing to the value of 'base'.
 ;
     sub rax, 48
     jb .handle_sign
     cmp rax, 10
     jb .check_base
     sub rax, 7
     cmp rax, 10
     jb .handle_sign
 
 .check_base:
 ; Check if the value is less than the value of 'base'.
 ;
 ; If the value is greater than 'base', we should stop parsing. Otherwise, we
 ; can add the value to our number and start parsing the next character.
 ;
     cmp rax, rdx
     jge .handle_sign
 
     add rbx, rax
     loop .next_char
 
 .handle_sign:
 ; Check if the sign flag was set, then negate the number.
 ;
     test r8, r8
     jz .end
     neg rbx
 
 .end:
     pop rsi
     ret
 
 .handle_empty_string:
 ; If an empty string was detected, return -1 as an error code.
 ;
     mov rcx, -1
     pop rsi
     ret
 
 
 defcode "INTERPRET", 9, 0, INTERPRET
     call _WORD
     call _FIND
 
     test rdx, rdx
     jz .try_number
 
     mov rbx, rdx ; rbx = word address
     call _TO_CFA ; rdx = word CFA
 
 .check_state:
     mov rax, [state]
     test rax, rax
     jz .execute_word
 
 .check_immediate:
     movzx rax, byte [rbx + 8]
     test al, FLAG_IMMEDIATE
     jnz .execute_word
     mov rax, rdx
     call _COMMA
     NEXT
 
 .execute_word:
     mov rax, rdx
     jmp qword [rax]
 
 .try_number:
     call _TO_NUMBER
     test rcx, rcx
     jnz .not_found
 
 .check_state_number:
     mov rax, [state]
     test rax, rax
     jz .execute_number
 
 .compile_number:
     mov rax, LIT
     call _COMMA
     mov rax, rbx
     call _COMMA
     NEXT
 
 .execute_number:
     push rbx
     NEXT
 
 .not_found:
     mov rcx, unrecognized_msg
     mov rdx, unrecognized_msg.length
     call sys_print_string
     NEXT
 
 defcode "BRANCH", 6, 0, BRANCH
     add rsi, [rsi]
     NEXT
 
 defword "QUIT", 4, 0, QUIT
     dq INTERPRET
     dq BRANCH, -16
 
 macro initialize_stack_s4 {
     push version_string
     push version_string.length
 }
 
 program_s4:
     dq TYPE
     dq QUIT
 
 set_program initialize_stack_s4, program_s4
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 5 - Printing Numbers
 ;
 
 defcode ".", 1, 0, DOT
 ; Print a signed integer.
 ;
     pop rax
     movzx rcx, [BASE]
     xor rbx, rbx
     xor r8, r8
 
 .check_negative:
     ; if positive, start dividing to get digits
     test rax, rax
     jns .divide
 
     ; if negative, negate and then start dividing to get digits
     neg rax
     inc r8
 
 .divide:
     xor rdx, rdx
     div rcx
     push rdx
     inc rbx
     test rax, rax
     jnz .divide
 
 .reverse_digits:
     mov rcx, rbx
     mov rdx, .buffer
 
 .handle_negative:
     test r8, r8
     jz .next_digit
     mov byte [rdx], 0x2D
     inc rdx
     inc rbx
 
 .next_digit:
     pop rax
     add al, 48
     cmp al, 58
     jl .store_in_buffer
     add al, 7
 
 .store_in_buffer:
     mov [rdx], al
     inc rdx
     dec rcx
     jnz .next_digit
 
 .end:
     mov byte [rdx], 0xA
     inc rbx
     mov rcx, .buffer
     mov rdx, rbx
     call sys_print_string
     NEXT
 
 
 defcode "U.", 2, 0, U_DOT
 ; Print an unsigned integer.
 ;
     pop rax
     movzx rcx, [BASE]
     xor rbx, rbx
 
 .divide:
     xor rdx, rdx
     div rcx
     push rdx
     inc rbx
     test rax, rax
     jnz .divide
 
 .reverse_digits:
     mov rcx, rbx
     mov rdx, .buffer
 
 .next_digit:
     pop rax
     add al, 48
     cmp al, 58
     jl .store_in_buffer
     add al, 7
 
 .store_in_buffer:
     mov [rdx], al
     inc rdx
     dec rcx
     jnz .next_digit
 
 .end:
     mov byte [rdx], 0xA
     inc rbx
     mov rcx, .buffer
     mov rdx, rbx
     call sys_print_string
     NEXT
 
 macro initialize_stack_s5 {
     push 0xBADC0DE
     push -0xBAD
     push version_string
     push version_string.length
 }
 
 program_s5:
     dq TYPE
     dq DOT
     dq U_DOT
 
 ;set_program initialize_stack_s5, program_s5
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 6 - Memory
 ;
 
 defcode "!", 1, 0, STORE_
     pop rbx
     pop rax
     mov [rbx], rax
     NEXT
 
 defcode "@", 1, 0, FETCH
     pop rbx
     mov rax, [rbx]
     push rax
     NEXT
 
 defcode "C@", 2, 0, FETCH_CHAR
     pop rbx
     movzx rax, byte [rbx]
     push rax
     NEXT
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 7 - Defining Words
 ;
 
 defcode "LATEST", 6, 0, LATEST
     push latest
     NEXT
 
 defcode "HERE", 4, 0, HERE
     push here
     NEXT
 
 defcode "CREATE", 6, 0, CREATE
     pop rcx ; string length
     pop rbx ; string address
     call _CREATE
     NEXT
 
 _CREATE:
     mov rdi, [here] ; address of new header
     mov rax, [latest] ; address of last entry
     stosq ; add link to last entry
     mov [latest], rdi ; Update LATEST to point to this word
 
     ; Store flags byte
     xor rax, rax
     stosb
 
     ; Store length byte
     mov rax, rcx
     stosb
 
     ; Store name
     push rsi
     mov rsi, rbx
     rep movsb
     pop rsi
 
     ; Align to nearest 8-byte boundary
     add rdi, 7
     and rdi, 0xFFFFFFFFFFFFFFF8
 
     ; Update LATEST and HERE
     mov rax, [here]
     mov [latest], rax
     mov [here], rdi
     ret
 
 defcode ",", 1, 0, COMMA
     pop rax
     call _COMMA
     NEXT
 
 _COMMA:
     mov rdi, [here]
     stosq
     mov [here], rdi
     ret
 
 defcode "C,", 2,  0, CHAR_COMMA
     pop rax
     mov rdi, [here]
     stosb
     mov [here], rdi
     NEXT
 
 defcode "LIT", 3, 0, LIT
     lodsq
     push rax
     NEXT
 
 defcode "[", 1, FLAG_IMMEDIATE, LEFT_BRACKET
     mov [state], 0
     NEXT
 
 defcode "]", 1, 0, RIGHT_BRACKET
     mov [state], 1
     NEXT
 
 defcode "STATE", 5, 0, STATE
     push [state]
     NEXT
 
 defcode "HIDDEN", 6, 0, HIDDEN
     pop rdi
     add rdi, 8
     mov rcx, FLAG_HIDDEN
     xor [rdi], rcx
     NEXT
 
 defcode "IMMEDIATE", 9, FLAG_IMMEDIATE, IMMEDIATE
     mov rdi, [latest]
     add rdi, 8
     xor byte [rdi], FLAG_IMMEDIATE
     NEXT
 
 defcode "+", 1, 0, PLUS
     pop rbx
     pop rcx
     add rbx, rcx
     push rbx
     NEXT
 
 defword ":", 1, 0, COLON
     dq WORD_
     dq CREATE                ; Create header
     dq LIT, DOCOL            ; Put DOCOL on stack...
     dq COMMA                 ; ...then append to definition
     dq LATEST, FETCH, HIDDEN ; Set HIDDEN
     dq RIGHT_BRACKET         ; Switch to COMPILE mode
     dq EXIT
 
 defword ";", 1, FLAG_IMMEDIATE, SEMICOLON
     dq LIT, EXIT             ; Put EXIT on stack...
     dq COMMA                 ; ...then append EXIT
     dq LATEST, FETCH, HIDDEN ; Unset HIDDEN
     dq LEFT_BRACKET          ; Switch to IMMEDIATE mode
     dq EXIT
 
 defcode "ALIGN", 5, 0, ALIGN_
     mov rax, [here]
     add rax, 7
     and rax, 0xFFFFFFFFFFFFFFF8
     mov [here], rax
     NEXT
 
 defcode "DUP", 3, 0, DUP_
     pop rcx
     push rcx
     push rcx
     NEXT
 
 defcode "DROP", 4, 0, DROP
     pop rcx
     NEXT
 
 defword "CONSTANT", 8, 0, CONSTANT
     dq WORD_
     dq CREATE
     dq LIT, DOCOL
     dq COMMA
     dq LIT, LIT
     dq COMMA
     dq COMMA
     dq LIT, EXIT
     dq COMMA
     dq EXIT
 
 defword "FIELD", 5, 0, FIELD
     dq DUP_
     dq CONSTANT
     dq EXIT
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 8 - String operations
 ;
 
 defcode 'S"', 2, 0, S_QUOTE
     mov rdx, .buffer
     mov [.length], 0
 
 .next_char:
     call sys_read_char
     cmp al, '"'
     je .end
 
 .store_char:
     mov byte [rdx], al
     inc rdx
     inc [.length]
     jmp .next_char
 
 .end:
     push .buffer
     push [.length]
     NEXT
 
 defcode 'S\"', 3, 0, S_BACKSLASH_QUOTE
     mov rdx, .buffer
     mov [.length], 0
 
 .next_char:
     call sys_read_char
     cmp al, '"'
     je .end
     cmp al, '\'
     jne .store_char
 
 .handle_escape:
     call sys_read_char
     cmp al, 'n'
     jne .next_char
 
     mov al, 0xA
 
 .store_char:
     mov byte [rdx], al
     inc rdx
     inc [.length]
     jmp .next_char
 
 .end:
     push .buffer
     push [.length]
     NEXT
 
 ;------------------------------------------------------------------------------
 ;
 ; Section 9 - Misc.
 ;
 
 defcode "WORDS", 5, 0, WORDS
 ; List all words in the dictionary.
 ;
 ; We search the dictionary starting from the end (the newest words) and move
 ; towards the beginning (the oldest words).
 ;
     mov rbx, [latest]
     jmp .print_word
 
 .next_word:
     mov rbx, [rbx]
 
 .check_out_of_words:
     test rbx, rbx
     je .end
 
 .next_line:
     mov rdx, 1
     mov rcx, .newline
     call sys_print_string
 
 .print_word:
     movzx rdx, byte [rbx + 9] ; al = word name length
     lea rcx, [rbx + 10] ; rcx = word name address of current entry
     call sys_print_string
     jmp .next_word
 
 .end:
     NEXT
 
 defcode "\", 1, 0, SLASH
 .skip_comment:
     call _KEY
     cmp al, 0xA
     je .end
     cmp al, 0xD
     je .end
     jmp .skip_comment
 .end:
     NEXT
 
 defcode "(", 1, 0, LEFT_PAREN
 .skip_comment:
     call _KEY
     cmp al, 0xA
     je .end
     cmp al, 0xD
     je .end
     cmp al, ')'
     je .end
     jmp .skip_comment
 .end:
     NEXT
 
 defcode "LOAD_BASE", 9, 0, LOAD_BASE
     mov [input_buffer], forth_base
     mov [input_buffer.len], forth_base.len
     NEXT
 
 defcode "LOAD_EFI", 8, 0, LOAD_EFI
     mov [input_buffer], forth_efi
     mov [input_buffer.len], forth_efi.len
     NEXT
 
 section '.data' data readable writable
 
 version_string db 'soup forth v0.1', 0xA
 .length = $ - version_string
 
 unrecognized_msg db 'unrecognized word', 0xA
 .length = $ - unrecognized_msg
 
 input_buffer dq 0
 input_buffer.len dq 0
 
 code_EMIT.char_buffer db ?
 
 code_DOT.buffer rb 64
 code_U_DOT.buffer rb 64
 
 _WORD.buffer rb 64
 
 code_S_QUOTE.buffer rb 64
 code_S_QUOTE.length dq ?
 
 code_S_BACKSLASH_QUOTE.buffer rb 64
 code_S_BACKSLASH_QUOTE.length dq ?
 
 code_WORDS.newline db 0xA
 
 BASE db 16
 
 latest dq link
 
 here dq here_top
 here_top rq 0x4000
 
 state dq 0
 
 FLAG_IMMEDIATE = 0x40
 FLAG_HIDDEN = 0x20
 
 forth_base:
 file './base.forth'
 forth_base.len = $ - forth_base
 
 forth_efi:
 file './efi.forth'
 forth_efi.len = $ - forth_efi
 
 align 4096
 return_stack rb 8192
 return_stack_top: