From b2580231367e4aba9a8fb313bd6ad42af685e116 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sat, 7 Nov 2020 00:47:05 -0600 Subject: [PATCH] eliminate *-WORDLIST & replace with VOCABULARY-style words --- jumpforth.S | 14 ++- startup.4th | 293 ++++++++++++++++++++++++++++------------------------ 2 files changed, 166 insertions(+), 141 deletions(-) diff --git a/jumpforth.S b/jumpforth.S index bca38db..f956aa7 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -226,13 +226,8 @@ defvar IN,0,">IN" defvar CP /* "compilation pointer", next free byte in the heap */ defvar BRK /* the (current) end of the heap */ -/* 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 */ -defvar FORTH_WORDLIST,last_primitive,"FORTH-WORDLIST" - -/* The current compilation word list, initially FORTH-WORDLIST */ -defvar CURRENT,data_FORTH_WORDLIST +/* The current compilation word list, initially BOOTSTRAP-WORDLIST */ +defvar CURRENT,data_BOOTSTRAP_WORDLIST /* ( a -- ) */ defcode DROP @@ -1236,6 +1231,9 @@ defcode BREAK .section .data 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 */ defvar BOOTSTRAP_WORDLIST,last_word,"BOOTSTRAP-WORDLIST" @@ -1367,7 +1365,7 @@ defword ISBOOTSTRAP,"BOOTSTRAP?",F_HIDDEN /* ( -- widn ... wid1 n ) Return the current search order */ /* Redefining this word with DEFER! will change the bootstrap search order */ 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 ) */ /* 0 = not found; 1 = non-immediate; -1 = immediate */ diff --git a/startup.4th b/startup.4th index a7d4e81..574a627 100644 --- a/startup.4th +++ b/startup.4th @@ -1,35 +1,21 @@ -\ Keep internal system definitions and ABI constants out of the main word list -CP @ 0 , DUP CURRENT ! CONSTANT SYSTEM-WORDLIST -CP @ 0 , CONSTANT UTILITY-WORDLIST -CP @ 0 , CONSTANT LINUX-WORDLIST -BOOTSTRAP-WORDLIST CONSTANT BOOTSTRAP-WORDLIST +\ Create the FORTH word list, which includes the name FORTH and all the primitives +CURRENT @ @ ( save the latest word in the bootstrap word list ) +CREATE FORTH CURRENT @ @ , ( create FORTH with itself as the initial value ) +CURRENT @ XCHG ( restore bootstrap list & get address of FORTH ) +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 -: STARTUP-ORDER ( -- widn ... wid1 n ) - BOOTSTRAP-WORDLIST - LINUX-WORDLIST - UTILITY-WORDLIST - SYSTEM-WORDLIST - FORTH-WORDLIST - 5 ; -' STARTUP-ORDER ' BOOTSTRAP-GET-ORDER DEFER! - -FORTH-WORDLIST CURRENT ! +\ Create the other startup word lists +\ These and FORTH will be edited later to have the DOES> effect of +\ changing the search order just like words defined with VOCABULARY +CREATE SYSTEM 0 , +CREATE UTILITY 0 , +CREATE LINUX 0 , \ 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 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" \ Signifies (the absence of) a memory address, not a number 0 CONSTANT NULL @@ -56,7 +42,17 @@ SYSTEM-WORDLIST SET-CURRENT \ Return the next address in the compilation/data area : 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 : >BODY ( xt -- a-addr ) [ 2 CELLS ] LITERAL + ; @@ -66,7 +62,16 @@ SYSTEM-WORDLIST SET-CURRENT : >FLAGS ( xt -- c-addr ) [ CELL 1+ ] LITERAL - ; : >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 : (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 ' STARTUP-ORDER (HIDE) ->>FORTH +' FORTH (DEFINITIONS) : IMMEDIATE? ( xt -- flag ) >FLAGS C@ F_IMMED AND 0<> ; : HIDDEN? ( xt -- flag ) >FLAGS C@ F_HIDDEN AND 0<> ; @@ -109,7 +114,7 @@ SYSTEM-WORDLIST SET-CURRENT -256 CONSTANT EXCP-HEAP-OVERFLOW -257 CONSTANT EXCP-DEFER-UNINITIALIZED ->>SYSTEM +' SYSTEM (DEFINITIONS) \ 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 @@ -122,7 +127,7 @@ NULL 0 THROWN-STRING 2! DEFER THROW-UNWIND ( k*x n -- i*x ) ' BAILOUT ' THROW-UNWIND DEFER! ->>FORTH +' FORTH (DEFINITIONS) \ QUIT needs to be defined after INTERPRET DEFER QUIT @@ -164,14 +169,14 @@ DEFER QUIT \ If the word list is empty the result will be zero : LATEST ( -- xt | NULL ) GET-CURRENT @ ; ->>UTILITY +' UTILITY (DEFINITIONS) \ 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, \ not just the most recent word : LATEST! ( xt -- ) GET-CURRENT ! ; ->>FORTH +' FORTH (DEFINITIONS) \ Set the latest defined word as immediate \ 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 ▪ DUP 8 RSHIFT OR ▪ DUP 16 RSHIFT OR ▪ 1+ ; ->>UTILITY +' UTILITY (DEFINITIONS) : 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 : DEFER@ ( deferred-xt -- 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 \ CONSTANT is still a bootstrap word here, but ⇒ is just temporary @@ -631,7 +636,7 @@ DEFER QUIT : SYSCALL5-RETRY [ ' SYSCALL5 ] LITERAL 5 SYSCALL-RETRY ; : SYSCALL6-RETRY [ ' SYSCALL6 ] LITERAL 6 SYSCALL-RETRY ; ->>FORTH +' FORTH (DEFINITIONS) \ Write a character array to the given file descriptor \ Repeat write syscall until entire string is written @@ -717,13 +722,13 @@ DEFER QUIT \ Emit a horizontal tab character : TAB ( -- "" ) HT EMIT ; ->>UTILITY +' UTILITY (DEFINITIONS) \ 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) ( -- c-addr u ) "\n" ; ->>FORTH +' FORTH (DEFINITIONS) \ Emit the implementation-dependent End-of-Line string : EOL ( -- "" ) (EOL) TYPE ; @@ -736,12 +741,12 @@ DEFER QUIT : BYE ( -- ) 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 65536 CONSTANT DATA-SEGMENT-ALIGNMENT ->>FORTH +' FORTH (DEFINITIONS) \ Allocate n consecutive bytes from the end of 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. \ This can be used as a base for control structures with zero or more branches. ->>UTILITY +' UTILITY (DEFINITIONS) : (ALWAYS) ( C: -- null-orig ) IMMEDIATE NULL ; @@ -860,7 +865,7 @@ DEFER QUIT : (AHEAD) ( C: -- orig ; flag -- ) IMMEDIATE POSTPONE (ALWAYS) POSTPONE (ONWARD-AHEAD) ; ->>FORTH +' FORTH (DEFINITIONS) \ IF \ {ELSE-IF THEN-IF }… @@ -961,7 +966,7 @@ CREATE LEAVE-ORIG NULL , : I 1 RPICK ; : J 3 RPICK ; ->>SYSTEM +' SYSTEM (DEFINITIONS) \ 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 @@ -980,7 +985,7 @@ CREATE PNO-POINTER PNO-BUFFER-END , \ 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 ; ->>FORTH +' FORTH (DEFINITIONS) : <# PNO-BUFFER-END PNO-POINTER ! ; : 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" : #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 : DU.R ( ud n -- "" ) >R <# #S BL R> #PAD #> TYPE ; @@ -1028,7 +1033,7 @@ CREATE PNO-POINTER PNO-BUFFER-END , : DEPTH ( -- n ) SP@ S0 SWAP - CELL / ; : RDEPTH ( -- n ) RSP@ CELL+ R0 SWAP - CELL / ; ->>SYSTEM +' SYSTEM (DEFINITIONS) : STARTUP-UNWIND ( k*x n -- i*x ) "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! ->>UTILITY +' UTILITY (DEFINITIONS) CREATE DISPLAY-ITEM-LIMIT 6 , ->>FORTH +' FORTH (DEFINITIONS) \ Display the content of the data stack : .S ( -- "" ) @@ -1115,7 +1120,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , THEN >NUMBER-BASE ; ->>UTILITY +' UTILITY (DEFINITIONS) \ Parse a signed number; to succeed the entire input string must be consumed : PARSENUMBER ( c-addr u -- 0 | n 1 | d 2 ) @@ -1133,7 +1138,7 @@ CREATE DISPLAY-ITEM-LIMIT 6 , ' PARSENUMBER ' BOOTSTRAP-PARSENUMBER DEFER! ->>SYSTEM +' SYSTEM (DEFINITIONS) \ Copy the bootstrap SOURCE values into variables to allow changing the input buffer 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 CREATE CURRENT-SOURCE-ID -1 , ->>FORTH +' FORTH (DEFINITIONS) \ Report the current input buffer region and SOURCE-ID : SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ; @@ -1153,7 +1158,7 @@ CREATE CURRENT-SOURCE-ID -1 , : SAVE-INPUT ( -- xu ... x1 u ) >IN @ 1 ; : RESTORE-INPUT ( xu ... x1 u -- flag ) OVER >IN ! NDROP TRUE ; ->>SYSTEM +' SYSTEM (DEFINITIONS) 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> SWAP >R SP! R> ; ->>UTILITY +' UTILITY (DEFINITIONS) \ Returns TRUE if currently executing inside CATCH, or FALSE otherwise : CATCHING? ( -- flag ) EXCEPTION-STACK @ NULL<> ; ->>FORTH +' FORTH (DEFINITIONS) \ 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 @@ -1198,7 +1203,7 @@ CREATE EXCEPTION-STACK NULL , : PARSE-AREA ( -- c-addr u ) SOURCE >IN @ /STRING ; ->>UTILITY +' UTILITY (DEFINITIONS) : PARSE-EMPTY? ( -- flag ) SOURCE NIP >IN @ = ; @@ -1212,7 +1217,7 @@ CREATE EXCEPTION-STACK NULL , : SKIP-SPACES ( "" -- ) 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 : \ ( "ccc" -- ) IMMEDIATE BEGIN NEXT-CHAR LF = UNTIL ; @@ -1238,7 +1243,7 @@ DEFER REFILL : CHAR ( "name" -- c ) PARSE-NAME DROP C@ ; ->>SYSTEM +' SYSTEM (DEFINITIONS) \ 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 @@ -1256,7 +1261,7 @@ DEFER REFILL \ The default target for DEFER words until initialized with DEFER! or IS : (DEFER-UNINITIALIZED) EXCP-DEFER-UNINITIALIZED THROW ; ->>UTILITY +' UTILITY (DEFINITIONS) \ Use to create words programmatically without reading the name from the input : (CREATE) ( c-addr u -- ) @@ -1268,7 +1273,7 @@ DEFER REFILL : (:) ( c-addr u -- ) (CREATE) LATEST ▪ DUP (HIDE) ▪ DOCOL SWAP >CFA ! ▪ POSTPONE ] ; ->>FORTH +' FORTH (DEFINITIONS) \ Append " (DOES) EXIT" to the current definition \ where is the next address after the "EXIT" as a literal number @@ -1281,7 +1286,7 @@ DEFER REFILL : ; IMMEDIATE 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 \ The default target throws an exception — replace it using DEFER! or IS @@ -1331,7 +1336,7 @@ DEFER REFILL : MARK ( "name" ) IMMEDIATE 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 : CREATE PARSE-NAME (CREATE) ; @@ -1357,7 +1362,7 @@ DEFER REFILL 1 ALIGNED 1 CELLS 2CONSTANT CELL% 1 ALIGNED 2 CELLS 2CONSTANT 2CELL% ->>UTILITY +' UTILITY (DEFINITIONS) \ Extra field type descriptors for FFI structs \ Each type is naturally aligned (contrast int64% vs 2CELL%) @@ -1382,7 +1387,7 @@ DEFER REFILL ▪ DUP ALIAS signed-long-long% ▪ ALIAS unsigned-long-long% ->>FORTH +' FORTH (DEFINITIONS) \ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size \ 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] IMMEDIATE ; ->>SYSTEM +' SYSTEM (DEFINITIONS) \ Orders 0 ... 17 with sizes 32 bytes ... 4 MiB 32 CONSTANT BUDDY-MIN-BYTES @@ -1554,7 +1559,7 @@ BUDDY-ORDERS ARRAY BUDDY-HEADS VARIABLE TOTAL ->>UTILITY +' UTILITY (DEFINITIONS) : BUDDY-STATS 0 TOTAL ! @@ -1567,7 +1572,7 @@ VARIABLE TOTAL ' TOTAL (HIDE) ->>LINUX +' LINUX (DEFINITIONS) 4 KB CONSTANT PAGESIZE @@ -1579,7 +1584,7 @@ VARIABLE TOTAL 2 CONSTANT MAP_PRIVATE 32 CONSTANT MAP_ANONYMOUS ->>UTILITY +' UTILITY (DEFINITIONS) \ Simple wrapper for munmap() that retries on EINTR : MMAP-UNMAP ( addr length -- ) @@ -1601,7 +1606,7 @@ VARIABLE TOTAL R@ OVER R@ - MMAP-UNMAP DUP R> R@ 2* + SWAP R> + TUCK - MMAP-UNMAP ; ->>SYSTEM +' SYSTEM (DEFINITIONS) STRUCT CELL% FIELD MEMBLOCK>SIZE @@ -1620,7 +1625,7 @@ ENDSTRUCT MEMBLOCK% : DATA>MEMBLOCK ( obj-addr -- memblock-addr ) MEMBLOCK-DATA-OFFSET - DUP MEMBLOCK-CHECK-MAGIC ; ->>FORTH +' FORTH (DEFINITIONS) : ALLOCATE ( size -- obj-addr ) DUP 0= IF EXIT THEN @@ -1644,7 +1649,7 @@ ENDSTRUCT MEMBLOCK% DUP BUDDY-ORDERS U< IF BUDDY-FREE ELSE MMAP-UNMAP THEN THEN ; ->>UTILITY +' UTILITY (DEFINITIONS) : OBJECT-SIZE ( obj-addr -- size ) DUP IF @@ -1654,7 +1659,7 @@ ENDSTRUCT MEMBLOCK% MEMBLOCK-DATA-OFFSET - THEN ; ->>FORTH +' FORTH (DEFINITIONS) \ 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 @@ -1689,7 +1694,7 @@ ENDSTRUCT MEMBLOCK% : DUPLICATE ( c-addr u -- obj-addr u ) DUP ALLOCATE >R >R 2R@ CMOVE 2R> ; ->>SYSTEM +' SYSTEM (DEFINITIONS) \ Execute the closure captured at a-addr \ 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 ) DUP @ SWAP CELL+ N@ EXECUTE ; ->>FORTH +' FORTH (DEFINITIONS) \ Read one cell and increment : @(+) ( 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 : %VARIABLE ( align bytes "name" -- ) %ALLOT CONSTANT ; ->>SYSTEM +' SYSTEM (DEFINITIONS) \ This structure describes one entry in the search order linked list STRUCT @@ -1745,7 +1750,9 @@ ENDSTRUCT ORDER% VARIABLE CURRENT-ORDER NULL CURRENT-ORDER ! ->>FORTH +DEFER MINIMUM-ORDER + +' FORTH (DEFINITIONS) \ Return the current search order : GET-ORDER ( -- widn ... wid1 n ) @@ -1774,27 +1781,16 @@ NULL CURRENT-ORDER ! \ Set the current search order : 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 NULL CURRENT-ORDER XCHG BEGIN ?DUP WHILE DUP ORDER>LINK @ SWAP FREE REPEAT \ Build the new search order linked list 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 : 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 ) : WITH-WORDLIST ( i*x wid xt -- j*x ) >R @ BEGIN ?DUP WHILE @@ -1833,18 +1829,43 @@ BOOTSTRAP-GET-ORDER SET-ORDER "Current: " TYPE GET-CURRENT U. EOL ; : 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 : VOCABULARY ( "name" ) CREATE NULL , 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 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 ; +: CONVERT ( xt -- ) + [[ ' ROOT >CFA @ ]] OVER >CFA ! + [[ ' ROOT >DFA @ ]] SWAP >DFA ! ; + +' 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 \ 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! 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 ) { 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 : 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 2R> 0 ; ->>UTILITY +UTILITY DEFINITIONS \ Same as FIND except that unknown words are reported and result in a call to THROW : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 ) FIND ?DUP 0= IF EXCP-UNDEFINED-WORD -ROT THROW-STRING THEN ; ->>FORTH +FORTH DEFINITIONS \ 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 : ' ( "name" -- xt ) PARSE-NAME FIND-OR-THROW DROP ; -\ "Append to"; set the compilation namespace to the given vocabulary (e.g. FORTH) -: >> ( "name" -- ) ' ALSO EXECUTE DEFINITIONS PREVIOUS ; - \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE 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 ) DUP @ >R >R CATCH 2R> ! RETHROW ; ->> SYSTEM +SYSTEM DEFINITIONS \ The size of this buffer will determine the maximum line length 4096 CONSTANT TERMINAL-BUFFER-BYTES @@ -1963,7 +1988,7 @@ TERMINAL-BUFFER-BYTES ALLOCATE CONSTANT TERMINAL-BUFFER 2VARIABLE TIB-LEFTOVER NULL 0 TIB-LEFTOVER 2! ->> FORTH +FORTH DEFINITIONS \ 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 @@ -2003,7 +2028,7 @@ NULL 0 TIB-LEFTOVER 2! DUP IF 0 >IN ! THEN 0<> ; ->> UTILITY +UTILITY DEFINITIONS \ Parse up to limit digits in the given base, appending them to u1 to produce u2. : ESCAPED-DIGITS ( u1 base limit -- u2 ) @@ -2036,12 +2061,12 @@ NULL 0 TIB-LEFTOVER 2! ENDCASE THEN ; ->> SYSTEM +SYSTEM DEFINITIONS 2VARIABLE STRING-BUFFER NULL 0 STRING-BUFFER 2! ->> UTILITY +UTILITY DEFINITIONS \ 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 @@ -2066,7 +2091,7 @@ NULL 0 STRING-BUFFER 2! ROT 2DUP + ESCAPED-CHAR SWAP C! -ROT 1+ REPEAT ▪ NIP ; ->> SYSTEM +SYSTEM DEFINITIONS : ?STACK SP@ S0 > IF ▪ S0 SP! ▪ EXCP-STACK-UNDERFLOW THROW ▪ THEN ; @@ -2106,14 +2131,14 @@ NULL 0 STRING-BUFFER 2! ?STACK REPEAT ; ->> FORTH +FORTH DEFINITIONS : EVALUATE ( i*x c-addr u -- j*x ) SAVE-INPUT N>R ▪ SOURCE 2>R ▪ SOURCE-ID >R 0 >IN ! ▪ INPUT-BUFFER 2! ▪ -1 CURRENT-SOURCE-ID ! ▪ INTERPRET R> CURRENT-SOURCE-ID ! ▪ 2R> INPUT-BUFFER 2! ▪ NR> RESTORE-INPUT DROP ; ->> LINUX +LINUX DEFINITIONS ' unsigned-char% ALIAS cc% ' unsigned-int% ALIAS speed% @@ -2132,11 +2157,11 @@ ENDSTRUCT termios% 0x5401 CONSTANT IOCTL_TCGETS ->> SYSTEM +SYSTEM DEFINITIONS termios% %VARIABLE SCRATCH-TERMIOS ->> FORTH +FORTH DEFINITIONS : TTY? ( fd -- flag ) IOCTL_TCGETS SCRATCH-TERMIOS SYS_IOCTL SYSCALL3 0= ; @@ -2158,7 +2183,7 @@ STDIN TTY? CONSTANT INTERACTIVE? [THEN] AGAIN ; ->> SYSTEM +SYSTEM DEFINITIONS 32 CONSTANT #REPORTERS #REPORTERS 2ARRAY REPORTERS ( reporter-xt exception-code ) @@ -2176,7 +2201,7 @@ REVERT THEN ▪ 2DROP LOOP ▪ DROP NULL FALSE ; ->> UTILITY +UTILITY DEFINITIONS \ Set the reporter for the given exception code : REPORTER! ( xt n -- ) ( xt: -- ) @@ -2191,7 +2216,7 @@ REVERT DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ; THEN ; ->> SYSTEM +SYSTEM DEFINITIONS { ( no message for ABORT ) } EXCP-ABORT 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 { PARSE-AREA EVALUATE QUIT } EXECUTE -FORTH-WORDLIST 1 SET-ORDER -DEFINITIONS - \ ***************************************************************************** \ Bootstrapping is complete \ From this point on we only execute threaded FORTH words defined in this file \ ***************************************************************************** +ONLY FORTH ALSO UTILITY ALSO SYSTEM +ALSO ->> SYSTEM +SYSTEM DEFINITIONS STRUCT CELL% FIELD LOCAL>LINK CELL% FIELD LOCAL>LENGTH CHAR% 0 * FIELD LOCAL>NAME-ADDR ENDSTRUCT LOCAL% + +\ Parameterize LOCAL% to include the length of the name : LOCAL% ( u -- align bytes ) >R LOCAL% R> + ; : 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 ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON ->> FORTH +FORTH DEFINITIONS \ 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 ; @@ -2317,11 +2343,11 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON LOCAL-NAMES BEGIN ?DUP WHILE DUP LOCAL>LINK @ SWAP FREE REPEAT TO LOCAL-NAMES ▪ POSTPONE UNLOCALS ; ->> UTILITY +UTILITY DEFINITIONS : (TRACE) ( xt -- ) >NAME TYPE SPACE .S ; ->> FORTH +FORTH DEFINITIONS \ Define a threaded word which also displays its name and the data stack when called : :TRACE ( "name" -- ) : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; @@ -2359,7 +2385,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON "∷" TYPE U. THEN ; ->> UTILITY +UTILITY DEFINITIONS \ Display a string in escaped (double-quoted) format, without the delimiters : CONTROL-CHAR? ( ch -- flag ) DUP 32 U< SWAP 127 = OR ; @@ -2390,7 +2416,7 @@ ARGV ARGC 1+ CELLS+ CONSTANT ENVIRON ELSE NIP THEN THEN NIP ; ->> UTILITY +UTILITY DEFINITIONS \ Display the threaded code which starts at a-addr \ 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 ENDCASE ; ->> FORTH +FORTH DEFINITIONS : SEE ( "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 \ 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 : 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 ) AGAIN ; ->> FORTH +FORTH DEFINITIONS \ Return TRUE if the given list is sorted, or FALSE otherwise : 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 ) [[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ; ->> UTILITY +UTILITY DEFINITIONS \ AA Tree, a variation on the Red-Black Tree \ @@ -2541,7 +2567,7 @@ STRUCT CELL% FIELD AA>COMPARE ( aa-compare-xt ) ENDSTRUCT AA-TREE% ->> SYSTEM +SYSTEM DEFINITIONS : AA-INIT-LEAF ( aa-node -- ) NULL OVER AA>LEFT ! ▪ NULL OVER AA>RIGHT ! ▪ 1 SWAP AA>LEVEL ! ; @@ -2653,7 +2679,7 @@ ENDSTRUCT AA-TREE% right-xt FREE-CLOSURE ENDLOCALS ; ->> UTILITY +UTILITY DEFINITIONS : NEW-AA-TREE ( aa-value-xt aa-compare-xt -- aa-tree ) 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 ) >R 0 { NIP >R EXECUTE R> EXECUTE 1+ } [[ ' ▪ ]] R> AA-TRAVERSE ; +LINUX DEFINITIONS + STRUCT unsigned-long-long% FIELD stat64>dev unsigned-char% 4 * FIELD stat64>__pad0 @@ -2713,7 +2741,7 @@ STRUCT unsigned-long-long% FIELD stat64>ino ENDSTRUCT stat64% ->> FORTH +FORTH DEFINITIONS ALSO LINUX O_RDONLY CONSTANT R/O ( -- fam ) @@ -2743,8 +2771,7 @@ PREVIOUS : FILE-STATUS ( c-addr u -- x ) ; -FORTH-WORDLIST 1 SET-ORDER -DEFINITIONS +ONLY FORTH DEFINITIONS : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;