revise the input system to better align with ANS FORTH

jumpforth.S

@@ -6,7 +6,6 @@
 
 .set JUMPFORTH_VERSION,1
 
-.set BUFFER_SIZE,4096
 .set RETURN_STACK_SIZE,8192
 
 .set DATA_SEGMENT_INITIAL_SIZE,65536
@@ -185,9 +184,6 @@ defconst VERSION,JUMPFORTH_VERSION
 
 defconst R0,return_stack_top
 
-defconst BUFFER,buffer
-defconst __BUFFER_SIZE,BUFFER_SIZE,"BUFFER_SIZE"
-
 defconst __DOCOL,DOCOL,"DOCOL"
 defconst __DODATA,DODATA,"DODATA"
 defconst __DOLOAD,DOLOAD,"DOLOAD"
@@ -616,13 +612,11 @@ defconst SIGABRT,6
 defvalue C0     /* first byte of the heap */
 defvalue S0     /* initial (empty) data stack pointer */
 
-/* STATE controls whether we are currently executing code (0) or compiling (1) */
+/* STATE controls whether we are currently interpreting (0) or compiling (1) */
-defvar STATE,0  /* default to executing code */
+defvar STATE,0  /* default to interpreting */
 
-/* Initially the KEY function "reads" the embedded file "startup.4th". */
+/* >IN gives the current offset of the parse area within the input buffer */
-/* When this is exhausted the pointers are reset to point to the input buffer. */
+defvar IN,0,">IN"
-defvar CURRKEY,startup_defs
-defvar BUFFTOP,startup_defs_end
 
 /* NOTE: These are initialized in _start but vary during runtime. */
 defvar CP       /* "compilation pointer", next free byte in the heap */
@@ -1051,7 +1045,7 @@ defcode FILL
    rep stosb
    NEXT
 
-/* ( src dst n -- ) ( block copy n bytes from src to dst ) */
+/* ( src dst n -- ) Block copy n bytes from src to dst (ascending addresses) */
 defcode CMOVE
    mov %esi,%edx
    pop %ecx
@@ -1061,6 +1055,20 @@ defcode CMOVE
    mov %edx,%esi
    NEXT
 
+/* ( src dst n -- ) Block copy n bytes from src to dst (descending addresses) */
+defcode CMOVE_UP,"CMOVE>"
+   mov %esi,%edx
+   pop %ecx
+   pop %edi
+   pop %esi
+   lea -1(%edi,%ecx),%edi
+   lea -1(%esi,%ecx),%esi
+   std
+   rep movsb
+   cld
+   mov %edx,%esi
+   NEXT
+
 /* ( a -- ) ( R: -- a ) */
 defcode TOR,">R"
    pop %eax
@@ -1101,7 +1109,7 @@ defcode TWOFROMR,"2R>"
    push %ebx
    NEXT
 
-/* (R: a b -- a b ) ( -- a b ) */
+/* ( R: a b -- a b ) ( -- a b ) */
 defcode TWORFETCH,"2R@"
    movl (%ebp),%ebx
    movl 4(%ebp),%eax
@@ -1109,27 +1117,77 @@ defcode TWORFETCH,"2R@"
    push %ebx
    NEXT
 
+/* ( xu ... x1 u -- ) ( R: -- xu ... x1 u ) */
+defcode NTOR,"N>R"
+   mov %esi,%edx
+   movl (%esp),%ecx
+   add $1,%ecx
+   mov %ecx,%ebx
+   shl $2,%ebx
+   sub %ebx,%ebp
+   mov %esp,%esi
+   mov %ebp,%edi
+   rep movsd
+   mov %esi,%esp
+   mov %edx,%esi
+   NEXT
+
+/* ( R: xu ... x1 u -- ) ( -- xu ... x1 u ) */
+defcode NFROMR,"NR>"
+   mov %esi,%edx
+   movl (%ebp),%ecx
+   add $1,%ecx
+   mov %ecx,%ebx
+   shl $2,%ebx
+   sub %ebx,%esp
+   mov %ebp,%esi
+   mov %esp,%edi
+   rep movsd
+   mov %esi,%ebp
+   mov %edx,%esi
+   NEXT
+
+/* ( R: xu ... x1 u -- xu ... x1 u ) ( -- xu ... x1 u ) */
+defcode NRFETCH,"NR@"
+   mov %esi,%edx
+   movl (%ebp),%ecx
+   add $1,%ecx
+   mov %ecx,%ebx
+   shl $2,%ebx
+   sub %ebx,%esp
+   mov %ebp,%esi
+   mov %esp,%edi
+   rep movsd
+   mov %edx,%esi
+   NEXT
+
+/* ( -- a-addr ) */
 defcode RSPFETCH,"RSP@"
    push %ebp
    NEXT
 
+/* ( a-addr -- ) */
 defcode RSPSTORE,"RSP!"
    pop %ebp
    NEXT
 
+/* ( R: x -- ) */
 defcode RDROP
    addl $4,%ebp
    NEXT
 
+/* ( R: a b -- ) */
 defcode TWORDROP,"2RDROP"
    addl $8,%ebp
    NEXT
 
+/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
 defcode SPFETCH,"SP@"
    mov %esp,%eax
    push %eax
    NEXT
 
+/* ( a-addr -- ) Set the data stack pointer */
 defcode SPSTORE,"SP!"
    pop %esp
    NEXT
@@ -1257,12 +1315,17 @@ defcode BREAK
    .section .data
 bootstrap_data_begin:
 
+/* ( c-addr u -- "ccc" ) */
 defword TYPE
    .int LIT,1,NROT,SYS_WRITE,SYSCALL3,DROP,EXIT
 
+/* ( c -- "c" ) */
+defword EMIT
+   .int SPFETCH,LIT,1,SWAP,LIT,1,SYS_WRITE,SYSCALL3,TWODROP,EXIT
+
+/* ( -- "<eol>" ) */
 defword EOL
-   litstring "\n"
+   .int LIT,10,EMIT,EXIT
-   .int TYPE,EXIT
 
 /* Used for any fatal errors that occur during bootstrapping */
 defword BAILOUT
@@ -1271,33 +1334,43 @@ defword BAILOUT
    .int TYPE
 0: .int LIT,254,SYS_EXIT,SYSCALL1,DROP,BRANCH,(0b - .)
 
-/* Simplified KEY that can only read from the pre-filled input buffer */
+defword UNEXPECTED_EOF,"UNEXPECTED-EOF"
-/* The startup.4th should replace this with a more complete version */
+   litstring "Unexpected end of input\n"
-/* If the input ends while this version is still in use the program will terminate */
-defword KEY
-   .int CURRKEY,FETCH,DUP,BUFFTOP,FETCH,GE,ZBRANCH,(1f - .)
-   litstring "Unexpected end of buffer\n"
    .int TYPE,BAILOUT
-1: .int DUP,ADD1,CURRKEY,STORE,FETCHBYTE,EXIT
 
-/* Puts the most recently read key back in the input buffer */
+/* During bootstrapping the source buffer is the embedded file "startup.4th". */
-/* CAUTION: Can only safely be used ONCE after each call to KEY! */
+/* ( -- c-addr u ) */
-defword PUTBACK
+defword SOURCE
-   .int CURRKEY,FETCH,SUB1,CURRKEY,STORE,EXIT
+   .int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT
 
+/* ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) */
+defword DROP_PREFIX,"DROP-PREFIX"
+   .int ROT,OVER,ADD,NROT,SUB,EXIT
+
+/* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */
+defword PARSE_AREA,"PARSE-AREA"
+   .int SOURCE,IN,FETCH,DROP_PREFIX,EXIT
+
+/* ( "c" -- c ) Leaves c at the start of the parse area */
+defword PEEK_CHAR,"PEEK-CHAR"
+   .int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT
+0: .int UNEXPECTED_EOF
+
+/* ( "c" -- c ) Removes and returns the first character in the parse area */
+defword NEXT_CHAR,"NEXT-CHAR"
+   .int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT
+
+/* ( c -- flag ) */
 defword ISSPACE,"SPACE?"
    /* check for space (32) first and return true if input matches */
    .int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
    /* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
 0: .int LIT,9,SUB,LIT,(13 - 9),ULT,EXIT
 
-defword SKIPSPACE
-0: .int KEY,ISSPACE,ZEQU,ZBRANCH,(0b - .),PUTBACK,EXIT
-
 /* Simplified version that can only work within the preallocated data region */
 /* The startup.4th should replace this with a more complete version */
 defword ALLOT
-   .int CP,FETCH,ADD,CP,STORE,EXIT
+   .int CP,INCREMENT,EXIT
 
 defword COMMA,","
    .int CP,FETCH,CELL,ALLOT,STORE,EXIT
@@ -1399,19 +1472,47 @@ defword FIND_OR_ABORT,"FIND-OR-ABORT"
 0: litstring "Word not found: "
    .int TYPE,TYPE,EOL,BAILOUT
 
+/* ( "<spaces>" -- ) */
+defword SKIPSPACE
+0: .int PARSE_AREA,ZBRANCH,(1f - .)
+   .int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
+   .int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
+1: .int DROP
+2: .int EXIT
+
+/* ( "<spaces?>ccc" -- c-addr u ) */
 defword WORD
-   .int SKIPSPACE,CP,FETCH
+   .int SKIPSPACE
-0: .int KEY,DUP,ISSPACE,ZBRANCH,(1f - .)
+   .int PARSE_AREA,DROP,LIT,1
-   .int DROP,PUTBACK,CP,FETCH,OVER,SUB,OVER,CP,STORE,EXIT
+   .int NEXT_CHAR,DROP
-1: .int COMMABYTE,BRANCH,(0b - .)
+0: .int PARSE_AREA,ZBRANCH,(1f - .)
+   .int FETCHBYTE,ISSPACE,ZEQU,ZBRANCH,(2f - .)
+   .int ADD1,LIT,1,IN,INCREMENT,BRANCH,(0b - .)
+1: .int DROP
+2: .int EXIT
+
+defword ESCAPED_CHAR
+   .int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
+0: .int DROP,NEXT_CHAR
+   .int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
+0: .int LIT,'a',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,7,EXIT
+0: .int LIT,'b',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,8,EXIT
+0: .int LIT,'t',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,9,EXIT
+0: .int LIT,'n',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,10,EXIT
+0: .int LIT,'v',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,11,EXIT
+0: .int LIT,'f',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,12,EXIT
+0: .int LIT,'r',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,13,EXIT
+0: .int LIT,34,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,34,EXIT /* double-quote */
+0: .int LIT,39,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,39,EXIT /* single-quote */
+0: .int LIT,92,OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,92,EXIT /* backslash */
+0: litstring "Unknown escape sequence: \\"
+   .int TYPE,EMIT,EOL,BAILOUT
 
 defword READSTRING
    .int CP,FETCH
-0: .int KEY,DUP,LIT,'\\',EQU,ZBRANCH,(1f - .)
+0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
-   .int DROP,KEY,BRANCH,(2f - .)
+   .int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .)
-1: .int DUP,LIT,'"',EQU,ZBRANCH,(2f - .)
+1: .int LIT,1,IN,INCREMENT,CP,FETCH,OVER,SUB,ALIGN,EXIT
-   .int DROP,CP,FETCH,OVER,SUB,ALIGN,EXIT
-2: .int COMMABYTE,BRANCH,(0b - .)
 
 defword PARSENUMBER
    .int DUP,LIT,0,GT,ZBRANCH,(6f - .)
@@ -1431,15 +1532,15 @@ defword PARSENUMBER
 
 defword INTERPRET
    .int SKIPSPACE
-   .int KEY,LIT,'"',EQU,ZBRANCH,(1f - .)
+   .int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
+   .int   LIT,1,IN,INCREMENT
    .int   STATE,FETCH,ZBRANCH,(0f - .)
    .int     LIT,LITSTRING,COMMA,CP,FETCH,LIT,0,COMMABYTE
    .int     READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT
    /*     ELSE */
 0: .int     READSTRING,EXIT
    /*   ELSE */
-1: .int   PUTBACK,LIT,64,ALLOT,WORD,LIT,-64,ALLOT
+1: .int   WORD,TWODUP,PARSENUMBER,ZBRANCH,(3f - .)
-   .int   TWODUP,PARSENUMBER,ZBRANCH,(3f - .)
    .int     NROT,TWODROP
    .int     STATE,FETCH,ZBRANCH,(2f - .)
    .int       LIT,LIT,COMMA,COMMA
@@ -1452,7 +1553,7 @@ defword INTERPRET
 4: .int       EXECUTE,EXIT
    /*       ELSE */
 5: .int       DUP,ISBOOTSTRAP,ZBRANCH,(6f - .)
-   litstring "Compiled bootstrap word: "
+   litstring "Tried to compile bootstrap word: "
    .int       TYPE,TNAME,TYPE,EOL,BAILOUT
 6: .int       COMMA,EXIT
 
@@ -1466,10 +1567,11 @@ defword CREATE
    .int LIT,DODATA,COMMA
    .int LIT,0,COMMA
    .int CURRENT,FETCH,FETCH,COMMA
-   .int LIT,0,COMMABYTE
+   .int WORD
-   .int WORD,NIP,DUP,ALLOT,ALIGN
+   .int DUP,COMMABYTE
-   .int OVER,TFLAGS,STOREBYTE
+   .int CP,FETCH,SWAP
-   .int CP,FETCH,OVER,TDFA,STORE
+   .int DUP,ALLOT,CMOVE
+   .int ALIGN,CP,FETCH,OVER,TDFA,STORE
    .int CURRENT,FETCH,STORE,EXIT
 
 /*
@@ -1484,10 +1586,10 @@ defword RBRACKET,"]",F_IMMED
    .int TRUE,STATE,STORE,EXIT
 
 defword SLASH,"\\",F_IMMED
-0: .int KEY,LIT,10,EQU,ZBRANCH,(0b - .),EXIT
+0: .int NEXT_CHAR,LIT,10,EQU,ZBRANCH,(0b - .),EXIT
 
 defword PAREN,"(",F_IMMED
-0: .int KEY,LIT,')',EQU,ZBRANCH,(0b - .),EXIT
+0: .int NEXT_CHAR,LIT,')',EQU,ZBRANCH,(0b - .),EXIT
 
 defword COLON,":"
    /* Make word & fetch address */
@@ -1521,6 +1623,12 @@ defword LITERAL,,F_IMMED
 defword COMPILE_QUOTE,"[']",F_IMMED
    .int QUOTE,LITERAL,EXIT
 
+defword CHAR
+   .int WORD,DROP,FETCHBYTE,EXIT
+
+defword COMPILE_CHAR,"[CHAR]",F_IMMED
+   .int CHAR,LITERAL,EXIT
+
 defword POSTPONE,,F_IMMED
    .int WORD,FIND_OR_ABORT,ZGT,ZBRANCH,(0f - .)
    .int LITERAL
@@ -1589,8 +1697,3 @@ startup_defs_end:
 return_stack:
    .space RETURN_STACK_SIZE
 return_stack_top:
-
-   .bss
-   .align 4096
-buffer:
-   .space BUFFER_SIZE

startup.4th

@@ -116,6 +116,40 @@
       SYS_GETPID SYSCALL0 SYS_GETTID SYSCALL0 SIGABRT SYS_TGKILL SYSCALL3 DROP
    AGAIN ;
 
+\ Display the unsigned number at the top of the stack
+: U. ( u -- "<digits>" )
+   \ Start with the highest place-value on the left
+   1000000000
+   \ Skip place-values that would be larger than the input
+   BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
+   \ Emit the remaining digits down to the units' place
+   BEGIN
+      TUCK U/MOD [CHAR] 0 + EMIT SWAP
+      DUP 1 U<= IF 2DROP EXIT THEN
+      10 U/
+   AGAIN ;
+
+\ Display the signed number at the top of the stack
+: . ( n -- "<minus?><digits>" )
+   DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
+
+\ Display the content of the data stack
+: .DS ( -- "<text>" )
+   SP@ S0
+   CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
+   BEGIN
+      CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
+   AGAIN ;
+
+\ Display the content of the return stack
+: .RS ( -- "<text>" )
+   \ Skip the topmost cell, which is the return address for the call to .RS
+   RSP@ CELL + R0
+   CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
+   BEGIN
+      CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
+   AGAIN ;
+
 \ Return the next address in the compilation/data area
 : HERE ( -- addr ) CP @ ;
 
@@ -184,6 +218,15 @@
 : ELSE ( C: orig1 -- orig2 ) IMMEDIATE
    POSTPONE AHEAD SWAP POSTPONE THEN ;
 
+\ Short-circuit logical operators
+\ Examples:
+\   <cond1> AND-THEN <cond2> THEN
+\   <cond1> OR-ELSE <cond2> THEN
+: AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | <dropped> ) IMMEDIATE
+   POSTPONE DUP POSTPONE IF POSTPONE DROP ;
+: OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | <dropped> ) IMMEDIATE
+   POSTPONE ?DUP POSTPONE 0= POSTPONE IF ;
+
 \ Unbounded loop: BEGIN <body> AGAIN
 \ BEGIN places the offset of the start of <code> on the stack.
 \ AGAIN creates a relative branch back to the start of <code>.
@@ -247,52 +290,116 @@
 : ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE
    POSTPONE DROP 0 DO POSTPONE THEN LOOP ;
 
-\ If the input buffer is empty, refill it from stdin
+SOURCE
-\ Return the next character from the input buffer
+CREATE INPUT-BUFFER-SIZE ,
-: KEY
+CREATE INPUT-BUFFER ,
-   CURRKEY @
-   DUP BUFFTOP @ >= IF
-      DROP BUFFER 0 OVER BUFFER_SIZE SYS_READ SYSCALL3
-      DUP 0<= IF
-         2DROP
-         BYE
-      THEN
-      OVER + BUFFTOP !
-   THEN
-   DUP 1+ CURRKEY ! C@
-;
 
-\ Puts the most recently read key back in the input buffer
+CREATE CURRENT-SOURCE-ID -1 ,
-\ CAUTION: Can only safely be used ONCE after each call to KEY!
-\ This takes advantage of the fact that the key is still in the buffer
-: PUTBACK CURRKEY @ 1- CURRKEY ! ;
 
-: SKIPSPACE BEGIN KEY SPACE? INVERT UNTIL PUTBACK ;
+: SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ;
+: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
+
+: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
+: RESTORE-INPUT ( xu ... x1 u -- ) OVER >IN ! NDROP ;
+
+\ The size of this buffer will determine the maximum line length
+4096 CONSTANT TERMINAL-BUFFER-SIZE
+CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
+
+CREATE TIB-LEFTOVER 0 ,
+CREATE TIB-LEFTOVER-SIZE 0 ,
+
+: REFILL ( -- flag )
+   SOURCE-ID 0< IF FALSE EXIT THEN
+   \ Shift any leftover characters after the previous line to the start of the buffer
+   TIB-LEFTOVER @ TERMINAL-BUFFER TIB-LEFTOVER-SIZE @ CMOVE
+   \ Look for the linefeed character which marks the end of the first line
+   TIB-LEFTOVER-SIZE @ 0 BEGIN
+      \ If at the end with room in the buffer, read more from the file descriptor
+      2DUP = IF
+         DUP TERMINAL-BUFFER-SIZE U< IF
+            \ SOURCE-ID is the file descriptor number to read from
+            SOURCE-ID OVER DUP TERMINAL-BUFFER + SWAP TERMINAL-BUFFER-SIZE SWAP -
+            ( S: length idx src-id buff buff-size )
+            \ Repeat read if interrupted by a signal (returns -EINTR)
+            BEGIN
+               SYS_READ SYSCALL3
+               DUP ERRNO_EINTR NEGATE <>
+            UNTIL
+            \ Any other negative (error) return value is fatal
+            DUP 0< IF
+               DROP "Error occurred while reading input\n" TYPE
+               FATAL-ERROR
+            THEN
+            ( S: length idx u-read )
+            \ Add the amount of data read to the length; index is unchanged
+            ROT + SWAP
+         THEN
+      THEN
+      \ At this point if index equals length then buffer is full or read returned 0
+      \ Either way, we won't be reading any more into the buffer
+      2DUP = OR-ELSE
+         \ Check if the next character is a linefeed
+         1+ DUP 1- TERMINAL-BUFFER + C@ LF =
+      THEN
+   UNTIL
+   ( S: length idx )
+   \ idx is the next location after the linefeed, if found, or else equal to length
+   \ Save the rest, if any, for the next REFILL
+   DUP TERMINAL-BUFFER + TIB-LEFTOVER !
+   TUCK - TIB-LEFTOVER-SIZE !
+   ( S: idx )
+   \ The new input buffer is the first idx characters of the terminal buffer
+   TERMINAL-BUFFER INPUT-BUFFER !
+   DUP INPUT-BUFFER-SIZE !
+   DUP IF 0 >IN ! THEN
+   0<> ;
+
+: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) ROT OVER + -ROT - ;
+
+: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
+
+: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
+
+: PEEK-CHAR ( -- c )
+   PARSE-AREA 0= IF
+      DROP "Unexpected end of input\n" TYPE
+      FATAL-ERROR
+   THEN C@ ;
+
+: SKIP-CHAR ( -- ) 1 >IN +! ;
+
+: NEXT-CHAR ( -- c ) PEEK-CHAR SKIP-CHAR ;
+
+: SKIPSPACE ( "<spaces?>" -- )
+   BEGIN
+      PARSE-EMPTY? 0= AND-THEN PEEK-CHAR SPACE? THEN
+   WHILE
+      SKIP-CHAR
+   REPEAT ;
+
+\ Comments; ignore all characters until the next EOL or ) character, respectively
+: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
+: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ;
 
 \ Skip whitespace; read and return the next word delimited by whitespace
-\ The word is stored in contiguous but *unallocated* data space
+\ The delimiting whitespace character is left in the parse area
-\ The delimiting whitespace character is left in the input buffer
 : WORD ( "<spaces>ccc" -- c-addr u )
    SKIPSPACE
-   HERE
+   PARSE-AREA DROP
    BEGIN
-      KEY DUP SPACE? 0=
+      PARSE-EMPTY? OR-ELSE PEEK-CHAR SPACE? THEN 0=
    WHILE
-      C,
+      SKIP-CHAR
    REPEAT
-   DROP
+   PARSE-AREA DROP OVER - ;
-   PUTBACK
-   HERE OVER -
-   OVER CP ! ;
 
 : CREATE ( "<spaces>ccc" -- )
    ALIGN HERE
    DODATA , 0 , LATEST ,
-   HERE 0 C, WORD
+   WORD DUP C, HERE SWAP DUP ALLOT CMOVE
-   NIP DUP ALLOT ALIGN SWAP C!
+   ALIGN HERE OVER >DFA !
-   HERE OVER >DFA !
+   GET-CURRENT ! ;
-   GET-CURRENT !
-;
 
 \ Called when a word using DOES> is executed (not compiled) to set
 \ the runtime behavior of the most recently defined word
@@ -328,6 +435,8 @@
 \   name execution: ( -- value )
 : VALUE CREATE , DOES> @ ;
 
+: (TRACE) >NAME TYPE SPACE .DS EOL ;
+
 \ Define a threaded FORTH word
 \ The word is initially hidden so it can refer to a prior word with the same name
 \ The definition is terminated with the ; immediate word, which unhides the name
@@ -335,7 +444,9 @@
    CREATE LATEST
    DUP >FLAGS DUP C@ F_HIDDEN OR SWAP C!
    DOCOL SWAP >CFA !
-   POSTPONE ] ;
+   POSTPONE ]
+   \ ( uncomment for tracing ) LATEST POSTPONE LITERAL POSTPONE (TRACE)
+   ;
 
 \ Like : but the definition has no name
 \ The zero-length name still included in the word list so LATEST can refer to it
@@ -452,23 +563,6 @@
       THEN
    AGAIN ;
 
-\ Display the unsigned number at the top of the stack
-: U. ( u -- "<digits>" )
-   \ Start with the highest place-value on the left
-   1000000000
-   \ Skip place-values that would be larger than the input
-   BEGIN 2DUP U< OVER 1 U> AND WHILE 10 U/ REPEAT
-   \ Emit the remaining digits down to the units' place
-   BEGIN
-      TUCK U/MOD [CHAR] 0 + EMIT SWAP
-      DUP 1 U<= IF 2DROP EXIT THEN
-      10 U/
-   AGAIN ;
-
-\ Display the signed number at the top of the stack
-: . ( n -- "<minus?><digits>" )
-   DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ;
-
 \ Field accessors for the search order linked list
 : ORDER>LINK ( a-addr1 -- a-addr2 ) ;
 : ORDER>WID ( a-addr1 -- a-addr2 ) CELL+ ;
@@ -605,8 +699,7 @@ DEFER ABORT ( -- <noreturn> )
 
 \ Same as FIND except that unknown words are reported and result in a call to ABORT
 : FIND-OR-ABORT ( c-addr u -- xt 1 | xt -1 )
-   FIND ?DUP IF EXIT THEN
+   FIND ?DUP 0= IF "UNKNOWN WORD: " TYPE TYPE EOL ABORT THEN ;
-   "UNKNOWN WORD: " TYPE TYPE EOL ABORT ;
 
 \ Read a word from the input (during runtime) and return its execution token
 \ Aborts if the word is not found in the current (runtime) search order list
@@ -658,6 +751,25 @@ HIDE ORDER-FREELIST
 HIDE ORDER>WID
 HIDE ORDER>LINK
 
+: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
+   NEXT-CHAR DUP [CHAR] \ = IF
+      DROP NEXT-CHAR CASE
+         [CHAR] 0 OF 0 ENDOF
+         [CHAR] a OF 7 ENDOF
+         [CHAR] b OF 8 ENDOF
+         [CHAR] t OF 9 ENDOF
+         [CHAR] n OF 10 ENDOF
+         [CHAR] v OF 11 ENDOF
+         [CHAR] f OF 12 ENDOF
+         [CHAR] r OF 13 ENDOF
+         [CHAR] " OF [CHAR] " ENDOF
+         [CHAR] ' OF [CHAR] ' ENDOF
+         [CHAR] \ OF [CHAR] \ ENDOF
+         "Unknown escape sequence: \\" TYPE DUP EMIT EOL
+         FATAL-ERROR
+      ENDCASE
+   THEN ;
+
 \ Read a literal character string up to the next double-quote character
 \ Unlike WORD the string is stored in contiguous *allocated* data space
 \ The delimiting double-quote character is removed from the input buffer
@@ -665,17 +777,12 @@ HIDE ORDER>LINK
 : READSTRING ( "ccc<doublequote>" -- c-addr u )
    HERE
    BEGIN
-      KEY
+      PEEK-CHAR [CHAR] " <>
-      DUP [CHAR] \ = IF
-         DROP KEY TRUE
-      ELSE
-         DUP [CHAR] " <>
-      THEN
    WHILE
-      C,
+      ESCAPED-CHAR C,
    REPEAT
-   DROP HERE OVER -
+   SKIP-CHAR
-;
+   HERE OVER - ;
 
 : PARSENUMBER ( c-addr u -- n TRUE | c-addr u FALSE )
    DUP 0= IF FALSE EXIT THEN
@@ -700,9 +807,12 @@ HIDE ORDER>LINK
 \ Read a word, number, or string and either execute it or compile it
 \ The stack effect depends on the input and the current value of STATE
 : INTERPRET ( i*x "<spaces>ccc" -- j*x )
+   BEGIN
       SKIPSPACE
-   KEY
+      PARSE-EMPTY? 0=
-   [CHAR] " = IF
+   WHILE
+      PEEK-CHAR [CHAR] " = IF
+         SKIP-CHAR
          STATE @ IF
             POSTPONE LITSTRING
             HERE 0 C,
@@ -711,7 +821,7 @@ HIDE ORDER>LINK
             READSTRING
          THEN
       ELSE
-      PUTBACK 64 ALLOT WORD -64 ALLOT
+         WORD
          PARSENUMBER IF
             STATE @ IF
                POSTPONE LITERAL
@@ -720,18 +830,45 @@ HIDE ORDER>LINK
             FIND-OR-ABORT
             \ -1 => immediate word; execute regardless of STATE
             \  1 => read STATE; compile if true, execute if false
-         0< IF EXECUTE EXIT THEN
+            0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN
-         STATE @ IF COMPILE, EXIT THEN
-         EXECUTE
          THEN
-   THEN ;
+      THEN
+   REPEAT ;
 
-\ Comments; ignore all characters until the next EOL or ) character, respectively
+\ Empty the return stack, make stdin the input source, and enter interpretation state
-: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN KEY LF = UNTIL ;
+: QUIT ( -- <noreturn> )
-: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN KEY [CHAR] ) = UNTIL ;
+   R0 RSP!
+   0 CURRENT-SOURCE-ID !
+   FALSE STATE !
+   BEGIN
+      REFILL 0= IF
+         EOL BYE
+      THEN
+      INTERPRET
+      STATE @ 0= IF
+         "OK> " TYPE
+      THEN
+   AGAIN ;
 
-\ Empty the return stack and enter interpretation state
+: EVALUATE ( i*x c-addr u -- j*x )
-: QUIT ( -- <noreturn> ) R0 RSP! FALSE STATE ! BEGIN INTERPRET AGAIN ;
+   SAVE-INPUT N>R
+   SOURCE 2>R
+   SOURCE-ID >R
+   INPUT-BUFFER-SIZE !
+   INPUT-BUFFER !
+   0 >IN !
+   -1 CURRENT-SOURCE-ID !
+   INTERPRET
+   R> CURRENT-SOURCE-ID !
+   2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
+   NR> RESTORE-INPUT ;
+
+HIDE CURRENT-SOURCE-ID
+HIDE INPUT-BUFFER
+HIDE INPUT-BUFFER-SIZE
+HIDE TERMINAL-BUFFER
+HIDE TIB-LEFTOVER
+HIDE TIB-LEFTOVER-SIZE
 
 \ Redefine ABORT as a non-deferred word; update deferred references to point here
 \ Empty the data stack and then perform the function of QUIT without any message
@@ -744,7 +881,7 @@ HIDE ABORT
 \ Switch to the interpreter defined in this startup file
 FORTH-WORDLIST 1 SET-ORDER
 DEFINITIONS
-QUIT
+{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
 
 \ *****************************************************************************
 \ Bootstrapping is complete
@@ -754,48 +891,48 @@ QUIT
 \ Return the number of words on the data stack
 : DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
 
-\ Display the content of the data stack
+\ Return TRUE if the given address is the execution token of a word in
-: .DS ( -- "<text>" )
+\ the current search order or compilation word list, or FALSE otherwise
-   SP@ S0
+\ The word's name may be hidden or shadowed by another definition
-   CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
+: WORD? ( addr -- flag )
-   BEGIN
-      CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
-   AGAIN ;
-
-\ Display the content of the return stack
-: .RS ( -- "<text>" )
-   \ Skip the topmost cell, which is the return address for the call to .RS
-   RSP@ CELL + R0
-   CELL - 2DUP > IF 2DROP EXIT THEN DUP @ .
-   BEGIN
-      CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE .
-   AGAIN ;
-
-\ Attempt to locate a visible word whose execution token matches the given address
-\ If found return the word name and TRUE; otherwise just return FALSE
-: LOOKUP ( addr -- c-addr u TRUE | FALSE )
    >R
    GET-ORDER
+   1+ GET-CURRENT SWAP
    BEGIN
       ?DUP
    WHILE
       1- SWAP R@ FALSE ROT
       ( S: widn ... wid1 n addr FALSE wid ) ( R: addr )
-      { ( addr FALSE xt -- addr FALSE FALSE | c-addr u TRUE TRUE )
+      \ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE )
-         NIP OVER = IF
+      { NIP OVER = DUP } WITH-WORDLIST
-            >NAME TRUE
+      NIP IF RDROP NDROP TRUE EXIT THEN
-         ELSE
-            FALSE
-         THEN DUP } WITH-VISIBLE
-      ?DUP IF RDROP EXIT THEN
-      DROP
    REPEAT
    RDROP FALSE ;
 
 \ Display the top of the stack as a word name if possible, or a number otherwise
 \ Words with zero-length names (e.g. from :NONAME) are displayed as numbers
 : .W ( addr -- "<name>" | "<digits>" )
-   DUP LOOKUP IF TYPE DROP ELSE . THEN ;
+   DUP WORD? IF
+      \ Some kind of word; is the name zero-length (:NONAME)?
+      DUP >NAME DUP IF
+         \ Is the name hidden?
+         2 PICK HIDDEN? IF
+            "×" TYPE
+         ELSE
+            \ Does FIND with the same name fail to return the same word?
+            2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF
+               "¤" TYPE
+            THEN
+         THEN
+         TYPE
+         DROP
+      ELSE
+         2DROP "∷" TYPE U.
+      THEN
+   ELSE
+      \ Not a word in the current search order or compilation word list
+      .
+   THEN ;
 
 \ Display the first `u` words in the body of the given execution token with .W
 : UNTHREAD ( xt u -- )
@@ -809,6 +946,7 @@ QUIT
    DROP
 ;
 
-: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;
+: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\nOK> " TYPE ;
 
 BANNER
+QUIT