diff --git a/jumpforth.S b/jumpforth.S index d9c59ef..17841fc 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -69,9 +69,18 @@ DOCOL: movl 4(%eax),%esi NEXT -/* The default behavior for words defined with CREATE */ +/* The entry point for deferred words */ +/* The real execution token is in the DFA field */ +/* Load the target xt and branch to the address in the target's codeword field */ + .text + .align 4 + .globl DODEFER +DODEFER: + movl 4(%eax),%eax + jmp *(%eax) + +/* The default behavior for words defined with CREATE, VARIABLE, or CONSTANT */ /* Place the value of the DFA field on the top of the stack */ -/* (By default the DFA field holds the address of the body of the definition) */ .text .align 4 .globl DODATA @@ -89,7 +98,7 @@ DOLOAD: pushl (%eax) NEXT -/* The entry point for threaded FORTH words defined with CREATE/DOES> */ +/* The entry point for threaded FORTH words defined with CREATE DOES> */ /* Push the return address (%esi) on the return stack */ /* Load the address of the DOES> code body from the DFA field at %eax+4 */ /* Push the address of the body of the word (not the DFA field) onto the stack */ @@ -106,8 +115,7 @@ DODOES: movb 12(%eax),%bl andb $F_LENMASK,%bl /* Calculate %eax + 13 + %ebx and round up to next cell for address of body */ - addl $16,%eax - addl %ebx,%eax + lea 16(%eax,%ebx),%eax andl $-4,%eax /* Push body address on the data stack */ push %eax @@ -185,6 +193,7 @@ defconst VERSION,JUMPFORTH_VERSION defconst R0,return_stack_top defconst __DOCOL,DOCOL,"DOCOL" +defconst __DODEFER,DODEFER,"DODEFER" defconst __DODATA,DODATA,"DODATA" defconst __DOLOAD,DOLOAD,"DOLOAD" defconst __DODOES,DODOES,"DODOES" @@ -1183,8 +1192,7 @@ defcode TWORDROP,"2RDROP" /* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */ defcode SPFETCH,"SP@" - mov %esp,%eax - push %eax + push %esp NEXT /* ( a-addr -- ) Set the data stack pointer */ @@ -1202,9 +1210,8 @@ defcode LITSTRING lodsb push %esi push %eax - addl %eax,%esi - addl $3,%esi - andl $0xfffffffc,%esi + lea 3(%esi,%eax),%esi + andl $-4,%esi NEXT defcode BRANCH @@ -1372,11 +1379,14 @@ defword ISSPACE,"SPACE?" defword ALLOT .int CP,INCREMENT,EXIT +defword HERE + .int CP,FETCH,EXIT + defword COMMA,"," - .int CP,FETCH,CELL,ALLOT,STORE,EXIT + .int HERE,CELL,ALLOT,STORE,EXIT defword COMMABYTE,"C," - .int CP,FETCH,LIT,1,ALLOT,STOREBYTE,EXIT + .int HERE,LIT,1,ALLOT,STOREBYTE,EXIT /* ( addr -- a-addr ) Round up to next cell-aligned address */ defword ALIGNED @@ -1385,7 +1395,7 @@ defword ALIGNED /* ( -- ) Allocate data space up to the next cell-aligned address */ /* Any bytes skipped over during alignment should be considered uninitialized */ defword ALIGN - .int CP,FETCH,DUP,ALIGNED,SWAP,SUB,ALLOT,EXIT + .int HERE,DUP,ALIGNED,SWAP,SUB,ALLOT,EXIT /* ( c-addr-1 u-1 c-addr-2 u-2 -- flag ) */ defword STREQU,"=S" @@ -1509,10 +1519,10 @@ defword ESCAPED_CHAR .int TYPE,EMIT,EOL,BAILOUT defword READSTRING - .int CP,FETCH + .int HERE 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 +1: .int LIT,1,IN,INCREMENT,HERE,OVER,SUB,ALIGN,EXIT defword PARSENUMBER .int DUP,LIT,0,GT,ZBRANCH,(6f - .) @@ -1535,7 +1545,7 @@ defword INTERPRET .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 LIT,LITSTRING,COMMA,HERE,LIT,0,COMMABYTE .int READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT /* ELSE */ 0: .int READSTRING,EXIT @@ -1561,17 +1571,15 @@ defword QUIT .int R0,RSPSTORE 0: .int INTERPRET,BRANCH,(0b - .) -/* CREATE depends on bootstrap ALIGN, COMMA, WORD, ALLOT, >FLAGS, and >DFA */ +defword LATEST + .int CURRENT,FETCH,FETCH,EXIT + +/* CREATE depends on bootstrap ALIGN, COMMA, LATEST, WORD, ALLOT, >FLAGS, and >DFA */ defword CREATE - .int ALIGN,CP,FETCH - .int LIT,DODATA,COMMA - .int LIT,0,COMMA - .int CURRENT,FETCH,FETCH,COMMA - .int WORD - .int DUP,COMMABYTE - .int CP,FETCH,SWAP - .int DUP,ALLOT,CMOVE - .int ALIGN,CP,FETCH,OVER,TDFA,STORE + .int ALIGN,HERE + .int LIT,DODATA,COMMA,LIT,0,COMMA,LATEST,COMMA + .int WORD,DUP,COMMABYTE,HERE,SWAP,DUP,ALLOT,CMOVE + .int ALIGN,HERE,OVER,TDFA,STORE .int CURRENT,FETCH,STORE,EXIT /* @@ -1593,7 +1601,7 @@ defword PAREN,"(",F_IMMED defword COLON,":" /* Make word & fetch address */ - .int CREATE,CURRENT,FETCH,FETCH + .int CREATE,LATEST /* Set as hidden */ .int DUP,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE /* Convert to DOCOL codeword */ @@ -1605,14 +1613,26 @@ defword SEMI,";",F_IMMED /* Terminate the code with EXIT */ .int LIT,EXIT,COMMA /* Fetch the address of the latest definition */ - .int CURRENT,FETCH,FETCH + .int LATEST /* Clear the F_HIDDEN flag */ .int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE /* Leave compilation mode */ .int FALSE,STATE,STORE,EXIT defword CONSTANT - .int CREATE,CURRENT,FETCH,FETCH,TDFA,STORE,EXIT + .int CREATE,LATEST,TDFA,STORE,EXIT + +/* ( target-xt deferred-xt -- ) */ +defword DEFERSTORE,"DEFER!" + .int __DODEFER,OVER,TCFA,STORE,TDFA,STORE,EXIT + +/* ( deferred-xt -- target-xt ) */ +defword DEFERFETCH,"DEFER@" + .int TDFA,FETCH,EXIT + +/* ( "ccc" -- ) */ +defword DEFER + .int CREATE,LIT,BAILOUT,LATEST,DEFERSTORE,EXIT defword QUOTE,"'" .int WORD,FIND_OR_ABORT,DROP,EXIT @@ -1646,25 +1666,25 @@ defword POSTPONE,,F_IMMED 1: .int COMMA,EXIT defword AHEAD,,F_IMMED - .int LIT,BRANCH,COMMA,CP,FETCH,LIT,0,COMMA,EXIT + .int LIT,BRANCH,COMMA,HERE,LIT,0,COMMA,EXIT defword IF,,F_IMMED - .int LIT,ZBRANCH,COMMA,CP,FETCH,LIT,0,COMMA,EXIT + .int LIT,ZBRANCH,COMMA,HERE,LIT,0,COMMA,EXIT defword THEN,,F_IMMED - .int CP,FETCH,OVER,SUB,SWAP,STORE,EXIT + .int HERE,OVER,SUB,SWAP,STORE,EXIT defword ELSE,,F_IMMED .int AHEAD,SWAP,THEN,EXIT defword BEGIN,,F_IMMED - .int CP,FETCH,EXIT + .int HERE,EXIT defword AGAIN,,F_IMMED - .int LIT,BRANCH,COMMA,CP,FETCH,SUB,COMMA,EXIT + .int LIT,BRANCH,COMMA,HERE,SUB,COMMA,EXIT defword UNTIL,,F_IMMED - .int LIT,ZBRANCH,COMMA,CP,FETCH,SUB,COMMA,EXIT + .int LIT,ZBRANCH,COMMA,HERE,SUB,COMMA,EXIT defword WHILE,,F_IMMED .int IF,SWAP,EXIT diff --git a/startup.4th b/startup.4th index 5b21f63..b0e8012 100644 --- a/startup.4th +++ b/startup.4th @@ -1,11 +1,3 @@ -\ Get and set the current compilation word list -: GET-CURRENT ( -- wid ) CURRENT @ ; -: SET-CURRENT ( wid -- ) CURRENT ! ; - -\ Get the execution token of the most recent word in the compilation word list -\ If the word list is empty the result will be zero -: LATEST ( -- xt | 0 ) GET-CURRENT @ ; - \ Shorthand for working with cell-aligned addresses : CELL+ ( addr1 -- addr2 ) CELL + ; : CELL- ( addr1 -- addr2 ) CELL - ; @@ -28,6 +20,85 @@ : IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; : HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ; +\ Set or clear the HIDDEN flag for word with the given execution token +: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; +: (UNHIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; + +\ QUIT needs to be deferred so that it can refer to INTERPRET +DEFER QUIT ( -- ) +' BAILOUT ' QUIT DEFER! + +\ This is called by THROW when n is nonzero +\ The initial value (DEFAULT-UNWIND) performs the function of ABORT +\ CATCH saves and restores the current target and substitutes its own version +DEFER THROW-UNWIND ( k*x n -- i*x ) + +\ If n is nonzero, return control to the nearest CATCH on the return stack +\ If there is no CATCH, perform the function of ABORT (clear data stack and QUIT) +\ Absent CATCH, whether a message is displayed depends on the value of n: +\ -1 (ABORT) no message +\ -2 (?FAIL) the string passed to ?FAIL +\ otherwise message is implementation-dependent +: THROW ( k*x n -- k*x | i*x n ) + ?DUP IF THROW-UNWIND THEN ; + +\ By default, clear the data stack and QUIT without any message +\ This behavior can be overridden with CATCH +: ABORT ( i*x -- ) ( R: j*x -- ) -1 THROW ; + +\ THROWN-STRING holds the address and size of the string passed to ?FAIL +\ It may also be used to hold context strings for other system exception codes +CREATE THROWN-STRING 0 , 0 , + +\ If flag is non-zero, display a message and ABORT +\ This behavior can be overridden with CATCH +: ?FAIL ( flag c-addr u -- | ) + ROT IF THROWN-STRING 2! -2 THROW ELSE 2DROP THEN ; + +\ Names for the standard file descriptor numbers +0 CONSTANT STDIN +1 CONSTANT STDOUT +2 CONSTANT STDERR + +\ Write one character to FD 1 (stdout) +: EMIT ( c -- "c" ) + SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ; + +\ Decrement the array size and increment the address by the same amount +: DROP-PREFIX ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; + +\ Write a character array to the given file descriptor +\ Repeat write syscall until entire string is written +\ Abandon output on any error other than EINTR +: TYPE-FD ( c-addr u fd -- "ccc" ) + >R + BEGIN + ?DUP + WHILE + 2DUP R@ -ROT SYS_WRITE SYSCALL3 + DUP 0<= IF + ERRNO_EINTR NEGATE <> IF + 2DROP RDROP EXIT + THEN + ELSE + DROP-PREFIX + THEN + REPEAT + DROP RDROP ; + +\ Specializations for output to stdout and stderr +: TYPE ( c-addr u -- "ccc" ) STDOUT TYPE-FD ; +: TYPE-ERR ( c-addr u -- "ccc" ) STDERR TYPE-FD ; + +\ Get and set the current compilation word list +: GET-CURRENT ( -- wid ) CURRENT @ ; +: SET-CURRENT ( wid -- ) CURRENT ! ; +' CURRENT (HIDE) + +\ Get the execution token of the most recent word in the compilation word list +\ If the word list is empty the result will be zero +: LATEST ( -- xt | 0 ) GET-CURRENT @ ; + \ Set the latest defined word as immediate \ Note that IMMEDIATE is itself an immediate word : IMMEDIATE ( -- ) LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE @@ -50,34 +121,8 @@ : FM/MOD ( d1 n1 -- d1%n1 d1/n1 ) DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ; -\ Names for the standard file descriptor numbers -0 CONSTANT STDIN -1 CONSTANT STDOUT -2 CONSTANT STDERR - -\ Write one character to FD 1 (stdout) -: EMIT ( c -- "c" ) - SP@ 2DUP C! STDOUT SWAP 1 SYS_WRITE SYSCALL3 2DROP ; - -\ Write a character array to stdout -\ Repeat write syscall until entire string is written -\ Abandon output on any error other than EINTR -: TYPE ( c-addr u -- "ccc" ) - BEGIN - ?DUP - WHILE - 2DUP STDOUT -ROT SYS_WRITE SYSCALL3 - DUP 0<= IF - ERRNO_EINTR NEGATE <> IF - 2DROP EXIT - THEN - ELSE - \ Decrement the array size and increment the - \ address by the number of bytes written - TUCK - -ROT + SWAP - THEN - REPEAT - DROP ; +: MIN 2DUP > IF NIP ELSE DROP THEN ; +: MAX 2DUP < IF NIP ELSE DROP THEN ; \ Define names for the whitespace characters 8 CONSTANT HT \ Horizontal Tab @@ -108,14 +153,6 @@ : BYE ( -- ) BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ; -\ Terminate the program with a fatal error (SIGABRT) -: FATAL-ERROR ( -- ) - BEGIN - \ A full version would also unmask SIGABRT and restore the default handler - \ For now we assume the mask and handler are already at default settings - 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 @@ -153,32 +190,35 @@ \ Return the next address in the compilation/data area : HERE ( -- addr ) CP @ ; -: ALLOT-BOUNDS "Allocation out of bounds!" TYPE EOL FATAL-ERROR ; -: ALLOT-OOM "Out of memory!" TYPE EOL FATAL-ERROR ; - \ When growing the data area, round the end address up to a multiple of this size 65536 CONSTANT DATA-SEGMENT-ALIGNMENT +\ Allocate n consecutive bytes from the end of the data area +\ If necessary use the brk system call to grow the data area +\ The value n can be negative to release the most recently allocated space : ALLOT ( n -- ) DUP 0< IF - DUP C0 HERE - < IF ALLOT-BOUNDS THEN + DUP C0 HERE - < IF -24 THROW THEN ELSE - DUP HERE INVERT U> IF ALLOT-BOUNDS THEN + DUP HERE INVERT U> IF -8 THROW THEN THEN HERE + DUP BRK @ U> IF [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND DUP SYS_BRK SYSCALL1 - OVER <> IF ALLOT-OOM THEN + OVER <> IF -8 THROW THEN BRK ! THEN CP ! ; +\ Allocate one cell from the data area and fill it with the value on the stack : , HERE CELL ALLOT ! ; +\ Allocate one character from the data area and fill it with the value on the stack : C, HERE 1 ALLOT C! ; +\ Allocate bytes from the data area (less than one cell) to cell-align the address : ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ; \ Append the effect of the token on top of the stack to the current definition. @@ -190,13 +230,17 @@ : LITERAL ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE POSTPONE LIT , ; +\ Append the LITSTRING xt and a copy of the string passed on the stack. +: SLITERAL ( Compilation: c-addr1 u -- ) ( Runtime: -- c-addr2 u ) IMMEDIATE + POSTPONE LITSTRING DUP C, HERE SWAP DUP ALLOT CMOVE ALIGN ; + \ Append the execution semantics of the current definition to the current definition : RECURSE ( -- ) IMMEDIATE LATEST COMPILE, ; \ Unhide the current definition so it can refer to itself by name : RECURSIVE ( -- ) IMMEDIATE - LATEST >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; + LATEST (UNHIDE) ; \ Our first control-flow primitive: IF {ELSE } THEN \ @@ -246,23 +290,6 @@ : REPEAT ( C: orig dest -- ) IMMEDIATE POSTPONE AGAIN POSTPONE THEN ; -\ Range loop: DO LOOP -\ DO +LOOP -: UNLOOP POSTPONE 2RDROP ; IMMEDIATE -: DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE -: (+LOOP) ( step limit index -- flag limit index' ) - ROT + 2DUP = -ROT ; -: +LOOP - POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R - POSTPONE UNTIL POSTPONE 2RDROP -; IMMEDIATE -: LOOP 1 POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE - -\ Return the current index value from the innermost or next-innermost loop. -\ The loops must be directly nested with no other changes to the return stack -: I 1 RPICK ; -: J 3 RPICK ; - \ Sequential equality tests: \ CASE \ OF ENDOF @@ -288,84 +315,72 @@ \ Drop the value in case none of the OF...ENDOF clauses matched \ Resolve all the forward branches from ENDOF to the location after ENDCASE : ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE - POSTPONE DROP 0 DO POSTPONE THEN LOOP ; + POSTPONE DROP BEGIN ?DUP WHILE 1- SWAP POSTPONE THEN REPEAT ; +\ Range loop: DO LOOP +\ DO +LOOP +: UNLOOP POSTPONE 2RDROP ; IMMEDIATE +: DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE +: (+LOOP) ( step limit index -- flag limit index' ) + ROT + 2DUP = -ROT ; +: +LOOP IMMEDIATE + POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R + POSTPONE UNTIL POSTPONE 2RDROP ; +' (+LOOP) (HIDE) +: LOOP IMMEDIATE 1 POSTPONE LITERAL POSTPONE +LOOP ; + +\ Return the current index value from the innermost or next-innermost loop. +\ The loops must be directly nested with no other changes to the return stack +: I 1 RPICK ; +: J 3 RPICK ; + +\ This function defines what happens when THROW is used outside of any CATCH +: DEFAULT-UNWIND ( k*x n -- i*x ) + CASE + -1 OF ENDOF + -2 OF + THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR + ENDOF + -8 OF + "Out of memory\n" TYPE-ERR + ENDOF + -13 OF + "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR + ENDOF + -37 OF + "I/O error\n" TYPE-ERR + ENDOF + "Uncaught exception\n" TYPE-ERR + ENDCASE + S0 SP! QUIT ; + +' DEFAULT-UNWIND ' THROW-UNWIND DEFER! +' DEFAULT-UNWIND (HIDE) + +\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer SOURCE CREATE INPUT-BUFFER-SIZE , CREATE INPUT-BUFFER , +\ The SOURCE-ID is -1 for a string (EVALUATE) or 0 for user input +\ Any other values are implementation-defined, for example FD numbers for file input CREATE CURRENT-SOURCE-ID -1 , +\ Report the current input buffer region and SOURCE-ID : SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ; : SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; +\ Save and restore the input source parameters (e.g. file position) +\ This does not include the input buffer (SOURCE) or the 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 - ; +: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; : 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@ ; + PARSE-AREA 0= "Unexpected end of input" ?FAIL C@ ; : SKIP-CHAR ( -- ) 1 >IN +! ; @@ -412,6 +427,8 @@ CREATE TIB-LEFTOVER-SIZE 0 , POSTPONE LIT HERE 0 , POSTPONE (DOES) POSTPONE EXIT HERE SWAP ! ; +' (DOES) (HIDE) + \ Define a named constant \ Execution: ( value "name" -- ) \ name Execution: ( -- value ) @@ -433,62 +450,50 @@ CREATE TIB-LEFTOVER-SIZE 0 , \ Named values defined with VALUE can be modified with TO. \ Execution: ( x "name" -- ) \ name execution: ( -- value ) -: VALUE CREATE , DOES> @ ; - -: (TRACE) >NAME TYPE SPACE .DS EOL ; +: VALUE CREATE , DOLOAD LATEST >CFA ! ; \ 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 : : ( "ccc" -- ) - CREATE LATEST - DUP >FLAGS DUP C@ F_HIDDEN OR SWAP C! - DOCOL SWAP >CFA ! - POSTPONE ] - \ ( uncomment for tracing ) LATEST POSTPONE LITERAL POSTPONE (TRACE) - ; + CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ; + +\ Define a threaded word which also displays its name and the data stack when called +: (TRACE) >NAME TYPE SPACE .DS EOL ; +: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; +' (TRACE) (HIDE) \ Like : but the definition has no name \ The zero-length name still included in the word list so LATEST can refer to it \ The execution token is left on the stack for use after the definition ends : :NONAME ( -- ) - ALIGN HERE - DOCOL , - HERE [ 3 CELLS ] LITERAL + , - LATEST , - F_HIDDEN C, ALIGN - DUP GET-CURRENT ! - POSTPONE ] ; + ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C, + DUP GET-CURRENT ! ALIGN POSTPONE ] ; -\ End a definition by appending EXIT, leaving compilation mode, and unhiding the name -\ As an optimization, zero-length names (from :NONAME) are left hidden +\ End a definition by appending EXIT and leaving compilation mode +\ Unhide the name if it isn't empty (e.g. from :NONAME) : ; ( -- ) IMMEDIATE - POSTPONE EXIT POSTPONE [ - LATEST >FLAGS DUP C@ - DUP F_LENMASK AND IF - \ Length is not zero; clear the F_HIDDEN flag - F_HIDDEN INVERT AND SWAP C! - ELSE - 2DROP - THEN ; - -\ Create a deferred word -\ At present a deferred word is just an ordinary threaded function -\ DEFER! and IS update which word is called by overwriting the threaded code -\ The explicit EXIT is just a placeholder to be overwritten by DEFER! or IS -\ A future version might use a special codeword with the target in the DFA field -: DEFER ( "ccc" -- ) : POSTPONE EXIT POSTPONE ; ; + POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; \ Fetch and store the target of the deferred word denoted by deferred-xt -: DEFER@ ( deferred-xt -- xt ) >DFA @ @ ; -: DEFER! ( xt deferred-xt -- ) >DFA @ ! ; +\ Note that this DEFER! can turn any word into a deferred word +: DEFER@ ( deferred-xt -- xt ) >DFA @ ; +: DEFER! ( xt deferred-xt -- ) DODEFER OVER >CFA ! >DFA ! ; + +\ Create a deferred word; the target is stored in the DFA field +\ The default target throws an exception — replace it using DEFER! or IS +: (DEFERRED-UNINIT) TRUE "Uninitialized deferred word" ?FAIL ; +: DEFER ( "ccc" -- ) + CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ; +' (DEFERRED-UNINIT) (HIDE) \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of on the top of the data stack. A branch is emitted to skip -\ over the memory used for the nested definition, which is removed from the -\ current word list upon completion. If RECURSE is used in it will -\ create a recursive call to the anonymous inner function. +\ over the memory used for the nested definition. If RECURSE is used in +\ it will create a recursive call to the anonymous inner function. In the word +\ list, after the }, the inner definition is ordered before the outer definition. +\ LATEST always refers to the innermost enclosing definition. \ \ Example: \ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ; @@ -498,30 +503,40 @@ CREATE TIB-LEFTOVER-SIZE 0 , \ Hello \ Hello \ -\ Compilation effect: ( C: -- latest orig state ) -\ Interpreter effect: ( S: -- latest state ) +\ Compilation effect: ( C: -- outer-xt orig inner-xt state ) +\ Interpreter effect: ( S: -- inner-xt state ) \ Enters compilation mode if not already compiling -: { ( -- latest {orig} state ) IMMEDIATE - LATEST +: { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE STATE @ DUP IF + LATEST + DUP >LINK @ GET-CURRENT ! + 0 OVER >LINK ! POSTPONE AHEAD - SWAP + ROT POSTPONE [ THEN - :NONAME ; + :NONAME SWAP ; -\ Resolve the forward branch over the inner function \ Leave compilation mode if STATE was 0 before { was executed -: } ( C: latest {orig} state -- ) IMMEDIATE - POSTPONE ; SWAP IF - -ROT - POSTPONE THEN - GET-CURRENT ! - POSTPONE LITERAL +\ Otherwise: +\ Resolve the forward branch over the inner function +\ Add outer-xt back to the word list after inner-xt +\ Generate a literal for inner-xt +: } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE + POSTPONE ; + IF + ( S: outer-xt orig inner-xt ) + \ Resolve the forward branch over the inner definition + -ROT POSTPONE THEN + \ Re-append the outer definition to the word list + LATEST OVER >LINK ! GET-CURRENT ! + \ Return to compilation mode (was ended by ; ) POSTPONE ] - ELSE - SWAP GET-CURRENT ! + \ Compile inner-xt as a literal in the outer definition + POSTPONE LITERAL + \ ELSE ( nothing to do ) + ( S: inner-xt ) THEN ; \ Read the next word and return the first character @@ -622,6 +637,12 @@ VARIABLE ORDER-FREELIST 0 SWAP ! ; +\ Abstract away the internals of the search order implementation +' CURRENT-ORDER (HIDE) +' ORDER-FREELIST (HIDE) +' ORDER>WID (HIDE) +' ORDER>LINK (HIDE) + \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word : WORDLIST ( -- wid ) @@ -692,18 +713,13 @@ VARIABLE ORDER-FREELIST REPEAT 2R> 0 ; -\ ABORT needs to be deferred so that it can refer to QUIT and INTERPRET -\ The initial target of FATAL-ERROR terminates the program with SIGABRT -DEFER ABORT ( -- ) -' FATAL-ERROR ' ABORT DEFER! - -\ 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 0= IF "UNKNOWN WORD: " TYPE TYPE EOL ABORT THEN ; +\ Same as FIND except that unknown words are reported and result in a call to THROW +: FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 ) + FIND ?DUP 0= IF THROWN-STRING 2! -13 THROW 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 -: ' ( "ccc" -- xt ) WORD FIND-OR-ABORT DROP ; +: ' ( "ccc" -- xt ) WORD FIND-OR-THROW DROP ; \ Like ' but generates a literal at compile-time. : ['] ( Compilation: "ccc" -- ) ( Runtime: -- xt ) IMMEDIATE @@ -711,7 +727,7 @@ DEFER ABORT ( -- ) \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE - WORD FIND-OR-ABORT 0< IF + WORD FIND-OR-THROW 0< IF COMPILE, ELSE DUP [ ' BOOTSTRAP? COMPILE, ] IF @@ -736,20 +752,67 @@ DEFER ABORT ( -- ) ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; \ Hide the named word: HIDE -: HIDE ( "ccc" -- ) - ' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; +: HIDE ( "ccc" -- ) ' (HIDE) ; -\ Hide internal utility functions -HIDE ALLOT-BOUNDS -HIDE ALLOT-OOM -HIDE (DOES) +\ Begin a new colon definition; hide & redirect the previous word +\ with the same name to the new definition +: :REPLACE ( "ccc" -- ) + : LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ; -\ Abstract away the internals of the search order implementation -HIDE CURRENT -HIDE CURRENT-ORDER -HIDE ORDER-FREELIST -HIDE ORDER>WID -HIDE ORDER>LINK +\ The size of this buffer will determine the maximum line length +4096 CONSTANT TERMINAL-BUFFER-SIZE +CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT + +\ If we read more than one line then these will refer to the rest of the data +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 -37 THROW 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<> ; + +HIDE TIB-LEFTOVER +HIDE TIB-LEFTOVER-SIZE +HIDE TERMINAL-BUFFER : ESCAPED-CHAR ( "" | "c" -- c ) NEXT-CHAR DUP [CHAR] \ = IF @@ -765,8 +828,7 @@ HIDE ORDER>LINK [CHAR] " OF [CHAR] " ENDOF [CHAR] ' OF [CHAR] ' ENDOF [CHAR] \ OF [CHAR] \ ENDOF - "Unknown escape sequence: \\" TYPE DUP EMIT EOL - FATAL-ERROR + TRUE "Unknown escape sequence" ?FAIL ENDCASE THEN ; @@ -827,7 +889,7 @@ HIDE ORDER>LINK POSTPONE LITERAL THEN ELSE - FIND-OR-ABORT + FIND-OR-THROW \ -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 @@ -835,8 +897,9 @@ HIDE ORDER>LINK THEN REPEAT ; +\ Redefine QUIT as a non-deferred word; update deferred references to point here \ Empty the return stack, make stdin the input source, and enter interpretation state -: QUIT ( -- ) +:REPLACE QUIT ( -- ) R0 RSP! 0 CURRENT-SOURCE-ID ! FALSE STATE ! @@ -861,27 +924,77 @@ HIDE ORDER>LINK INTERPRET R> CURRENT-SOURCE-ID ! 2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER ! - NR> RESTORE-INPUT ; + NR> RESTORE-INPUT DROP ; + +0 VALUE EXCEPTION-STACK + +\ Called when THROW is called inside of CATCH +\ Restore the input source specification, stack point, and return stack pointer +\ Push the error code from THROW onto the data stack +\ Return to the code that called CATCH +: CATCH-UNWIND ( k*x n -- i*x ) + EXCEPTION-STACK RSP! + R> TO EXCEPTION-STACK + R> ['] THROW-UNWIND DEFER! + R> CURRENT-SOURCE-ID ! + 2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER ! + NR> RESTORE-INPUT DROP + R> SWAP >R SP! R> ; + +\ Run xt while trapping calls to THROW, ABORT, ?FAIL, etc. +\ On success has the effect of xt and also leaves the value 0 on top of the stack +\ On failure the stacks and input source are reverted and the THROW code is pushed +: CATCH ( i*x xt -- j*x 0 | i*x n ) + \ Get original RSP to be saved on return stack later, after the exception frame + RSP@ + \ Don't include the xt or RSP when saving the stack pointer + 2>R SP@ 2R> ROT >R + \ Save the input source specification + SAVE-INPUT N>R + SOURCE 2>R + SOURCE-ID >R + \ We'll need these to revert the effect of CATCH, with or without THROW + ['] THROW-UNWIND DEFER@ >R + EXCEPTION-STACK >R + \ Push the new exception stack frame + RSP@ TO EXCEPTION-STACK + \ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND + ['] CATCH-UNWIND IS THROW-UNWIND + \ Save the original return stack so we can quickly free the exception frame + ( RSP@ from start of CATCH ) >R + \ Run the function; if THROW is called then EXECUTE won't return + \ If it does return then push 0 to indicate success + EXECUTE 0 + R> R> R> + \ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame + ['] THROW-UNWIND DEFER! + TO EXCEPTION-STACK + \ We don't need the rest so just reset the RSP to where it was on entering CATCH + RSP! ; + +HIDE EXCEPTION-STACK +HIDE CATCH-UNWIND +HIDE THROW-UNWIND 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 -' ABORT -HIDE ABORT -: ABORT ( -- ) S0 SP! QUIT ; -' ABORT SWAP DEFER! +HIDE (HIDE) +HIDE (UNHIDE) + +HIDE ESCAPED-CHAR +HIDE READSTRING +HIDE PARSENUMBER + +\ Switch to the interpreter defined in this startup file +{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE +HIDE INTERPRET \ Remove the bootstrap word list from the search order -\ Switch to the interpreter defined in this startup file +HIDE BOOTSTRAP-WORDLIST FORTH-WORDLIST 1 SET-ORDER DEFINITIONS -{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE \ ***************************************************************************** \ Bootstrapping is complete @@ -917,7 +1030,7 @@ DEFINITIONS DUP >NAME DUP IF \ Is the name hidden? 2 PICK HIDDEN? IF - "×" TYPE + "⌀" 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 @@ -934,17 +1047,84 @@ DEFINITIONS . THEN ; -\ Display the first `u` words in the body of the given execution token with .W -: UNTHREAD ( xt u -- ) - SWAP >DFA @ SWAP +\ Read one cell and increment +: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; + +: TYPE-ESCAPED ( c-addr u -- "" ) + 0 DO DUP 1+ SWAP C@ CASE + 0 OF "\\0" TYPE ENDOF + 7 OF "\\a" TYPE ENDOF + 8 OF "\\b" TYPE ENDOF + 9 OF "\\t" TYPE ENDOF + 10 OF "\\n" TYPE ENDOF + 11 OF "\\v" TYPE ENDOF + 12 OF "\\f" TYPE ENDOF + 13 OF "\\r" TYPE ENDOF + [CHAR] " OF "\\\"" TYPE ENDOF + \ escape sequence not needed in strings + \ [CHAR] ' OF "\\\'" TYPE ENDOF + [CHAR] \ OF "\\\\" TYPE ENDOF + DUP 32 < OR-ELSE DUP 127 = THEN IF + "⌷" TYPE + ELSE + DUP EMIT + THEN + ENDCASE LOOP DROP ; + +: UNTHREAD ( a-addr -- ) + DUP >R BEGIN - ?DUP - WHILE - SWAP DUP @ .W SPACE - CELL + SWAP 1- - REPEAT - DROP -; + @(+) + DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF + 2DROP RDROP EXIT + THEN + DUP ['] LIT = IF + DROP @(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE + ELSE + DUP ['] LITSTRING = IF + DROP DUP C@ OVER 1+ OVER + "\"" TYPE TYPE-ESCAPED "\"" TYPE SPACE + + ALIGNED + ELSE + DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF + >NAME TYPE SPACE + @(+) DUP "{" TYPE . "}" TYPE SPACE + OVER + R> MAX >R + ELSE + DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF + "POSTPONE " TYPE + THEN + .W SPACE + THEN + THEN + THEN + AGAIN ; + +: SEE ( "name" -- ) + ' DUP >CFA @ CASE + DOCOL OF + ": " TYPE DUP >NAME TYPE + DUP IMMEDIATE? IF " IMMEDIATE" TYPE THEN + " " TYPE >DFA @ UNTHREAD ";\n" TYPE + ENDOF + DODEFER OF + "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W " IS " >NAME TYPE EOL + ENDOF + DODATA OF + DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL + ENDOF + DOLOAD OF + DUP EXECUTE . " VALUE " TYPE >NAME TYPE EOL + ENDOF + DODOES OF + "CREATE " TYPE DUP >NAME TYPE " … DOES> " TYPE + " " TYPE >DFA @ UNTHREAD ";\n" TYPE + ENDOF + \ Anything else can be assumed to be implemented in assembly + SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE + ENDCASE ; + +HIDE UNTHREAD : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\nOK> " TYPE ;