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, immediate {
  36   local .string_end
  37
  38 label#_entry:
  39   dq initial_latest_entry
  40   if immediate eq
  41     db 0
  42   else
  43     db 1
  44   end if
  45   db .string_end - ($ + 1)
  46   db name
  47   .string_end:
  48 label:
  49
  50 initial_latest_entry = label#_entry
  51 }
  52
  53 ;; Define a Forth word that is implemented in assembly. See 'header' for details.
  54 macro forth_asm label, name, immediate {
  55   header label, name, immediate
  56   dq .start
  57 .start:
  58 }
  59
  60 ;; Define a Forth word that is implemented in Forth. (The body will be a list of
  61 ;; 'dq' statements.)
  62 macro forth label, name, immediate {
  63   header label, name, immediate
  64   dq DOCOL
  65 }
  66
  67 segment readable executable
  68
  69 entry main
  70
  71 include "impl.asm"
  72
  73 main:
  74   cld                        ; Clear direction flag so LODSQ does the right thing.
  75   mov rbp, return_stack_top  ; Initialize return stack
  76
  77   mov rax, MAIN
  78   jmp qword [rax]
  79
  80 program: dq MAIN
  81
  82 ;; The codeword is the code that will be executed at the beginning of a forth
  83 ;; word. It needs to save the old RSI and update it to point to the next word to
  84 ;; execute.
  85 header DOCOL, 'DOCOL'
  86   pushr rsi            ; Save old value of RSI on return stack; we will continue execution there after we are done executing this word
  87   lea rsi, [rax + 8]   ; RAX currently points to the address of the codeword, so we want to continue at RAX+8
  88   next                 ; Execute word pointed to by RSI
  89
  90 ;; This word is called at the end of a Forth definition. It just needs to
  91 ;; restore the old value of RSI (saved by 'DOCOL') and resume execution.
  92 forth_asm EXIT, 'EXIT'
  93   popr rsi
  94   next
  95
  96 ;; LIT is a special word that reads the next "word pointer" and causes it to be
  97 ;; placed on the stack rather than executed.
  98 forth_asm LIT, 'LIT'
  99   lodsq
 100   push rax
 101   next
 102
 103 ;; Given a string (a pointer following by a size), return the location of the
 104 ;; dictionary entry for that word. If no such word exists, return 0.
 105 forth_asm FIND, 'FIND'
 106   mov [.rsi], rsi
 107
 108   pop [find.search_length]
 109   pop [find.search_buffer]
 110   mov rsi, [latest_entry]       ; Start with the last added word
 111   call find
 112   push rsi
 113
 114   mov rsi, [.rsi]
 115   next
 116   push rsi
 117
 118   mov rsi, [.rsi]
 119   next
 120
 121 ;; Given an entry in the dictionary, return a pointer to the codeword of that
 122 ;; entry.
 123 forth_asm TCFA, '>CFA'
 124   pop rax
 125   add rax, 8 + 1                ; [rax] = length of name
 126   movzx rbx, byte [rax]
 127   inc rax
 128   add rax, rbx                  ; [rax] = codeword
 129   push rax
 130   next
 131
 132 ;; BRANCH is the fundamental mechanism for branching. BRANCH reads the next word
 133 ;; as a signed integer literal and jumps by that offset.
 134 forth_asm BRANCH, 'BRANCH'
 135   add rsi, [rsi] ; [RSI], which is the next word, contains the offset; we add this to the instruction pointer.
 136   next           ; Then, we can just continue execution as normal
 137
 138 ;; 0BRANCH is like BRANCH, but it jumps only if the top of the stack is zero.
 139 forth_asm ZBRANCH, '0BRANCH'
 140   ;; Compare top of stack to see if we should branch
 141   pop rax
 142   cmp rax, 0
 143   jnz .dont_branch
 144 .do_branch:
 145   jmp BRANCH.start
 146 .dont_branch:
 147   add rsi, 8     ; We need to skip over the next word, which contains the offset.
 148   next
 149
 150 ;; Duplicate the top of the stack.
 151 forth_asm DUP_, 'DUP'
 152   push qword [rsp]
 153   next
 154
 155 ;; Execute the codeword at the given address.
 156 forth_asm EXEC, 'EXEC'
 157   pop rax
 158   jmp qword [rax]
 159
 160 ;; Expects a character on the stack and prints it to standard output.
 161 forth_asm EMIT, 'EMIT'
 162   pushr rsi
 163   pushr rax
 164   mov rax, 1
 165   mov rdi, 1
 166   lea rsi, [rsp]
 167   mov rdx, 1
 168   syscall
 169   add rsp, 8
 170   popr rax
 171   popr rsi
 172   next
 173
 174 ;; Prints a newline to standard output.
 175 forth NEWLINE, 'NEWLINE'
 176   dq LIT, $A
 177   dq EMIT
 178   dq EXIT
 179
 180 ;; Prints a space to standard output.
 181 forth SPACE, 'SPACE'
 182   dq LIT, ' '
 183   dq EMIT
 184   dq EXIT
 185
 186 ;; Read a word from standard input and push it onto the stack as a pointer and a
 187 ;; size. The pointer is valid until the next call to READ_WORD.
 188 forth_asm READ_WORD, 'READ-WORD'
 189   mov [.rsi], rsi
 190
 191   call read_word
 192   push rdi                      ; Buffer
 193   push rdx                      ; Length
 194
 195   mov rsi, [.rsi]
 196   next
 197
 198 ;; Takes a string on the stack and replaces it with the decimal number that the
 199 ;; string represents.
 200 forth_asm PARSE_NUMBER, 'PARSE-NUMBER'
 201   pop rcx     ; Length
 202   pop rdi     ; String pointer
 203
 204   push rsi
 205   call parse_number
 206   pop rsi
 207
 208   push rax                      ; Result
 209   next
 210
 211 forth READ_NUMBER, 'READ-NUMBER'
 212   dq READ_WORD
 213   dq PARSE_NUMBER
 214   dq EXIT
 215
 216 ;; Takes a string (in the form of a pointer and a length on the stack) and
 217 ;; prints it to standard output.
 218 forth_asm TELL, 'TELL'
 219   mov rbx, rsi
 220   mov rcx, rax
 221
 222   mov rax, 1
 223   mov rdi, 1
 224   pop rdx     ; Length
 225   pop rsi     ; Buffer
 226   syscall
 227
 228   mov rax, rcx
 229   mov rsi, rbx
 230   next
 231
 232 ;; Exit the program cleanly.
 233 forth_asm TERMINATE, 'TERMINATE'
 234   mov rax, $3C
 235   mov rdi, 0
 236   syscall
 237
 238 forth HELLO, 'HELLO'
 239   dq LIT, 'H', EMIT
 240   dq LIT, 'e', EMIT
 241   dq LIT, 'l', EMIT
 242   dq LIT, 'l', EMIT
 243   dq LIT, 'o', EMIT
 244   dq LIT, '!', EMIT
 245   dq NEWLINE
 246   dq EXIT
 247
 248 ;; Duplicate a pair of elements.
 249 forth_asm PAIRDUP, '2DUP'
 250   pop rbx
 251   pop rax
 252   push rax
 253   push rbx
 254   push rax
 255   push rbx
 256   next
 257
 258 ;; Swap the top two elements on the stack.
 259 forth_asm SWAP, 'SWAP'
 260   pop rax
 261   pop rbx
 262   push rax
 263   push rbx
 264   next
 265
 266 ;; Remove the top element from the stack.
 267 forth_asm DROP, 'DROP'
 268   add rsp, 8
 269   next
 270
 271 forth_asm NOT_, 'NOT'
 272   pop rax
 273   cmp rax, 0
 274   jz .false
 275 .true:
 276   push 0
 277   next
 278 .false:
 279   push 1
 280   next
 281
 282 ;; The INTERPRET word reads and interprets user input. It's behavior depends on
 283 ;; the current STATE. It provides special handling for integers.
 284 forth INTERPRET, 'INTERPRET'
 285   ;; Read word
 286   dq READ_WORD
 287   dq PAIRDUP
 288   ;; Stack is (word length word length).
 289   dq FIND                       ; Try to find word
 290   dq DUP_
 291   dq ZBRANCH, 8 * 20            ; Check if word is found
 292
 293   ;; - Word is found -
 294
 295   dq STATE, GET, ZBRANCH, 8 * 9 ; Check whether we are in compilation or immediate mode
 296
 297   ;; (Word found, compilation mode)
 298   dq DUP_, IS_IMMEDIATE, NOT_, ZBRANCH, 8 * 4 ; If the word is immediate, continue as we would in immediate mode
 299
 300   ;; Otherwise, we want to compile this word
 301   dq TCFA
 302   dq COMMA
 303   dq EXIT
 304
 305   ;; (Word found, immediate mode)
 306   ;; Execute word
 307   dq TCFA
 308   ;; Stack is (word length addr)
 309   dq SWAP, DROP
 310   dq SWAP, DROP
 311   ;; Stack is (addr)
 312   dq EXEC
 313   dq EXIT
 314
 315   ;; - No word is found, assume it is an integer literal -
 316   ;; Stack is (word length addr)
 317   dq DROP
 318   dq PARSE_NUMBER
 319
 320   dq STATE, GET, ZBRANCH, 8 * 5 ; Check whether we are in compilation or immediate mode
 321
 322   ;; (Number, compilation mode)
 323   dq LIT, LIT, COMMA
 324   dq COMMA
 325   dq EXIT
 326
 327   ;; (Number, immediate mode)
 328   dq EXIT
 329
 330 ;; .U prints the value on the stack as an unsigned integer in hexadecimal.
 331 forth_asm DOTU, '.U'
 332   mov [.length], 0
 333   mov [.printed_length], 1
 334   pop rax                       ; RAX = value to print
 335   push rsi                      ; Save value of RSI
 336
 337   ;; We start by constructing the buffer to print in reverse
 338
 339 .loop:
 340   mov rdx, 0
 341   mov rbx, $10
 342   div rbx                       ; Put remainer in RDX and quotient in RAX
 343
 344   ;; Place the appropriate character in the buffer
 345   mov rsi, .chars
 346   add rsi, rdx
 347   mov bl, [rsi]
 348   mov rdi, .rbuffer
 349   add rdi, [.length]
 350   mov [rdi], bl
 351   inc [.length]
 352
 353   ;; .printed_length is the number of characters that we ulitmately want to
 354   ;; print. If we have printed a non-zero character, then we should update
 355   ;; .printed_length.
 356   cmp bl, '0'
 357   je .skip_updating_real_length
 358   mov rbx, [.length]
 359   mov [.printed_length], rbx
 360 .skip_updating_real_length:
 361
 362   cmp [.length], 16
 363   jle .loop
 364
 365   ;; Flip buffer around, since it is currently reversed
 366   mov rcx, [.printed_length]
 367 .flip:
 368   mov rsi, .rbuffer
 369   add rsi, rcx
 370   dec rsi
 371   mov al, [rsi]
 372
 373   mov rdi, .buffer
 374   add rdi, [.printed_length]
 375   sub rdi, rcx
 376   mov [rdi], al
 377
 378   loop .flip
 379
 380   ;; Print the buffer
 381   mov rax, 1
 382   mov rdi, 1
 383   mov rsi, .buffer
 384   mov rdx, [.printed_length]
 385   syscall
 386
 387   ;; Restore RSI and continue execution
 388   pop rsi
 389   next
 390
 391 ;; Takes a value and an address, and stores the value at the given address.
 392 forth_asm PUT, '!'
 393   pop rbx                       ; Address
 394   pop rax                       ; Value
 395   mov [rbx], rax
 396   next
 397
 398 ;; Takes an address and returns the value at the given address.
 399 forth_asm GET, '@'
 400   pop rax
 401   mov rax, [rax]
 402   push rax
 403   next
 404
 405 forth_asm PUT_BYTE, 'C!'
 406   pop rbx
 407   pop rax                       ; Value
 408   mov [rbx], al
 409   next
 410
 411 forth_asm GET_BYTE, 'C@'
 412   pop rax
 413   movzx rax, byte [rax]
 414   push rax
 415   next
 416
 417 ;; Add two integers on the stack.
 418 forth_asm PLUS, '+'
 419   pop rax
 420   pop rbx
 421   add rax, rbx
 422   push rax
 423   next
 424
 425 ;; Calculate difference between two integers on the stack. The second number is
 426 ;; subtracted from the first.
 427 forth_asm MINUS, '-'
 428   pop rax
 429   pop rbx
 430   sub rbx, rax
 431   push rbx
 432   next
 433
 434 ;; Given two integers a and b on the stack, pushes the quotient and remainder of
 435 ;; division of a by b.
 436 forth_asm TIMESMOD, '/MOD'
 437   pop rbx                       ; b
 438   pop rax                       ; a
 439   mov rdx, 0
 440   div rbx
 441   push rax                      ; a / b
 442   push rdx                      ; a % b
 443   next
 444
 445 ;; Get the location of the STATE variable. It can be set with '!' and read with
 446 ;; '@'.
 447 forth STATE, 'STATE'
 448   dq LIT, var_STATE
 449   dq EXIT
 450
 451 ;; Get the location of the LATEST variable. It can be set with '!' and read with
 452 ;; '@'.
 453 forth LATEST, 'LATEST'
 454   dq LIT, latest_entry
 455   dq EXIT
 456
 457 ;; Get the location at which compiled words are expected to be added. This
 458 ;; pointer is usually modified automatically when calling ',', but we can also
 459 ;; read it manually with 'HERE'.
 460 forth HERE, 'HERE'
 461   dq LIT, here
 462   dq EXIT
 463
 464 forth COMMA, ','
 465   dq HERE, GET, PUT             ; Set the memory at the address pointed to by HERE
 466   dq HERE, GET, LIT, 8, PLUS    ; Calculate new address for HERE to point to
 467   dq HERE, PUT                  ; Update HERE to point to the new address
 468   dq EXIT
 469
 470 ;; Read user input until next " character is found. Push a string containing the
 471 ;; input on the stack as (buffer length). Note that the buffer is only valid
 472 ;; until the next call to S" and that no more than 255 character can be read.
 473 forth_asm READ_STRING, 'S"'
 474   push rsi
 475
 476   mov [.length], 0
 477
 478 .read_char:
 479   mov rax, 0
 480   mov rdi, 0
 481   mov rsi, .char_buffer
 482   mov rdx, 1
 483   syscall
 484
 485   mov al, [.char_buffer]
 486   cmp al, '"'
 487   je .done
 488
 489   mov rdx, .buffer
 490   add rdx, [.length]
 491   mov [rdx], al
 492   inc [.length]
 493   jmp .read_char
 494
 495 .done:
 496   pop rsi
 497
 498   push .buffer
 499   push [.length]
 500
 501   next
 502
 503 ;; CREATE inserts a new header in the dictionary, and updates LATEST so that it
 504 ;; points to the header. To compile a word, the user can then call ',' to
 505 ;; continue to append data after the header.
 506 ;;
 507 ;; It takes the name of the word as a string (address length) on the stack.
 508 forth_asm CREATE, 'CREATE'
 509   pop rcx                       ; Word string length
 510   pop rdx                       ; Word string pointer
 511
 512   mov rdi, [here]               ; rdi = Address at which to insert this entry
 513   mov rax, [latest_entry]       ; rax = Address of the previous entry
 514   mov [rdi], rax                ; Insert link to previous entry
 515   mov [latest_entry], rdi       ; Update LATEST to point to this word
 516
 517   add rdi, 8
 518   mov [rdi], byte 0             ; Insert immediate flag
 519
 520   add rdi, 1
 521   mov [rdi], byte cl            ; Insert length
 522
 523   ;; Insert word string
 524   add rdi, 1
 525
 526   push rsi
 527   mov rsi, rdx                  ; rsi = Word string pointer
 528   rep movsb
 529   pop rsi
 530
 531   ;; Update HERE
 532   mov [here], rdi
 533
 534   next
 535
 536 ;; Mark the last added word as immediate.
 537 forth IMMEDIATE, 'IMMEDIATE', 1
 538   dq LIT, 1
 539   dq LATEST, GET
 540   dq LIT, 8, PLUS
 541   dq PUT_BYTE
 542   dq EXIT
 543
 544 ;; Given the address of a word, return 0 if the given word is not immediate.
 545 forth IS_IMMEDIATE, 'IMMEDIATE?'
 546   dq LIT, 8, PLUS
 547   dq GET_BYTE
 548   dq EXIT
 549
 550 ;; Enter immediate mode, immediately
 551 forth INTO_IMMEDIATE, '[', 1
 552   dq LIT, 0, STATE, PUT_BYTE
 553   dq EXIT
 554
 555 ;; Enter compilation mode
 556 forth OUTOF_IMMEDIATE, ']'
 557   dq LIT, 1, STATE, PUT_BYTE
 558   dq EXIT
 559
 560 forth MAIN, 'MAIN'
 561   dq HELLO
 562   dq INTERPRET
 563   dq BRANCH, -8 * 2
 564   dq TERMINATE
 565
 566 segment readable writable
 567
 568 ;; The LATEST variable holds a pointer to the word that was last added to the
 569 ;; dictionary. This pointer is updated as new words are added, and its value is
 570 ;; used by FIND to look up words.
 571 latest_entry dq initial_latest_entry
 572
 573 ;; The STATE variable is 0 when the interpreter is executing, and non-zero when
 574 ;; it is compiling.
 575 var_STATE dq 0
 576
 577 FIND.rsi dq ?
 578
 579 READ_WORD.rsi dq ?
 580 READ_WORD.rbp dq ?
 581
 582 READ_STRING.char_buffer db ?
 583 READ_STRING.buffer rb $FF
 584 READ_STRING.length dq ?
 585
 586 DOTU.chars db '0123456789ABCDEF'
 587 DOTU.buffer rq 16               ; 64-bit number has no more than 16 digits in hex
 588 DOTU.rbuffer rq 16
 589 DOTU.length dq ?
 590 DOTU.printed_length dq ?
 591
 592 ;; Reserve space for compiled words, accessed through HERE.
 593 here dq here_top
 594 here_top rq $2000
 595
 596 ;; Return stack
 597 rq $2000
 598 return_stack_top: