From c0391de969ccabb9fbbbd0fea877f9264f33bc24 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Wed, 14 Oct 2020 02:11:35 -0500 Subject: [PATCH] revise the input system to better align with ANS FORTH --- jumpforth.S | 209 +++++++++++++++++++++-------- startup.4th | 374 +++++++++++++++++++++++++++++++++++----------------- 2 files changed, 412 insertions(+), 171 deletions(-) diff --git a/jumpforth.S b/jumpforth.S index 0d661c7..d9c59ef 100644 --- a/jumpforth.S +++ b/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) */ -defvar STATE,0 /* default to executing code */ +/* STATE controls whether we are currently interpreting (0) or compiling (1) */ +defvar STATE,0 /* default to interpreting */ -/* Initially the KEY function "reads" the embedded file "startup.4th". */ -/* When this is exhausted the pointers are reset to point to the input buffer. */ -defvar CURRKEY,startup_defs -defvar BUFFTOP,startup_defs_end +/* >IN gives the current offset of the parse area within the input buffer */ +defvar IN,0,">IN" /* 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 + +/* ( -- "" ) */ defword EOL - litstring "\n" - .int TYPE,EXIT + .int LIT,10,EMIT,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 */ -/* The startup.4th should replace this with a more complete version */ -/* 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" +defword UNEXPECTED_EOF,"UNEXPECTED-EOF" + litstring "Unexpected end of input\n" .int TYPE,BAILOUT -1: .int DUP,ADD1,CURRKEY,STORE,FETCHBYTE,EXIT -/* Puts the most recently read key back in the input buffer */ -/* CAUTION: Can only safely be used ONCE after each call to KEY! */ -defword PUTBACK - .int CURRKEY,FETCH,SUB1,CURRKEY,STORE,EXIT +/* During bootstrapping the source buffer is the embedded file "startup.4th". */ +/* ( -- c-addr u ) */ +defword SOURCE + .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 +/* ( "" -- ) */ +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 + +/* ( "ccc" -- c-addr u ) */ defword WORD - .int SKIPSPACE,CP,FETCH -0: .int KEY,DUP,ISSPACE,ZBRANCH,(1f - .) - .int DROP,PUTBACK,CP,FETCH,OVER,SUB,OVER,CP,STORE,EXIT -1: .int COMMABYTE,BRANCH,(0b - .) + .int SKIPSPACE + .int PARSE_AREA,DROP,LIT,1 + .int NEXT_CHAR,DROP +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 - .) - .int DROP,KEY,BRANCH,(2f - .) -1: .int DUP,LIT,'"',EQU,ZBRANCH,(2f - .) - .int DROP,CP,FETCH,OVER,SUB,ALIGN,EXIT -2: .int COMMABYTE,BRANCH,(0b - .) +0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .) + .int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .) +1: .int LIT,1,IN,INCREMENT,CP,FETCH,OVER,SUB,ALIGN,EXIT 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 - .int TWODUP,PARSENUMBER,ZBRANCH,(3f - .) +1: .int WORD,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,NIP,DUP,ALLOT,ALIGN - .int OVER,TFLAGS,STOREBYTE - .int CP,FETCH,OVER,TDFA,STORE + .int WORD + .int DUP,COMMABYTE + .int CP,FETCH,SWAP + .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 diff --git a/startup.4th b/startup.4th index 4e9c8dc..5b21f63 100644 --- a/startup.4th +++ b/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 -- "" ) + \ 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 -- "" ) + DUP 0< IF [CHAR] - EMIT NEGATE THEN U. ; + +\ Display the content of the data stack +: .DS ( -- "" ) + 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 ( -- "" ) + \ 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: +\ AND-THEN THEN +\ OR-ELSE THEN +: AND-THEN ( C: -- orig ) ( Runtime S: flag -- FALSE | ) IMMEDIATE + POSTPONE DUP POSTPONE IF POSTPONE DROP ; +: OR-ELSE ( C: -- orig ) ( Runtime S: flag -- nonzero-flag | ) IMMEDIATE + POSTPONE ?DUP POSTPONE 0= POSTPONE IF ; + \ Unbounded loop: BEGIN AGAIN \ BEGIN places the offset of the start of on the stack. \ AGAIN creates a relative branch back to the start of . @@ -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 -\ Return the next character from the input buffer -: KEY - CURRKEY @ - DUP BUFFTOP @ >= IF - DROP BUFFER 0 OVER BUFFER_SIZE SYS_READ SYSCALL3 - DUP 0<= IF - 2DROP - BYE +SOURCE +CREATE INPUT-BUFFER-SIZE , +CREATE INPUT-BUFFER , + +CREATE CURRENT-SOURCE-ID -1 , + +: 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 - OVER + BUFFTOP ! - THEN - DUP 1+ CURRKEY ! C@ -; + \ 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<> ; -\ Puts the most recently read key back in the input buffer -\ 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 ! ; +: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) ROT OVER + -ROT - ; -: SKIPSPACE BEGIN KEY SPACE? INVERT UNTIL PUTBACK ; +: 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 ( "" -- ) + 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" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; +: ( ( "ccc" -- ) 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 input buffer +\ The delimiting whitespace character is left in the parse area : WORD ( "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 - PUTBACK - HERE OVER - - OVER CP ! ; + PARSE-AREA DROP OVER - ; : CREATE ( "ccc" -- ) ALIGN HERE DODATA , 0 , LATEST , - HERE 0 C, WORD - NIP DUP ALLOT ALIGN SWAP C! - HERE OVER >DFA ! - GET-CURRENT ! -; + WORD DUP C, HERE SWAP DUP ALLOT CMOVE + ALIGN HERE OVER >DFA ! + 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 -- "" ) - \ 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 -- "" ) - 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 ( -- ) \ 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 - "UNKNOWN WORD: " TYPE TYPE EOL ABORT ; + FIND ?DUP 0= IF "UNKNOWN WORD: " TYPE TYPE EOL ABORT THEN ; \ 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 ( "" | "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" -- c-addr u ) HERE BEGIN - KEY - DUP [CHAR] \ = IF - DROP KEY TRUE - ELSE - DUP [CHAR] " <> - THEN + PEEK-CHAR [CHAR] " <> 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,38 +807,68 @@ 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 "ccc" -- j*x ) - SKIPSPACE - KEY - [CHAR] " = IF - STATE @ IF - POSTPONE LITSTRING - HERE 0 C, - READSTRING NIP SWAP C! ALIGN - ELSE - READSTRING - THEN - ELSE - PUTBACK 64 ALLOT WORD -64 ALLOT - PARSENUMBER IF + BEGIN + SKIPSPACE + PARSE-EMPTY? 0= + WHILE + PEEK-CHAR [CHAR] " = IF + SKIP-CHAR STATE @ IF - POSTPONE LITERAL + POSTPONE LITSTRING + HERE 0 C, + READSTRING NIP SWAP C! ALIGN + ELSE + READSTRING THEN ELSE - FIND-OR-ABORT - \ -1 => immediate word; execute regardless of STATE - \ 1 => read STATE; compile if true, execute if false - 0< IF EXECUTE EXIT THEN - STATE @ IF COMPILE, EXIT THEN - EXECUTE + WORD + PARSENUMBER IF + STATE @ IF + POSTPONE LITERAL + THEN + ELSE + FIND-OR-ABORT + \ -1 => immediate word; execute regardless of STATE + \ 1 => read STATE; compile if true, execute if false + 0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN + THEN THEN - THEN ; + REPEAT ; -\ Comments; ignore all characters until the next EOL or ) character, respectively -: \ ( "ccc" -- ) IMMEDIATE BEGIN KEY LF = UNTIL ; -: ( ( "ccc" -- ) IMMEDIATE BEGIN KEY [CHAR] ) = UNTIL ; +\ Empty the return stack, make stdin the input source, and enter interpretation state +: QUIT ( -- ) + 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 -: QUIT ( -- ) R0 RSP! FALSE STATE ! BEGIN INTERPRET AGAIN ; +: EVALUATE ( i*x c-addr u -- j*x ) + 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 -: .DS ( -- "" ) - 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 ( -- "" ) - \ 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 ) +\ Return TRUE if the given address is the execution token of a word in +\ the current search order or compilation word list, or FALSE otherwise +\ The word's name may be hidden or shadowed by another definition +: WORD? ( addr -- flag ) >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 ) - NIP OVER = IF - >NAME TRUE - ELSE - FALSE - THEN DUP } WITH-VISIBLE - ?DUP IF RDROP EXIT THEN - DROP + \ Inner function: ( addr FALSE xt -- addr FALSE FALSE | addr TRUE TRUE ) + { NIP OVER = DUP } WITH-WORDLIST + NIP IF RDROP NDROP TRUE EXIT THEN 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 -- "" | "" ) - 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