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

eliminate *-WORDLIST & replace with VOCABULARY-style words

This commit is contained in:
Jesse D. McDonald 2020-11-07 00:47:05 -06:00
parent 7d859d4f23
commit b258023136
2 changed files with 166 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
jumpforth.S
View File

@ -226,13 +226,8 @@ 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 word list containing all the standard FORTH words */ /* The current compilation word list, initially BOOTSTRAP-WORDLIST */
/* Initially it just mirrors the primitive list */ defvar CURRENT,data_BOOTSTRAP_WORDLIST
/* The rest will be populated by the startup.4th script */
defvar FORTH_WORDLIST,last_primitive,"FORTH-WORDLIST"
/* The current compilation word list, initially FORTH-WORDLIST */
defvar CURRENT,data_FORTH_WORDLIST
/* ( a -- ) */ /* ( a -- ) */
defcode DROP defcode DROP
@ -1236,6 +1231,9 @@ defcode BREAK
.section .data .section .data
bootstrap_data_begin: bootstrap_data_begin:
/* The word list containing all the primitive words */
defvar PRIMITIVE_WORDLIST,last_primitive,"PRIMITIVE-WORDLIST"
/* The list of basic non-primitive words used to bootstrap the startup.4th file */ /* The list of basic non-primitive words used to bootstrap the startup.4th file */
defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST" defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST"
@ -1367,7 +1365,7 @@ defword ISBOOTSTRAP,"BOOTSTRAP?",F_HIDDEN
/* ( -- 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 GET_ORDER,"GET-ORDER",F_HIDDEN defword GET_ORDER,"GET-ORDER",F_HIDDEN
.int BOOTSTRAP_WORDLIST,FORTH_WORDLIST,CURRENT,FETCH,LIT,3,EXIT .int BOOTSTRAP_WORDLIST,PRIMITIVE_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 */

293
startup.4th
View File

@ -1,35 +1,21 @@
\ Keep internal system definitions and ABI constants out of the main word list \ Create the FORTH word list, which includes the name FORTH and all the primitives
CP @ 0 , DUP CURRENT ! CONSTANT SYSTEM-WORDLIST CURRENT @ @ ( save the latest word in the bootstrap word list )
CP @ 0 , CONSTANT UTILITY-WORDLIST CREATE FORTH CURRENT @ @ , ( create FORTH with itself as the initial value )
CP @ 0 , CONSTANT LINUX-WORDLIST CURRENT @ XCHG ( restore bootstrap list & get address of FORTH )
BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST PRIMITIVE-WORDLIST @ OVER CELL - ! ( set the link field to the last primitive word )
CELL 2* + CURRENT ! ( make FORTH the current compilation word list )
\ Use this list until we get around to defining the real GET-ORDER \ Create the other startup word lists
: STARTUP-ORDER ( -- widn ... wid1 n ) \ These and FORTH will be edited later to have the DOES> effect of
BOOTSTRAP-WORDLIST \ changing the search order just like words defined with VOCABULARY
LINUX-WORDLIST CREATE SYSTEM 0 ,
UTILITY-WORDLIST CREATE UTILITY 0 ,
SYSTEM-WORDLIST CREATE LINUX 0 ,
FORTH-WORDLIST
5 ;
' STARTUP-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
FORTH-WORDLIST CURRENT !
\ Get and set the current compilation word list \ Get and set the current compilation word list
: GET-CURRENT ( -- wid ) CURRENT @ ; : GET-CURRENT ( -- wid ) CURRENT @ ;
: SET-CURRENT ( wid -- ) CURRENT ! ; : SET-CURRENT ( wid -- ) CURRENT ! ;
SYSTEM-WORDLIST SET-CURRENT
\ Shorthand for selecting the current compilation word list until >> is defined
: >>SYSTEM SYSTEM-WORDLIST SET-CURRENT ;
: >>UTILITY UTILITY-WORDLIST SET-CURRENT ;
: >>FORTH FORTH-WORDLIST SET-CURRENT ;
: >>LINUX LINUX-WORDLIST SET-CURRENT ;
>>FORTH
\ Reserved for "invalid address" or "object not present" \ Reserved for "invalid address" or "object not present"
\ Signifies (the absence of) a memory address, not a number \ Signifies (the absence of) a memory address, not a number
0 CONSTANT NULL 0 CONSTANT NULL
@ -56,7 +42,17 @@ SYSTEM-WORDLIST SET-CURRENT
\ Return the next address in the compilation/data area \ Return the next address in the compilation/data area
: HERE ( -- addr ) CP @ ; : HERE ( -- addr ) CP @ ;
>>UTILITY \ Use this list until we get around to defining the real GET-ORDER
: STARTUP-ORDER ( -- widn ... wid1 n )
[ BOOTSTRAP-WORDLIST ] LITERAL
[ LINUX ] LITERAL
[ UTILITY ] LITERAL
[ SYSTEM ] LITERAL
[ FORTH ] LITERAL
5 ;
' STARTUP-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
UTILITY SET-CURRENT
\ Field accessors for execution tokens \ Field accessors for execution tokens
: >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ; : >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ;
@ -66,7 +62,16 @@ SYSTEM-WORDLIST SET-CURRENT
: >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ; : >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ;
: >NAME ( xt -- c-addr u ) >FLAGS DUP C@ F_LENMASK AND TUCK - SWAP ; : >NAME ( xt -- c-addr u ) >FLAGS DUP C@ F_LENMASK AND TUCK - SWAP ;
>>SYSTEM ' FORTH >BODY SET-CURRENT
\ Given the xt of a word defined with VOCABULARY, return the word list identifier
\ This allows the use of vocabulary words with SET-ORDER or SEARCH-WORDLIST
: >WORDLIST ( vocabulary-xt -- wid ) >BODY ;
' SYSTEM >WORDLIST SET-CURRENT
\ Set the current compilation word list to the given vocabulary
: (DEFINITIONS) ( vocabulary-xt -- ) >WORDLIST SET-CURRENT ;
\ Set or clear the HIDDEN flag for word with the given execution token \ Set or clear the HIDDEN flag for word with the given execution token
: (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; : (HIDE) ( xt -- ) >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;
@ -78,7 +83,7 @@ SYSTEM-WORDLIST SET-CURRENT
\ This is only used during early startup \ This is only used during early startup
' STARTUP-ORDER (HIDE) ' STARTUP-ORDER (HIDE)
>>FORTH ' FORTH (DEFINITIONS)
: 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<> ;
@ -109,7 +114,7 @@ SYSTEM-WORDLIST SET-CURRENT
-256 CONSTANT EXCP-HEAP-OVERFLOW -256 CONSTANT EXCP-HEAP-OVERFLOW
-257 CONSTANT EXCP-DEFER-UNINITIALIZED -257 CONSTANT EXCP-DEFER-UNINITIALIZED
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ THROWN-STRING holds the address and size of the string passed to FAIL \ THROWN-STRING holds the address and size of the string passed to FAIL
\ It may also be used to hold context strings for other system exception codes \ It may also be used to hold context strings for other system exception codes
@ -122,7 +127,7 @@ NULL 0 THROWN-STRING 2!
DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> ) DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
' BAILOUT ' THROW-UNWIND DEFER! ' BAILOUT ' THROW-UNWIND DEFER!
>>FORTH ' FORTH (DEFINITIONS)
\ QUIT needs to be defined after INTERPRET \ QUIT needs to be defined after INTERPRET
DEFER QUIT DEFER QUIT
@ -164,14 +169,14 @@ DEFER QUIT
\ If the word list is empty the result will be zero \ If the word list is empty the result will be zero
: LATEST ( -- xt | NULL ) GET-CURRENT @ ; : LATEST ( -- xt | NULL ) GET-CURRENT @ ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ Set the given xt as the most recent word in the compilation word list \ Set the given xt as the most recent word in the compilation word list
\ Since this replaces the head of a linked list it may affect the entire list, \ Since this replaces the head of a linked list it may affect the entire list,
\ not just the most recent word \ not just the most recent word
: LATEST! ( xt -- ) GET-CURRENT ! ; : LATEST! ( xt -- ) GET-CURRENT ! ;
>>FORTH ' FORTH (DEFINITIONS)
\ Set the latest defined word as immediate \ Set the latest defined word as immediate
\ Note that IMMEDIATE is itself an immediate word \ Note that IMMEDIATE is itself an immediate word
@ -189,17 +194,17 @@ DEFER QUIT
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+ ;
>>UTILITY ' UTILITY (DEFINITIONS)
: DEFERRED? ( xt -- ) >CFA @ ▪ DODEFER <> ▪ EXCP-TYPE-MISMATCH AND ▪ THROW ; : DEFERRED? ( xt -- ) >CFA @ ▪ DODEFER <> ▪ EXCP-TYPE-MISMATCH AND ▪ THROW ;
>>FORTH ' FORTH (DEFINITIONS)
\ Fetch and store the target of the deferred word denoted by deferred-xt \ Fetch and store the target of the deferred word denoted by deferred-xt
: DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? ▪ >DFA @ ; : DEFER@ ( deferred-xt -- xt ) DUP DEFERRED? ▪ >DFA @ ;
: DEFER! ( xt deferred-xt -- ) DUP DEFERRED? ▪ >DFA ! ; : DEFER! ( xt deferred-xt -- ) DUP DEFERRED? ▪ >DFA ! ;
>>LINUX ' LINUX (DEFINITIONS)
\ Next we'll be defining a lot of constants for system calls and other ABI data \ Next we'll be defining a lot of constants for system calls and other ABI data
\ CONSTANT is still a bootstrap word here, but ⇒ is just temporary \ CONSTANT is still a bootstrap word here, but ⇒ is just temporary
@ -631,7 +636,7 @@ DEFER QUIT
: SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ; : SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ;
: SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ; : SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ;
>>FORTH ' FORTH (DEFINITIONS)
\ Write a character array to the given file descriptor \ Write a character array to the given file descriptor
\ Repeat write syscall until entire string is written \ Repeat write syscall until entire string is written
@ -717,13 +722,13 @@ DEFER QUIT
\ Emit a horizontal tab character \ Emit a horizontal tab character
: TAB ( -- "<tab>" ) HT EMIT ; : TAB ( -- "<tab>" ) HT EMIT ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ The implementation-dependent End-of-Line string \ 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) ( -- c-addr u ) "\n" ; : (EOL) ( -- c-addr u ) "\n" ;
>>FORTH ' FORTH (DEFINITIONS)
\ Emit the implementation-dependent End-of-Line string \ Emit the implementation-dependent End-of-Line string
: EOL ( -- "<eol>" ) (EOL) TYPE ; : EOL ( -- "<eol>" ) (EOL) TYPE ;
@ -736,12 +741,12 @@ DEFER QUIT
: BYE ( -- <noreturn> ) : BYE ( -- <noreturn> )
BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ; BEGIN 0 SYS_EXIT SYSCALL1 DROP AGAIN ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ 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
>>FORTH ' FORTH (DEFINITIONS)
\ Allocate n consecutive bytes from the end of the data area \ Allocate n consecutive bytes from the end of the data area
\ If necessary use the brk system call to grow the data area \ If necessary use the brk system call to grow the data area
@ -844,7 +849,7 @@ DEFER QUIT
\ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD. \ by THEN and marks the end of the list if consumed by ONWARD-IF or ONWARD-AHEAD.
\ This can be used as a base for control structures with zero or more branches. \ This can be used as a base for control structures with zero or more branches.
>>UTILITY ' UTILITY (DEFINITIONS)
: (ALWAYS) ( C: -- null-orig ) IMMEDIATE : (ALWAYS) ( C: -- null-orig ) IMMEDIATE
NULL ; NULL ;
@ -860,7 +865,7 @@ DEFER QUIT
: (AHEAD) ( C: -- orig ; flag -- ) IMMEDIATE : (AHEAD) ( C: -- orig ; flag -- ) IMMEDIATE
POSTPONE (ALWAYS) POSTPONE (ONWARD-AHEAD) ; POSTPONE (ALWAYS) POSTPONE (ONWARD-AHEAD) ;
>>FORTH ' FORTH (DEFINITIONS)
\ <cond1> IF <code1> \ <cond1> IF <code1>
\ {ELSE-IF <cond2> THEN-IF <code2>}… \ {ELSE-IF <cond2> THEN-IF <code2>}…
@ -961,7 +966,7 @@ CREATE LEAVE-ORIG NULL ,
: I 1 RPICK ; : I 1 RPICK ;
: J 3 RPICK ; : J 3 RPICK ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ With 32-bit cells, a double-cell number has 64 bits \ 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 \ Space is reserved for binary output with a leading minus sign and a trailing space
@ -980,7 +985,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
\ THROW if there are less than u bytes remaining in the PNO buffer \ THROW if there are less than u bytes remaining in the PNO buffer
: PNO-CHECK ( u -- ) PNO-REMAINING U> IF EXCP-PNO-OVERFLOW THROW THEN ; : PNO-CHECK ( u -- ) PNO-REMAINING U> IF EXCP-PNO-OVERFLOW THROW THEN ;
>>FORTH ' FORTH (DEFINITIONS)
: <# PNO-BUFFER-END PNO-POINTER ! ; : <# PNO-BUFFER-END PNO-POINTER ! ;
: HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ; : HOLD ( char -- ) PNO-POINTER 1 DUP PNO-CHECK OVER -! @ C! ;
@ -1005,7 +1010,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
\ Example: 12345 0 <# 3 #DFP #> ≡ "12.345" \ Example: 12345 0 <# 3 #DFP #> ≡ "12.345"
: #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ; : #DFP ( ud1 u -- ud2 ) BEGIN ?DUP WHILE 1- >R # R> REPEAT [[ CHAR . ]] HOLD #S ;
>>FORTH ' FORTH (DEFINITIONS)
\ Display the unsigned double-cell number at the top of the stack, right-aligned \ Display the unsigned double-cell number at the top of the stack, right-aligned
: DU.R ( ud n -- "<digits>" ) >R <# #S BL R> #PAD #> TYPE ; : DU.R ( ud n -- "<digits>" ) >R <# #S BL R> #PAD #> TYPE ;
@ -1028,7 +1033,7 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
: DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; : DEPTH ( -- n ) SP@ S0 SWAP - CELL / ;
: RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ; : RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
: STARTUP-UNWIND ( k*x n -- i*x <noreturn> ) : STARTUP-UNWIND ( k*x n -- i*x <noreturn> )
"Exception " TYPE-ERR DUP ABS 0 <# (EOL) HOLDS #S ROT SIGN #> TYPE-ERR "Exception " TYPE-ERR DUP ABS 0 <# (EOL) HOLDS #S ROT SIGN #> TYPE-ERR
@ -1037,11 +1042,11 @@ CREATE PNO-POINTER PNO-BUFFER-END ,
' STARTUP-UNWIND ' THROW-UNWIND DEFER! ' STARTUP-UNWIND ' THROW-UNWIND DEFER!
>>UTILITY ' UTILITY (DEFINITIONS)
CREATE DISPLAY-ITEM-LIMIT 6 , CREATE DISPLAY-ITEM-LIMIT 6 ,
>>FORTH ' FORTH (DEFINITIONS)
\ Display the content of the data stack \ Display the content of the data stack
: .S ( -- "<text>" ) : .S ( -- "<text>" )
@ -1115,7 +1120,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
THEN THEN
>NUMBER-BASE ; >NUMBER-BASE ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ 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 -- 0 | n 1 | d 2 ) : PARSENUMBER ( c-addr u -- 0 | n 1 | d 2 )
@ -1133,7 +1138,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER! ' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER!
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer \ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
CREATE INPUT-BUFFER SOURCE 2, CREATE INPUT-BUFFER SOURCE 2,
@ -1142,7 +1147,7 @@ CREATE INPUT-BUFFER SOURCE 2,
\ Any other values are implementation-defined, for example FD numbers for file input \ Any other values are implementation-defined, for example FD numbers for file input
CREATE CURRENT-SOURCE-ID -1 , CREATE CURRENT-SOURCE-ID -1 ,
>>FORTH ' FORTH (DEFINITIONS)
\ Report the current input buffer region and SOURCE-ID \ Report the current input buffer region and SOURCE-ID
: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ; : SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ;
@ -1153,7 +1158,7 @@ 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 ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
CREATE EXCEPTION-STACK NULL , CREATE EXCEPTION-STACK NULL ,
@ -1167,12 +1172,12 @@ CREATE EXCEPTION-STACK NULL ,
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP
R> SWAP >R SP! R> ; R> SWAP >R SP! R> ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ Returns TRUE if currently executing inside CATCH, or FALSE otherwise \ Returns TRUE if currently executing inside CATCH, or FALSE otherwise
: CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ; : CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ;
>>FORTH ' FORTH (DEFINITIONS)
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc. \ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
\ On success has the effect of xt and also leaves the value 0 on top of the stack \ On success has the effect of xt and also leaves the value 0 on top of the stack
@ -1198,7 +1203,7 @@ CREATE EXCEPTION-STACK NULL ,
: PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; : PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ;
>>UTILITY ' UTILITY (DEFINITIONS)
: PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; : PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ;
@ -1212,7 +1217,7 @@ CREATE EXCEPTION-STACK NULL ,
: SKIP-SPACES ( "<spaces?>" -- ) : SKIP-SPACES ( "<spaces?>" -- )
BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? WHILE ▪ SKIP-CHAR ▪ REPEAT ; BEGIN ▪ PARSE-EMPTY? 0= WHILE ▪ PEEK-CHAR SPACE? WHILE ▪ SKIP-CHAR ▪ REPEAT ;
>>FORTH ' FORTH (DEFINITIONS)
\ 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 ;
@ -1238,7 +1243,7 @@ DEFER REFILL
: CHAR ( "<spaces?>name" -- c ) : CHAR ( "<spaces?>name" -- c )
PARSE-NAME DROP C@ ; PARSE-NAME DROP C@ ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ Create the header for a word in the data space and return its xt \ Create the header for a word in the data space and return its xt
\ The word is NOT added to the current compilation word list \ The word is NOT added to the current compilation word list
@ -1256,7 +1261,7 @@ DEFER REFILL
\ The default target for DEFER words until initialized with DEFER! or IS \ The default target for DEFER words until initialized with DEFER! or IS
: (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ; : (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ Use to create words programmatically without reading the name from the input \ Use to create words programmatically without reading the name from the input
: (CREATE) ( c-addr u -- ) : (CREATE) ( c-addr u -- )
@ -1268,7 +1273,7 @@ DEFER REFILL
: (:) ( c-addr u -- ) : (:) ( c-addr u -- )
(CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ; (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ;
>>FORTH ' FORTH (DEFINITIONS)
\ Append "<addr> (DOES) EXIT" to the current definition \ Append "<addr> (DOES) EXIT" to the current definition
\ where <addr> is the next address after the "EXIT" as a literal number \ where <addr> is the next address after the "EXIT" as a literal number
@ -1281,7 +1286,7 @@ DEFER REFILL
: ; IMMEDIATE : ; IMMEDIATE
POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ; POSTPONE EXIT POSTPONE [ LATEST DUP >NAME NIP IF (UNHIDE) ELSE DROP THEN ;
>>UTILITY ' UTILITY (DEFINITIONS)
\ 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
@ -1331,7 +1336,7 @@ DEFER REFILL
: MARK ( "<spaces?>name" ) IMMEDIATE : MARK ( "<spaces?>name" ) IMMEDIATE
PARSE-NAME STATE @ IF POSTPONE SLITERAL POSTPONE (MARK) ELSE (MARK) THEN ; PARSE-NAME STATE @ IF POSTPONE SLITERAL POSTPONE (MARK) ELSE (MARK) THEN ;
>>FORTH ' FORTH (DEFINITIONS)
\ The utility words defined previously, but with the name read from the parse area \ The utility words defined previously, but with the name read from the parse area
: CREATE PARSE-NAME (CREATE) ; : CREATE PARSE-NAME (CREATE) ;
@ -1357,7 +1362,7 @@ DEFER REFILL
1 ALIGNED 1 CELLS 2CONSTANT CELL% 1 ALIGNED 1 CELLS 2CONSTANT CELL%
1 ALIGNED 2 CELLS 2CONSTANT 2CELL% 1 ALIGNED 2 CELLS 2CONSTANT 2CELL%
>>UTILITY ' UTILITY (DEFINITIONS)
\ Extra field type descriptors for FFI structs \ Extra field type descriptors for FFI structs
\ Each type is naturally aligned (contrast int64% vs 2CELL%) \ Each type is naturally aligned (contrast int64% vs 2CELL%)
@ -1382,7 +1387,7 @@ DEFER REFILL
▪ DUP ALIAS signed-long-long% ▪ DUP ALIAS signed-long-long%
▪ ALIAS unsigned-long-long% ▪ ALIAS unsigned-long-long%
>>FORTH ' FORTH (DEFINITIONS)
\ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size \ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size
\ Each field word has runtime effect ( struct-addr -- field-addr) \ Each field word has runtime effect ( struct-addr -- field-addr)
@ -1489,7 +1494,7 @@ DEFER REFILL
\ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect \ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect
: [THEN] IMMEDIATE ; : [THEN] IMMEDIATE ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB \ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB
32 CONSTANT BUDDY-MIN-BYTES 32 CONSTANT BUDDY-MIN-BYTES
@ -1554,7 +1559,7 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS
VARIABLE TOTAL VARIABLE TOTAL
>>UTILITY ' UTILITY (DEFINITIONS)
: BUDDY-STATS : BUDDY-STATS
0 TOTAL ! 0 TOTAL !
@ -1567,7 +1572,7 @@ VARIABLE TOTAL
' TOTAL (HIDE) ' TOTAL (HIDE)
>>LINUX ' LINUX (DEFINITIONS)
4 KB CONSTANT PAGESIZE 4 KB CONSTANT PAGESIZE
@ -1579,7 +1584,7 @@ VARIABLE TOTAL
2 CONSTANT MAP_PRIVATE 2 CONSTANT MAP_PRIVATE
32 CONSTANT MAP_ANONYMOUS 32 CONSTANT MAP_ANONYMOUS
>>UTILITY ' UTILITY (DEFINITIONS)
\ Simple wrapper for munmap() that retries on EINTR \ Simple wrapper for munmap() that retries on EINTR
: MMAP-UNMAP ( addr length -- ) : MMAP-UNMAP ( addr length -- )
@ -1601,7 +1606,7 @@ VARIABLE TOTAL
R@ OVER R@ - MMAP-UNMAP R@ OVER R@ - MMAP-UNMAP
DUP R> R@ 2* + SWAP R> + TUCK - MMAP-UNMAP ; DUP R> R@ 2* + SWAP R> + TUCK - MMAP-UNMAP ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
STRUCT STRUCT
CELL% FIELD MEMBLOCK>SIZE CELL% FIELD MEMBLOCK>SIZE
@ -1620,7 +1625,7 @@ ENDSTRUCT MEMBLOCK%
: DATA>MEMBLOCK ( obj-addr -- memblock-addr ) : DATA>MEMBLOCK ( obj-addr -- memblock-addr )
MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ; MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ;
>>FORTH ' FORTH (DEFINITIONS)
: ALLOCATE ( size -- obj-addr ) : ALLOCATE ( size -- obj-addr )
DUP 0= IF EXIT THEN DUP 0= IF EXIT THEN
@ -1644,7 +1649,7 @@ ENDSTRUCT MEMBLOCK%
DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN
THEN ; THEN ;
>>UTILITY ' UTILITY (DEFINITIONS)
: OBJECT-SIZE ( obj-addr -- size ) : OBJECT-SIZE ( obj-addr -- size )
DUP IF DUP IF
@ -1654,7 +1659,7 @@ ENDSTRUCT MEMBLOCK%
MEMBLOCK-DATA-OFFSET - MEMBLOCK-DATA-OFFSET -
THEN ; THEN ;
>>FORTH ' FORTH (DEFINITIONS)
\ If size is 0 then free obj-addr1 (which may be NULL) and return NULL \ If size is 0 then free obj-addr1 (which may be NULL) and return NULL
\ Otherwise if obj-addr1 is NULL then allocate size bytes \ Otherwise if obj-addr1 is NULL then allocate size bytes
@ -1689,7 +1694,7 @@ ENDSTRUCT MEMBLOCK%
: DUPLICATE ( c-addr u -- obj-addr u ) : DUPLICATE ( c-addr u -- obj-addr u )
DUP ALLOCATE >R >R 2R@ CMOVE 2R> ; DUP ALLOCATE >R >R 2R@ CMOVE 2R> ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ Execute the closure captured at a-addr \ Execute the closure captured at a-addr
\ The memory at a-addr consists of a cell count, an xt, and >=0 cells of data \ The memory at a-addr consists of a cell count, an xt, and >=0 cells of data
@ -1699,7 +1704,7 @@ ENDSTRUCT MEMBLOCK%
: (CLOSURE) ( i*x a-addr -- j*x ) : (CLOSURE) ( i*x a-addr -- j*x )
DUP @ SWAP CELL+ N@ EXECUTE ; DUP @ SWAP CELL+ N@ EXECUTE ;
>>FORTH ' FORTH (DEFINITIONS)
\ Read one cell and increment \ Read one cell and increment
: @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ; : @(+) ( a-addr1 -- a-addr2 x ) DUP CELL+ SWAP @ ;
@ -1734,7 +1739,7 @@ ENDSTRUCT MEMBLOCK%
\ The content is indeterminate and must be initialized before the first use \ The content is indeterminate and must be initialized before the first use
: %VARIABLE ( align bytes "<spaces?>name" -- ) %ALLOT CONSTANT ; : %VARIABLE ( align bytes "<spaces?>name" -- ) %ALLOT CONSTANT ;
>>SYSTEM ' SYSTEM (DEFINITIONS)
\ This structure describes one entry in the search order linked list \ This structure describes one entry in the search order linked list
STRUCT STRUCT
@ -1745,7 +1750,9 @@ ENDSTRUCT ORDER%
VARIABLE CURRENT-ORDER VARIABLE CURRENT-ORDER
NULL CURRENT-ORDER ! NULL CURRENT-ORDER !
>>FORTH DEFER MINIMUM-ORDER
' FORTH (DEFINITIONS)
\ Return the current search order \ Return the current search order
: GET-ORDER ( -- widn ... wid1 n ) : GET-ORDER ( -- widn ... wid1 n )
@ -1774,27 +1781,16 @@ NULL CURRENT-ORDER !
\ Set the current search order \ Set the current search order
: SET-ORDER ( widn ... wid1 n | -n -- ) : SET-ORDER ( widn ... wid1 n | -n -- )
DUP 0< IF DROP FORTH-WORDLIST 1 THEN DUP 0< IF DROP MINIMUM-ORDER THEN
\ Free the previous search order linked list \ Free the previous search order linked list
NULL CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT NULL CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT
\ Build the new search order linked list \ Build the new search order linked list
0 OVER ?DO I PICK PUSH-ORDER -1 +LOOP NDROP ; 0 OVER ?DO I PICK PUSH-ORDER -1 +LOOP NDROP ;
\ Prepare the initial search order
BOOTSTRAP-GET-ORDER SET-ORDER
\ Use the real search order as the bootstrap search order from now on
' GET-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
\ Create a new wordlist
\ In this implementation a word list is just a pointer to the most recent word
: WORDLIST ( -- wid )
ALIGN HERE NULL , ;
\ Make the first list in the search order the current compilation word list \ Make the first list in the search order the current compilation word list
: DEFINITIONS PEEK-ORDER SET-CURRENT ; : DEFINITIONS PEEK-ORDER SET-CURRENT ;
\ Run a function for each word in the given wordlist \ Run a function for each word in the given word list
\ xt Execution: ( i*x word-xt -- stop-flag j*x ) \ xt Execution: ( i*x word-xt -- stop-flag j*x )
: WITH-WORDLIST ( i*x wid xt -- j*x ) : WITH-WORDLIST ( i*x wid xt -- j*x )
>R @ BEGIN ?DUP WHILE >R @ BEGIN ?DUP WHILE
@ -1833,18 +1829,43 @@ BOOTSTRAP-GET-ORDER SET-ORDER
"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 \ Create a unnamed word list
\ In this implementation a word list is just a pointer to the most recent word
: WORDLIST ( -- wid )
ALIGN HERE NULL , ;
\ Define a new named word list
\ Executing the word will replace the first item in the search order \ Executing the word will replace the first item in the search order
: VOCABULARY ( "<spaces?>name" ) : VOCABULARY ( "<spaces?>name" )
CREATE NULL , CREATE NULL ,
DOES> POP-ORDER DROP PUSH-ORDER ; DOES> POP-ORDER DROP PUSH-ORDER ;
\ Names to select the predefined word lists ' SYSTEM (DEFINITIONS)
VOCABULARY ROOT
{ [[ ' ROOT >WORDLIST ]] 1 } ' MINIMUM-ORDER DEFER!
\ Redefine the predefined word lists as named vocabularies
\ FORTH is a Search-Order extension word \ FORTH is a Search-Order extension word
: FORTH FORTH-WORDLIST POP-ORDER DROP PUSH-ORDER ; : CONVERT ( xt -- )
: LINUX LINUX-WORDLIST POP-ORDER DROP PUSH-ORDER ; [[ ' ROOT >CFA @ ]] OVER >CFA !
: UTILITY UTILITY-WORDLIST POP-ORDER DROP PUSH-ORDER ; [[ ' ROOT >DFA @ ]] SWAP >DFA ! ;
: SYSTEM SYSTEM-WORDLIST POP-ORDER DROP PUSH-ORDER ;
' FORTH CONVERT
' UTILITY CONVERT
' SYSTEM CONVERT
' LINUX CONVERT
' CONVERT (HIDE)
\ Prepare the initial search order
BOOTSTRAP-WORDLIST ▪ ' LINUX >WORDLIST ▪ ' UTILITY >WORDLIST
' SYSTEM >WORDLIST ▪ ' FORTH >WORDLIST ▪ DUP ▪ 6 SET-ORDER
\ Use the real search order as the bootstrap search order from now on
' GET-ORDER ' BOOTSTRAP-GET-ORDER DEFER!
FORTH DEFINITIONS
\ Create a word to revert the search order, data space, and compilation word list \ 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. \ to their respective states from immediately before the marker was defined.
@ -1855,12 +1876,19 @@ BOOTSTRAP-GET-ORDER SET-ORDER
CREATE ▪ DUP 4 + ▪ DUP 1+ ▪ HERE ▪ OVER CELLS ALLOT ▪ N! CREATE ▪ DUP 4 + ▪ DUP 1+ ▪ HERE ▪ OVER CELLS ALLOT ▪ N!
DOES> @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ; DOES> @(+) SWAP N@ ▪ SET-ORDER ▪ SET-CURRENT ▪ LATEST! ▪ CP ! ;
>>SYSTEM SYSTEM DEFINITIONS
DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
{ 0 } ' FIND-HOOK DEFER! { 0 } ' FIND-HOOK DEFER!
>>FORTH ROOT DEFINITIONS
' ONLY ALIAS ONLY
' FORTH ALIAS FORTH
' SET-ORDER ALIAS SET-ORDER
' >WORDLIST ALIAS >WORDLIST
FORTH DEFINITIONS
\ 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 )
@ -1876,21 +1904,18 @@ DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
REPEAT REPEAT
2R> 0 ; 2R> 0 ;
>>UTILITY UTILITY DEFINITIONS
\ Same as FIND except that unknown words are reported and result in a call to THROW \ Same as FIND except that unknown words are reported and result in a call to THROW
: FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 ) : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 )
FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ; FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ;
>>FORTH FORTH DEFINITIONS
\ Read a word from the input (during runtime) and return its execution token \ Read a word from the input (during runtime) and return its execution token
\ Aborts if the word is not found in the current (runtime) search order list \ Aborts if the word is not found in the current (runtime) search order list
: ' ( "<spaces?>name" -- xt ) PARSE-NAME FIND-OR-THROW DROP ; : ' ( "<spaces?>name" -- xt ) PARSE-NAME FIND-OR-THROW DROP ;
\ "Append to"; set the compilation namespace to the given vocabulary (e.g. FORTH)
: >> ( "<spaces?>name" -- ) ' ALSO EXECUTE DEFINITIONS PREVIOUS ;
\ 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
@ -1953,7 +1978,7 @@ DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 )
: PRESERVED ( i*x xt addr -- j*x ) : PRESERVED ( i*x xt addr -- j*x )
DUP @ >R >R CATCH 2R> ! RETHROW ; DUP @ >R >R CATCH 2R> ! RETHROW ;
>> SYSTEM SYSTEM DEFINITIONS
\ The size of this buffer will determine the maximum line length \ The size of this buffer will determine the maximum line length
4096 CONSTANT TERMINAL-BUFFER-BYTES 4096 CONSTANT TERMINAL-BUFFER-BYTES
@ -1963,7 +1988,7 @@ TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER
2VARIABLE TIB-LEFTOVER 2VARIABLE TIB-LEFTOVER
NULL 0 TIB-LEFTOVER 2! NULL 0 TIB-LEFTOVER 2!
>> FORTH FORTH DEFINITIONS
\ Attempt to replace the parse area with the next line from the current source \ Attempt to replace the parse area with the next line from the current source
\ Return TRUE if the parse area was refilled, or FALSE otherwise \ Return TRUE if the parse area was refilled, or FALSE otherwise
@ -2003,7 +2028,7 @@ NULL 0 TIB-LEFTOVER 2!
DUP IF 0 >IN ! THEN DUP IF 0 >IN ! THEN
0<> ; 0<> ;
>> UTILITY UTILITY DEFINITIONS
\ Parse up to limit digits in the given base, appending them to u1 to produce u2. \ Parse up to limit digits in the given base, appending them to u1 to produce u2.
: ESCAPED-DIGITS ( u1 base limit -- u2 ) : ESCAPED-DIGITS ( u1 base limit -- u2 )
@ -2036,12 +2061,12 @@ NULL 0 TIB-LEFTOVER 2!
ENDCASE ENDCASE
THEN ; THEN ;
>> SYSTEM SYSTEM DEFINITIONS
2VARIABLE STRING-BUFFER 2VARIABLE STRING-BUFFER
NULL 0 STRING-BUFFER 2! NULL 0 STRING-BUFFER 2!
>> UTILITY UTILITY DEFINITIONS
\ Read a literal character string up to the next double-quote character \ Read a literal character string up to the next double-quote character
\ The string is stored in a transient buffer and will become invalid when \ The string is stored in a transient buffer and will become invalid when
@ -2066,7 +2091,7 @@ NULL 0 STRING-BUFFER 2!
ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+ ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+
REPEAT ▪ NIP ; REPEAT ▪ NIP ;
>> SYSTEM SYSTEM DEFINITIONS
: ?STACK SP@ S0 > IF ▪ S0 SP! ▪ EXCP-STACK-UNDERFLOW THROW ▪ THEN ; : ?STACK SP@ S0 > IF ▪ S0 SP! ▪ EXCP-STACK-UNDERFLOW THROW ▪ THEN ;
@ -2106,14 +2131,14 @@ NULL 0 STRING-BUFFER 2!
?STACK ?STACK
REPEAT ; REPEAT ;
>> FORTH FORTH DEFINITIONS
: EVALUATE ( i*x c-addr u -- j*x ) : EVALUATE ( i*x c-addr u -- j*x )
SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R
0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET 0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET
R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ; R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ;
>> LINUX LINUX DEFINITIONS
' unsigned-char% ALIAS cc% ' unsigned-char% ALIAS cc%
' unsigned-int% ALIAS speed% ' unsigned-int% ALIAS speed%
@ -2132,11 +2157,11 @@ ENDSTRUCT termios%
0x5401 CONSTANT IOCTL_TCGETS 0x5401 CONSTANT IOCTL_TCGETS
>> SYSTEM SYSTEM DEFINITIONS
termios% %VARIABLE SCRATCH-TERMIOS termios% %VARIABLE SCRATCH-TERMIOS
>> FORTH FORTH DEFINITIONS
: TTY? ( fd -- flag ) : TTY? ( fd -- flag )
IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ; IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ;
@ -2158,7 +2183,7 @@ STDIN TTY? CONSTANT INTERACTIVE?
[THEN] [THEN]
AGAIN ; AGAIN ;
>> SYSTEM SYSTEM DEFINITIONS
32 CONSTANT #REPORTERS 32 CONSTANT #REPORTERS
#REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code ) #REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code )
@ -2176,7 +2201,7 @@ REVERT
THEN ▪ 2DROP THEN ▪ 2DROP
LOOP ▪ DROP NULL FALSE ; LOOP ▪ DROP NULL FALSE ;
>> UTILITY UTILITY DEFINITIONS
\ Set the reporter for the given exception code \ Set the reporter for the given exception code
: REPORTER! ( xt n -- ) ( xt: -- ) : REPORTER! ( xt n -- ) ( xt: -- )
@ -2191,7 +2216,7 @@ REVERT
DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ; DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ;
THEN ; THEN ;
>> SYSTEM SYSTEM DEFINITIONS
{ ( no message for ABORT ) } EXCP-ABORT REPORTER! { ( no message for ABORT ) } EXCP-ABORT REPORTER!
{ THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR } EXCP-FAIL REPORTER! { THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR } EXCP-FAIL REPORTER!
@ -2221,24 +2246,25 @@ REVERT
\ 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
{ PARSE-AREA EVALUATE QUIT } EXECUTE { PARSE-AREA EVALUATE QUIT } EXECUTE
FORTH-WORDLIST 1 SET-ORDER
DEFINITIONS
\ ***************************************************************************** \ *****************************************************************************
\ Bootstrapping is complete \ Bootstrapping is complete
\ From this point on we only execute threaded FORTH words defined in this file \ From this point on we only execute threaded FORTH words defined in this file
\ ***************************************************************************** \ *****************************************************************************
ONLY FORTH
ALSO UTILITY ALSO UTILITY
ALSO SYSTEM ALSO SYSTEM
ALSO
>> SYSTEM SYSTEM DEFINITIONS
STRUCT STRUCT
CELL% FIELD LOCAL>LINK CELL% FIELD LOCAL>LINK
CELL% FIELD LOCAL>LENGTH CELL% FIELD LOCAL>LENGTH
CHAR% 0 * FIELD LOCAL>NAME-ADDR CHAR% 0 * FIELD LOCAL>NAME-ADDR
ENDSTRUCT LOCAL% ENDSTRUCT LOCAL%
\ Parameterize LOCAL% to include the length of the name
: LOCAL% ( u -- align bytes ) >R LOCAL% R> + ; : LOCAL% ( u -- align bytes ) >R LOCAL% R> + ;
: LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ; : LOCAL>NAME ( local -- c-addr u ) DUP LOCAL>NAME-ADDR SWAP LOCAL>LENGTH @ ;
@ -2276,7 +2302,7 @@ REVERT
\ immediately following the NULL-terminated array of argument pointers \ immediately following the NULL-terminated array of argument pointers
ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
>> FORTH FORTH DEFINITIONS
\ Convert a C string to a FORTH string by counting the characters \ Convert a C string to a FORTH string by counting the characters
: CSTRING ( c-addr -- c-addr u ) 0 BEGIN 2DUP + C@ WHILE 1+ REPEAT ; : CSTRING ( c-addr -- c-addr u ) 0 BEGIN 2DUP + C@ WHILE 1+ REPEAT ;
@ -2317,11 +2343,11 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT
TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ; TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ;
>> UTILITY UTILITY DEFINITIONS
: (TRACE) ( xt -- ) >NAME TYPE SPACE .S ; : (TRACE) ( xt -- ) >NAME TYPE SPACE .S ;
>> FORTH FORTH DEFINITIONS
\ 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 ( "<spaces?>name" -- ) : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; : :TRACE ( "<spaces?>name" -- ) : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
@ -2359,7 +2385,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
"∷" TYPE U. "∷" TYPE U.
THEN ; THEN ;
>> UTILITY UTILITY DEFINITIONS
\ Display a string in escaped (double-quoted) format, without the delimiters \ Display a string in escaped (double-quoted) format, without the delimiters
: CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ; : CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ;
@ -2390,7 +2416,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
ELSE NIP THEN ELSE NIP THEN
THEN NIP ; THEN NIP ;
>> UTILITY UTILITY DEFINITIONS
\ Display the threaded code which starts at a-addr \ Display the threaded code which starts at a-addr
\ Continues until it encounters a reference to EXIT beyond any forward branches \ Continues until it encounters a reference to EXIT beyond any forward branches
@ -2447,7 +2473,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE
ENDCASE ; ENDCASE ;
>> FORTH FORTH DEFINITIONS
: SEE ( "<spaces?>name" -- ) ' (SEE) ; : SEE ( "<spaces?>name" -- ) ' (SEE) ;
@ -2462,7 +2488,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
\ node at the beginning of a list, or NULL if the list is empty. &link is the \ node at the beginning of a list, or NULL if the list is empty. &link is the
\ address of either a cell holding the head of the list or a node's link field. \ address of either a cell holding the head of the list or a node's link field.
>> UTILITY UTILITY DEFINITIONS
\ Put the even items from head into head1 and the odd items into head2 \ Put the even items from head into head1 and the odd items into head2
: SPLIT ( head link-xt -- head1 head2 ) : SPLIT ( head link-xt -- head1 head2 )
@ -2488,7 +2514,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
( S: head1 head2' &link2 R: link-xt compare-xt head ) ( S: head1 head2' &link2 R: link-xt compare-xt head )
AGAIN ; AGAIN ;
>> FORTH FORTH DEFINITIONS
\ Return TRUE if the given list is sorted, or FALSE otherwise \ Return TRUE if the given list is sorted, or FALSE otherwise
: SORTED? ( head link-xt compare-xt -- flag ) : SORTED? ( head link-xt compare-xt -- flag )
@ -2518,7 +2544,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON
: 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 ;
>> UTILITY UTILITY DEFINITIONS
\ AA Tree, a variation on the Red-Black Tree \ AA Tree, a variation on the Red-Black Tree
\ <https://en.wikipedia.org/wiki/AA_tree> \ <https://en.wikipedia.org/wiki/AA_tree>
@ -2541,7 +2567,7 @@ STRUCT
CELL% FIELD AA>COMPARE ( aa-compare-xt ) CELL% FIELD AA>COMPARE ( aa-compare-xt )
ENDSTRUCT AA-TREE% ENDSTRUCT AA-TREE%
>> SYSTEM SYSTEM DEFINITIONS
: AA-INIT-LEAF ( aa-node -- ) : AA-INIT-LEAF ( aa-node -- )
NULL OVER AA>LEFT ! ▪ NULL OVER AA>RIGHT ! ▪ 1 SWAP AA>LEVEL ! ; NULL OVER AA>LEFT ! ▪ NULL OVER AA>RIGHT ! ▪ 1 SWAP AA>LEVEL ! ;
@ -2653,7 +2679,7 @@ ENDSTRUCT AA-TREE%
right-xt FREE-CLOSURE right-xt FREE-CLOSURE
ENDLOCALS ; ENDLOCALS ;
>> UTILITY UTILITY DEFINITIONS
: NEW-AA-TREE ( aa-value-xt aa-compare-xt -- aa-tree ) : NEW-AA-TREE ( aa-value-xt aa-compare-xt -- aa-tree )
AA-TREE% %ALLOCATE ▪ TUCK AA>COMPARE ! ▪ TUCK AA>VALUE ! ▪ NULL OVER AA>ROOT ! ; AA-TREE% %ALLOCATE ▪ TUCK AA>COMPARE ! ▪ TUCK AA>VALUE ! ▪ NULL OVER AA>ROOT ! ;
@ -2691,6 +2717,8 @@ ENDSTRUCT AA-TREE%
: AA-#NODES ( aa-tree -- u ) : AA-#NODES ( aa-tree -- u )
>R 0 { NIP >R EXECUTE R> EXECUTE 1+ } [[ ' ▪ ]] R> AA-TRAVERSE ; >R 0 { NIP >R EXECUTE R> EXECUTE 1+ } [[ ' ▪ ]] R> AA-TRAVERSE ;
LINUX DEFINITIONS
STRUCT STRUCT
unsigned-long-long% FIELD stat64>dev unsigned-long-long% FIELD stat64>dev
unsigned-char% 4 * FIELD stat64>__pad0 unsigned-char% 4 * FIELD stat64>__pad0
@ -2713,7 +2741,7 @@ STRUCT
unsigned-long-long% FIELD stat64>ino unsigned-long-long% FIELD stat64>ino
ENDSTRUCT stat64% ENDSTRUCT stat64%
>> FORTH FORTH DEFINITIONS
ALSO LINUX ALSO LINUX
O_RDONLY CONSTANT R/O ( -- fam ) O_RDONLY CONSTANT R/O ( -- fam )
@ -2743,8 +2771,7 @@ PREVIOUS
: FILE-STATUS ( c-addr u -- x ) ; : FILE-STATUS ( c-addr u -- x ) ;
FORTH-WORDLIST 1 SET-ORDER ONLY FORTH DEFINITIONS
DEFINITIONS
: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;