main.asm

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