add exception handling with THROW and CATCH, and a version of SEE
This commit is contained in:
parent
c0391de969
commit
29b949d583
90
jumpforth.S
90
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
|
||||
|
||||
/* ( "<spaces>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
|
||||
|
|
|
|||
642
startup.4th
642
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 ( -- <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
|
||||
\ 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 ( -- <noreturn> )
|
||||
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
|
||||
: U. ( u -- "<digits>" )
|
||||
\ 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: <cond> IF <true> {ELSE <false>} THEN
|
||||
\
|
||||
|
|
@ -246,23 +290,6 @@
|
|||
: REPEAT ( C: orig dest -- ) IMMEDIATE
|
||||
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:
|
||||
\ <x> CASE
|
||||
\ <x0> OF <code0> ENDOF
|
||||
|
|
@ -288,84 +315,72 @@
|
|||
\ 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
|
||||
: 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
|
||||
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 "<spaces>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 "<spaces>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
|
||||
: : ( "<spaces>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 ( "<spaces>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 ( "<spaces>ccc" -- )
|
||||
CREATE ['] (DEFERRED-UNINIT) LATEST DEFER! ;
|
||||
' (DEFERRED-UNINIT) (HIDE)
|
||||
|
||||
\ Inline :NONAME-style function literals. "{ <code> }" has the runtime effect
|
||||
\ 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
|
||||
\ over the memory used for the nested definition, which is removed from the
|
||||
\ current word list upon completion. If RECURSE is used in <code> it will
|
||||
\ create a recursive call to the anonymous inner function.
|
||||
\ over the memory used for the nested definition. If RECURSE is used in <code>
|
||||
\ 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 ( -- <noreturn> )
|
||||
' 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
|
||||
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-ABORT DROP ;
|
||||
: ' ( "<spaces>ccc" -- xt ) WORD FIND-OR-THROW DROP ;
|
||||
|
||||
\ Like ' but generates a literal at compile-time.
|
||||
: ['] ( 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.
|
||||
: POSTPONE ( "<spaces>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 ( -- <noreturn> )
|
|||
' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ;
|
||||
|
||||
\ Hide the named word: HIDE <name>
|
||||
: HIDE ( "<spaces>ccc" -- )
|
||||
' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
|
||||
: HIDE ( "<spaces>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 ( "<spaces>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 ( "<escapeseq>" | "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 ( -- <noreturn> )
|
||||
:REPLACE QUIT ( -- <noreturn> )
|
||||
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 <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 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 ( -- <noreturn> ) 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 -- "<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
|
||||
?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 ( "<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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue