diff --git a/jumpforth.S b/jumpforth.S index 17841fc..76e4a7b 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -1340,10 +1340,11 @@ defword BAILOUT litstring "Fatal error\n" .int TYPE 0: .int LIT,254,SYS_EXIT,SYSCALL1,DROP,BRANCH,(0b - .) + .int EXIT /* just to mark the end */ defword UNEXPECTED_EOF,"UNEXPECTED-EOF" litstring "Unexpected end of input\n" - .int TYPE,BAILOUT + .int TYPE,BAILOUT,EXIT /* During bootstrapping the source buffer is the embedded file "startup.4th". */ /* ( -- c-addr u ) */ @@ -1361,7 +1362,7 @@ defword PARSE_AREA,"PARSE-AREA" /* ( "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 +0: .int UNEXPECTED_EOF,EXIT /* ( "c" -- c ) Removes and returns the first character in the parse area */ defword NEXT_CHAR,"NEXT-CHAR" @@ -1480,7 +1481,7 @@ defword FIND defword FIND_OR_ABORT,"FIND-OR-ABORT" .int FIND,QDUP,ZBRANCH,(0f - .),EXIT 0: litstring "Word not found: " - .int TYPE,TYPE,EOL,BAILOUT + .int TYPE,TYPE,EOL,BAILOUT,EXIT /* ( "" -- ) */ defword SKIPSPACE @@ -1516,7 +1517,7 @@ defword ESCAPED_CHAR 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 + .int TYPE,EMIT,EOL,BAILOUT,EXIT defword READSTRING .int HERE @@ -1570,6 +1571,7 @@ defword INTERPRET defword QUIT .int R0,RSPSTORE 0: .int INTERPRET,BRANCH,(0b - .) + .int EXIT defword LATEST .int CURRENT,FETCH,FETCH,EXIT diff --git a/startup.4th b/startup.4th index b0e8012..32cebb1 100644 --- a/startup.4th +++ b/startup.4th @@ -37,7 +37,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) \ 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 +\ -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 ; @@ -46,14 +46,19 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) \ 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 +\ 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 , +\ Display a message and ABORT +\ This behavior can be overridden with CATCH +: FAIL ( c-addr u -- | ) + THROWN-STRING 2! -2 THROW ; + \ 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 ; + ROT IF FAIL ELSE 2DROP THEN ; \ Names for the standard file descriptor numbers 0 CONSTANT STDIN @@ -482,7 +487,7 @@ CREATE CURRENT-SOURCE-ID -1 , \ 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 ; +: (DEFERRED-UNINIT) "Uninitialized deferred word" FAIL ; : DEFER ( "ccc" -- ) CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ; ' (DEFERRED-UNINIT) (HIDE) @@ -828,7 +833,7 @@ HIDE TERMINAL-BUFFER [CHAR] " OF [CHAR] " ENDOF [CHAR] ' OF [CHAR] ' ENDOF [CHAR] \ OF [CHAR] \ ENDOF - TRUE "Unknown escape sequence" ?FAIL + "Unknown escape sequence" FAIL ENDCASE THEN ; @@ -941,7 +946,7 @@ HIDE TERMINAL-BUFFER NR> RESTORE-INPUT DROP R> SWAP >R SP! R> ; -\ Run xt while trapping calls to THROW, ABORT, ?FAIL, etc. +\ 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 ) @@ -1050,6 +1055,7 @@ DEFINITIONS \ Read one cell and increment : @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; +\ Display a string in escaped (double-quoted) format, without the delimiters : TYPE-ESCAPED ( c-addr u -- "" ) 0 DO DUP 1+ SWAP C@ CASE 0 OF "\\0" TYPE ENDOF @@ -1071,7 +1077,25 @@ DEFINITIONS THEN ENDCASE LOOP DROP ; -: UNTHREAD ( a-addr -- ) +\ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b} +\ This pattern is generated by the { … } inline :NONAME syntax +: NONAME-LITERAL? ( a-addr -- flag ) + @(+) ['] BRANCH = AND-THEN + @(+) DUP 0> AND-THEN + ( S: addr-b offset-c-a ) + OVER CELL- + @(+) ['] LIT = AND-THEN + ( S: addr-b addr-d ) + @ OVER = AND-THEN + DUP WORD? + THEN + ELSE NIP THEN + ELSE NIP THEN + THEN NIP ; + +\ Display the threaded code which starts at a-addr +\ Continues until it encounters a reference to EXIT beyond any forward branches +\ Numeric, string, and { … } literals are decoded, plus offsets for branches +: UNTHREAD ( a-addr -- ) RECURSIVE DUP >R BEGIN @(+) @@ -1086,20 +1110,27 @@ DEFINITIONS "\"" 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 + OVER CELL- NONAME-LITERAL? IF + DROP DUP @ OVER + 2 CELLS+ DUP R> MAX >R SWAP + "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE ELSE - DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF - "POSTPONE " TYPE + DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF + >NAME TYPE SPACE + @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "}" TYPE SPACE + OVER CELL- + R> MAX >R + ELSE + DUP WORD? AND-THEN DUP IMMEDIATE? THEN IF + "POSTPONE " TYPE + THEN + .W SPACE THEN - .W SPACE THEN THEN THEN AGAIN ; +HIDE NONAME-LITERAL? + : SEE ( "name" -- ) ' DUP >CFA @ CASE DOCOL OF @@ -1108,7 +1139,8 @@ DEFINITIONS " " TYPE >DFA @ UNTHREAD ";\n" TYPE ENDOF DODEFER OF - "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W " IS " >NAME TYPE EOL + "DEFER " TYPE DUP >NAME TYPE " ' " TYPE DUP >DFA @ .W + " IS " TYPE >NAME TYPE EOL ENDOF DODATA OF DUP EXECUTE . " CONSTANT " TYPE >NAME TYPE EOL