main.asm

   1 format ELF64 executable
   2
   3 ;; The code in this macro is placed at the end of each Forth word. When we are
   4 ;; executing a definition, this code is what causes execution to resume at the
   5 ;; next word in that definition.
   6 macro next {
   7   ;; RSI points to the address of the definition of the next word to execute.
   8   lodsq                   ; Load value at RSI into RAX and increment RSI
   9   ;; Now RAX contains the location of the next word to execute. The first 8
  10   ;; bytes of this word is the address of the codeword, which is what we want
  11   ;; to execute.
  12   jmp qword [rax]         ; Jump to the codeword of the current word
  13 }
  14
  15 ;; pushr and popr work on the return stack, whose location is stored in the
  16 ;; register RBP.
  17 macro pushr x {
  18   sub rbp, 8
  19   mov qword [rbp], x
  20 }
  21 macro popr x {
  22   mov x, [rbp]
  23   add rbp, 8
  24 }
  25
  26 ;; The following macro generates the dictionary header. It updates the
  27 ;; initial_latest_entry variable, which is used as the initial value of the
  28 ;; latest_entry variable that is made available at runtime.
  29 ;;
  30 ;; The header contains a link to the previous entry, the length of the name of
  31 ;; the word and the word itself as a string literal.
  32 ;;
  33 ;; This macro also defines a label LABEL_entry.
  34 initial_latest_entry = 0
  35 macro header label, name {
  36   local .string_end
  37
  38 label#_entry:
  39   dq initial_latest_entry
  40   db .string_end - ($ + 1)
  41   db name
  42   .string_end:
  43 label:
  44
  45 initial_latest_entry = label#_entry
  46 }
  47
  48 ;; Define a Forth word that is implemented in assembly. See 'header' for details.
  49 macro forth_asm label, name {
  50   header label, name
  51   dq .start
  52 .start:
  53 }
  54
  55 ;; Define a Forth word that is implemented in Forth. (The body will be a list of
  56 ;; 'dq' statements.)
  57 macro forth label, name {
  58   header label, name
  59   dq docol
  60 }
  61
  62 segment readable executable
  63
  64 main:
  65   cld                        ; Clear direction flag so LODSQ does the right thing.
  66   mov rbp, return_stack_top  ; Initialize return stack
  67
  68   mov rax, MAIN
  69   jmp qword [rax]
  70
  71 program: dq MAIN
  72
  73 ;; The codeword is the code that will be executed at the beginning of a forth
  74 ;; word. It needs to save the old RSI and update it to point to the next word to
  75 ;; execute.
  76 docol:
  77   pushr rsi            ; Save old value of RSI on return stack; we will continue execution there after we are done executing this word
  78   lea rsi, [rax + 8]   ; RAX currently points to the address of the codeword, so we want to continue at RAX+8
  79   next                 ; Execute word pointed to by RSI
  80
  81 ;; This word is called at the end of a Forth definition. It just needs to
  82 ;; restore the old value of RSI (saved by 'docol') and resume execution.
  83 forth_asm EXIT, 'EXIT'
  84   popr rsi
  85   next
  86
  87 ;; LIT is a special word that reads the next "word pointer" and causes it to be
  88 ;; placed on the stack rather than executed.
  89 forth_asm LIT, 'LIT'
  90   lodsq
  91   push rax
  92   next
  93
  94 ;; Given a string (a pointer following by a size), return the location of the
  95 ;; dictionary entry for that word. If no such word exists, return 0.
  96 forth_asm FIND, 'FIND'
  97   mov [.rsi], rsi
  98   pop [.search_length]
  99   pop [.search_buffer]
 100
 101   ;; RSI contains the entry we are currently looking at
 102   mov rsi, [latest_entry]       ; Start with the last added word
 103
 104 .loop:
 105   movzx rcx, byte [rsi + 8]     ; Length of word being looked at
 106   cmp rcx, [.search_length]
 107   jne .next    ; If the words don't have the same length, we have the wrong word
 108
 109   ;; Otherwise, we need to compare strings
 110   lea rdx, [rsi + 8 + 1]        ; Location of character being compared in entry
 111   mov rdi, [.search_buffer]     ; Location of character being compared in search buffer
 112 .compare_char:
 113   mov al, [rdx]
 114   mov ah, [rdi]
 115   cmp al, ah
 116   jne .next                     ; They don't match; try again
 117   inc rdx                       ; These characters match; look at the next ones
 118   inc rdi
 119   loop .compare_char
 120
 121   jmp .found                    ; They match! We are done.
 122
 123 .next:
 124   mov rsi, [rsi]                ; Look at the previous entry
 125   cmp rsi, 0
 126   jnz .loop                    ; If there is no previous word, exit and return 0
 127
 128 .found:
 129   push rsi
 130
 131   mov rsi, [.rsi]
 132   next
 133
 134 ;; Given an entry in the dictionary, return a pointer to the codeword of that
 135 ;; entry.
 136 forth_asm TCFA, '>CFA'
 137   pop rax
 138   add rax, 8                    ; [rax] = length of name
 139   movzx rbx, byte [rax]
 140   inc rax
 141   add rax, rbx                  ; [rax] = codeword
 142   push rax
 143   next
 144
 145 ;; BRANCH is the fundamental mechanism for branching. BRANCH reads the next word
 146 ;; as a signed integer literal and jumps by that offset.
 147 forth_asm BRANCH, 'BRANCH'
 148   add rsi, [rsi] ; [RSI], which is the next word, contains the offset; we add this to the instruction pointer.
 149   next           ; Then, we can just continue execution as normal
 150
 151 ;; 0BRANCH is like BRANCH, but it jumps only if the top of the stack is zero.
 152 forth_asm ZBRANCH, '0BRANCH'
 153   ;; Compare top of stack to see if we should branch
 154   pop rax
 155   cmp rax, 0
 156   jnz .dont_branch
 157 .do_branch:
 158   jmp BRANCH.start
 159 .dont_branch:
 160   add rsi, 8     ; We need to skip over the next word, which contains the offset.
 161   next
 162
 163 ;; Duplicate the top of the stack.
 164 forth_asm DUP_, 'DUP'
 165   push qword [rsp]
 166   next
 167
 168 ;; Execute the codeword at the given address.
 169 forth_asm EXEC, 'EXEC'
 170   pop rax
 171   jmp qword [rax]
 172
 173 ;; Expects a character on the stack and prints it to standard output.
 174 forth_asm EMIT, 'EMIT'
 175   pushr rsi
 176   pushr rax
 177   mov rax, 1
 178   mov rdi, 1
 179   lea rsi, [rsp]
 180   mov rdx, 1
 181   syscall
 182   add rsp, 8
 183   popr rax
 184   popr rsi
 185   next
 186
 187 ;; Prints a newline to standard output.
 188 forth NEWLINE, 'NEWLINE'
 189   dq LIT, $A
 190   dq EMIT
 191   dq EXIT
 192
 193 ;; Prints a space to standard output.
 194 forth SPACE, 'SPACE'
 195   dq LIT, ' '
 196   dq EMIT
 197   dq EXIT
 198
 199 ;; Read a word from standard input and push it onto the stack as a pointer and a
 200 ;; size. The pointer is valid until the next call to READ_WORD.
 201 forth_asm READ_WORD, 'READ-WORD'
 202   mov [.rsi], rsi
 203   mov [.rax], rax
 204
 205 .skip_whitespace:
 206   ;; Read characters into .char_buffer until one of them is not whitespace.
 207   mov rax, 0
 208   mov rdi, 0
 209   mov rsi, .char_buffer
 210   mov rdx, 1
 211   syscall
 212
 213   cmp [.char_buffer], ' '
 214   je .skip_whitespace
 215   cmp [.char_buffer], $A
 216   je .skip_whitespace
 217
 218 .alpha:
 219   ;; We got a character that wasn't whitespace. Now read the actual word.
 220   mov [.length], 0
 221
 222 .read_alpha:
 223   mov al, [.char_buffer]
 224   movzx rbx, [.length]
 225   mov rsi, .buffer
 226   add rsi, rbx
 227   mov [rsi], al
 228   inc [.length]
 229
 230   mov rax, 0
 231   mov rdi, 0
 232   mov rsi, .char_buffer
 233   mov rdx, 1
 234   syscall
 235
 236   cmp [.char_buffer], ' '
 237   je .end
 238   cmp [.char_buffer], $A
 239   jne .read_alpha
 240
 241 .end:
 242   push .buffer
 243   movzx rax, [.length]
 244   push rax
 245
 246   mov rsi, [.rsi]
 247   mov rax, [.rax]
 248
 249   next
 250
 251 ;; Takes a string on the stack and replaces it with the decimal number that the
 252 ;; string represents.
 253 forth_asm PARSE_NUMBER, 'PARSE-NUMBER'
 254   pop [.length]                 ; Length
 255   pop rdi                       ; String pointer
 256   mov r8, 0                     ; Result
 257
 258   ;; Add (10^(rcx-1) * parse_char(rdi[length - rcx])) to the accumulated value
 259   ;; for each rcx.
 260   mov rcx, [.length]
 261 .loop:
 262   ;; First, calcuate 10^(rcx - 1)
 263   mov rax, 1
 264
 265   mov r9, rcx
 266   .exp_loop:
 267     dec r9
 268     jz .break
 269     mov rbx, 10
 270     mul rbx
 271     jmp .exp_loop
 272   .break:
 273
 274   ;; Now, rax = 10^(rcx - 1).
 275
 276   ;; We need to calulate the value of the character at rdi[length - rcx].
 277   mov rbx, rdi
 278   add rbx, [.length]
 279   sub rbx, rcx
 280   movzx rbx, byte [rbx]
 281   sub rbx, '0'
 282
 283   ;; Multiply this value by rax to get (10^(rcx-1) * parse_char(rdi[length - rcx])),
 284   ;; then add this to the result.
 285   mul rbx
 286
 287   ;; Add that value to r8
 288   add r8, rax
 289
 290   dec rcx
 291   jnz .loop
 292
 293   push r8
 294
 295   next
 296
 297 forth READ_NUMBER, 'READ-NUMBER'
 298   dq READ_WORD
 299   dq PARSE_NUMBER
 300   dq EXIT
 301
 302 ;; Takes a string (in the form of a pointer and a length on the stack) and
 303 ;; prints it to standard output.
 304 forth_asm TELL, 'TELL'
 305   mov rbx, rsi
 306   mov rcx, rax
 307
 308   mov rax, 1
 309   mov rdi, 1
 310   pop rdx     ; Length
 311   pop rsi     ; Buffer
 312   syscall
 313
 314   mov rax, rcx
 315   mov rsi, rbx
 316   next
 317
 318 ;; Exit the program cleanly.
 319 forth_asm TERMINATE, 'TERMINATE'
 320   mov rax, $3C
 321   mov rdi, 0
 322   syscall
 323
 324 forth HELLO, 'HELLO'
 325   dq LIT, 'H', EMIT
 326   dq LIT, 'e', EMIT
 327   dq LIT, 'l', EMIT
 328   dq LIT, 'l', EMIT
 329   dq LIT, 'o', EMIT
 330   dq LIT, '!', EMIT
 331   dq NEWLINE
 332   dq EXIT
 333
 334 ;; .U prints the value on the stack as an unsigned integer in hexadecimal.
 335 forth_asm DOTU, '.U'
 336   mov [.length], 0
 337   mov [.printed_length], 1
 338   pop rax                       ; RAX = value to print
 339   push rsi                      ; Save value of RSI
 340
 341   ;; We start by constructing the buffer to print in reverse
 342
 343 .loop:
 344   mov rdx, 0
 345   mov rbx, $10
 346   div rbx                       ; Put remainer in RDX and quotient in RAX
 347
 348   ;; Place the appropriate character in the buffer
 349   mov rsi, .chars
 350   add rsi, rdx
 351   mov bl, [rsi]
 352   mov rdi, .rbuffer
 353   add rdi, [.length]
 354   mov [rdi], bl
 355   inc [.length]
 356
 357   ;; .printed_length is the number of characters that we ulitmately want to
 358   ;; print. If we have printed a non-zero character, then we should update
 359   ;; .printed_length.
 360   cmp bl, '0'
 361   je .skip_updating_real_length
 362   mov rbx, [.length]
 363   mov [.printed_length], rbx
 364 .skip_updating_real_length:
 365
 366   cmp [.length], 16
 367   jle .loop
 368
 369   ;; Flip buffer around, since it is currently reversed
 370   mov rcx, [.printed_length]
 371 .flip:
 372   mov rsi, .rbuffer
 373   add rsi, rcx
 374   dec rsi
 375   mov al, [rsi]
 376
 377   mov rdi, .buffer
 378   add rdi, [.printed_length]
 379   sub rdi, rcx
 380   mov [rdi], al
 381
 382   loop .flip
 383
 384   ;; Print the buffer
 385   mov rax, 1
 386   mov rdi, 1
 387   mov rsi, .buffer
 388   mov rdx, [.printed_length]
 389   syscall
 390
 391   ;; Restore RSI and continue execution
 392   pop rsi
 393   next
 394
 395 forth MAIN, 'MAIN'
 396   dq HELLO
 397   dq READ_WORD, FIND, TCFA, EXEC
 398   dq BRANCH, -8 * 5
 399   dq TERMINATE
 400
 401 segment readable writable
 402
 403 latest_entry dq initial_latest_entry
 404
 405 FIND.search_length dq ?
 406 FIND.search_buffer dq ?
 407 FIND.rsi dq ?
 408
 409 READ_WORD.rsi dq ?
 410 READ_WORD.rax dq ?
 411 READ_WORD.max_size = $FF
 412 READ_WORD.buffer rb READ_WORD.max_size
 413 READ_WORD.length db ?
 414 READ_WORD.char_buffer db ?
 415
 416 DOTU.chars db '0123456789ABCDEF'
 417 DOTU.buffer rq 16               ; 64-bit number has no more than 16 digits in hex
 418 DOTU.rbuffer rq 16
 419 DOTU.length dq ?
 420 DOTU.printed_length dq ?
 421
 422 PARSE_NUMBER.length dq ?
 423
 424 ;; Return stack
 425 rq $2000
 426 return_stack_top: