add decoding for { … } literals in SEE
This commit is contained in:
parent
29b949d583
commit
2eaa43f85f
10
jumpforth.S
10
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
|
||||
|
||||
/* ( "<spaces>" -- ) */
|
||||
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
|
||||
|
|
|
|||
62
startup.4th
62
startup.4th
|
|
@ -37,7 +37,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ 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 <noreturn> )
|
||||
?DUP IF THROW-UNWIND THEN ;
|
||||
|
|
@ -46,14 +46,19 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ 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 -- <none> | <noreturn> )
|
||||
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 -- <none> | <noreturn> )
|
||||
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 ( "<spaces>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 -- "<escapeseq*>" )
|
||||
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 ( "<spaces>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
|
||||
|
|
|
|||
Loading…
Reference in New Issue