jonesforth.S.9

   1 /* A minimal FORTH interpreter for Linux / i386 systems. -*- asm -*-
   2  * By Richard W.M. Jones <rich@annexia.org>
   3  *
   4  * gcc -m32 -nostdlib -static -Wl,-Ttext,0 -o jonesforth jonesforth.S
   5  */
   6
   7 #include <asm-i386/unistd.h>
   8
   9 /* NOTES-------------------------------------------------------------------------------------------------------------------
  10
  11 Need to say something about $ before constants.
  12
  13 And about je/jne/ja/jb/jbe/etc
  14
  15
  16
  17
  18 */
  19
  20 /* NEXT macro. */
  21         .macro NEXT
  22         lodsl
  23         jmp *(%eax)
  24         .endm
  25
  26 /* Macros to deal with the return stack. */
  27         .macro PUSHRSP reg
  28         lea -4(%ebp),%ebp       // push reg on to return stack
  29         movl \reg,(%ebp)
  30         .endm
  31
  32         .macro POPRSP reg
  33         mov (%ebp),\reg         // pop top of return stack to reg
  34         lea 4(%ebp),%ebp
  35         .endm
  36
  37 /* ELF entry point. */
  38         .text
  39         .globl _start
  40 _start:
  41         cld
  42         mov $return_stack,%ebp  // Initialise the return stack.
  43
  44         mov $cold_start,%esi    // Initialise interpreter.
  45         NEXT                    // Run interpreter!
  46
  47         .section .rodata
  48 cold_start:                     // High-level code without a codeword.
  49         .int COLD
  50
  51 /* DOCOL - the interpreter! */
  52         .text
  53         .align 4
  54 DOCOL:
  55         PUSHRSP %esi            // push %esi on to the return stack
  56         addl $4,%eax            // %eax points to codeword, so make
  57         movl %eax,%esi          // %esi point to first data word
  58         NEXT
  59
  60 /*----------------------------------------------------------------------
  61  * Fixed sized buffers for everything.
  62  */
  63         .bss
  64
  65 /* FORTH return stack. */
  66 #define RETURN_STACK_SIZE 8192
  67         .align 4096
  68         .space RETURN_STACK_SIZE
  69 return_stack:
  70
  71 /* Space for user-defined words. */
  72 #define USER_DEFS_SIZE 16384
  73         .align 4096
  74 user_defs_start:
  75         .space USER_DEFS_SIZE
  76
  77
  78
  79
  80
  81
  82 /*----------------------------------------------------------------------
  83  * Built-in words defined the long way.
  84  */
  85 #define F_IMMED 0x80
  86 #define F_HIDDEN 0x20
  87
  88         // Store the chain of links.
  89         .set link,0
  90
  91         .macro defcode name, namelen, flags=0, label
  92         .section .rodata
  93         .align 4
  94         .globl name_\label
  95 name_\label :
  96         .int link               // link
  97         .set link,name_\label
  98         .byte \flags+\namelen   // flags + length byte
  99         .ascii "\name"          // the name
 100         .align 4
 101         .globl \label
 102 \label :
 103         .int code_\label        // codeword
 104         .text
 105         .align 4
 106         .globl code_\label
 107 code_\label :                   // assembler code follows
 108         .endm
 109
 110         .macro defword name, namelen, flags=0, label
 111         .section .rodata
 112         .align 4
 113         .globl name_\label
 114 name_\label :
 115         .int link               // link
 116         .set link,name_\label
 117         .byte \flags+\namelen   // flags + length byte
 118         .ascii "\name"          // the name
 119         .align 4
 120         .globl \label
 121 \label :
 122         .int DOCOL              // codeword - the interpreter
 123         // list of word pointers follow
 124         .endm
 125
 126         .macro defvar name, namelen, flags=0, label, initial=0
 127         defcode \name,\namelen,\flags,\label
 128         push $var_\name
 129         NEXT
 130         .data
 131         .align 4
 132 var_\name :
 133         .int \initial
 134         .endm
 135
 136         // Some easy ones, written in assembly for speed
 137         defcode "DROP",4,,DROP
 138         pop %eax                // drop top of stack
 139         NEXT
 140
 141         defcode "DUP",3,,DUP
 142         pop %eax                // duplicate top of stack
 143         push %eax
 144         push %eax
 145         NEXT
 146
 147         defcode "SWAP",4,,SWAP
 148         pop %eax                // swap top of stack
 149         pop %ebx
 150         push %eax
 151         push %ebx
 152         NEXT
 153
 154         defcode "OVER",4,,OVER
 155         mov 4(%esp),%eax        // get the second element of stack
 156         push %eax               // and push it on top
 157         NEXT
 158
 159         // COLD must not return (ie. must not call EXIT).
 160         defword "COLD",4,,COLD
 161         // XXX reinitialisation of the interpreter
 162         .int INTERPRETER        // call the interpreter loop (never returns)
 163         .int LIT,1,SYSEXIT      // hmmm, but in case it does, exit(1).
 164
 165         defcode "EXIT",4,,EXIT
 166         POPRSP %esi             // pop return stack into %esi
 167         NEXT
 168
 169         defcode "LIT",3,,LIT
 170         // %esi points to the next command, but in this case it points to the next
 171         // literal 32 bit integer.  Get that literal into %eax and increment %esi.
 172         // On x86, it's a convenient single byte instruction!  (cf. NEXT macro)
 173         lodsl
 174         push %eax               // push the literal number on to stack
 175         NEXT
 176
 177 #if 0
 178         defcode "0SKIP",5,,ZSKIP
 179         // If the top of stack is zero, skip the next instruction.
 180         pop %eax
 181         test %eax,%eax
 182         jnz 1f
 183         lodsl                   // this does the skip
 184 1:      NEXT
 185 #endif
 186
 187         defcode "!",1,,STORE
 188         pop %ebx                // address to store at
 189         pop %eax                // data to store there
 190         mov %eax,(%ebx)         // store it
 191         NEXT
 192
 193         defcode "@",1,,FETCH
 194         pop %ebx                // address to fetch
 195         mov (%ebx),%eax         // fetch it
 196         push %eax               // push value onto stack
 197         NEXT
 198
 199         // The STATE variable is 0 for execute mode, != 0 for compile mode
 200         defvar "STATE",5,,STATE
 201
 202         // This points to where compiled words go.
 203         defvar "HERE",4,,HERE,user_defs_start
 204
 205         // This is the last definition in the dictionary.
 206         defvar "LATEST",6,,LATEST,name_SYSEXIT // SYSEXIT must be last in built-in dictionary
 207
 208         // _X, _Y and _Z are scratch variables used by standard words.
 209         defvar "_X",2,,TX
 210         defvar "_Y",2,,TY
 211         defvar "_Z",2,,TZ
 212
 213         defcode ">R",2,,TOR
 214         pop %eax                // pop parameter stack into %eax
 215         PUSHRSP %eax            // push it on to the return stack
 216         NEXT
 217
 218         defcode "R>",2,,FROMR
 219         POPRSP %eax             // pop return stack on to %eax
 220         push %eax               // and push on to parameter stack
 221         NEXT
 222
 223         defcode "RSP@",4,,RSPFETCH
 224         push %ebp
 225         NEXT
 226
 227         defcode "RSP!",4,,RSPSTORE
 228         pop %ebp
 229         NEXT
 230
 231         defcode "RDROP",5,,RDROP
 232         lea 4(%ebp),%ebp        // pop return stack and throw away
 233         NEXT
 234
 235         defcode "KEY",3,,KEY
 236         call _KEY
 237         push %eax               // push return value on stack
 238         NEXT
 239 _KEY:
 240         mov (currkey),%ebx
 241         cmp (bufftop),%ebx
 242         jge 1f
 243         xor %eax,%eax
 244         mov (%ebx),%al
 245         inc %ebx
 246         mov %ebx,(currkey)
 247         ret
 248
 249 1:      // out of input; use read(2) to fetch more input from stdin
 250         xor %ebx,%ebx           // 1st param: stdin
 251         mov $buffer,%ecx        // 2nd param: buffer
 252         mov %ecx,currkey
 253         mov $buffend-buffer,%edx // 3rd param: max length
 254         mov $__NR_read,%eax     // syscall: read
 255         int $0x80
 256         test %eax,%eax          // If %eax <= 0, then exit.
 257         jbe 2f
 258         addl %eax,%ecx          // buffer+%eax = bufftop
 259         mov %ecx,bufftop
 260         jmp _KEY
 261
 262 2:      // error or out of input: exit
 263         xor %ebx,%ebx
 264         mov $__NR_exit,%eax     // syscall: exit
 265         int $0x80
 266
 267         defcode "EMIT",4,,EMIT
 268         pop %eax
 269         call _EMIT
 270         NEXT
 271 _EMIT:
 272         mov $1,%ebx             // 1st param: stdout
 273
 274         // write needs the address of the byte to write
 275         mov %al,(2f)
 276         mov $2f,%ecx            // 2nd param: address
 277
 278         mov $1,%edx             // 3rd param: nbytes = 1
 279
 280         mov $__NR_write,%eax    // write syscall
 281         int $0x80
 282         ret
 283
 284         .bss
 285 2:      .space 1                // scratch used by EMIT
 286
 287         defcode "WORD",4,,WORD
 288         call _WORD
 289         push %ecx               // push length
 290         push %edi               // push base address
 291         NEXT
 292
 293 _WORD:
 294         /* Search for first non-blank character.  Also skip \ comments. */
 295 1:
 296         call _KEY               // get next key, returned in %eax
 297         cmpb $'\\',%al          // start of a comment?
 298         je 3f                   // if so, skip the comment
 299         cmpb $' ',%al
 300         jbe 1b                  // if so, keep looking
 301
 302         /* Search for the end of the word, storing chars as we go. */
 303         mov $5f,%edi            // pointer to return buffer
 304 2:
 305         stosb                   // add character to return buffer
 306         call _KEY               // get next key, returned in %al
 307         cmpb $' ',%al           // is blank?
 308         ja 2b                   // if not, keep looping
 309
 310         /* Return the word (well, the static buffer) and length. */
 311         sub $5f,%edi
 312         mov %edi,%ecx           // return length of the word
 313         mov $5f,%edi            // return address of the word
 314         ret
 315
 316         /* Code to skip \ comments to end of the current line. */
 317 3:
 318         call _KEY
 319         cmpb $'\n',%al          // end of line yet?
 320         jne 3b
 321         jmp 1b
 322
 323         .bss
 324         // A static buffer where WORD returns.  Subsequent calls
 325         // overwrite this buffer.  Maximum word length is 32 chars.
 326 5:      .space 32
 327
 328         defcode "EMITWORD",8,,EMITWORD
 329         mov $1,%ebx             // 1st param: stdout
 330         pop %ecx                // 2nd param: address of string
 331         pop %edx                // 3rd param: length of string
 332
 333         mov $__NR_write,%eax    // write syscall
 334         int $0x80
 335
 336         NEXT
 337
 338         defcode ".",1,,DOT
 339         pop %eax                // Get the number to print into %eax
 340         call _DOT               // Easier to do this recursively ...
 341         NEXT
 342 _DOT:
 343         mov $10,%ecx            // Base 10
 344         cmp %ecx,%eax
 345         jb 1f
 346         pushl %eax
 347         xor %edx,%edx
 348         idivl %ecx
 349         call _DOT
 350         popl %eax
 351 1:
 352         aam $10
 353         cbw
 354         cwde
 355         addl $'0',%eax
 356         call _EMIT
 357         ret
 358
 359         // Parse a number from a string on the stack -- almost the opposite of . (DOT)
 360         // Note that there is absolutely no error checking.  In particular the length of the
 361         // string must be >= 1 bytes.
 362         defcode "SNUMBER",7,,SNUMBER
 363         pop %edi
 364         pop %ecx
 365         call _SNUMBER
 366         push %eax
 367         NEXT
 368 _SNUMBER:
 369         xor %eax,%eax
 370         xor %ebx,%ebx
 371 1:
 372         imull $10,%eax          // %eax *= 10
 373         movb (%edi),%bl
 374         inc %edi
 375         subb $'0',%bl           // ASCII -> digit
 376         add %ebx,%eax
 377         dec %ecx
 378         jnz 1b
 379         ret
 380
 381         defcode "FIND",4,,FIND
 382         pop %edi                // %edi = address
 383         pop %ecx                // %ecx = length
 384         call _FIND
 385         push %eax
 386         NEXT
 387
 388 _FIND:
 389         push %esi               // Save %esi so we can use it in string comparison.
 390
 391         // Now we start searching backwards through the dictionary for this word.
 392         mov var_LATEST,%edx     // LATEST points to name header of the latest word in the dictionary
 393 1:
 394         test %edx,%edx          // NULL pointer?  (end of the linked list)
 395         je 4f
 396
 397         // Compare the length expected and the length of the word.
 398         // Note that if the F_HIDDEN flag is set on the word, then by a bit of trickery
 399         // this won't pick the word (the length will appear to be wrong).
 400         xor %eax,%eax
 401         movb 4(%edx),%al        // %al = flags+length field
 402         andb $(F_HIDDEN|0x1f),%al // %al = name length
 403         cmpb %cl,%al            // Length is the same?
 404         jne 2f
 405
 406         // Compare the strings in detail.
 407         push %ecx               // Save the length
 408         push %edi               // Save the address (repe cmpsb will move this pointer)
 409         lea 5(%edx),%esi        // Dictionary string we are checking against.
 410         repe cmpsb              // Compare the strings.
 411         pop %edi
 412         pop %ecx
 413         jne 2f                  // Not the same.
 414
 415         // The strings are the same - return the header pointer in %eax
 416         pop %esi
 417         mov %edx,%eax
 418         ret
 419
 420 2:
 421         mov (%edx),%edx         // Move back through the link field to the previous word
 422         jmp 1b                  // .. and loop.
 423
 424 4:      // Not found.
 425         pop %esi
 426         xor %eax,%eax           // Return zero to indicate not found.
 427         ret
 428
 429         defcode ">CFA",4,,TCFA  // DEA -> Codeword address
 430         pop %edi
 431         call _TCFA
 432         push %edi
 433         NEXT
 434 _TCFA:
 435         xor %eax,%eax
 436         add $4,%edi             // Skip link pointer.
 437         movb (%edi),%al         // Load flags+len into %al.
 438         inc %edi                // Skip flags+len byte.
 439         andb $0x1f,%al          // Just the length, not the flags.
 440         add %eax,%edi           // Skip the name.
 441         addl $3,%edi            // The codeword is 4-byte aligned.
 442         andl $~3,%edi
 443         ret
 444
 445 #if 0
 446         defword "'",1,,TICK
 447         .int WORD               // Get the following word.
 448         .int FIND               // Look it up in the dictionary.
 449         .int DUP                // If not found, skip >CFA (TCFA) instruction.
 450         .int ZSKIP
 451         .int TCFA               // Convert to a codeword pointer.
 452         .int EXIT               // Return.
 453 #endif
 454
 455         defcode ":",1,,COLON
 456
 457         // Get the word and create a dictionary entry header for it.
 458         call _WORD              // Returns %ecx = length, %edi = pointer to word.
 459         mov %edi,%ebx           // %ebx = address of the word
 460
 461         movl var_HERE,%edi      // %edi is the address of the header
 462         movl var_LATEST,%eax    // Get link pointer
 463         stosl                   // and store it in the header.
 464
 465         mov %cl,%al             // Get the length.
 466         orb $F_HIDDEN,%al       // Set the HIDDEN flag on this entry.
 467         stosb                   // Store the length/flags byte.
 468         push %esi
 469         mov %ebx,%esi           // %esi = word
 470         rep movsb               // Copy the word
 471         pop %esi
 472         addl $3,%edi            // Align to next 4 byte boundary.
 473         andl $~3,%edi
 474
 475         movl $DOCOL,%eax        // The codeword for user-created words is always DOCOL (the interpreter)
 476         stosl
 477
 478         // Header built, so now update LATEST and HERE.
 479         // We'll be compiling words and putting them HERE.
 480         movl var_HERE,%eax
 481         movl %eax,var_LATEST
 482         movl %edi,var_HERE
 483
 484         // And go into compile mode by setting STATE to 1.
 485         xor %eax,%eax
 486         inc %eax
 487         mov %eax,var_STATE
 488         NEXT
 489
 490         defcode ",",1,,COMMA
 491         pop %eax                // Code pointer to store.
 492         call _COMMA
 493         NEXT
 494 _COMMA:
 495         movl var_HERE,%edi      // HERE
 496         stosl                   // Store it.
 497         movl %edi,var_HERE      // Update HERE (incremented)
 498         ret
 499
 500         defcode "HIDDEN",6,,HIDDEN
 501         call _HIDDEN
 502         NEXT
 503 _HIDDEN:
 504         movl var_LATEST,%edi    // LATEST word.
 505         addl $4,%edi            // Point to name/flags byte.
 506         xorb $F_HIDDEN,(%edi)   // Toggle the HIDDEN bit.
 507         ret
 508
 509         defcode "IMMEDIATE",9,F_IMMED,IMMEDIATE
 510         call _IMMEDIATE
 511         NEXT
 512 _IMMEDIATE:
 513         movl var_LATEST,%edi    // LATEST word.
 514         addl $4,%edi            // Point to name/flags byte.
 515         xorb $F_IMMED,(%edi)    // Toggle the IMMED bit.
 516         ret
 517
 518         defcode ";",1,F_IMMED,SEMICOLON
 519         movl $EXIT,%eax         // EXIT is the final codeword in compiled words.
 520         call _COMMA             // Store it.
 521         call _HIDDEN            // Toggle the HIDDEN flag (unhides the new word).
 522         xor %eax,%eax           // Set STATE to 0 (back to execute mode).
 523         movl %eax,var_STATE
 524         NEXT
 525
 526 /* This interpreter is pretty simple, but remember that in FORTH you can always override
 527  * it later with a more powerful one!
 528  */
 529         defword "INTERPRETER",11,,INTERPRETER
 530         .int INTERPRET,RDROP,INTERPRETER
 531
 532         defcode "INTERPRET",9,,INTERPRET
 533         call _WORD              // Returns %ecx = length, %edi = pointer to word.
 534
 535         // Is it in the dictionary?
 536         call _FIND              // Returns %eax = pointer to header or 0 if not found.
 537         test %eax,%eax          // Found?
 538         jz 1f
 539
 540         // In the dictionary.  Is it an IMMEDIATE codeword?
 541         mov %eax,%edi           // %edi = dictionary entry
 542         movb 4(%edi),%al        // Get name+flags.
 543         push %ax                // Just save it for now.
 544         call _TCFA              // Convert dictionary entry (in %edi) to codeword pointer.
 545         pop %ax
 546         andb $F_IMMED,%al       // Is IMMED flag set?
 547         mov %edi,%eax
 548         jnz 3f                  // If IMMED, jump straight to executing.
 549
 550         jmp 2f
 551
 552 1:      // Not in the dictionary (not a word) so assume it's a number.
 553         call _SNUMBER           // Returns the parsed number in %eax
 554         mov %eax,%ebx
 555         mov $LIT,%eax           // The word is LIT
 556
 557 2:      // Are we compiling or executing?
 558         movl var_STATE,%edx
 559         test %edx,%edx
 560         jz 3f                   // Jump if executing.
 561
 562         // Compiling - just append the word to the current dictionary definition.
 563         call _COMMA
 564         cmp $LIT,%eax           // Was it LIT?
 565         jne 4f
 566         mov %ebx,%eax           // Yes, so LIT is followed by a number.
 567         call _COMMA
 568         NEXT
 569
 570 3:      // Executing - run it!
 571         cmp $LIT,%eax           // Literal?
 572         je 4f
 573         // Not a literal, execute it now.  This never returns, but the codeword will
 574         // eventually call NEXT which will reenter the loop in INTERPRETER.
 575         jmp *(%eax)
 576
 577 4:      // Executing a literal, which means push it on the stack.
 578         push %ebx
 579         NEXT
 580
 581         // NB: SYSEXIT must be the last entry in the built-in dictionary.
 582         defcode SYSEXIT,7,,SYSEXIT
 583         pop %ebx
 584         mov $__NR_exit,%eax
 585         int $0x80
 586
 587 /*----------------------------------------------------------------------
 588  * Input buffer & initial input.
 589  */
 590         .data
 591         .align 4096
 592 buffer:
 593         // XXX gives 'Warning: unterminated string; newline inserted' messages which you can ignore
 594         .ascii "\
 595 \\ Define some character constants
 596 : '\\n'   10 ;
 597 : 'SPACE' 32 ;
 598 : '\"'    34 ;
 599
 600 \\ CR prints a carriage return
 601 : CR '\\n' EMIT ;
 602
 603 \\ SPACE prints a space
 604 : SPACE 'SPACE' EMIT ;
 605
 606 \\ Primitive . (DOT) function doesn't follow with a blank, so redefine it to behave like FORTH.
 607 \\ Notice how we can trivially redefine existing functions.
 608 : . . SPACE ;
 609
 610 \\ XXX SPACES
 611
 612 \\ DUP, DROP are defined in assembly for speed, but this is how you might define them
 613 \\ in FORTH.  Notice use of the scratch variables _X and _Y.
 614 \\ : DUP _X ! _X @ _X @ ;
 615 \\ : DROP _X ! ;
 616
 617
 618
 619 \\ Finally print the welcome prompt.
 620 79 EMIT 75 EMIT 'SPACE' EMIT
 621 "
 622
 623 _initbufftop:
 624         .align 4096
 625 buffend:
 626
 627 currkey:
 628         .int buffer
 629 bufftop:
 630         .int _initbufftop