From 3009bc84e521c59edc05af957501ff61774ac8c2 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Thu, 29 Oct 2020 14:36:09 -0500 Subject: [PATCH] remove ['] and [CHAR], add MARKER and PRESERVED, tweak bootstrap word lists, etc. --- jumpforth.S | 118 +++++---- startup.4th | 506 +++++++++++++++++++++----------------- test/compares.4th | 2 + test/double-compares.4th | 2 + test/numeric-literals.4th | 4 +- test/preserved.4th | 27 ++ test/preserved.exp | 12 + test/resize.4th | 4 +- 8 files changed, 399 insertions(+), 276 deletions(-) create mode 100644 test/preserved.4th create mode 100644 test/preserved.exp diff --git a/jumpforth.S b/jumpforth.S index 9c27ee2..b37e945 100644 --- a/jumpforth.S +++ b/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 . */ +/* 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 /* ( -- "" ) */ -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 /* ( "" -- ) */ -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 /* ( "ccc" -- 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" -- 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 diff --git a/startup.4th b/startup.4th index 4aa3c46..7416f78 100644 --- a/startup.4th +++ b/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 ) +' 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 ) \ 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 ) - ?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 ) - 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 ) - 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 ) 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 ) 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 ) \ Emit a horizontal tab character : 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 ( -- "" ) LF EMIT ; +: (EOL) ( -- c-addr u ) "\n" ; + +>>FORTH + +\ Emit the implementation-dependent End-of-Line string +: EOL ( -- "" ) (EOL) TYPE ; \ Emit n blank (space) characters : SPACES ( n -- "" ) BEGIN ?DUP WHILE 1- SPACE REPEAT ; @@ -709,82 +729,6 @@ DEFER THROW-UNWIND ( k*x n -- i*x ) >>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 -- "" ) <# #S #> TYPE ; -: U. ( u -- "" ) 0 DU. ; - -\ Display the signed number at the top of the stack -: D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; -: . ( n -- "" ) 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 ( -- "" ) - "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 ( -- "" ) - \ 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 -- "" ) <# #S #> TYPE ; +: U. ( u -- "" ) 0 DU. ; + +\ Display the signed number at the top of the stack +: D. ( d -- "" ) DUP -ROT DABS <# #S ROT SIGN #> TYPE ; +: . ( n -- "" ) 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 ) + "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 ( -- "" ) + "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 ( -- "" ) + \ 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 ( -- ) -' BAILOUT ' QUIT DEFER! - >>SYSTEM -\ This function defines what happens when THROW is used outside of any CATCH -: DEFAULT-UNWIND ( k*x n -- i*x ) - 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 ) 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" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; -: ( ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR [CHAR] ) = UNTIL ; +: ( ( "ccc" -- ) 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 "ccc" -- ) - CREATE LATEST DEFER! ; + CREATE LATEST DODEFER OVER >CFA ! >DFA ! ; \ Define a named constant \ Execution: ( value "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 ( "ccc" -- ) { "Uninitialized deferred word" FAIL } ALIAS ; +: DEFER ( "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 ( "name" -- c ) PARSE-NAME DROP C@ ; -\ Like CHAR but generates a literal at compile-time. -: [CHAR] ( Compilation: "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 ( "name" -- ) + 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 : ' ( "ccc" -- xt ) PARSE-NAME FIND-OR-THROW DROP ; -\ Like ' but generates a literal at compile-time. -: ['] ( Compilation: "ccc" -- ) ( Runtime: -- xt ) IMMEDIATE - ' POSTPONE LITERAL ; - \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE PARSE-NAME FIND-OR-THROW 0< IF @@ -1822,12 +1826,11 @@ BOOTSTRAP-GET-ORDER SET-ORDER POSTPONE COMPILE, THEN ; -\ Shorthand for { ' DEFER! } or { ['] DEFER! } depending on STATE +\ Shorthand for { ' DEFER! } or { [[ ' ]] DEFER! } depending on STATE \ If used during compilation, capture the name immediately but set target at runtime -: IS ( Compilation: "ccc" -- ) - ( Runtime: xt -- ) - ( Interpreted: xt "ccc" -- ) - ' STATE @ IF POSTPONE LITERAL POSTPONE DEFER! ELSE DEFER! THEN ; IMMEDIATE +: IS ( "ccc" -- ; xt -- ) IMMEDIATE + ( Interpret: xt "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 ( "" -- 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 ( "" | "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 ( -- ) +{ ( -- ) + 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 -- ) 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] diff --git a/test/compares.4th b/test/compares.4th index 078bcf0..03e3061 100644 --- a/test/compares.4th +++ b/test/compares.4th @@ -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 diff --git a/test/double-compares.4th b/test/double-compares.4th index b0ce21b..e52f378 100644 --- a/test/double-compares.4th +++ b/test/double-compares.4th @@ -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 diff --git a/test/numeric-literals.4th b/test/numeric-literals.4th index e0c4912..73f5507 100644 --- a/test/numeric-literals.4th +++ b/test/numeric-literals.4th @@ -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 diff --git a/test/preserved.4th b/test/preserved.4th new file mode 100644 index 0000000..85d1f8f --- /dev/null +++ b/test/preserved.4th @@ -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 diff --git a/test/preserved.exp b/test/preserved.exp new file mode 100644 index 0000000..ecf1257 --- /dev/null +++ b/test/preserved.exp @@ -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 diff --git a/test/resize.4th b/test/resize.4th index a4ad8c4..14cfe94 100644 --- a/test/resize.4th +++ b/test/resize.4th @@ -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