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

remove ['] and [CHAR], add MARKER and PRESERVED, tweak bootstrap word lists, etc.

This commit is contained in:
Jesse D. McDonald 2020-10-29 14:36:09 -05:00
parent a1c55c0d64
commit 3009bc84e5
8 changed files with 399 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
jumpforth.S
View File

@ -174,7 +174,7 @@ defdata \label,"\name",\flags
.int \initial .int \initial
.endm .endm
.macro defconst label:req,value,name="",flags=0 .macro defconst label:req,value:req,name="",flags=0
defname \label,DODATA,\value,"\name",\flags defname \label,DODATA,\value,"\name",\flags
.endm .endm
@ -188,6 +188,10 @@ data_\label :
.int \initial .int \initial
.endm .endm
.macro defdefer label:req,value:req,name="",flags=0
defname \label,DODEFER,\value,"\name",\flags
.endm
defconst VERSION,JUMPFORTH_VERSION defconst VERSION,JUMPFORTH_VERSION
defconst R0,return_stack_top defconst R0,return_stack_top
@ -221,9 +225,6 @@ defvar IN,0,">IN"
defvar CP /* "compilation pointer", next free byte in the heap */ defvar CP /* "compilation pointer", next free byte in the heap */
defvar BRK /* the (current) end of the heap */ defvar BRK /* the (current) end of the heap */
/* The list of basic non-primitive words used to bootstrap the startup.4th file */
defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST"
/* The word list containing all the standard FORTH words */ /* The word list containing all the standard FORTH words */
/* Initially it just mirrors the primitive list */ /* Initially it just mirrors the primitive list */
/* The rest will be populated by the startup.4th script */ /* The rest will be populated by the startup.4th script */
@ -1058,6 +1059,22 @@ defcode EXECUTE
pop %eax pop %eax
jmp *(%eax) jmp *(%eax)
/* ( x1 -- x2 ) Compute a non-cryptographic 32-bit hash of a 32-bit cell */
/* Adapted from Bob Jenkins's "4-byte integer hash, full avalanche" */
/* hashint() algorithm <http://burtleburtle.net/bob/hash/integer.html>. */
/* This is intended for use in hash tables and coded in assembly for performance */
defcode HASHCELL
pop %eax
mov %eax,%ebx; shl $6,%ebx; sub %ebx,%eax
mov %eax,%ebx; shr $17,%ebx; xor %ebx,%eax
mov %eax,%ebx; shl $9,%ebx; sub %ebx,%eax
mov %eax,%ebx; shl $4,%ebx; xor %ebx,%eax
mov %eax,%ebx; shl $3,%ebx; sub %ebx,%eax
mov %eax,%ebx; shl $10,%ebx; xor %ebx,%eax
mov %eax,%ebx; shr $15,%ebx; xor %ebx,%eax
push %eax
NEXT
/* ( ebx ecx edx esi edi ebp eax/sc -- eax/result ) */ /* ( ebx ecx edx esi edi ebp eax/sc -- eax/result ) */
defcode SYSCALL6 defcode SYSCALL6
mov %ebp,%ecx mov %ebp,%ecx
@ -1147,16 +1164,23 @@ defcode BREAK
.section .data .section .data
bootstrap_data_begin: bootstrap_data_begin:
/* The list of basic non-primitive words used to bootstrap the startup.4th file */
defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST"
defdefer BOOTSTRAP_ALLOT,ALLOT,"BOOTSTRAP-ALLOT"
defdefer BOOTSTRAP_GET_ORDER,GET_ORDER,"BOOTSTRAP-GET-ORDER"
defdefer BOOTSTRAP_PARSENUMBER,PARSENUMBER,"BOOTSTRAP-PARSENUMBER"
/* ( c-addr u -- "ccc" ) */ /* ( c-addr u -- "ccc" ) */
defword TYPE defword TYPE,,F_HIDDEN
.int LIT,1,NROT,LIT,__NR_write,SYSCALL3,DROP,EXIT .int LIT,1,NROT,LIT,__NR_write,SYSCALL3,DROP,EXIT
/* ( c -- "c" ) */ /* ( c -- "c" ) */
defword EMIT defword EMIT,,F_HIDDEN
.int SPFETCH,LIT,1,SWAP,LIT,1,LIT,__NR_write,SYSCALL3,TWODROP,EXIT .int SPFETCH,LIT,1,SWAP,LIT,1,LIT,__NR_write,SYSCALL3,TWODROP,EXIT
/* ( -- "<eol>" ) */ /* ( -- "<eol>" ) */
defword EOL defword EOL,,F_HIDDEN
.int LIT,10,EMIT,EXIT .int LIT,10,EMIT,EXIT
/* Used for any fatal errors that occur during bootstrapping */ /* Used for any fatal errors that occur during bootstrapping */
@ -1167,7 +1191,7 @@ defword BAILOUT
0: .int LIT,254,LIT,__NR_exit,SYSCALL1,DROP,BRANCH,(0b - .) 0: .int LIT,254,LIT,__NR_exit,SYSCALL1,DROP,BRANCH,(0b - .)
.int EXIT /* just to mark the end */ .int EXIT /* just to mark the end */
defword UNEXPECTED_EOF,"UNEXPECTED-EOF" defword UNEXPECTED_EOF,"UNEXPECTED-EOF",F_HIDDEN
litstring "Unexpected end of input\n" litstring "Unexpected end of input\n"
.int TYPE,BAILOUT,EXIT .int TYPE,BAILOUT,EXIT
@ -1177,20 +1201,20 @@ defword SOURCE
.int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT .int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT
/* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */ /* ( -- c-addr u ) Current parse area (input buffer minus first >IN characters) */
defword PARSE_AREA,"PARSE-AREA" defword PARSE_AREA,"PARSE-AREA",F_HIDDEN
.int SOURCE,IN,FETCH,ROT,OVER,ADD,NROT,SUB,EXIT .int SOURCE,IN,FETCH,ROT,OVER,ADD,NROT,SUB,EXIT
/* ( "c" -- c ) Leaves c at the start of the parse area */ /* ( "c" -- c ) Leaves c at the start of the parse area */
defword PEEK_CHAR,"PEEK-CHAR" defword PEEK_CHAR,"PEEK-CHAR",F_HIDDEN
.int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT .int PARSE_AREA,ZBRANCH,(0f - .),FETCHBYTE,EXIT
0: .int UNEXPECTED_EOF,EXIT 0: .int UNEXPECTED_EOF,EXIT
/* ( "c" -- c ) Removes and returns the first character in the parse area */ /* ( "c" -- c ) Removes and returns the first character in the parse area */
defword NEXT_CHAR,"NEXT-CHAR" defword NEXT_CHAR,"NEXT-CHAR",F_HIDDEN
.int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT .int PEEK_CHAR,LIT,1,IN,INCREMENT,EXIT
/* ( c -- flag ) */ /* ( c -- flag ) */
defword ISSPACE,"SPACE?" defword ISSPACE,"SPACE?",F_HIDDEN
/* check for space (32) first and return true if input matches */ /* check for space (32) first and return true if input matches */
.int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT .int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
/* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */ /* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
@ -1201,26 +1225,26 @@ defword ISSPACE,"SPACE?"
defword ALLOT defword ALLOT
.int CP,INCREMENT,EXIT .int CP,INCREMENT,EXIT
defword HERE defword HERE,,F_HIDDEN
.int CP,FETCH,EXIT .int CP,FETCH,EXIT
defword COMMA,"," defword COMMA,","
.int HERE,CELL,ALLOT,STORE,EXIT .int HERE,CELL,BOOTSTRAP_ALLOT,STORE,EXIT
defword COMMABYTE,"C," defword COMMABYTE,"C,",F_HIDDEN
.int HERE,LIT,1,ALLOT,STOREBYTE,EXIT .int HERE,LIT,1,BOOTSTRAP_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,,F_HIDDEN
.int LIT,3,ADD,LIT,-4,AND,EXIT .int LIT,3,ADD,LIT,-4,AND,EXIT
/* ( -- ) 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,,F_HIDDEN
.int HERE,DUP,ALIGNED,SWAP,SUB,ALLOT,EXIT .int HERE,DUP,ALIGNED,SWAP,SUB,BOOTSTRAP_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",F_HIDDEN
.int ROT,OVER,EQU,ZBRANCH,(1f - .) /* c-addr-1 c-addr-2 u-2 R: */ .int ROT,OVER,EQU,ZBRANCH,(1f - .) /* c-addr-1 c-addr-2 u-2 R: */
0: .int DUP,ZBRANCH,(2f - .) /* c-addr-1 c-addr-2 u R: */ 0: .int DUP,ZBRANCH,(2f - .) /* c-addr-1 c-addr-2 u R: */
.int SUB1 /* c-addr-1 c-addr-2 u' R: */ .int SUB1 /* c-addr-1 c-addr-2 u' R: */
@ -1231,47 +1255,47 @@ defword STREQU,"=S"
2: .int TWODROP,DROP,TRUE,EXIT /* TRUE R: */ 2: .int TWODROP,DROP,TRUE,EXIT /* TRUE R: */
/* ( xt -- cfa-addr ) Address of the codeword field */ /* ( xt -- cfa-addr ) Address of the codeword field */
defword TCFA,">CFA" defword TCFA,">CFA",F_HIDDEN
.int EXIT .int EXIT
/* ( xt -- dfa-addr ) Address of the dataword field */ /* ( xt -- dfa-addr ) Address of the dataword field */
defword TDFA,">DFA" defword TDFA,">DFA",F_HIDDEN
.int CELL,ADD,EXIT .int CELL,ADD,EXIT
/* ( xt -- link-addr ) Address of the dataword field */ /* ( xt -- link-addr ) Address of the dataword field */
defword TLINK,">LINK" defword TLINK,">LINK",F_HIDDEN
.int LIT,8,ADD,EXIT .int LIT,8,ADD,EXIT
/* ( xt -- flags-addr ) Address of the flag/length byte */ /* ( xt -- flags-addr ) Address of the flag/length byte */
defword TFLAGS,">FLAGS" defword TFLAGS,">FLAGS",F_HIDDEN
.int LIT,12,ADD,EXIT .int LIT,12,ADD,EXIT
/* ( xt -- name-addr name-len ) Address and length of the name field */ /* ( xt -- name-addr name-len ) Address and length of the name field */
defword TNAME,">NAME" defword TNAME,">NAME",F_HIDDEN
.int TFLAGS,DUP,ADD1,SWAP,FETCHBYTE,__F_LENMASK,AND,EXIT .int TFLAGS,DUP,ADD1,SWAP,FETCHBYTE,__F_LENMASK,AND,EXIT
/* ( xt -- a-addr ) Data-field address (next cell after the name) */ /* ( xt -- a-addr ) Data-field address (next cell after the name) */
defword TBODY,">BODY" defword TBODY,">BODY",F_HIDDEN
.int TNAME,ADD,ALIGNED,EXIT .int TNAME,ADD,ALIGNED,EXIT
/* ( xt -- flag ) Is the F_IMMED flag set? */ /* ( xt -- flag ) Is the F_IMMED flag set? */
defword ISIMMEDIATE,"IMMEDIATE?" defword ISIMMEDIATE,"IMMEDIATE?",F_HIDDEN
.int LIT,12,ADD,FETCHBYTE,__F_IMMED,AND,LIT,0,NEQU,EXIT .int LIT,12,ADD,FETCHBYTE,__F_IMMED,AND,LIT,0,NEQU,EXIT
/* ( xt -- flag ) Is the F_HIDDEN flag set? */ /* ( xt -- flag ) Is the F_HIDDEN flag set? */
defword ISHIDDEN,"HIDDEN?" defword ISHIDDEN,"HIDDEN?",F_HIDDEN
.int LIT,12,ADD,FETCHBYTE,__F_HIDDEN,AND,LIT,0,NEQU,EXIT .int LIT,12,ADD,FETCHBYTE,__F_HIDDEN,AND,LIT,0,NEQU,EXIT
/* ( xt -- flag ) Is the xt a non-primitive bootstrap word? */ /* ( xt -- flag ) Is the xt a non-primitive bootstrap word? */
defword ISBOOTSTRAP,"BOOTSTRAP?" defword ISBOOTSTRAP,"BOOTSTRAP?",F_HIDDEN
.int DUP,LIT,bootstrap_data_begin,UGE,ZBRANCH,(0f - .) .int DUP,LIT,bootstrap_data_begin,UGE,ZBRANCH,(0f - .)
.int LIT,bootstrap_data_end,ULT,EXIT .int LIT,bootstrap_data_end,ULT,EXIT
0: .int DROP,FALSE,EXIT 0: .int DROP,FALSE,EXIT
/* ( -- widn ... wid1 n ) Return the current search order */ /* ( -- widn ... wid1 n ) Return the current search order */
/* Redefining this word with DEFER! will change the bootstrap search order */ /* Redefining this word with DEFER! will change the bootstrap search order */
defword BOOTSTRAP_GET_ORDER,"BOOTSTRAP-GET-ORDER" defword GET_ORDER,"GET-ORDER",F_HIDDEN
.int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,LIT,2,EXIT .int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,CURRENT,FETCH,LIT,3,EXIT
/* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */ /* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */
/* 0 = not found; 1 = non-immediate; -1 = immediate */ /* 0 = not found; 1 = non-immediate; -1 = immediate */
@ -1287,7 +1311,7 @@ defword SEARCH_WORDLIST,"SEARCH-WORDLIST"
4: .int NIP,NIP,EXIT /* 0 */ 4: .int NIP,NIP,EXIT /* 0 */
/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */ /* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
defword FIND defword FIND,,F_HIDDEN
.int TWOTOR,BOOTSTRAP_GET_ORDER .int TWOTOR,BOOTSTRAP_GET_ORDER
0: .int DUP,ZBRANCH,(1f - .) 0: .int DUP,ZBRANCH,(1f - .)
.int SUB1,SWAP,TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .) .int SUB1,SWAP,TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .)
@ -1295,13 +1319,13 @@ defword FIND
1: .int TWOFROMR,ROT,EXIT 1: .int TWOFROMR,ROT,EXIT
/* ( c-addr u -- xt 1 | xt -1 ) */ /* ( c-addr u -- xt 1 | xt -1 ) */
defword FIND_OR_BAILOUT,"FIND-OR-BAILOUT" defword FIND_OR_BAILOUT,"FIND-OR-BAILOUT",F_HIDDEN
.int FIND,QDUP,ZBRANCH,(0f - .),EXIT .int FIND,QDUP,ZBRANCH,(0f - .),EXIT
0: litstring "Word not found: " 0: litstring "Word not found: "
.int TYPE,TYPE,EOL,BAILOUT,EXIT .int TYPE,TYPE,EOL,BAILOUT,EXIT
/* ( "<spaces>" -- ) */ /* ( "<spaces>" -- ) */
defword SKIP_SPACE,"SKIP-SPACE" defword SKIP_SPACE,"SKIP-SPACE",F_HIDDEN
0: .int PARSE_AREA,ZBRANCH,(1f - .) 0: .int PARSE_AREA,ZBRANCH,(1f - .)
.int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .) .int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
.int LIT,1,IN,INCREMENT,BRANCH,(0b - .) .int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
@ -1309,7 +1333,7 @@ defword SKIP_SPACE,"SKIP-SPACE"
2: .int EXIT 2: .int EXIT
/* ( "<spaces?>ccc<space>" -- c-addr u ) */ /* ( "<spaces?>ccc<space>" -- c-addr u ) */
defword PARSE_NAME,"PARSE-NAME" defword PARSE_NAME,"PARSE-NAME",F_HIDDEN
.int SKIP_SPACE .int SKIP_SPACE
.int PARSE_AREA,DROP,LIT,1 .int PARSE_AREA,DROP,LIT,1
.int NEXT_CHAR,DROP .int NEXT_CHAR,DROP
@ -1319,7 +1343,7 @@ defword PARSE_NAME,"PARSE-NAME"
1: .int DROP 1: .int DROP
2: .int EXIT 2: .int EXIT
defword ESCAPED_CHAR defword ESCAPED_CHAR,,F_HIDDEN
.int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT .int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
0: .int DROP,NEXT_CHAR 0: .int DROP,NEXT_CHAR
.int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT .int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
@ -1337,13 +1361,13 @@ defword ESCAPED_CHAR
.int TYPE,EMIT,EOL,BAILOUT,EXIT .int TYPE,EMIT,EOL,BAILOUT,EXIT
/* ( "ccc<quote>" -- c-addr u ) */ /* ( "ccc<quote>" -- c-addr u ) */
defword READSTRING defword READSTRING,,F_HIDDEN
.int HERE .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,HERE,OVER,SUB,ALIGN,EXIT 1: .int LIT,1,IN,INCREMENT,HERE,OVER,SUB,ALIGN,EXIT
defword PARSENUMBER defword PARSENUMBER,,F_HIDDEN
.int DUP,LIT,0,GT,ZBRANCH,(7f - .) .int DUP,LIT,0,GT,ZBRANCH,(7f - .)
.int OVER,FETCHBYTE,LIT,'-',EQU,DUP,TOR,LIT,0,TOR,ZBRANCH,(0f - .) .int OVER,FETCHBYTE,LIT,'-',EQU,DUP,TOR,LIT,0,TOR,ZBRANCH,(0f - .)
.int DUP,LIT,1,GT,ZBRANCH,(6f - .),BRANCH,(1f - .) .int DUP,LIT,1,GT,ZBRANCH,(6f - .),BRANCH,(1f - .)
@ -1359,7 +1383,7 @@ defword PARSENUMBER
.int NEGATE .int NEGATE
9: .int TRUE,EXIT 9: .int TRUE,EXIT
defword INTERPRET defword INTERPRET,,F_HIDDEN
.int SKIP_SPACE .int SKIP_SPACE
.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
@ -1370,7 +1394,7 @@ defword INTERPRET
litstring "Tried to interpret a string literal\n" litstring "Tried to interpret a string literal\n"
.int TYPE,BAILOUT .int TYPE,BAILOUT
/* ELSE */ /* ELSE */
1: .int PARSE_NAME,TWODUP,PARSENUMBER,ZBRANCH,(3f - .) 1: .int PARSE_NAME,TWODUP,BOOTSTRAP_PARSENUMBER,ZBRANCH,(3f - .)
.int STATE,FETCH,TWONIP,ZBRANCH,(2f - .) .int STATE,FETCH,TWONIP,ZBRANCH,(2f - .)
.int LIT,LIT,COMMA,COMMA .int LIT,LIT,COMMA,COMMA
2: .int EXIT 2: .int EXIT
@ -1386,19 +1410,19 @@ defword INTERPRET
.int TYPE,TNAME,TYPE,EOL,BAILOUT .int TYPE,TNAME,TYPE,EOL,BAILOUT
6: .int COMMA,EXIT 6: .int COMMA,EXIT
defword QUIT defword QUIT,,F_HIDDEN
.int R0,RSPSTORE .int R0,RSPSTORE
0: .int INTERPRET,BRANCH,(0b - .) 0: .int INTERPRET,BRANCH,(0b - .)
.int EXIT .int EXIT
defword LATEST defword LATEST,,F_HIDDEN
.int CURRENT,FETCH,FETCH,EXIT .int CURRENT,FETCH,FETCH,EXIT
/* CREATE depends on bootstrap ALIGN, COMMA, LATEST, PARSE_NAME, ALLOT, >FLAGS, and >DFA */ /* CREATE depends on various bootstrap words */
defword CREATE defword CREATE
.int ALIGN,HERE .int ALIGN,HERE
.int LIT,DODATA,COMMA,LIT,0,COMMA,LATEST,COMMA .int LIT,DODATA,COMMA,LIT,0,COMMA,LATEST,COMMA
.int PARSE_NAME,DUP,COMMABYTE,HERE,SWAP,DUP,ALLOT,CMOVE .int PARSE_NAME,DUP,COMMABYTE,HERE,SWAP,DUP,BOOTSTRAP_ALLOT,CMOVE
.int ALIGN,HERE,OVER,TDFA,STORE .int ALIGN,HERE,OVER,TDFA,STORE
.int CURRENT,FETCH,STORE,EXIT .int CURRENT,FETCH,STORE,EXIT
@ -1456,15 +1480,9 @@ defword QUOTE,"'"
defword LITERAL,,F_IMMED defword LITERAL,,F_IMMED
.int LIT,LIT,COMMA,COMMA,EXIT .int LIT,LIT,COMMA,COMMA,EXIT
defword COMPILE_QUOTE,"[']",F_IMMED
.int QUOTE,LITERAL,EXIT
defword CHAR defword CHAR
.int PARSE_NAME,DROP,FETCHBYTE,EXIT .int PARSE_NAME,DROP,FETCHBYTE,EXIT
defword COMPILE_CHAR,"[CHAR]",F_IMMED
.int CHAR,LITERAL,EXIT
defword POSTPONE,,F_IMMED defword POSTPONE,,F_IMMED
.int PARSE_NAME,FIND_OR_BAILOUT,ZGT,ZBRANCH,(0f - .) .int PARSE_NAME,FIND_OR_BAILOUT,ZGT,ZBRANCH,(0f - .)
.int LITERAL .int LITERAL

506
startup.4th
View File

@ -1,17 +1,8 @@
\ Get and set the current compilation word list
: GET-CURRENT ( -- wid ) CURRENT @ ;
: SET-CURRENT ( wid -- ) CURRENT ! ;
\ Reserved for "invalid address" or "object not present"
\ Signifies (the absence of) a memory address, not a number
0 CONSTANT NULL
\ Keep internal system definitions and ABI constants out of the main word list \ Keep internal system definitions and ABI constants out of the main word list
CREATE SYSTEM-WORDLIST NULL , CP @ 0 , DUP CURRENT ! CONSTANT SYSTEM-WORDLIST
CREATE UTILITY-WORDLIST NULL , CP @ 0 , CONSTANT UTILITY-WORDLIST
CREATE LINUX-WORDLIST NULL , CP @ 0 , CONSTANT LINUX-WORDLIST
BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST
SYSTEM-WORDLIST SET-CURRENT
\ Use this list until we get around to defining the real GET-ORDER \ Use this list until we get around to defining the real GET-ORDER
: STARTUP-ORDER ( -- widn ... wid1 n ) : STARTUP-ORDER ( -- widn ... wid1 n )
@ -21,7 +12,15 @@ SYSTEM-WORDLIST SET-CURRENT
SYSTEM-WORDLIST SYSTEM-WORDLIST
FORTH-WORDLIST FORTH-WORDLIST
5 ; 5 ;
LATEST ' BOOTSTRAP-GET-ORDER DEFER! ' STARTUP-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
FORTH-WORDLIST CURRENT !
\ Get and set the current compilation word list
: GET-CURRENT ( -- wid ) CURRENT @ ;
: SET-CURRENT ( wid -- ) CURRENT ! ;
SYSTEM-WORDLIST SET-CURRENT
\ Shorthand for selecting the current compilation word list \ Shorthand for selecting the current compilation word list
: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ; : >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ;
@ -31,6 +30,10 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
>>FORTH >>FORTH
\ Reserved for "invalid address" or "object not present"
\ Signifies (the absence of) a memory address, not a number
0 CONSTANT NULL
\ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes) \ Unit suffixes, e.g. 4 KB ≡ 4096 (bytes)
: KB 10 LSHIFT ; : KB 10 LSHIFT ;
: MB 20 LSHIFT ; : MB 20 LSHIFT ;
@ -50,6 +53,9 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
\ Round up to the next cell-aligned address \ Round up to the next cell-aligned address
: ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ; : ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ;
\ Return the next address in the compilation/data area
: HERE ( -- addr ) CP @ ;
>>UTILITY >>UTILITY
\ Field accessors for execution tokens \ Field accessors for execution tokens
@ -77,32 +83,30 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
: 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<> ;
\ Fetch and store the target of the deferred word denoted by deferred-xt
\ 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 ! ;
\ Decrement the array size and increment the address by the same amount \ Decrement the array size and increment the address by the same amount
: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ; : /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
\ Semantically equivalent to "1 /STRING" \ Semantically equivalent to "1 /STRING"
: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ; : 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ;
\ Standard (ANS FORTH) THROW code assignments (-255 ... -1) \ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
-1 CONSTANT EXCP-ABORT -1 CONSTANT EXCP-ABORT
-2 CONSTANT EXCP-FAIL -2 CONSTANT EXCP-FAIL
-3 CONSTANT EXCP-STACK-OVERFLOW -3 CONSTANT EXCP-STACK-OVERFLOW
-4 CONSTANT EXCP-STACK-UNDERFLOW -4 CONSTANT EXCP-STACK-UNDERFLOW
-5 CONSTANT EXCP-RETURN-OVERFLOW -5 CONSTANT EXCP-RETURN-OVERFLOW
-6 CONSTANT EXCP-RETURN-UNDERFLOW -6 CONSTANT EXCP-RETURN-UNDERFLOW
-8 CONSTANT EXCP-DICTIONARY-OVERFLOW -8 CONSTANT EXCP-DICTIONARY-OVERFLOW
-9 CONSTANT EXCP-INVALID-ADDRESS -9 CONSTANT EXCP-INVALID-ADDRESS
-12 CONSTANT EXCP-TYPE-MISMATCH
-13 CONSTANT EXCP-UNDEFINED-WORD -13 CONSTANT EXCP-UNDEFINED-WORD
-17 CONSTANT EXCP-PNO-OVERFLOW -17 CONSTANT EXCP-PNO-OVERFLOW
-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT -24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
-37 CONSTANT EXCP-FILE-IO -37 CONSTANT EXCP-FILE-IO
-56 CONSTANT EXCP-QUIT
\ Non-standard system error codes (-4095 ... -256) \ Non-standard system error codes (-4095 ... -256)
-256 CONSTANT EXCP-HEAP-OVERFLOW -256 CONSTANT EXCP-HEAP-OVERFLOW
-257 CONSTANT EXCP-DEFER-UNINITIALIZED
>>SYSTEM >>SYSTEM
@ -112,12 +116,17 @@ CREATE THROWN-STRING 2 CELLS ALLOT
NULL 0 THROWN-STRING 2! NULL 0 THROWN-STRING 2!
\ This is called by THROW when n is nonzero \ 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 \ CATCH saves and restores the current target and substitutes its own version
\ BAILOUT will be replaced by DEFAULT-UNWIND later in the startup
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> ) DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
' BAILOUT ' THROW-UNWIND DEFER!
>>FORTH >>FORTH
\ QUIT needs to be defined after INTERPRET
DEFER QUIT
' BAILOUT ' QUIT DEFER!
\ If n is nonzero, return control to the nearest CATCH on the return stack \ 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) \ 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: \ Absent CATCH, whether a message is displayed depends on the value of n:
@ -126,14 +135,15 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
\ otherwise message is implementation-dependent \ otherwise message is implementation-dependent
\ \
\ For use after CATCH; like THROW but doesn't change the string \ For use after CATCH; like THROW but doesn't change the string
\ Also, if n is EXCP-QUIT then invokes QUIT for special handling (keeps data stack)
: RETHROW ( k*x n -- k*x | i*x n <noreturn> ) : RETHROW ( k*x n -- k*x | i*x n <noreturn> )
?DUP IF THROW-UNWIND THEN ; ?DUP IF DUP EXCP-QUIT = IF QUIT THEN THROW-UNWIND THEN ;
\ THROW while storing a string for context \ THROW while storing a string for context
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> ) : THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
THROWN-STRING 2! RETHROW ; 2>R ?DUP IF 2R> THROWN-STRING 2! THROW-UNWIND ELSE 2RDROP THEN ;
\ Basic THROW without any string (store an empty string) \ Basic THROW without any string (store an empty string)
: THROW ( k*x n -- k*x | i*x n <noreturn> ) : THROW ( k*x n -- k*x | i*x n <noreturn> )
NULL 0 THROW-STRING ; "" THROW-STRING ;
\ By default, clear the data stack and QUIT without any message \ By default, clear the data stack and QUIT without any message
\ This behavior can be overridden with CATCH \ This behavior can be overridden with CATCH
@ -178,12 +188,15 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
1- ▪ DUP U2/ OR ▪ DUP 2 RSHIFT OR ▪ DUP 4 RSHIFT OR 1- ▪ DUP U2/ OR ▪ DUP 2 RSHIFT OR ▪ DUP 4 RSHIFT OR
▪ DUP 8 RSHIFT OR ▪ DUP 16 RSHIFT OR ▪ 1+ ; ▪ DUP 8 RSHIFT OR ▪ DUP 16 RSHIFT OR ▪ 1+ ;
>>SYSTEM >>UTILITY
\ Use the latest word to replace the same name in the bootstrap word list : DEFERRED? ( xt -- ) >CFA @ DODEFER <> EXCP-TYPE-MISMATCH AND THROW ;
: REPLACE-BOOTSTRAP ( -- )
LATEST DUP >NAME BOOTSTRAP-WORDLIST [ ' SEARCH-WORDLIST , ] >>FORTH
0= IF >NAME EXCP-UNDEFINED-WORD THROW-STRING ELSE DEFER! THEN ;
\ Fetch and store the target of the deferred word denoted by deferred-xt
: DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? >DFA @ ;
: DEFER! ( xt deferred-xt -- ) DUP DEFERRED? DODEFER OVER >CFA ! >DFA ! ;
>>LINUX >>LINUX
@ -609,13 +622,13 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
1+ 1+ N>R NULL BEGIN DROP NR@ DROP EXECUTE DUP ERRNO_EINTR + UNTIL NR> NDROP ; 1+ 1+ N>R NULL BEGIN DROP NR@ DROP EXECUTE DUP ERRNO_EINTR + UNTIL NR> NDROP ;
\ Specializations for specific numbers of parameters \ Specializations for specific numbers of parameters
: SYSCALL0-RETRY ['] SYSCALL0 0 SYSCALL-RETRY ; : SYSCALL0-RETRY [ ' SYSCALL0 ] LITERAL 0 SYSCALL-RETRY ;
: SYSCALL1-RETRY ['] SYSCALL1 1 SYSCALL-RETRY ; : SYSCALL1-RETRY [ ' SYSCALL1 ] LITERAL 1 SYSCALL-RETRY ;
: SYSCALL2-RETRY ['] SYSCALL2 2 SYSCALL-RETRY ; : SYSCALL2-RETRY [ ' SYSCALL2 ] LITERAL 2 SYSCALL-RETRY ;
: SYSCALL3-RETRY ['] SYSCALL3 3 SYSCALL-RETRY ; : SYSCALL3-RETRY [ ' SYSCALL3 ] LITERAL 3 SYSCALL-RETRY ;
: SYSCALL4-RETRY ['] SYSCALL4 4 SYSCALL-RETRY ; : SYSCALL4-RETRY [ ' SYSCALL4 ] LITERAL 4 SYSCALL-RETRY ;
: SYSCALL5-RETRY ['] SYSCALL5 5 SYSCALL-RETRY ; : SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ;
: SYSCALL6-RETRY ['] SYSCALL6 6 SYSCALL-RETRY ; : SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ;
>>FORTH >>FORTH
@ -695,9 +708,16 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
\ Emit a horizontal tab character \ Emit a horizontal tab character
: TAB ( -- "<tab>" ) HT EMIT ; : TAB ( -- "<tab>" ) HT EMIT ;
\ Emit an implementation-dependent End-of-Line sequence >>UTILITY
\ The implementation-dependent End-of-Line string
\ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS) \ Here this is just a LF (Unix convention) but it could be CR (Mac) or CR+LF (DOS)
: EOL ( -- "<eol>" ) LF EMIT ; : (EOL) ( -- c-addr u ) "\n" ;
>>FORTH
\ Emit the implementation-dependent End-of-Line string
: EOL ( -- "<eol>" ) (EOL) TYPE ;
\ Emit n blank (space) characters \ Emit n blank (space) characters
: SPACES ( n -- "<spaces>" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; : SPACES ( n -- "<spaces>" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ;
@ -709,82 +729,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
>>SYSTEM >>SYSTEM
\ With 32-bit cells, a double-cell number has 64 bits
\ Space is reserved for binary output with a leading minus sign and a trailing space
\ The minimum pictured numeric output buffer size is thus 66 bytes
\ The PNO buffer may be used for transient data like interpreted string literals
80 CONSTANT PNO-BUFFER-BYTES
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
CREATE PNO-POINTER PNO-BUFFER-END ,
\ THROW if there are less than u bytes remaining in the PNO buffer
: PNO-CHECK ( u -- )
PNO-POINTER @ PNO-BUFFER - U> IF EXCP-PNO-OVERFLOW THROW THEN ;
>>FORTH
: <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ;
: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ;
: HOLDS ( c-addr u -- ) PNO-POINTER OVER DUP PNO-CHECK OVER -! @ SWAP CMOVE ;
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
: SIGN ( n -- ) 0< IF [CHAR] - HOLD THEN ;
: #B ( ud1 u -- ud2 )
UM/MOD ROT DUP 10 >= IF 10 - [CHAR] A + ELSE [CHAR] 0 + THEN HOLD ;
: # ( ud1 -- ud2 ) 10 #B ;
: #SB ( ud u -- )
>R BEGIN R@ #B 2DUP D0= UNTIL RDROP ;
: #S ( ud -- ) 10 #SB ;
\ Decimal Fixed Precision with u digits after the decimal point
\ Example: 12345 0 <# 3 #DFP #> ≡ "12.345"
: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [CHAR] . HOLD #S ;
\ Display the unsigned number at the top of the stack
: DU. ( ud -- "<digits>" ) <# #S #> TYPE ;
: U. ( u -- "<digits>" ) 0 DU. ;
\ Display the signed number at the top of the stack
: D. ( d -- "<minus?><digits>" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ;
: . ( n -- "<minus?><digits>" ) S>D D. ;
\ Return the number of words on the data and return stacks, respectively
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ;
>>UTILITY
CREATE DISPLAY-ITEM-LIMIT 6 ,
>>FORTH
\ Display the content of the data stack
: .S ( -- "<text>" )
"S(" TYPE DEPTH . "):" TYPE
SP@ DUP DISPLAY-ITEM-LIMIT @ CELLS+ S0 UMIN
DUP S0 <> IF " …" TYPE THEN
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
\ Display the content of the return stack
: .RS ( -- "<text>" )
\ Skip the topmost cell, which is the return address for the call to .RS
"R(" TYPE RDEPTH 1- . "):" TYPE
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
DUP R0 <> IF " …" TYPE THEN
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
\ Return the next address in the compilation/data area
: HERE ( -- addr ) CP @ ;
>>SYSTEM
\ 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
@ -805,8 +749,9 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
BRK ! BRK !
THEN THEN
CP ! ; CP ! ;
\ Only use this version of ALLOT from here on \ Only use this version of ALLOT from here on
REPLACE-BOOTSTRAP ' ALLOT ' BOOTSTRAP-ALLOT DEFER!
\ Allocate one character from the data area and fill it with the value on the stack \ 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! ;
@ -979,6 +924,87 @@ CREATE LEAVE-ORIG NULL ,
: I 1 RPICK ; : I 1 RPICK ;
: J 3 RPICK ; : J 3 RPICK ;
>>SYSTEM
\ With 32-bit cells, a double-cell number has 64 bits
\ Space is reserved for binary output with a leading minus sign and a trailing space
\ The minimum pictured numeric output buffer size is thus 66 bytes
\ The PNO buffer may be used for transient data like interpreted string literals
80 CONSTANT PNO-BUFFER-BYTES
CREATE PNO-BUFFER PNO-BUFFER-BYTES ALLOT
PNO-BUFFER PNO-BUFFER-BYTES + CONSTANT PNO-BUFFER-END
CREATE PNO-POINTER PNO-BUFFER-END ,
\ THROW if there are less than u bytes remaining in the PNO buffer
: PNO-CHECK ( u -- )
PNO-POINTER @ PNO-BUFFER - U> IF EXCP-PNO-OVERFLOW THROW THEN ;
>>FORTH
: <# ( -- ) PNO-BUFFER-END PNO-POINTER ! ;
: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ;
: HOLDS ( c-addr u -- ) PNO-POINTER OVER DUP PNO-CHECK OVER -! @ SWAP CMOVE ;
: #> ( xd -- c-addr u ) 2DROP PNO-BUFFER-END PNO-POINTER @ TUCK - ;
: SIGN ( n -- ) 0< IF [[ CHAR - ]] HOLD THEN ;
: #B ( ud1 u -- ud2 )
UM/MOD ROT DUP 10 >= IF 10 - [[ CHAR A ]] + ELSE [[ CHAR 0 ]] + THEN HOLD ;
: # ( ud1 -- ud2 ) 10 #B ;
: #SB ( ud u -- )
>R BEGIN R@ #B 2DUP D0= UNTIL RDROP ;
: #S ( ud -- ) 10 #SB ;
\ Decimal Fixed Precision with u digits after the decimal point
\ Example: 12345 0 <# 3 #DFP #> ≡ "12.345"
: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ;
\ Display the unsigned number at the top of the stack
: DU. ( ud -- "<digits>" ) <# #S #> TYPE ;
: U. ( u -- "<digits>" ) 0 DU. ;
\ Display the signed number at the top of the stack
: D. ( d -- "<minus?><digits>" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ;
: . ( n -- "<minus?><digits>" ) S>D D. ;
\ Return the number of words on the data and return stacks, respectively
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ;
>>SYSTEM
: STARTUP-UNWIND ( k*x n -- i*x <noreturn> )
"Exception " TYPE-ERR DUP ABS 0 <# (EOL) HOLDS #S ROT SIGN #> TYPE-ERR
THROWN-STRING 2@ DUP IF TYPE-ERR "\n" TYPE-ERR THEN
[ ' BAILOUT COMPILE, ] ;
' STARTUP-UNWIND ' THROW-UNWIND DEFER!
>>UTILITY
CREATE DISPLAY-ITEM-LIMIT 6 ,
>>FORTH
\ Display the content of the data stack
: .S ( -- "<text>" )
"S(" TYPE DEPTH . "):" TYPE
SP@ DUP DISPLAY-ITEM-LIMIT @ CELLS+ S0 UMIN
DUP S0 <> IF " …" TYPE THEN
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
\ Display the content of the return stack
: .RS ( -- "<text>" )
\ Skip the topmost cell, which is the return address for the call to .RS
"R(" TYPE RDEPTH 1- . "):" TYPE
RSP@ CELL+ DUP DISPLAY-ITEM-LIMIT @ CELLS+ R0 UMIN
DUP R0 <> IF " …" TYPE THEN
BEGIN 2DUP < WHILE CELL- DUP @ SPACE . REPEAT 2DROP EOL ;
\ Remove trailing whitespace from a string (only affects length) \ Remove trailing whitespace from a string (only affects length)
: -TRAILING ( c-addr u1 -- c-addr u2 ) : -TRAILING ( c-addr u1 -- c-addr u2 )
BEGIN DUP AND-THEN 2DUP 1- + C@ SPACE? THEN WHILE 1- REPEAT ; BEGIN DUP AND-THEN 2DUP 1- + C@ SPACE? THEN WHILE 1- REPEAT ;
@ -995,16 +1021,16 @@ CREATE LEAVE-ORIG NULL ,
\ Convert a character to lowercase or uppercase, respectively \ Convert a character to lowercase or uppercase, respectively
: TO-LOWER ( ch1 -- ch2 ) : TO-LOWER ( ch1 -- ch2 )
DUP [CHAR] A [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] + THEN ; DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] + THEN ;
: TO-UPPER ( ch1 -- ch2 ) : TO-UPPER ( ch1 -- ch2 )
DUP [CHAR] a [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] - THEN ; DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a CHAR A - ]] - THEN ;
\ If ch is a digit (any base) return the value in range [0, 36) and TRUE \ If ch is a digit (any base) return the value in range [0, 36) and TRUE
\ Otherwise just return FALSE \ Otherwise just return FALSE
: >DIGIT ( ch -- u TRUE | FALSE ) : >DIGIT ( ch -- u TRUE | FALSE )
DUP [CHAR] 0 [[ CHAR 9 1+ ]] WITHIN IF [CHAR] 0 - TRUE EXIT THEN DUP [[ CHAR 0 ]] [[ CHAR 9 1+ ]] WITHIN IF [[ CHAR 0 ]] - TRUE EXIT THEN
DUP [CHAR] A [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR A 10 - ]] - TRUE EXIT THEN DUP [[ CHAR A ]] [[ CHAR Z 1+ ]] WITHIN IF [[ CHAR A 10 - ]] - TRUE EXIT THEN
DUP [CHAR] a [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a 10 - ]] - TRUE EXIT THEN DUP [[ CHAR a ]] [[ CHAR z 1+ ]] WITHIN IF [[ CHAR a 10 - ]] - TRUE EXIT THEN
DROP FALSE ; DROP FALSE ;
\ Convert a string in the given base to an unsigned double-cell number \ Convert a string in the given base to an unsigned double-cell number
@ -1021,12 +1047,12 @@ CREATE LEAVE-ORIG NULL ,
: >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 ) : >NUMBER ( c-addr1 u1 -- ud c-addr2 u2 )
DUP 0= IF 0 0 2SWAP EXIT THEN DUP 0= IF 0 0 2SWAP EXIT THEN
OVER C@ [CHAR] 0 = IF OVER C@ [[ CHAR 0 ]] = IF
1/STRING 1/STRING
DUP 0= IF 0 0 2SWAP EXIT THEN DUP 0= IF 0 0 2SWAP EXIT THEN
OVER C@ TO-UPPER CASE OVER C@ TO-UPPER CASE
[CHAR] B OF 1/STRING 2 ENDOF [[ CHAR B ]] OF 1/STRING 2 ENDOF
[CHAR] X OF 1/STRING 16 ENDOF [[ CHAR X ]] OF 1/STRING 16 ENDOF
8 SWAP 8 SWAP
ENDCASE ENDCASE
ELSE ELSE
@ -1034,12 +1060,15 @@ CREATE LEAVE-ORIG NULL ,
THEN THEN
>NUMBER-BASE ; >NUMBER-BASE ;
>>UTILITY
\ Parse a signed number; to succeed the entire input string must be consumed \ Parse a signed number; to succeed the entire input string must be consumed
: PARSENUMBER ( c-addr u -- n TRUE | FALSE ) : PARSENUMBER ( c-addr u -- n TRUE | FALSE )
DUP 0= IF NIP EXIT THEN ▪ OVER C@ [CHAR] - = DUP 0= IF NIP EXIT THEN ▪ OVER C@ [[ CHAR - ]] =
DUP >R IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN DUP >R IF 1/STRING DUP 0= IF RDROP NIP EXIT THEN THEN
>NUMBER R> 2NIP SWAP 0= DUP >R IF IF NEGATE THEN ELSE 2DROP THEN R> ; >NUMBER R> 2NIP SWAP 0= DUP >R IF IF NEGATE THEN ELSE 2DROP THEN R> ;
REPLACE-BOOTSTRAP
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
>>SYSTEM >>SYSTEM
@ -1061,41 +1090,8 @@ CREATE CURRENT-SOURCE-ID -1 ,
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ; : SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
: RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; : RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ;
\ QUIT needs to be deferred so that it can refer to INTERPRET
DEFER QUIT ( -- <noreturn> )
' BAILOUT ' QUIT DEFER!
>>SYSTEM >>SYSTEM
\ This function defines what happens when THROW is used outside of any CATCH
: DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
CASE
EXCP-ABORT OF ENDOF
EXCP-FAIL OF
THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
ENDOF
EXCP-DICTIONARY-OVERFLOW OF
"Dictionary overflow\n" TYPE-ERR
ENDOF
EXCP-INVALID-ADDRESS OF
"Invalid memory address\n" TYPE-ERR
ENDOF
EXCP-UNDEFINED-WORD OF
"Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
ENDOF
EXCP-PNO-OVERFLOW OF
"Pictured numeric output string overflow\n" TYPE-ERR
ENDOF
EXCP-FILE-IO OF
"I/O error\n" TYPE-ERR
ENDOF
"Uncaught exception: " TYPE-ERR
DUP DUP S>D DABS <# #S ROT SIGN #> TYPE-ERR EOL
ENDCASE
S0 SP! QUIT ;
' DEFAULT-UNWIND ' THROW-UNWIND DEFER!
CREATE EXCEPTION-STACK NULL , CREATE EXCEPTION-STACK NULL ,
\ Called when THROW is called inside of CATCH \ Called when THROW is called inside of CATCH
@ -1105,12 +1101,17 @@ CREATE EXCEPTION-STACK NULL ,
: CATCH-UNWIND ( k*x n -- i*x <noreturn> ) : CATCH-UNWIND ( k*x n -- i*x <noreturn> )
EXCEPTION-STACK @ RSP! EXCEPTION-STACK @ RSP!
R> EXCEPTION-STACK ! R> EXCEPTION-STACK !
R> ['] THROW-UNWIND DEFER! R> [[ ' THROW-UNWIND ]] DEFER!
R> CURRENT-SOURCE-ID ! R> CURRENT-SOURCE-ID !
2R> INPUT-BUFFER 2! 2R> INPUT-BUFFER 2!
NR> RESTORE-INPUT DROP NR> RESTORE-INPUT DROP
R> SWAP >R SP! R> ; R> SWAP >R SP! R> ;
>>UTILITY
\ Returns TRUE if currently executing inside CATCH, or FALSE otherwise
: CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ;
>>FORTH >>FORTH
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc. \ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
@ -1126,12 +1127,12 @@ CREATE EXCEPTION-STACK NULL ,
SOURCE 2>R SOURCE 2>R
SOURCE-ID >R SOURCE-ID >R
\ We'll need these to revert the effect of CATCH, with or without THROW \ We'll need these to revert the effect of CATCH, with or without THROW
['] THROW-UNWIND DEFER@ >R [[ ' THROW-UNWIND ]] DEFER@ >R
EXCEPTION-STACK @ >R EXCEPTION-STACK @ >R
\ Push the new exception stack frame \ Push the new exception stack frame
RSP@ EXCEPTION-STACK ! RSP@ EXCEPTION-STACK !
\ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND \ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND
['] CATCH-UNWIND ['] THROW-UNWIND DEFER! [[ ' CATCH-UNWIND ]] [[ ' THROW-UNWIND ]] DEFER!
\ Save the original return stack so we can quickly free the exception frame \ Save the original return stack so we can quickly free the exception frame
( RSP@ from start of CATCH ) >R ( RSP@ from start of CATCH ) >R
\ Run the function; if THROW is called then EXECUTE won't return \ Run the function; if THROW is called then EXECUTE won't return
@ -1139,7 +1140,7 @@ CREATE EXCEPTION-STACK NULL ,
EXECUTE 0 EXECUTE 0
R> R> R> R> R> R>
\ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame \ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame
['] THROW-UNWIND DEFER! [[ ' THROW-UNWIND ]] DEFER!
EXCEPTION-STACK ! EXCEPTION-STACK !
\ We don't need the rest so just reset the RSP to where it was on entering CATCH \ We don't need the rest so just reset the RSP to where it was on entering CATCH
RSP! ; RSP! ;
@ -1164,7 +1165,7 @@ CREATE EXCEPTION-STACK NULL ,
\ Comments; ignore all characters until the next EOL or ) character, respectively \ Comments; ignore all characters until the next EOL or ) character, respectively
: \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; : \ ( "ccc<eol>" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ;
: ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ; : ( ( "ccc<closeparen>" -- ) IMMEDIATE BEGIN NEXT-CHAR [[ CHAR ) ]] = UNTIL ;
\ Placeholder to be replaced before switching to terminal input \ Placeholder to be replaced before switching to terminal input
DEFER REFILL DEFER REFILL
@ -1236,7 +1237,7 @@ DEFER REFILL
\ A deferred word, while indirect, is more compact than a single-word colon \ A deferred word, while indirect, is more compact than a single-word colon
\ definition and avoids the setup and teardown of a redundant return stack frame \ definition and avoids the setup and teardown of a redundant return stack frame
: ALIAS ( xt "<spaces>ccc" -- ) : ALIAS ( xt "<spaces>ccc" -- )
CREATE LATEST DEFER! ; CREATE LATEST DODEFER OVER >CFA ! >DFA ! ;
\ Define a named constant \ Define a named constant
\ Execution: ( value "<spaces>name" -- ) \ Execution: ( value "<spaces>name" -- )
@ -1390,7 +1391,8 @@ DEFER REFILL
\ Create a deferred word; the target is stored in the DFA field \ Create a deferred word; the target is stored in the DFA field
\ The default target throws an exception — replace it using DEFER! or IS \ The default target throws an exception — replace it using DEFER! or IS
: DEFER ( "<spaces>ccc" -- ) { "Uninitialized deferred word" FAIL } ALIAS ; : DEFER ( "<spaces>ccc" -- )
CREATE { EXCP-DEFER-UNINITIALIZED THROW } LATEST DODEFER OVER >CFA ! >DFA ! ;
\ Conditional compilation / interpreted conditions \ Conditional compilation / interpreted conditions
\ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN] \ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN]
@ -1431,10 +1433,6 @@ DEFER REFILL
: CHAR ( "<spaces>name" -- c ) : CHAR ( "<spaces>name" -- c )
PARSE-NAME DROP C@ ; PARSE-NAME DROP C@ ;
\ Like CHAR but generates a literal at compile-time.
: [CHAR] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- c ) IMMEDIATE
CHAR POSTPONE LITERAL ;
>>SYSTEM >>SYSTEM
\ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB \ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB
@ -1569,7 +1567,7 @@ ENDSTRUCT MEMBLOCK%
PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE
ELSE ELSE
NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
BUDDY-ORDER-FROM-BYTES DUP ['] BUDDY-ALLOCATE CATCH ?DUP IF BUDDY-ORDER-FROM-BYTES DUP [[ ' BUDDY-ALLOCATE ]] CATCH ?DUP IF
DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP
BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-ORDERS 1- BUDDY-FREE BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-ORDERS 1- BUDDY-FREE
BUDDY-ALLOCATE BUDDY-ALLOCATE
@ -1769,8 +1767,8 @@ BOOTSTRAP-GET-ORDER SET-ORDER
: ALSO ( -- ) PEEK-ORDER PUSH-ORDER ; : ALSO ( -- ) PEEK-ORDER PUSH-ORDER ;
: ONLY ( -- ) -1 SET-ORDER ; : ONLY ( -- ) -1 SET-ORDER ;
: ORDER ( -- ) : ORDER ( -- )
"ORDER:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL "Order:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL
"CURRENT: " TYPE GET-CURRENT U. EOL ; "Current: " TYPE GET-CURRENT U. EOL ;
: PREVIOUS ( -- ) POP-ORDER DROP ; : PREVIOUS ( -- ) POP-ORDER DROP ;
\ Define a new named wordlist \ Define a new named wordlist
@ -1783,6 +1781,16 @@ BOOTSTRAP-GET-ORDER SET-ORDER
: FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ; : FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ;
: LINUX ( -- ) LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ; : LINUX ( -- ) LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ;
: UTILITY ( -- ) UTILITY-WORDLIST POP-ORDER DROP PUSH-ORDER ; : UTILITY ( -- ) UTILITY-WORDLIST POP-ORDER DROP PUSH-ORDER ;
: SYSTEM ( -- ) SYSTEM-WORDLIST POP-ORDER DROP PUSH-ORDER ;
\ Create a word to revert the search order, data space, and compilation word list
\ to their respective states from immediately before the marker was defined.
\ An ambiguous condition exists if anything defined after the marker is referenced
\ after the marker word is executed, including words created in other word lists.
: MARKER ( "<spaces?>name<space>" -- )
HERE ▪ LATEST ▪ GET-CURRENT ▪ GET-ORDER
CREATE ▪ DUP 4 + ▪ DUP 1+ ▪ HERE ▪ OVER CELLS ALLOT ▪ N!
DOES> ( -- ) @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ;
\ Apply SEARCH-WORDLIST to each word list in the current search order \ Apply SEARCH-WORDLIST to each word list in the current search order
: FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) : FIND ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
@ -1809,10 +1817,6 @@ BOOTSTRAP-GET-ORDER SET-ORDER
\ 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 ) PARSE-NAME FIND-OR-THROW DROP ; : ' ( "<spaces>ccc" -- xt ) PARSE-NAME FIND-OR-THROW DROP ;
\ Like ' but generates a literal at compile-time.
: ['] ( Compilation: "<spaces>ccc" -- ) ( Runtime: -- xt ) IMMEDIATE
' POSTPONE LITERAL ;
\ 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
PARSE-NAME FIND-OR-THROW 0< IF PARSE-NAME FIND-OR-THROW 0< IF
@ -1822,12 +1826,11 @@ BOOTSTRAP-GET-ORDER SET-ORDER
POSTPONE COMPILE, POSTPONE COMPILE,
THEN ; THEN ;
\ Shorthand for { ' <name> DEFER! } or { ['] <name> DEFER! } depending on STATE \ Shorthand for { ' <name> DEFER! } or { [[ ' <name> ]] DEFER! } depending on STATE
\ If used during compilation, capture the name immediately but set target at runtime \ If used during compilation, capture the name immediately but set target at runtime
: IS ( Compilation: "<spaces>ccc" -- ) : IS ( "<spaces>ccc" -- ; xt -- ) IMMEDIATE
( Runtime: xt -- ) ( Interpret: xt "<spaces>ccc" -- )
( Interpreted: xt "<spaces>ccc" -- ) ' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ;
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; IMMEDIATE
\ When compiling, append code to store to the data field area of the named value. \ When compiling, append code to store to the data field area of the named value.
\ When interpreting, store to the data field directly. \ When interpreting, store to the data field directly.
@ -1855,6 +1858,11 @@ BOOTSTRAP-GET-ORDER SET-ORDER
: OFFSETOF ( "<spaces><field-name>" -- offset ) IMMEDIATE : OFFSETOF ( "<spaces><field-name>" -- offset ) IMMEDIATE
0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ; 0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ;
\ Save the single-cell value at addr and then execute xt
\ When xt returns normally or THROWs (without CATCH), restore the saved value
: PRESERVED ( i*x xt addr -- j*x )
DUP @ >R >R CATCH 2R> ! RETHROW ;
>>SYSTEM >>SYSTEM
\ The size of this buffer will determine the maximum line length \ The size of this buffer will determine the maximum line length
@ -1908,19 +1916,19 @@ NULL 0 TIB-LEFTOVER 2!
>>UTILITY >>UTILITY
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c ) : ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
NEXT-CHAR DUP [CHAR] \ = IF NEXT-CHAR DUP [[ CHAR \ ]] = IF
DROP NEXT-CHAR CASE DROP NEXT-CHAR CASE
[CHAR] 0 OF 0 ENDOF [[ CHAR 0 ]] OF 0 ENDOF
[CHAR] a OF 7 ENDOF [[ CHAR a ]] OF 7 ENDOF
[CHAR] b OF 8 ENDOF [[ CHAR b ]] OF 8 ENDOF
[CHAR] t OF 9 ENDOF [[ CHAR t ]] OF 9 ENDOF
[CHAR] n OF 10 ENDOF [[ CHAR n ]] OF 10 ENDOF
[CHAR] v OF 11 ENDOF [[ CHAR v ]] OF 11 ENDOF
[CHAR] f OF 12 ENDOF [[ CHAR f ]] OF 12 ENDOF
[CHAR] r OF 13 ENDOF [[ CHAR r ]] OF 13 ENDOF
[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" FAIL "Unknown escape sequence" FAIL
ENDCASE ENDCASE
THEN ; THEN ;
@ -1941,7 +1949,7 @@ NULL 0 STRING-BUFFER 2!
STRING-BUFFER 2@ 0 STRING-BUFFER 2@ 0
( S: addr length index ) ( S: addr length index )
BEGIN BEGIN
PARSE-EMPTY? OR-ELSE PEEK-CHAR [CHAR] " = DUP IF SKIP-CHAR THEN THEN 0= PARSE-EMPTY? OR-ELSE PEEK-CHAR [[ CHAR " ]] = DUP IF SKIP-CHAR THEN THEN 0=
WHILE WHILE
2DUP <= IF 2DUP <= IF
\ Grow the buffer by at least 50% + 16 bytes \ Grow the buffer by at least 50% + 16 bytes
@ -1961,7 +1969,7 @@ NULL 0 STRING-BUFFER 2!
SKIP-SPACES SKIP-SPACES
PARSE-EMPTY? 0= PARSE-EMPTY? 0=
WHILE WHILE
PEEK-CHAR [CHAR] " = IF PEEK-CHAR [[ CHAR " ]] = IF
SKIP-CHAR SKIP-CHAR
READSTRING READSTRING
STATE @ IF STATE @ IF
@ -2021,9 +2029,9 @@ termios% %VARIABLE SCRATCH-TERMIOS
STDIN TTY? CONSTANT INTERACTIVE? STDIN TTY? CONSTANT INTERACTIVE?
\ 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
:REPLACE QUIT ( -- <noreturn> ) { ( -- <noreturn> )
CATCHING? IF EXCP-QUIT THROW THEN
R0 RSP! R0 RSP!
0 CURRENT-SOURCE-ID ! 0 CURRENT-SOURCE-ID !
FALSE STATE ! FALSE STATE !
@ -2034,12 +2042,66 @@ STDIN TTY? CONSTANT INTERACTIVE?
[ INTERACTIVE? ] [IF] [ INTERACTIVE? ] [IF]
STATE @ 0= IF "OK\n" TYPE THEN STATE @ 0= IF "OK\n" TYPE THEN
[THEN] [THEN]
AGAIN ; AGAIN
} IS QUIT
' BOOTSTRAP-WORDLIST HIDE BOOTSTRAP-WORDLIST
>>SYSTEM >>SYSTEM
ALIAS BOOTSTRAP-WORDLIST
>>FORTH 32 CONSTANT #REPORTERS
#REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code )
MARKER REVERT
{ #REPORTERS 0 ?DO NULL 0 I REPORTERS 2! LOOP } EXECUTE
REVERT
\ Return the matching entry, the next empty slot, or NULL if neither exists
: REPORTER ( n -- addr t=match )
DUP HASHCELL ▪ DUP #REPORTERS + SWAP ?DO
I #REPORTERS 1- AND ▪ REPORTERS
2DUP 2@ SWAP -ROT = TUCK SWAP NULL= OR IF
ROT DROP UNLOOP EXIT
THEN ▪ 2DROP
LOOP ▪ DROP NULL FALSE ;
>>UTILITY
\ Set the reporter for the given exception code
: REPORTER! ( xt n -- ) ( xt: -- )
DUP REPORTER DROP ▪ DUP NULL= "hash table is full" ?FAIL ▪ 2! ;
\ Run the reporter for the given exception code, or give the default report
: REPORT ( n -- )
DUP REPORTER IF
NIP THROWN-STRING 2@ ROT 2@ DROP EXECUTE
ELSE
DROP ▪ "Uncaught exception: " TYPE-ERR
DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ;
THEN ;
>>SYSTEM
{ ( no message for ABORT ) } EXCP-ABORT REPORTER!
{ THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR } EXCP-FAIL REPORTER!
{ "Stack overflow\n" TYPE-ERR } EXCP-STACK-OVERFLOW REPORTER!
{ "Stack underflow\n" TYPE-ERR } EXCP-STACK-UNDERFLOW REPORTER!
{ "Return stack overflow\n" TYPE-ERR } EXCP-RETURN-OVERFLOW REPORTER!
{ "Return stack underflow\n" TYPE-ERR } EXCP-RETURN-UNDERFLOW REPORTER!
{ "Dictionary overflow\n" TYPE-ERR } EXCP-DICTIONARY-OVERFLOW REPORTER!
{ "Invalid memory address\n" TYPE-ERR } EXCP-INVALID-ADDRESS REPORTER!
{ "Argument type mismatch\n" TYPE-ERR } EXCP-TYPE-MISMATCH REPORTER!
{ "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR }
EXCP-UNDEFINED-WORD REPORTER!
{ "Pictured numeric output string overflow\n" TYPE-ERR }
EXCP-PNO-OVERFLOW REPORTER!
{ "Invalid numeric argument\n" TYPE-ERR } EXCP-BAD-NUMERIC-ARGUMENT REPORTER!
{ "File I/O exception\n" TYPE-ERR } EXCP-FILE-IO REPORTER!
{ "Quit\n" TYPE-ERR } EXCP-QUIT REPORTER!
{ "Out of memory\n" TYPE-ERR } EXCP-HEAP-OVERFLOW REPORTER!
{ "Uninitialized deferred word\n" TYPE-ERR } EXCP-DEFER-UNINITIALIZED REPORTER!
: DEFAULT-UNWIND ( i*x n -- <noreturn> ) REPORT S0 SP! QUIT ;
' DEFAULT-UNWIND IS THROW-UNWIND
\ Switch to the interpreter defined in this startup file \ Switch to the interpreter defined in this startup file
\ Process the rest of the startup file and then switch to terminal input \ Process the rest of the startup file and then switch to terminal input
@ -2054,8 +2116,6 @@ DEFINITIONS
\ ***************************************************************************** \ *****************************************************************************
ALSO UTILITY ALSO UTILITY
' >NAME ALIAS >NAME
PREVIOUS
\ Define a threaded word which also displays its name and the data stack when called \ Define a threaded word which also displays its name and the data stack when called
: (TRACE) >NAME TYPE SPACE .S ; : (TRACE) >NAME TYPE SPACE .S ;
@ -2112,10 +2172,10 @@ HIDE (TRACE)
11 OF "\\v" TYPE ENDOF 11 OF "\\v" TYPE ENDOF
12 OF "\\f" TYPE ENDOF 12 OF "\\f" TYPE ENDOF
13 OF "\\r" TYPE ENDOF 13 OF "\\r" TYPE ENDOF
[CHAR] " OF "\\\"" TYPE ENDOF [[ CHAR " ]] OF "\\\"" TYPE ENDOF
\ escape sequence not needed in strings \ escape sequence not needed in strings
\ [CHAR] ' OF "\\\'" TYPE ENDOF \ [[ CHAR ' ]] OF "\\\'" TYPE ENDOF
[CHAR] \ OF "\\\\" TYPE ENDOF [[ CHAR \ ]] OF "\\\\" TYPE ENDOF
DUP 32 < OR-ELSE DUP 127 = THEN IF DUP 32 < OR-ELSE DUP 127 = THEN IF
"⌷" TYPE "⌷" TYPE
ELSE ELSE
@ -2126,10 +2186,10 @@ HIDE (TRACE)
\ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b} \ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b}
\ This pattern is generated by the { … } inline :NONAME syntax \ This pattern is generated by the { … } inline :NONAME syntax
: NONAME-LITERAL? ( a-addr -- flag ) : NONAME-LITERAL? ( a-addr -- flag )
@(+) ['] BRANCH = AND-THEN @(+) [[ ' BRANCH ]] = AND-THEN
@(+) DUP 0> AND-THEN @(+) DUP 0> AND-THEN
( S: addr-b offset-c-a ) ( S: addr-b offset-c-a )
OVER CELL- + @(+) ['] LIT = AND-THEN OVER CELL- + @(+) [[ ' LIT ]] = AND-THEN
( S: addr-b addr-d ) ( S: addr-b addr-d )
@ OVER = AND-THEN @ OVER = AND-THEN
DUP WORD? DUP WORD?
@ -2147,24 +2207,24 @@ ALSO UTILITY
DUP >R DUP >R
BEGIN BEGIN
@(+) @(+)
DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF DUP [[ ' EXIT ]] = AND-THEN OVER R@ U> THEN IF
2DROP RDROP EXIT 2DROP RDROP EXIT
THEN THEN
CASE CASE
['] LIT OF [[ ' LIT ]] OF
@(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE @(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN
ENDOF ENDOF
['] 2LIT OF [[ ' 2LIT ]] OF
"[ " TYPE @(+) >R @(+) U. SPACE R> . " ] 2LITERAL " TYPE "[ " TYPE @(+) >R @(+) U. SPACE R> . " ] 2LITERAL " TYPE
ENDOF ENDOF
['] LITSTRING OF [[ ' LITSTRING ]] OF
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
ENDOF ENDOF
OVER CELL- NONAME-LITERAL? IF OVER CELL- NONAME-LITERAL? IF
DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
"{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE "{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE
ELSE ELSE
DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF DUP [[ ' BRANCH ]] = OR-ELSE DUP [[ ' 0BRANCH ]] = THEN IF
>NAME TYPE SPACE >NAME TYPE SPACE
@(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE @(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE
OVER CELL- + R> UMAX >R OVER CELL- + R> UMAX >R
@ -2273,11 +2333,13 @@ HIDE UNTHREAD
\ Sort in descending order by negating the result of compare-xt \ Sort in descending order by negating the result of compare-xt
: MERGE-SORT> ( head1 link-xt compare-xt -- head2 ) : MERGE-SORT> ( head1 link-xt compare-xt -- head2 )
['] NEGATE COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ; [[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ;
HIDE SPLIT HIDE SPLIT
HIDE MERGE HIDE MERGE
FORTH-WORDLIST 1 SET-ORDER
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
INTERACTIVE? [IF] BANNER [THEN] INTERACTIVE? [IF] BANNER [THEN]

2
test/compares.4th
View File

@ -1,3 +1,5 @@
ALSO UTILITY
: X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES : X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES
-1 R@ EXECUTE NEGATE . SPACE -1 R@ EXECUTE NEGATE . SPACE
0 R@ EXECUTE NEGATE . SPACE 0 R@ EXECUTE NEGATE . SPACE

2
test/double-compares.4th
View File

@ -1,3 +1,5 @@
ALSO UTILITY
: X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES : X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES
-1 S>D R@ EXECUTE NEGATE . SPACE -1 S>D R@ EXECUTE NEGATE . SPACE
0 S>D R@ EXECUTE NEGATE . SPACE 0 S>D R@ EXECUTE NEGATE . SPACE

4
test/numeric-literals.4th
View File

@ -6,8 +6,8 @@
2DUP INSPECT " ( " TYPE EVALUATE DUP R> EXECUTE " ) " TYPE 2DUP INSPECT " ( " TYPE EVALUATE DUP R> EXECUTE " ) " TYPE
R> = IF " ✓\n" ELSE " ✗\n" THEN TYPE ; R> = IF " ✓\n" ELSE " ✗\n" THEN TYPE ;
: SREPORT ['] . REPORT ; : SREPORT [[ ' . ]] REPORT ;
: UREPORT ['] U. REPORT ; : UREPORT [[ ' U. ]] REPORT ;
: TEST : TEST
"0" "0 DUP -" SREPORT "0" "0 DUP -" SREPORT

27
test/preserved.4th Normal file
View File

@ -0,0 +1,27 @@
VARIABLE X
0 X !
"Change X from 0 to 3\n" TYPE
1 2 { 3 X ! } X PRESERVED
.S
"X: " TYPE X @ . EOL
DEPTH NDROP
EOL
"Change X from 4 to 7 and then QUIT\n" TYPE
4 X !
5 6 { 7 X ! QUIT } X PRESERVED
.S
"X: " TYPE X @ . EOL
DEPTH NDROP
EOL
"QUIT without changing X from 8\n" TYPE
8 X !
9 10 ' QUIT X PRESERVED
.S
"X: " TYPE X @ . EOL
DEPTH NDROP

12
test/preserved.exp Normal file
View File

@ -0,0 +1,12 @@
Change X from 0 to 3
S(2): 1 2
X: 0
Change X from 4 to 7 and then QUIT
S(3): 5 6 -56
X: 4
QUIT without changing X from 8
S(3): 9 10 -56
X: 8
exit-code: 0

4
test/resize.4th
View File

@ -4,7 +4,7 @@ ALSO UTILITY
"\n Object size: " TYPE DUP OBJECT-SIZE U. EOL EOL ; "\n Object size: " TYPE DUP OBJECT-SIZE U. EOL EOL ;
PREVIOUS PREVIOUS
SYSTEM-WORDLIST PUSH-ORDER ALSO SYSTEM
256 KB SIZEOF MEMBLOCK% - CONSTANT 256-KB-BLOCK 256 KB SIZEOF MEMBLOCK% - CONSTANT 256-KB-BLOCK
PREVIOUS PREVIOUS
@ -17,6 +17,6 @@ PREVIOUS
24 RESIZE "Resized to 24 bytes" STATUS 24 RESIZE "Resized to 24 bytes" STATUS
4 RESIZE "Resized to 4 bytes" STATUS 4 RESIZE "Resized to 4 bytes" STATUS
DUP FREE DUP FREE
['] FREE CATCH "CATCH after double-free: " TYPE . EOL ; [[ ' FREE ]] CATCH "CATCH after double-free: " TYPE . EOL ;
TEST TEST