remove ['] and [CHAR], add MARKER and PRESERVED, tweak bootstrap word lists, etc.
This commit is contained in:
parent
a1c55c0d64
commit
3009bc84e5
118
jumpforth.S
118
jumpforth.S
|
|
@ -174,7 +174,7 @@ defdata \label,"\name",\flags
|
|||
.int \initial
|
||||
.endm
|
||||
|
||||
.macro defconst label:req,value,name="",flags=0
|
||||
.macro defconst label:req,value:req,name="",flags=0
|
||||
defname \label,DODATA,\value,"\name",\flags
|
||||
.endm
|
||||
|
||||
|
|
@ -188,6 +188,10 @@ data_\label :
|
|||
.int \initial
|
||||
.endm
|
||||
|
||||
.macro defdefer label:req,value:req,name="",flags=0
|
||||
defname \label,DODEFER,\value,"\name",\flags
|
||||
.endm
|
||||
|
||||
defconst VERSION,JUMPFORTH_VERSION
|
||||
|
||||
defconst R0,return_stack_top
|
||||
|
|
@ -221,9 +225,6 @@ defvar IN,0,">IN"
|
|||
defvar CP /* "compilation pointer", next free byte in 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 */
|
||||
/* Initially it just mirrors the primitive list */
|
||||
/* The rest will be populated by the startup.4th script */
|
||||
|
|
@ -1058,6 +1059,22 @@ defcode EXECUTE
|
|||
pop %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 ) */
|
||||
defcode SYSCALL6
|
||||
mov %ebp,%ecx
|
||||
|
|
@ -1147,16 +1164,23 @@ defcode BREAK
|
|||
.section .data
|
||||
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" ) */
|
||||
defword TYPE
|
||||
defword TYPE,,F_HIDDEN
|
||||
.int LIT,1,NROT,LIT,__NR_write,SYSCALL3,DROP,EXIT
|
||||
|
||||
/* ( c -- "c" ) */
|
||||
defword EMIT
|
||||
defword EMIT,,F_HIDDEN
|
||||
.int SPFETCH,LIT,1,SWAP,LIT,1,LIT,__NR_write,SYSCALL3,TWODROP,EXIT
|
||||
|
||||
/* ( -- "<eol>" ) */
|
||||
defword EOL
|
||||
defword EOL,,F_HIDDEN
|
||||
.int LIT,10,EMIT,EXIT
|
||||
|
||||
/* 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 - .)
|
||||
.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"
|
||||
.int TYPE,BAILOUT,EXIT
|
||||
|
||||
|
|
@ -1177,20 +1201,20 @@ defword SOURCE
|
|||
.int LIT,startup_defs,LIT,(startup_defs_end - startup_defs),EXIT
|
||||
|
||||
/* ( -- 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
|
||||
|
||||
/* ( "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
|
||||
0: .int UNEXPECTED_EOF,EXIT
|
||||
|
||||
/* ( "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
|
||||
|
||||
/* ( c -- flag ) */
|
||||
defword ISSPACE,"SPACE?"
|
||||
defword ISSPACE,"SPACE?",F_HIDDEN
|
||||
/* check for space (32) first and return true if input matches */
|
||||
.int DUP,LIT,32,EQU,QDUP,ZBRANCH,(0f - .),NIP,EXIT
|
||||
/* otherwise test for 9...13 inclusive (HT, LF, VT, FF, CR) */
|
||||
|
|
@ -1201,26 +1225,26 @@ defword ISSPACE,"SPACE?"
|
|||
defword ALLOT
|
||||
.int CP,INCREMENT,EXIT
|
||||
|
||||
defword HERE
|
||||
defword HERE,,F_HIDDEN
|
||||
.int CP,FETCH,EXIT
|
||||
|
||||
defword COMMA,","
|
||||
.int HERE,CELL,ALLOT,STORE,EXIT
|
||||
.int HERE,CELL,BOOTSTRAP_ALLOT,STORE,EXIT
|
||||
|
||||
defword COMMABYTE,"C,"
|
||||
.int HERE,LIT,1,ALLOT,STOREBYTE,EXIT
|
||||
defword COMMABYTE,"C,",F_HIDDEN
|
||||
.int HERE,LIT,1,BOOTSTRAP_ALLOT,STOREBYTE,EXIT
|
||||
|
||||
/* ( addr -- a-addr ) Round up to next cell-aligned address */
|
||||
defword ALIGNED
|
||||
defword ALIGNED,,F_HIDDEN
|
||||
.int LIT,3,ADD,LIT,-4,AND,EXIT
|
||||
|
||||
/* ( -- ) Allocate data space up to the next cell-aligned address */
|
||||
/* Any bytes skipped over during alignment should be considered uninitialized */
|
||||
defword ALIGN
|
||||
.int HERE,DUP,ALIGNED,SWAP,SUB,ALLOT,EXIT
|
||||
defword ALIGN,,F_HIDDEN
|
||||
.int HERE,DUP,ALIGNED,SWAP,SUB,BOOTSTRAP_ALLOT,EXIT
|
||||
|
||||
/* ( 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: */
|
||||
0: .int DUP,ZBRANCH,(2f - .) /* 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: */
|
||||
|
||||
/* ( xt -- cfa-addr ) Address of the codeword field */
|
||||
defword TCFA,">CFA"
|
||||
defword TCFA,">CFA",F_HIDDEN
|
||||
.int EXIT
|
||||
|
||||
/* ( xt -- dfa-addr ) Address of the dataword field */
|
||||
defword TDFA,">DFA"
|
||||
defword TDFA,">DFA",F_HIDDEN
|
||||
.int CELL,ADD,EXIT
|
||||
|
||||
/* ( xt -- link-addr ) Address of the dataword field */
|
||||
defword TLINK,">LINK"
|
||||
defword TLINK,">LINK",F_HIDDEN
|
||||
.int LIT,8,ADD,EXIT
|
||||
|
||||
/* ( xt -- flags-addr ) Address of the flag/length byte */
|
||||
defword TFLAGS,">FLAGS"
|
||||
defword TFLAGS,">FLAGS",F_HIDDEN
|
||||
.int LIT,12,ADD,EXIT
|
||||
|
||||
/* ( 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
|
||||
|
||||
/* ( xt -- a-addr ) Data-field address (next cell after the name) */
|
||||
defword TBODY,">BODY"
|
||||
defword TBODY,">BODY",F_HIDDEN
|
||||
.int TNAME,ADD,ALIGNED,EXIT
|
||||
|
||||
/* ( 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
|
||||
|
||||
/* ( 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
|
||||
|
||||
/* ( 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 LIT,bootstrap_data_end,ULT,EXIT
|
||||
0: .int DROP,FALSE,EXIT
|
||||
|
||||
/* ( -- widn ... wid1 n ) Return the current search order */
|
||||
/* Redefining this word with DEFER! will change the bootstrap search order */
|
||||
defword BOOTSTRAP_GET_ORDER,"BOOTSTRAP-GET-ORDER"
|
||||
.int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,LIT,2,EXIT
|
||||
defword GET_ORDER,"GET-ORDER",F_HIDDEN
|
||||
.int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,CURRENT,FETCH,LIT,3,EXIT
|
||||
|
||||
/* ( c-addr u wid -- 0 | xt 1 | xt -1 ) */
|
||||
/* 0 = not found; 1 = non-immediate; -1 = immediate */
|
||||
|
|
@ -1287,7 +1311,7 @@ defword SEARCH_WORDLIST,"SEARCH-WORDLIST"
|
|||
4: .int NIP,NIP,EXIT /* 0 */
|
||||
|
||||
/* ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) */
|
||||
defword FIND
|
||||
defword FIND,,F_HIDDEN
|
||||
.int TWOTOR,BOOTSTRAP_GET_ORDER
|
||||
0: .int DUP,ZBRANCH,(1f - .)
|
||||
.int SUB1,SWAP,TWORFETCH,ROT,SEARCH_WORDLIST,QDUP,ZBRANCH,(0b - .)
|
||||
|
|
@ -1295,13 +1319,13 @@ defword FIND
|
|||
1: .int TWOFROMR,ROT,EXIT
|
||||
|
||||
/* ( 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
|
||||
0: litstring "Word not found: "
|
||||
.int TYPE,TYPE,EOL,BAILOUT,EXIT
|
||||
|
||||
/* ( "<spaces>" -- ) */
|
||||
defword SKIP_SPACE,"SKIP-SPACE"
|
||||
defword SKIP_SPACE,"SKIP-SPACE",F_HIDDEN
|
||||
0: .int PARSE_AREA,ZBRANCH,(1f - .)
|
||||
.int FETCHBYTE,ISSPACE,ZBRANCH,(2f - .)
|
||||
.int LIT,1,IN,INCREMENT,BRANCH,(0b - .)
|
||||
|
|
@ -1309,7 +1333,7 @@ defword SKIP_SPACE,"SKIP-SPACE"
|
|||
2: .int EXIT
|
||||
|
||||
/* ( "<spaces?>ccc<space>" -- c-addr u ) */
|
||||
defword PARSE_NAME,"PARSE-NAME"
|
||||
defword PARSE_NAME,"PARSE-NAME",F_HIDDEN
|
||||
.int SKIP_SPACE
|
||||
.int PARSE_AREA,DROP,LIT,1
|
||||
.int NEXT_CHAR,DROP
|
||||
|
|
@ -1319,7 +1343,7 @@ defword PARSE_NAME,"PARSE-NAME"
|
|||
1: .int DROP
|
||||
2: .int EXIT
|
||||
|
||||
defword ESCAPED_CHAR
|
||||
defword ESCAPED_CHAR,,F_HIDDEN
|
||||
.int NEXT_CHAR,DUP,LIT,'\\',NEQU,ZBRANCH,(0f - .),EXIT
|
||||
0: .int DROP,NEXT_CHAR
|
||||
.int LIT,'0',OVER,EQU,ZBRANCH,(0f - .),DROP,LIT,0,EXIT
|
||||
|
|
@ -1337,13 +1361,13 @@ defword ESCAPED_CHAR
|
|||
.int TYPE,EMIT,EOL,BAILOUT,EXIT
|
||||
|
||||
/* ( "ccc<quote>" -- c-addr u ) */
|
||||
defword READSTRING
|
||||
defword READSTRING,,F_HIDDEN
|
||||
.int HERE
|
||||
0: .int PEEK_CHAR,LIT,34,NEQU,ZBRANCH,(1f - .)
|
||||
.int ESCAPED_CHAR,COMMABYTE,BRANCH,(0b - .)
|
||||
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 OVER,FETCHBYTE,LIT,'-',EQU,DUP,TOR,LIT,0,TOR,ZBRANCH,(0f - .)
|
||||
.int DUP,LIT,1,GT,ZBRANCH,(6f - .),BRANCH,(1f - .)
|
||||
|
|
@ -1359,7 +1383,7 @@ defword PARSENUMBER
|
|||
.int NEGATE
|
||||
9: .int TRUE,EXIT
|
||||
|
||||
defword INTERPRET
|
||||
defword INTERPRET,,F_HIDDEN
|
||||
.int SKIP_SPACE
|
||||
.int PEEK_CHAR,LIT,34,EQU,ZBRANCH,(1f - .)
|
||||
.int LIT,1,IN,INCREMENT
|
||||
|
|
@ -1370,7 +1394,7 @@ defword INTERPRET
|
|||
litstring "Tried to interpret a string literal\n"
|
||||
.int TYPE,BAILOUT
|
||||
/* 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 LIT,LIT,COMMA,COMMA
|
||||
2: .int EXIT
|
||||
|
|
@ -1386,19 +1410,19 @@ defword INTERPRET
|
|||
.int TYPE,TNAME,TYPE,EOL,BAILOUT
|
||||
6: .int COMMA,EXIT
|
||||
|
||||
defword QUIT
|
||||
defword QUIT,,F_HIDDEN
|
||||
.int R0,RSPSTORE
|
||||
0: .int INTERPRET,BRANCH,(0b - .)
|
||||
.int EXIT
|
||||
|
||||
defword LATEST
|
||||
defword LATEST,,F_HIDDEN
|
||||
.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
|
||||
.int ALIGN,HERE
|
||||
.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 CURRENT,FETCH,STORE,EXIT
|
||||
|
||||
|
|
@ -1456,15 +1480,9 @@ defword QUOTE,"'"
|
|||
defword LITERAL,,F_IMMED
|
||||
.int LIT,LIT,COMMA,COMMA,EXIT
|
||||
|
||||
defword COMPILE_QUOTE,"[']",F_IMMED
|
||||
.int QUOTE,LITERAL,EXIT
|
||||
|
||||
defword CHAR
|
||||
.int PARSE_NAME,DROP,FETCHBYTE,EXIT
|
||||
|
||||
defword COMPILE_CHAR,"[CHAR]",F_IMMED
|
||||
.int CHAR,LITERAL,EXIT
|
||||
|
||||
defword POSTPONE,,F_IMMED
|
||||
.int PARSE_NAME,FIND_OR_BAILOUT,ZGT,ZBRANCH,(0f - .)
|
||||
.int LITERAL
|
||||
|
|
|
|||
506
startup.4th
506
startup.4th
|
|
@ -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
|
||||
CREATE SYSTEM-WORDLIST NULL ,
|
||||
CREATE UTILITY-WORDLIST NULL ,
|
||||
CREATE LINUX-WORDLIST NULL ,
|
||||
|
||||
SYSTEM-WORDLIST SET-CURRENT
|
||||
CP @ 0 , DUP CURRENT ! CONSTANT SYSTEM-WORDLIST
|
||||
CP @ 0 , CONSTANT UTILITY-WORDLIST
|
||||
CP @ 0 , CONSTANT LINUX-WORDLIST
|
||||
BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST
|
||||
|
||||
\ Use this list until we get around to defining the real GET-ORDER
|
||||
: STARTUP-ORDER ( -- widn ... wid1 n )
|
||||
|
|
@ -21,7 +12,15 @@ SYSTEM-WORDLIST SET-CURRENT
|
|||
SYSTEM-WORDLIST
|
||||
FORTH-WORDLIST
|
||||
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
|
||||
: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ;
|
||||
|
|
@ -31,6 +30,10 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
|
|||
|
||||
>>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)
|
||||
: KB 10 LSHIFT ;
|
||||
: MB 20 LSHIFT ;
|
||||
|
|
@ -50,6 +53,9 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
|
|||
\ Round up to the next cell-aligned address
|
||||
: ALIGNED ( addr -- a-addr ) CELL ALIGNED-TO ;
|
||||
|
||||
\ Return the next address in the compilation/data area
|
||||
: HERE ( -- addr ) CP @ ;
|
||||
|
||||
>>UTILITY
|
||||
|
||||
\ Field accessors for execution tokens
|
||||
|
|
@ -77,32 +83,30 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER!
|
|||
: IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED 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
|
||||
: /STRING ( c-addr u1 u2 -- c-addr+u2 u1-u2 ) TUCK - -ROT + SWAP ;
|
||||
\ Semantically equivalent to "1 /STRING"
|
||||
: 1/STRING ( c-addr u -- c-addr+1 u-1 ) 1- SWAP 1+ SWAP ;
|
||||
|
||||
\ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
|
||||
-1 CONSTANT EXCP-ABORT
|
||||
-2 CONSTANT EXCP-FAIL
|
||||
-3 CONSTANT EXCP-STACK-OVERFLOW
|
||||
-4 CONSTANT EXCP-STACK-UNDERFLOW
|
||||
-5 CONSTANT EXCP-RETURN-OVERFLOW
|
||||
-6 CONSTANT EXCP-RETURN-UNDERFLOW
|
||||
-8 CONSTANT EXCP-DICTIONARY-OVERFLOW
|
||||
-9 CONSTANT EXCP-INVALID-ADDRESS
|
||||
-1 CONSTANT EXCP-ABORT
|
||||
-2 CONSTANT EXCP-FAIL
|
||||
-3 CONSTANT EXCP-STACK-OVERFLOW
|
||||
-4 CONSTANT EXCP-STACK-UNDERFLOW
|
||||
-5 CONSTANT EXCP-RETURN-OVERFLOW
|
||||
-6 CONSTANT EXCP-RETURN-UNDERFLOW
|
||||
-8 CONSTANT EXCP-DICTIONARY-OVERFLOW
|
||||
-9 CONSTANT EXCP-INVALID-ADDRESS
|
||||
-12 CONSTANT EXCP-TYPE-MISMATCH
|
||||
-13 CONSTANT EXCP-UNDEFINED-WORD
|
||||
-17 CONSTANT EXCP-PNO-OVERFLOW
|
||||
-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
|
||||
-37 CONSTANT EXCP-FILE-IO
|
||||
-56 CONSTANT EXCP-QUIT
|
||||
|
||||
\ Non-standard system error codes (-4095 ... -256)
|
||||
-256 CONSTANT EXCP-HEAP-OVERFLOW
|
||||
-257 CONSTANT EXCP-DEFER-UNINITIALIZED
|
||||
|
||||
>>SYSTEM
|
||||
|
||||
|
|
@ -112,12 +116,17 @@ CREATE THROWN-STRING 2 CELLS ALLOT
|
|||
NULL 0 THROWN-STRING 2!
|
||||
|
||||
\ 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
|
||||
\ BAILOUT will be replaced by DEFAULT-UNWIND later in the startup
|
||||
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
' BAILOUT ' THROW-UNWIND DEFER!
|
||||
|
||||
>>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 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:
|
||||
|
|
@ -126,14 +135,15 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ otherwise message is implementation-dependent
|
||||
\
|
||||
\ 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> )
|
||||
?DUP IF THROW-UNWIND THEN ;
|
||||
?DUP IF DUP EXCP-QUIT = IF QUIT THEN THROW-UNWIND THEN ;
|
||||
\ THROW while storing a string for context
|
||||
: 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)
|
||||
: 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
|
||||
\ 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
|
||||
▪ 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
|
||||
: REPLACE-BOOTSTRAP ( -- )
|
||||
LATEST DUP >NAME BOOTSTRAP-WORDLIST [ ' SEARCH-WORDLIST , ]
|
||||
0= IF >NAME EXCP-UNDEFINED-WORD THROW-STRING ELSE DEFER! THEN ;
|
||||
: DEFERRED? ( xt -- ) >CFA @ DODEFER <> EXCP-TYPE-MISMATCH AND THROW ;
|
||||
|
||||
>>FORTH
|
||||
|
||||
\ 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
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
\ Specializations for specific numbers of parameters
|
||||
: SYSCALL0-RETRY ['] SYSCALL0 0 SYSCALL-RETRY ;
|
||||
: SYSCALL1-RETRY ['] SYSCALL1 1 SYSCALL-RETRY ;
|
||||
: SYSCALL2-RETRY ['] SYSCALL2 2 SYSCALL-RETRY ;
|
||||
: SYSCALL3-RETRY ['] SYSCALL3 3 SYSCALL-RETRY ;
|
||||
: SYSCALL4-RETRY ['] SYSCALL4 4 SYSCALL-RETRY ;
|
||||
: SYSCALL5-RETRY ['] SYSCALL5 5 SYSCALL-RETRY ;
|
||||
: SYSCALL6-RETRY ['] SYSCALL6 6 SYSCALL-RETRY ;
|
||||
: SYSCALL0-RETRY [ ' SYSCALL0 ] LITERAL 0 SYSCALL-RETRY ;
|
||||
: SYSCALL1-RETRY [ ' SYSCALL1 ] LITERAL 1 SYSCALL-RETRY ;
|
||||
: SYSCALL2-RETRY [ ' SYSCALL2 ] LITERAL 2 SYSCALL-RETRY ;
|
||||
: SYSCALL3-RETRY [ ' SYSCALL3 ] LITERAL 3 SYSCALL-RETRY ;
|
||||
: SYSCALL4-RETRY [ ' SYSCALL4 ] LITERAL 4 SYSCALL-RETRY ;
|
||||
: SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ;
|
||||
: SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ;
|
||||
|
||||
>>FORTH
|
||||
|
||||
|
|
@ -695,9 +708,16 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ Emit a horizontal tab character
|
||||
: 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)
|
||||
: 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
|
||||
: SPACES ( n -- "<spaces>" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ;
|
||||
|
|
@ -709,82 +729,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
|
||||
>>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
|
||||
65536 CONSTANT DATA-SEGMENT-ALIGNMENT
|
||||
|
||||
|
|
@ -805,8 +749,9 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|||
BRK !
|
||||
THEN
|
||||
CP ! ;
|
||||
|
||||
\ 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
|
||||
: C, HERE 1 ALLOT C! ;
|
||||
|
|
@ -979,6 +924,87 @@ CREATE LEAVE-ORIG NULL ,
|
|||
: I 1 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)
|
||||
: -TRAILING ( c-addr u1 -- c-addr u2 )
|
||||
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
|
||||
: 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 )
|
||||
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
|
||||
\ Otherwise just return FALSE
|
||||
: >DIGIT ( ch -- u TRUE | FALSE )
|
||||
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 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
|
||||
DROP FALSE ;
|
||||
|
||||
\ 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 )
|
||||
DUP 0= IF 0 0 2SWAP EXIT THEN
|
||||
OVER C@ [CHAR] 0 = IF
|
||||
OVER C@ [[ CHAR 0 ]] = IF
|
||||
1/STRING
|
||||
DUP 0= IF 0 0 2SWAP EXIT THEN
|
||||
OVER C@ TO-UPPER CASE
|
||||
[CHAR] B OF 1/STRING 2 ENDOF
|
||||
[CHAR] X OF 1/STRING 16 ENDOF
|
||||
[[ CHAR B ]] OF 1/STRING 2 ENDOF
|
||||
[[ CHAR X ]] OF 1/STRING 16 ENDOF
|
||||
8 SWAP
|
||||
ENDCASE
|
||||
ELSE
|
||||
|
|
@ -1034,12 +1060,15 @@ CREATE LEAVE-ORIG NULL ,
|
|||
THEN
|
||||
>NUMBER-BASE ;
|
||||
|
||||
>>UTILITY
|
||||
|
||||
\ Parse a signed number; to succeed the entire input string must be consumed
|
||||
: 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
|
||||
>NUMBER R> 2NIP SWAP 0= DUP >R IF IF NEGATE THEN ELSE 2DROP THEN R> ;
|
||||
REPLACE-BOOTSTRAP
|
||||
|
||||
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
|
||||
|
||||
>>SYSTEM
|
||||
|
||||
|
|
@ -1061,41 +1090,8 @@ CREATE CURRENT-SOURCE-ID -1 ,
|
|||
: SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ;
|
||||
: 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
|
||||
|
||||
\ 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 ,
|
||||
|
||||
\ Called when THROW is called inside of CATCH
|
||||
|
|
@ -1105,12 +1101,17 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
: CATCH-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
EXCEPTION-STACK @ RSP!
|
||||
R> EXCEPTION-STACK !
|
||||
R> ['] THROW-UNWIND DEFER!
|
||||
R> [[ ' THROW-UNWIND ]] DEFER!
|
||||
R> CURRENT-SOURCE-ID !
|
||||
2R> INPUT-BUFFER 2!
|
||||
NR> RESTORE-INPUT DROP
|
||||
R> SWAP >R SP! R> ;
|
||||
|
||||
>>UTILITY
|
||||
|
||||
\ Returns TRUE if currently executing inside CATCH, or FALSE otherwise
|
||||
: CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ;
|
||||
|
||||
>>FORTH
|
||||
|
||||
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
|
||||
|
|
@ -1126,12 +1127,12 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
SOURCE 2>R
|
||||
SOURCE-ID >R
|
||||
\ 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
|
||||
\ Push the new exception stack frame
|
||||
RSP@ EXCEPTION-STACK !
|
||||
\ 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
|
||||
( RSP@ from start of CATCH ) >R
|
||||
\ Run the function; if THROW is called then EXECUTE won't return
|
||||
|
|
@ -1139,7 +1140,7 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
EXECUTE 0
|
||||
R> R> R>
|
||||
\ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame
|
||||
['] THROW-UNWIND DEFER!
|
||||
[[ ' THROW-UNWIND ]] DEFER!
|
||||
EXCEPTION-STACK !
|
||||
\ We don't need the rest so just reset the RSP to where it was on entering CATCH
|
||||
RSP! ;
|
||||
|
|
@ -1164,7 +1165,7 @@ CREATE EXCEPTION-STACK NULL ,
|
|||
|
||||
\ Comments; ignore all characters until the next EOL or ) character, respectively
|
||||
: \ ( "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
|
||||
DEFER REFILL
|
||||
|
|
@ -1236,7 +1237,7 @@ DEFER REFILL
|
|||
\ 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
|
||||
: ALIAS ( xt "<spaces>ccc" -- )
|
||||
CREATE LATEST DEFER! ;
|
||||
CREATE LATEST DODEFER OVER >CFA ! >DFA ! ;
|
||||
|
||||
\ Define a named constant
|
||||
\ Execution: ( value "<spaces>name" -- )
|
||||
|
|
@ -1390,7 +1391,8 @@ DEFER REFILL
|
|||
|
||||
\ Create a deferred word; the target is stored in the DFA field
|
||||
\ 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
|
||||
\ No effect if flag is true, otherwise skips words until matching [ELSE] or [THEN]
|
||||
|
|
@ -1431,10 +1433,6 @@ DEFER REFILL
|
|||
: CHAR ( "<spaces>name" -- 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
|
||||
|
||||
\ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB
|
||||
|
|
@ -1569,7 +1567,7 @@ ENDSTRUCT MEMBLOCK%
|
|||
PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE
|
||||
ELSE
|
||||
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
|
||||
BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-ORDERS 1- BUDDY-FREE
|
||||
BUDDY-ALLOCATE
|
||||
|
|
@ -1769,8 +1767,8 @@ BOOTSTRAP-GET-ORDER SET-ORDER
|
|||
: ALSO ( -- ) PEEK-ORDER PUSH-ORDER ;
|
||||
: ONLY ( -- ) -1 SET-ORDER ;
|
||||
: ORDER ( -- )
|
||||
"ORDER:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL
|
||||
"CURRENT: " TYPE GET-CURRENT U. EOL ;
|
||||
"Order:" TYPE GET-ORDER 0 ?DO SPACE U. LOOP EOL
|
||||
"Current: " TYPE GET-CURRENT U. EOL ;
|
||||
: PREVIOUS ( -- ) POP-ORDER DROP ;
|
||||
|
||||
\ Define a new named wordlist
|
||||
|
|
@ -1783,6 +1781,16 @@ BOOTSTRAP-GET-ORDER SET-ORDER
|
|||
: FORTH ( -- ) FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ;
|
||||
: LINUX ( -- ) LINUX-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
|
||||
: 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
|
||||
: ' ( "<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.
|
||||
: POSTPONE ( "<spaces>name" -- ) IMMEDIATE
|
||||
PARSE-NAME FIND-OR-THROW 0< IF
|
||||
|
|
@ -1822,12 +1826,11 @@ BOOTSTRAP-GET-ORDER SET-ORDER
|
|||
POSTPONE COMPILE,
|
||||
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
|
||||
: IS ( Compilation: "<spaces>ccc" -- )
|
||||
( Runtime: xt -- )
|
||||
( Interpreted: xt "<spaces>ccc" -- )
|
||||
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; IMMEDIATE
|
||||
: IS ( "<spaces>ccc" -- ; xt -- ) IMMEDIATE
|
||||
( Interpret: xt "<spaces>ccc" -- )
|
||||
' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ;
|
||||
|
||||
\ When compiling, append code to store to the data field area of the named value.
|
||||
\ When interpreting, store to the data field directly.
|
||||
|
|
@ -1855,6 +1858,11 @@ BOOTSTRAP-GET-ORDER SET-ORDER
|
|||
: OFFSETOF ( "<spaces><field-name>" -- offset ) IMMEDIATE
|
||||
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
|
||||
|
||||
\ The size of this buffer will determine the maximum line length
|
||||
|
|
@ -1908,19 +1916,19 @@ NULL 0 TIB-LEFTOVER 2!
|
|||
>>UTILITY
|
||||
|
||||
: ESCAPED-CHAR ( "<escapeseq>" | "c" -- c )
|
||||
NEXT-CHAR DUP [CHAR] \ = IF
|
||||
NEXT-CHAR DUP [[ CHAR \ ]] = IF
|
||||
DROP NEXT-CHAR CASE
|
||||
[CHAR] 0 OF 0 ENDOF
|
||||
[CHAR] a OF 7 ENDOF
|
||||
[CHAR] b OF 8 ENDOF
|
||||
[CHAR] t OF 9 ENDOF
|
||||
[CHAR] n OF 10 ENDOF
|
||||
[CHAR] v OF 11 ENDOF
|
||||
[CHAR] f OF 12 ENDOF
|
||||
[CHAR] r OF 13 ENDOF
|
||||
[CHAR] " OF [CHAR] " ENDOF
|
||||
[CHAR] ' OF [CHAR] ' ENDOF
|
||||
[CHAR] \ OF [CHAR] \ ENDOF
|
||||
[[ CHAR 0 ]] OF 0 ENDOF
|
||||
[[ CHAR a ]] OF 7 ENDOF
|
||||
[[ CHAR b ]] OF 8 ENDOF
|
||||
[[ CHAR t ]] OF 9 ENDOF
|
||||
[[ CHAR n ]] OF 10 ENDOF
|
||||
[[ CHAR v ]] OF 11 ENDOF
|
||||
[[ CHAR f ]] OF 12 ENDOF
|
||||
[[ CHAR r ]] OF 13 ENDOF
|
||||
[[ CHAR " ]] OF [[ CHAR " ]] ENDOF
|
||||
[[ CHAR ' ]] OF [[ CHAR ' ]] ENDOF
|
||||
[[ CHAR \ ]] OF [[ CHAR \ ]] ENDOF
|
||||
"Unknown escape sequence" FAIL
|
||||
ENDCASE
|
||||
THEN ;
|
||||
|
|
@ -1941,7 +1949,7 @@ NULL 0 STRING-BUFFER 2!
|
|||
STRING-BUFFER 2@ 0
|
||||
( S: addr length index )
|
||||
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
|
||||
2DUP <= IF
|
||||
\ Grow the buffer by at least 50% + 16 bytes
|
||||
|
|
@ -1961,7 +1969,7 @@ NULL 0 STRING-BUFFER 2!
|
|||
SKIP-SPACES
|
||||
PARSE-EMPTY? 0=
|
||||
WHILE
|
||||
PEEK-CHAR [CHAR] " = IF
|
||||
PEEK-CHAR [[ CHAR " ]] = IF
|
||||
SKIP-CHAR
|
||||
READSTRING
|
||||
STATE @ IF
|
||||
|
|
@ -2021,9 +2029,9 @@ termios% %VARIABLE SCRATCH-TERMIOS
|
|||
|
||||
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
|
||||
:REPLACE QUIT ( -- <noreturn> )
|
||||
{ ( -- <noreturn> )
|
||||
CATCHING? IF EXCP-QUIT THROW THEN
|
||||
R0 RSP!
|
||||
0 CURRENT-SOURCE-ID !
|
||||
FALSE STATE !
|
||||
|
|
@ -2034,12 +2042,66 @@ STDIN TTY? CONSTANT INTERACTIVE?
|
|||
[ INTERACTIVE? ] [IF]
|
||||
STATE @ 0= IF "OK\n" TYPE THEN
|
||||
[THEN]
|
||||
AGAIN ;
|
||||
AGAIN
|
||||
} IS QUIT
|
||||
|
||||
' BOOTSTRAP-WORDLIST HIDE BOOTSTRAP-WORDLIST
|
||||
>>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
|
||||
\ Process the rest of the startup file and then switch to terminal input
|
||||
|
|
@ -2054,8 +2116,6 @@ DEFINITIONS
|
|||
\ *****************************************************************************
|
||||
|
||||
ALSO UTILITY
|
||||
' >NAME ALIAS >NAME
|
||||
PREVIOUS
|
||||
|
||||
\ Define a threaded word which also displays its name and the data stack when called
|
||||
: (TRACE) >NAME TYPE SPACE .S ;
|
||||
|
|
@ -2112,10 +2172,10 @@ HIDE (TRACE)
|
|||
11 OF "\\v" TYPE ENDOF
|
||||
12 OF "\\f" TYPE ENDOF
|
||||
13 OF "\\r" TYPE ENDOF
|
||||
[CHAR] " OF "\\\"" TYPE ENDOF
|
||||
[[ CHAR " ]] OF "\\\"" TYPE ENDOF
|
||||
\ 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
|
||||
"⌷" TYPE
|
||||
ELSE
|
||||
|
|
@ -2126,10 +2186,10 @@ HIDE (TRACE)
|
|||
\ Recognize the pattern BRANCH a:{c-a} b:{word} {code…} c:LIT d:{b}
|
||||
\ This pattern is generated by the { … } inline :NONAME syntax
|
||||
: NONAME-LITERAL? ( a-addr -- flag )
|
||||
@(+) ['] BRANCH = AND-THEN
|
||||
@(+) [[ ' BRANCH ]] = AND-THEN
|
||||
@(+) DUP 0> AND-THEN
|
||||
( S: addr-b offset-c-a )
|
||||
OVER CELL- + @(+) ['] LIT = AND-THEN
|
||||
OVER CELL- + @(+) [[ ' LIT ]] = AND-THEN
|
||||
( S: addr-b addr-d )
|
||||
@ OVER = AND-THEN
|
||||
DUP WORD?
|
||||
|
|
@ -2147,24 +2207,24 @@ ALSO UTILITY
|
|||
DUP >R
|
||||
BEGIN
|
||||
@(+)
|
||||
DUP ['] EXIT = AND-THEN OVER R@ U> THEN IF
|
||||
DUP [[ ' EXIT ]] = AND-THEN OVER R@ U> THEN IF
|
||||
2DROP RDROP EXIT
|
||||
THEN
|
||||
CASE
|
||||
['] LIT OF
|
||||
@(+) DUP WORD? IF "['] " TYPE .W ELSE . THEN SPACE
|
||||
[[ ' LIT ]] OF
|
||||
@(+) DUP WORD? IF "[[ ' " TYPE .W " ]] " TYPE ELSE . SPACE THEN
|
||||
ENDOF
|
||||
['] 2LIT OF
|
||||
[[ ' 2LIT ]] OF
|
||||
"[ " TYPE @(+) >R @(+) U. SPACE R> . " ] 2LITERAL " TYPE
|
||||
ENDOF
|
||||
['] LITSTRING OF
|
||||
[[ ' LITSTRING ]] OF
|
||||
DUP 1+ SWAP C@ 2DUP "\"" TYPE TYPE-ESCAPED "\" " TYPE + ALIGNED
|
||||
ENDOF
|
||||
OVER CELL- NONAME-LITERAL? IF
|
||||
DROP DUP @ OVER + 2 CELLS+ DUP R> UMAX >R SWAP
|
||||
"{ " TYPE CELL+ >DFA @ UNTHREAD "} " TYPE
|
||||
ELSE
|
||||
DUP ['] BRANCH = OR-ELSE DUP ['] 0BRANCH = THEN IF
|
||||
DUP [[ ' BRANCH ]] = OR-ELSE DUP [[ ' 0BRANCH ]] = THEN IF
|
||||
>NAME TYPE SPACE
|
||||
@(+) DUP "{" TYPE DUP 0> IF "+" TYPE THEN . "} " TYPE
|
||||
OVER CELL- + R> UMAX >R
|
||||
|
|
@ -2273,11 +2333,13 @@ HIDE UNTHREAD
|
|||
|
||||
\ Sort in descending order by negating the result of compare-xt
|
||||
: 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 MERGE
|
||||
|
||||
FORTH-WORDLIST 1 SET-ORDER
|
||||
|
||||
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
|
||||
|
||||
INTERACTIVE? [IF] BANNER [THEN]
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
ALSO UTILITY
|
||||
|
||||
: X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES
|
||||
-1 R@ EXECUTE NEGATE . SPACE
|
||||
0 R@ EXECUTE NEGATE . SPACE
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
ALSO UTILITY
|
||||
|
||||
: X DUP >R >NAME TUCK TYPE 6 SWAP - SPACES
|
||||
-1 S>D R@ EXECUTE NEGATE . SPACE
|
||||
0 S>D R@ EXECUTE NEGATE . SPACE
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@
|
|||
2DUP INSPECT " ( " TYPE EVALUATE DUP R> EXECUTE " ) " TYPE
|
||||
R> = IF " ✓\n" ELSE " ✗\n" THEN TYPE ;
|
||||
|
||||
: SREPORT ['] . REPORT ;
|
||||
: UREPORT ['] U. REPORT ;
|
||||
: SREPORT [[ ' . ]] REPORT ;
|
||||
: UREPORT [[ ' U. ]] REPORT ;
|
||||
|
||||
: TEST
|
||||
"0" "0 DUP -" SREPORT
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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,7 +4,7 @@ ALSO UTILITY
|
|||
"\n Object size: " TYPE DUP OBJECT-SIZE U. EOL EOL ;
|
||||
PREVIOUS
|
||||
|
||||
SYSTEM-WORDLIST PUSH-ORDER
|
||||
ALSO SYSTEM
|
||||
256 KB SIZEOF MEMBLOCK% - CONSTANT 256-KB-BLOCK
|
||||
PREVIOUS
|
||||
|
||||
|
|
@ -17,6 +17,6 @@ PREVIOUS
|
|||
24 RESIZE "Resized to 24 bytes" STATUS
|
||||
4 RESIZE "Resized to 4 bytes" STATUS
|
||||
DUP FREE
|
||||
['] FREE CATCH "CATCH after double-free: " TYPE . EOL ;
|
||||
[[ ' FREE ]] CATCH "CATCH after double-free: " TYPE . EOL ;
|
||||
|
||||
TEST
|
||||
|
|
|
|||
Loading…
Reference in New Issue