nybble
/
jumpforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

add exception handling with THROW and CATCH, and a version of SEE

This commit is contained in:
Jesse D. McDonald 2020-10-15 05:07:15 -05:00
parent c0391de969
commit 29b949d583
2 changed files with 466 additions and 266 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
jumpforth.S
View File

@ -69,9 +69,18 @@ DOCOL:
movl 4(%eax),%esi movl 4(%eax),%esi
NEXT 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 */ /* 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 .text
.align 4 .align 4
.globl DODATA .globl DODATA
@ -89,7 +98,7 @@ DOLOAD:
pushl (%eax) pushl (%eax)
NEXT 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 */ /* Push the return address (%esi) on the return stack */
/* Load the address of the DOES> code body from the DFA field at %eax+4 */ /* 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 */ /* 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 movb 12(%eax),%bl
andb $F_LENMASK,%bl andb $F_LENMASK,%bl
/* Calculate %eax + 13 + %ebx and round up to next cell for address of body */ /* Calculate %eax + 13 + %ebx and round up to next cell for address of body */
addl $16,%eax lea 16(%eax,%ebx),%eax
addl %ebx,%eax
andl $-4,%eax andl $-4,%eax
/* Push body address on the data stack */ /* Push body address on the data stack */
push %eax push %eax
@ -185,6 +193,7 @@ defconst VERSION,JUMPFORTH_VERSION
defconst R0,return_stack_top defconst R0,return_stack_top
defconst __DOCOL,DOCOL,"DOCOL" defconst __DOCOL,DOCOL,"DOCOL"
defconst __DODEFER,DODEFER,"DODEFER"
defconst __DODATA,DODATA,"DODATA" defconst __DODATA,DODATA,"DODATA"
defconst __DOLOAD,DOLOAD,"DOLOAD" defconst __DOLOAD,DOLOAD,"DOLOAD"
defconst __DODOES,DODOES,"DODOES" defconst __DODOES,DODOES,"DODOES"
@ -1183,8 +1192,7 @@ defcode TWORDROP,"2RDROP"
/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */ /* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
defcode SPFETCH,"SP@" defcode SPFETCH,"SP@"
mov %esp,%eax push %esp
push %eax
NEXT NEXT
/* ( a-addr -- ) Set the data stack pointer */ /* ( a-addr -- ) Set the data stack pointer */
@ -1202,9 +1210,8 @@ defcode LITSTRING
lodsb lodsb
push %esi push %esi
push %eax push %eax
addl %eax,%esi lea 3(%esi,%eax),%esi
addl $3,%esi andl $-4,%esi
andl $0xfffffffc,%esi
NEXT NEXT
defcode BRANCH defcode BRANCH
@ -1372,11 +1379,14 @@ defword ISSPACE,"SPACE?"
defword ALLOT defword ALLOT
.int CP,INCREMENT,EXIT .int CP,INCREMENT,EXIT
defword HERE
.int CP,FETCH,EXIT
defword COMMA,"," defword COMMA,","
.int CP,FETCH,CELL,ALLOT,STORE,EXIT .int HERE,CELL,ALLOT,STORE,EXIT
defword COMMABYTE,"C," 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 */ /* ( addr -- a-addr ) Round up to next cell-aligned address */
defword ALIGNED defword ALIGNED
@ -1385,7 +1395,7 @@ defword ALIGNED
/* ( -- ) Allocate data space up to the next cell-aligned address */ /* ( -- ) Allocate data space up to the next cell-aligned address */
/* Any bytes skipped over during alignment should be considered uninitialized */ /* Any bytes skipped over during alignment should be considered uninitialized */
defword ALIGN 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 ) */ /* ( c-addr-1 u-1 c-addr-2 u-2 -- flag ) */
defword STREQU,"=S" defword STREQU,"=S"
@ -1509,10 +1519,10 @@ defword ESCAPED_CHAR
.int TYPE,EMIT,EOL,BAILOUT .int TYPE,EMIT,EOL,BAILOUT
defword READSTRING defword READSTRING
.int CP,FETCH .int HERE
0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .) 0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
.int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .) .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 defword PARSENUMBER
.int DUP,LIT,0,GT,ZBRANCH,(6f - .) .int DUP,LIT,0,GT,ZBRANCH,(6f - .)
@ -1535,7 +1545,7 @@ defword INTERPRET
.int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .) .int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
.int LIT,1,IN,INCREMENT .int LIT,1,IN,INCREMENT
.int STATE,FETCH,ZBRANCH,(0f - .) .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 .int READSTRING,ROT,STOREBYTE,DROP,ALIGN,EXIT
/* ELSE */ /* ELSE */
0: .int READSTRING,EXIT 0: .int READSTRING,EXIT
@ -1561,17 +1571,15 @@ defword QUIT
.int R0,RSPSTORE .int R0,RSPSTORE
0: .int INTERPRET,BRANCH,(0b - .) 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 defword CREATE
.int ALIGN,CP,FETCH .int ALIGN,HERE
.int LIT,DODATA,COMMA .int LIT,DODATA,COMMA,LIT,0,COMMA,LATEST,COMMA
.int LIT,0,COMMA .int WORD,DUP,COMMABYTE,HERE,SWAP,DUP,ALLOT,CMOVE
.int CURRENT,FETCH,FETCH,COMMA .int ALIGN,HERE,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 .int CURRENT,FETCH,STORE,EXIT
/* /*
@ -1593,7 +1601,7 @@ defword PAREN,"(",F_IMMED
defword COLON,":" defword COLON,":"
/* Make word & fetch address */ /* Make word & fetch address */
.int CREATE,CURRENT,FETCH,FETCH .int CREATE,LATEST
/* Set as hidden */ /* Set as hidden */
.int DUP,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE .int DUP,TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,OR,SWAP,STOREBYTE
/* Convert to DOCOL codeword */ /* Convert to DOCOL codeword */
@ -1605,14 +1613,26 @@ defword SEMI,";",F_IMMED
/* Terminate the code with EXIT */ /* Terminate the code with EXIT */
.int LIT,EXIT,COMMA .int LIT,EXIT,COMMA
/* Fetch the address of the latest definition */ /* Fetch the address of the latest definition */
.int CURRENT,FETCH,FETCH .int LATEST
/* Clear the F_HIDDEN flag */ /* Clear the F_HIDDEN flag */
.int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE .int TFLAGS,DUP,FETCHBYTE,__F_HIDDEN,INVERT,AND,SWAP,STOREBYTE
/* Leave compilation mode */ /* Leave compilation mode */
.int FALSE,STATE,STORE,EXIT .int FALSE,STATE,STORE,EXIT
defword CONSTANT 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
/* ( "<spaces>ccc" -- ) */
defword DEFER
.int CREATE,LIT,BAILOUT,LATEST,DEFERSTORE,EXIT
defword QUOTE,"'" defword QUOTE,"'"
.int WORD,FIND_OR_ABORT,DROP,EXIT .int WORD,FIND_OR_ABORT,DROP,EXIT
@ -1646,25 +1666,25 @@ defword POSTPONE,,F_IMMED
1: .int COMMA,EXIT 1: .int COMMA,EXIT
defword AHEAD,,F_IMMED 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 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 defword THEN,,F_IMMED
.int CP,FETCH,OVER,SUB,SWAP,STORE,EXIT .int HERE,OVER,SUB,SWAP,STORE,EXIT
defword ELSE,,F_IMMED defword ELSE,,F_IMMED
.int AHEAD,SWAP,THEN,EXIT .int AHEAD,SWAP,THEN,EXIT
defword BEGIN,,F_IMMED defword BEGIN,,F_IMMED
.int CP,FETCH,EXIT .int HERE,EXIT
defword AGAIN,,F_IMMED 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 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 defword WHILE,,F_IMMED
.int IF,SWAP,EXIT .int IF,SWAP,EXIT

642
startup.4th
View File

@ -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 \ Shorthand for working with cell-aligned addresses
: CELL+ ( addr1 -- addr2 ) CELL + ; : CELL+ ( addr1 -- addr2 ) CELL + ;
: CELL- ( addr1 -- addr2 ) CELL - ; : CELL- ( addr1 -- addr2 ) CELL - ;
@ -28,6 +20,85 @@
: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; : IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ;
: HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN 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 ( -- <noreturn> )
' 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 <noreturn> )
\ 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 <noreturn> )
?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 -- <none> | <noreturn> )
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 \ Set the latest defined word as immediate
\ Note that IMMEDIATE is itself an immediate word \ Note that IMMEDIATE is itself an immediate word
: IMMEDIATE ( -- ) LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE : IMMEDIATE ( -- ) LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE
@ -50,34 +121,8 @@
: FM/MOD ( d1 n1 -- d1%n1 d1/n1 ) : FM/MOD ( d1 n1 -- d1%n1 d1/n1 )
DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ; DUP >R SM/REM OVER 0< IF 1- SWAP R> + SWAP ELSE RDROP THEN ;
\ Names for the standard file descriptor numbers : MIN 2DUP > IF NIP ELSE DROP THEN ;
0 CONSTANT STDIN : MAX 2DUP < IF NIP ELSE DROP THEN ;
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 ;
\ Define names for the whitespace characters \ Define names for the whitespace characters
8 CONSTANT HT \ Horizontal Tab 8 CONSTANT HT \ Horizontal Tab
@ -108,14 +153,6 @@
: BYE ( -- <noreturn> ) : BYE ( -- <noreturn> )
BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ; BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
\ Terminate the program with a fatal error (SIGABRT)
: FATAL-ERROR ( -- <noreturn> )
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 \ Display the unsigned number at the top of the stack
: U. ( u -- "<digits>" ) : U. ( u -- "<digits>" )
\ Start with the highest place-value on the left \ Start with the highest place-value on the left
@ -153,32 +190,35 @@
\ Return the next address in the compilation/data area \ Return the next address in the compilation/data area
: HERE ( -- addr ) CP @ ; : 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 \ When growing the data area, round the end address up to a multiple of this size
65536 CONSTANT DATA-SEGMENT-ALIGNMENT 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 -- ) : ALLOT ( n -- )
DUP 0< IF DUP 0< IF
DUP C0 HERE - < IF ALLOT-BOUNDS THEN DUP C0 HERE - < IF -24 THROW THEN
ELSE ELSE
DUP HERE INVERT U> IF ALLOT-BOUNDS THEN DUP HERE INVERT U> IF -8 THROW THEN
THEN THEN
HERE + DUP BRK @ U> IF HERE + DUP BRK @ U> IF
[ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
DUP DUP
SYS_BRK SYSCALL1 SYS_BRK SYSCALL1
OVER <> IF ALLOT-OOM THEN OVER <> IF -8 THROW THEN
BRK ! BRK !
THEN THEN
CP ! CP !
; ;
\ Allocate one cell from the data area and fill it with the value on the stack
: , HERE CELL ALLOT ! ; : , HERE CELL ALLOT ! ;
\ Allocate one character from the data area and fill it with the value on the stack
: C, HERE 1 ALLOT C! ; : 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 ; : 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. \ 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 : LITERAL ( Compilation: x -- ) ( Runtime: -- x ) IMMEDIATE
POSTPONE LIT , ; 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 \ Append the execution semantics of the current definition to the current definition
: RECURSE ( -- ) IMMEDIATE : RECURSE ( -- ) IMMEDIATE
LATEST COMPILE, ; LATEST COMPILE, ;
\ Unhide the current definition so it can refer to itself by name \ Unhide the current definition so it can refer to itself by name
: RECURSIVE ( -- ) IMMEDIATE : RECURSIVE ( -- ) IMMEDIATE
LATEST >FLAGS DUP C@ F_HIDDEN INVERT AND SWAP C! ; LATEST (UNHIDE) ;
\ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} THEN \ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} THEN
\ \
@ -246,23 +290,6 @@
: REPEAT ( C: orig dest -- ) IMMEDIATE : REPEAT ( C: orig dest -- ) IMMEDIATE
POSTPONE AGAIN POSTPONE THEN ; POSTPONE AGAIN POSTPONE THEN ;
\ Range loop: <limit> <index> DO <code> LOOP
\ <limit> <index> DO <code> <step> +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: \ Sequential equality tests:
\ <x> CASE \ <x> CASE
\ <x0> OF <code0> ENDOF \ <x0> OF <code0> ENDOF
@ -288,84 +315,72 @@
\ Drop the <x> value in case none of the OF...ENDOF clauses matched \ Drop the <x> value in case none of the OF...ENDOF clauses matched
\ Resolve all the forward branches from ENDOF to the location after ENDCASE \ Resolve all the forward branches from ENDOF to the location after ENDCASE
: ENDCASE ( C: orign ... orig1 n -- ) IMMEDIATE : 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: <limit> <index> DO <code> LOOP
\ <limit> <index> DO <code> <step> +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 <noreturn> )
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 SOURCE
CREATE INPUT-BUFFER-SIZE , CREATE INPUT-BUFFER-SIZE ,
CREATE INPUT-BUFFER , 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 , CREATE CURRENT-SOURCE-ID -1 ,
\ Report the current input buffer region and SOURCE-ID
: SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ; : SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ;
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ; : 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 ; : SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
: RESTORE-INPUT ( xu ... x1 u -- ) OVER >IN ! NDROP ; : RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ;
\ 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-AREA ( -- c-addr u ) SOURCE >IN @ DROP-PREFIX ;
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; : PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
: PEEK-CHAR ( -- c ) : PEEK-CHAR ( -- c )
PARSE-AREA 0= IF PARSE-AREA 0= "Unexpected end of input" ?FAIL C@ ;
DROP "Unexpected end of input\n" TYPE
FATAL-ERROR
THEN C@ ;
: SKIP-CHAR ( -- ) 1 >IN +! ; : SKIP-CHAR ( -- ) 1 >IN +! ;
@ -412,6 +427,8 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
POSTPONE LIT HERE 0 , POSTPONE (DOES) POSTPONE EXIT POSTPONE LIT HERE 0 , POSTPONE (DOES) POSTPONE EXIT
HERE SWAP ! ; HERE SWAP ! ;
' (DOES) (HIDE)
\ Define a named constant \ Define a named constant
\ Execution: ( value "<spaces>name" -- ) \ Execution: ( value "<spaces>name" -- )
\ name Execution: ( -- value ) \ name Execution: ( -- value )
@ -433,62 +450,50 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
\ Named values defined with VALUE can be modified with TO. \ Named values defined with VALUE can be modified with TO.
\ Execution: ( x "<spaces>name" -- ) \ Execution: ( x "<spaces>name" -- )
\ name execution: ( -- value ) \ name execution: ( -- value )
: VALUE CREATE , DOES> @ ; : VALUE CREATE , DOLOAD LATEST >CFA ! ;
: (TRACE) >NAME TYPE SPACE .DS EOL ;
\ Define a threaded FORTH word \ Define a threaded FORTH word
\ The word is initially hidden so it can refer to a prior word with the same name \ 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 \ The definition is terminated with the ; immediate word, which unhides the name
: : ( "<spaces>ccc" -- ) : : ( "<spaces>ccc" -- )
CREATE LATEST CREATE LATEST DUP (HIDE) DOCOL SWAP >CFA ! POSTPONE ] ;
DUP >FLAGS DUP C@ F_HIDDEN OR SWAP C!
DOCOL SWAP >CFA ! \ Define a threaded word which also displays its name and the data stack when called
POSTPONE ] : (TRACE) >NAME TYPE SPACE .DS EOL ;
\ ( uncomment for tracing ) LATEST POSTPONE LITERAL POSTPONE (TRACE) : :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
; ' (TRACE) (HIDE)
\ Like : but the definition has no name \ Like : but the definition has no name
\ The zero-length name still included in the word list so LATEST can refer to it \ 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 \ The execution token is left on the stack for use after the definition ends
: :NONAME ( -- ) : :NONAME ( -- )
ALIGN HERE ALIGN HERE DOCOL , HERE 3 CELLS+ , LATEST , F_HIDDEN C,
DOCOL , DUP GET-CURRENT ! ALIGN POSTPONE ] ;
HERE [ 3 CELLS ] LITERAL + ,
LATEST ,
F_HIDDEN C, ALIGN
DUP GET-CURRENT !
POSTPONE ] ;
\ End a definition by appending EXIT, leaving compilation mode, and unhiding the name \ End a definition by appending EXIT and leaving compilation mode
\ As an optimization, zero-length names (from :NONAME) are left hidden \ Unhide the name if it isn't empty (e.g. from :NONAME)
: ; ( -- ) IMMEDIATE : ; ( -- ) IMMEDIATE
POSTPONE EXIT POSTPONE [ POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
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 ( "<spaces>ccc" -- ) : POSTPONE EXIT POSTPONE ; ;
\ Fetch and store the target of the deferred word denoted by deferred-xt \ Fetch and store the target of the deferred word denoted by deferred-xt
: DEFER@ ( deferred-xt -- xt ) >DFA @ @ ; \ Note that this DEFER! can turn any word into a deferred word
: DEFER! ( xt deferred-xt -- ) >DFA @ ! ; : 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 ( "<spaces>ccc" -- )
CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ;
' (DEFERRED-UNINIT) (HIDE)
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect \ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
\ of placing the execution token for an anonymous function with the runtime \ of placing the execution token for an anonymous function with the runtime
\ effect of <code> on the top of the data stack. A branch is emitted to skip \ effect of <code> 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 \ over the memory used for the nested definition. If RECURSE is used in <code>
\ current word list upon completion. If RECURSE is used in <code> it will \ it will create a recursive call to the anonymous inner function. In the word
\ create a recursive call to the anonymous inner function. \ list, after the }, the inner definition is ordered before the outer definition.
\ LATEST always refers to the innermost enclosing definition.
\ \
\ Example: \ Example:
\ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ; \ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ;
@ -498,30 +503,40 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
\ Hello \ Hello
\ Hello \ Hello
\ \
\ Compilation effect: ( C: -- latest orig state ) \ Compilation effect: ( C: -- outer-xt orig inner-xt state )
\ Interpreter effect: ( S: -- latest state ) \ Interpreter effect: ( S: -- inner-xt state )
\ Enters compilation mode if not already compiling \ Enters compilation mode if not already compiling
: { ( -- latest {orig} state ) IMMEDIATE : { ( -- {outer-xt orig} inner-xt state ) IMMEDIATE
LATEST
STATE @ STATE @
DUP IF DUP IF
LATEST
DUP >LINK @ GET-CURRENT !
0 OVER >LINK !
POSTPONE AHEAD POSTPONE AHEAD
SWAP ROT
POSTPONE [ POSTPONE [
THEN THEN
:NONAME ; :NONAME SWAP ;
\ Resolve the forward branch over the inner function
\ Leave compilation mode if STATE was 0 before { was executed \ Leave compilation mode if STATE was 0 before { was executed
: } ( C: latest {orig} state -- ) IMMEDIATE \ Otherwise:
POSTPONE ; SWAP IF \ Resolve the forward branch over the inner function
-ROT \ Add outer-xt back to the word list after inner-xt
POSTPONE THEN \ Generate a literal for inner-xt
GET-CURRENT ! : } ( {outer-xt orig} inner-xt state -- {inner-xt} ) IMMEDIATE
POSTPONE LITERAL 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 ] POSTPONE ]
ELSE \ Compile inner-xt as a literal in the outer definition
SWAP GET-CURRENT ! POSTPONE LITERAL
\ ELSE ( nothing to do )
( S: inner-xt )
THEN ; THEN ;
\ Read the next word and return the first character \ Read the next word and return the first character
@ -622,6 +637,12 @@ VARIABLE ORDER-FREELIST
0 SWAP ! 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 \ Create a new wordlist
\ In this implementation a word list is just a pointer to the most recent word \ In this implementation a word list is just a pointer to the most recent word
: WORDLIST ( -- wid ) : WORDLIST ( -- wid )
@ -692,18 +713,13 @@ VARIABLE ORDER-FREELIST
REPEAT REPEAT
2R> 0 ; 2R> 0 ;
\ ABORT needs to be deferred so that it can refer to QUIT and INTERPRET \ Same as FIND except that unknown words are reported and result in a call to THROW
\ The initial target of FATAL-ERROR terminates the program with SIGABRT : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 )
DEFER ABORT ( -- <noreturn> ) FIND ?DUP 0= IF THROWN-STRING 2! -13 THROW THEN ;
' 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 ;
\ Read a word from the input (during runtime) and return its execution token \ 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 \ Aborts if the word is not found in the current (runtime) search order list
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-ABORT DROP ; : ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-THROW DROP ;
\ Like ' but generates a literal at compile-time. \ Like ' but generates a literal at compile-time.
: ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE : ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE
@ -711,7 +727,7 @@ DEFER ABORT ( -- <noreturn> )
\ Read a word and append its compilation semantics to the current definition. \ Read a word and append its compilation semantics to the current definition.
: POSTPONE ( "<spaces>name" -- ) IMMEDIATE : POSTPONE ( "<spaces>name" -- ) IMMEDIATE
WORD FIND-OR-ABORT 0< IF WORD FIND-OR-THROW 0< IF
COMPILE, COMPILE,
ELSE ELSE
DUP [ ' BOOTSTRAP? COMPILE, ] IF DUP [ ' BOOTSTRAP? COMPILE, ] IF
@ -736,20 +752,67 @@ DEFER ABORT ( -- <noreturn> )
' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ;
\ Hide the named word: HIDE <name> \ Hide the named word: HIDE <name>
: HIDE ( "<spaces>ccc" -- ) : HIDE ( "<spaces>ccc" -- ) ' (HIDE) ;
' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
\ Hide internal utility functions \ Begin a new colon definition; hide & redirect the previous word
HIDE ALLOT-BOUNDS \ with the same name to the new definition
HIDE ALLOT-OOM : :REPLACE ( "<spaces>ccc" -- )
HIDE (DOES) : LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ;
\ Abstract away the internals of the search order implementation \ The size of this buffer will determine the maximum line length
HIDE CURRENT 4096 CONSTANT TERMINAL-BUFFER-SIZE
HIDE CURRENT-ORDER CREATE TERMINAL-BUFFER TERMINAL-BUFFER-SIZE ALLOT
HIDE ORDER-FREELIST
HIDE ORDER>WID \ If we read more than one line then these will refer to the rest of the data
HIDE ORDER>LINK 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 ( "<escapeseq>" | "c" -- c ) : ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
NEXT-CHAR DUP [CHAR] \ = IF NEXT-CHAR DUP [CHAR] \ = IF
@ -765,8 +828,7 @@ HIDE ORDER>LINK
[CHAR] " OF [CHAR] " ENDOF [CHAR] " OF [CHAR] " ENDOF
[CHAR] ' OF [CHAR] ' ENDOF [CHAR] ' OF [CHAR] ' ENDOF
[CHAR] \ OF [CHAR] \ ENDOF [CHAR] \ OF [CHAR] \ ENDOF
"Unknown escape sequence: \\" TYPE DUP EMIT EOL TRUE "Unknown escape sequence" ?FAIL
FATAL-ERROR
ENDCASE ENDCASE
THEN ; THEN ;
@ -827,7 +889,7 @@ HIDE ORDER>LINK
POSTPONE LITERAL POSTPONE LITERAL
THEN THEN
ELSE ELSE
FIND-OR-ABORT FIND-OR-THROW
\ -1 => immediate word; execute regardless of STATE \ -1 => immediate word; execute regardless of STATE
\ 1 => read STATE; compile if true, execute if false \ 1 => read STATE; compile if true, execute if false
0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN 0< OR-ELSE STATE @ 0= THEN IF EXECUTE ELSE COMPILE, THEN
@ -835,8 +897,9 @@ HIDE ORDER>LINK
THEN THEN
REPEAT ; 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 \ Empty the return stack, make stdin the input source, and enter interpretation state
: QUIT ( -- <noreturn> ) :REPLACE QUIT ( -- <noreturn> )
R0 RSP! R0 RSP!
0 CURRENT-SOURCE-ID ! 0 CURRENT-SOURCE-ID !
FALSE STATE ! FALSE STATE !
@ -861,27 +924,77 @@ HIDE ORDER>LINK
INTERPRET INTERPRET
R> CURRENT-SOURCE-ID ! R> CURRENT-SOURCE-ID !
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER ! 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 <noreturn> )
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 CURRENT-SOURCE-ID
HIDE INPUT-BUFFER HIDE INPUT-BUFFER
HIDE INPUT-BUFFER-SIZE 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 HIDE (HIDE)
\ Empty the data stack and then perform the function of QUIT without any message HIDE (UNHIDE)
' ABORT
HIDE ABORT HIDE ESCAPED-CHAR
: ABORT ( -- <noreturn> ) S0 SP! QUIT ; HIDE READSTRING
' ABORT SWAP DEFER! 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 \ 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 FORTH-WORDLIST 1 SET-ORDER
DEFINITIONS DEFINITIONS
{ R0 RSP! BEGIN INTERPRET AGAIN } EXECUTE
\ ***************************************************************************** \ *****************************************************************************
\ Bootstrapping is complete \ Bootstrapping is complete
@ -917,7 +1030,7 @@ DEFINITIONS
DUP >NAME DUP IF DUP >NAME DUP IF
\ Is the name hidden? \ Is the name hidden?
2 PICK HIDDEN? IF 2 PICK HIDDEN? IF
"×" TYPE "⌀" TYPE
ELSE ELSE
\ Does FIND with the same name fail to return the same word? \ Does FIND with the same name fail to return the same word?
2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF 2DUP FIND AND-THEN 3 PICK = ELSE NIP NIP THEN 0= IF
@ -934,17 +1047,84 @@ DEFINITIONS
. .
THEN ; THEN ;
\ Display the first `u` words in the body of the given execution token with .W \ Read one cell and increment
: UNTHREAD ( xt u -- ) : @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ;
SWAP >DFA @ SWAP
: TYPE-ESCAPED ( c-addr u -- "<escapeseq*>" )
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 BEGIN
?DUP @(+)
WHILE DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF
SWAP DUP @ .W SPACE 2DROP RDROP EXIT
CELL + SWAP 1- THEN
REPEAT DUP ['] LIT = IF
DROP 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 ( "<spaces>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 ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\nOK> " TYPE ;