\ Read the next word and return the first character ( "name" -- c ) : CHAR WORD DROP C@ ; \ Some common non-word characters : HT 9 ; \ Horizontal Tab : LF 10 ; \ Line Feed (newline) : CR 13 ; \ Carriage Return : BL 32 ; \ BLank (space) \ Emit an implementation-dependent End-of-Line sequence : EOL LF EMIT ; \ Emit a blank (space) character : SPACE BL EMIT ; \ Separate division and modulus operators : / /MOD NIP ; : MOD /MOD DROP ; \ Get and set the current compilation word list : GET-CURRENT CURRENT @ ; : SET-CURRENT CURRENT ! ; \ Get the execution token of the most recent word in the compilation word list : LATEST GET-CURRENT @ ; \ Set the latest defined word as immediate \ Note that IMMEDIATE is itself an immediate word : IMMEDIATE LATEST >FLAGS DUP C@ F_IMMED OR SWAP C! ; IMMEDIATE \ Switch from compiling to interpreting, or vice-versa : [ FALSE STATE ! ; IMMEDIATE : ] TRUE STATE ! ; IMMEDIATE \ COMPILE, appends the effect of the execution token on the top of the stack \ to the current definition. In this implementation it's equivalent to , since \ definitions are just arrays of execution tokens. : COMPILE, , ; \ Append the execution semantics of the current definition to the current definition. : RECURSE LATEST COMPILE, ; IMMEDIATE \ Append the LIT xt and the topmost word on the stack to the current definition. \ If POSTPONE were already defined then this could simply be written as: \ \ : LITERAL POSTPONE LIT , ; IMMEDIATE \ \ ... but since it isn't we must manually insert the LIT sequence to obtain the \ address of LIT as a literal to be compiled into the current definition. : LITERAL [ ' LIT COMPILE, ' LIT , ] COMPILE, , ; IMMEDIATE \ Read a word and append its compilation semantics to the current definition. : POSTPONE ( "name" -- ) IMMEDIATE WORD FIND-OR-ABORT DROP \ Would be: DUP IMMEDIATE? IF COMPILE, EXIT THEN DUP IMMEDIATE? 0BRANCH [ HERE 0 , ] COMPILE, EXIT [ HERE OVER - SWAP ! ] [ ' LITERAL COMPILE, ' COMPILE, ] LITERAL COMPILE, ; \ Like CHAR but generates a literal at compile-time. : [CHAR] CHAR POSTPONE LITERAL ; IMMEDIATE \ Like ' but generates a literal at compile-time. : ['] ' POSTPONE LITERAL ; IMMEDIATE \ Set the F_HIDDEN flag on the named word: HIDE : HIDE ' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ; \ Our first control-flow primitive: IF {ELSE } THEN \ \ IF compiles an unresolved conditional branch. \ AHEAD compiles an unconditional branch (same effect as TRUE IF). \ Both AHEAD and IF leave the address of the unresolved offset on the stack. \ \ THEN consumes the offset address and resolves it to the next code address. \ \ ELSE inserts an unconditional branch (to THEN) and also resolves the \ previous forward reference (from IF). \ : IF POSTPONE 0BRANCH HERE 0 , ; IMMEDIATE : AHEAD POSTPONE BRANCH HERE 0 , ; IMMEDIATE : THEN HERE OVER - SWAP ! ; IMMEDIATE : ELSE POSTPONE AHEAD SWAP POSTPONE THEN ; IMMEDIATE \ Inline :NONAME-style function literals. "{ }" has the runtime effect \ of placing the execution token for an anonymous function with the runtime \ effect of on the top of the data stack. A branch is emitted to skip \ over the memory used for the nested definition, which is removed from the \ current word list upon completion. If RECURSE is used in it will \ create a recursive call to the anonymous inner function. \ \ Example: \ OK> : TIMES 0 DO DUP EXECUTE LOOP DROP ; \ OK> : GREETINGS { "Hello" TYPE EOL } 3 TIMES ; \ OK> GREETINGS \ Hello \ Hello \ Hello \ \ Compilation effect: ( C: -- latest orig state ) \ Interpreter effect: ( C: -- latest state ) \ Enters compilation mode if not already compiling : { LATEST STATE @ DUP IF POSTPONE AHEAD SWAP POSTPONE [ THEN :NONAME ; IMMEDIATE \ ( C: latest {orig} state -- ) \ Leave compilation mode if (prior) state was 0 : } POSTPONE ; SWAP IF -ROT POSTPONE THEN GET-CURRENT ! POSTPONE LITERAL POSTPONE ] ELSE SWAP GET-CURRENT ! THEN ; IMMEDIATE \ Unbounded loop: BEGIN AGAIN \ BEGIN places the offset of the start of on the stack. \ AGAIN creates a relative branch back to the start of . : BEGIN HERE ; IMMEDIATE : AGAIN POSTPONE BRANCH HERE - , ; IMMEDIATE \ Conditional loop: BEGIN WHILE REPEAT : WHILE POSTPONE IF SWAP ; IMMEDIATE : REPEAT POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE \ Alternate conditional loop: BEGIN UNTIL \ UNTIL consumes the top of the stack and branches back to BEGIN if the value was zero. : UNTIL POSTPONE 0BRANCH HERE - , ; IMMEDIATE \ Range loop: DO LOOP \ DO +LOOP : UNLOOP POSTPONE 2RDROP ; IMMEDIATE : DO POSTPONE 2>R POSTPONE BEGIN ; IMMEDIATE : (+LOOP) ( step limit index -- flag limit index' ) ROT + 2DUP <> -ROT ; : +LOOP POSTPONE 2R> POSTPONE (+LOOP) POSTPONE 2>R POSTPONE UNTIL POSTPONE 2RDROP ; IMMEDIATE : LOOP 1 POSTPONE LITERAL POSTPONE +LOOP ; IMMEDIATE \ Return the current index value from the innermost or next-innermost loop. : I RSP@ [ CELL ] LITERAL + @ ; : J RSP@ [ 3 CELL * ] LITERAL + @ ; \ Sequential equality tests: \ CASE \ OF ENDOF \ OF ENDOF \ ... \ ENDCASE \ \ When equals execute , when equals execute , etc. \ During compilation the stack holds a list of forward references to the ENDCASE, \ with the number of references on top. Inside OF ... ENDOF there is additionally \ a forward reference to the ENDOF (as with IF ... THEN) above the ENDCASE counter. : CASE 0 ; IMMEDIATE : OF POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE : ENDOF POSTPONE AHEAD -ROT POSTPONE THEN 1+ ; IMMEDIATE : ENDCASE POSTPONE DROP 0 DO POSTPONE THEN LOOP ; IMMEDIATE \ Define a named constant. \ Execution: ( value "name" -- ) \ name Execution: ( -- value ) \ Alternate definition: \ : CONSTANT : POSTPONE LITERAL POSTPONE ; ; : CONSTANT CREATE LATEST DODATA OVER >CFA ! >DFA ! ; \ Define a single-cell named variable which returns its data address when executed. \ The initial value is formally undefined. This implementation sets it to zero. \ Execution: ( "name" -- ) \ name Execution: ( -- a-addr ) : VARIABLE CREATE 0 , ; \ Define a single-cell named value which returns its data (not address) when executed. \ Named values defined with VALUE can be modified with TO. \ Execution: ( x "name" -- ) \ name execution: ( -- value ) : VALUE CREATE , DOES> @ ; \ When compiling, append code to store to the data field area of the named value. \ When interpreting, store to the data field directly. \ An ambiguous condition exists if the name was not created with VALUE. ( x "name" -- ) : TO ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE \ Display the signed number at the top of the stack : . ( n -- "" ) DUP -2147483648 = IF \ Special case, can't negate due to overflow DROP "-2147483648" TYPE ELSE \ Emit the - sign and use absolute value if input is negative DUP 0 < IF [CHAR] - EMIT NEGATE THEN \ Start with the highest place-value on the left 1000000000 \ Skip place-values that would be larger than the input BEGIN 2DUP < OVER 1 > AND WHILE 10 / REPEAT \ Emit the remaining digits down to the units' place BEGIN TUCK /MOD [CHAR] 0 + EMIT SWAP DUP 1 <= IF 2DROP EXIT THEN 10 / AGAIN THEN ; \ When the search order is changed previously allocated entries that are not \ currently needed will be retained on this linked list for later reuse. VARIABLE ORDER-FREELIST 0 ORDER-FREELIST ! \ Return the current search order : GET-ORDER ( -- widn ... wid1 n ) 0 CURRENT-ORDER @ \ Traverse the linked list, placing identifiers on the return stack and counting BEGIN ?DUP WHILE DUP ORDER>WID @ >R ORDER>LINK @ SWAP 1+ SWAP REPEAT ( S: n ) ( R: wid1 ... widn ) \ Shift the search order list from the return stack back to the data stack DUP BEGIN ?DUP WHILE 1- R> -ROT REPEAT ( S: widn ... wid1 n ) ; \ Set the current search order : SET-ORDER ( widn ... wid1 n | -n -- ) DUP 0 < IF DROP FORTH-WORDLIST 1 THEN \ Move all the previous search order entries to the free list CURRENT-ORDER @ BEGIN ( S: widn ... wid1 n entry ) ?DUP WHILE DUP ORDER>LINK @ SWAP ORDER-FREELIST @ OVER ORDER>LINK ! ORDER-FREELIST ! REPEAT \ Build the new search order linked list CURRENT-ORDER SWAP BEGIN ( S: widn ... wid1 tail n ) ?DUP WHILE -ROT ( S: widn ... wid2 n wid1 tail ) ORDER-FREELIST @ ?DUP IF \ Remove an entry from the free list DUP ORDER>LINK @ ORDER-FREELIST ! ELSE \ Allocate a new entry from the data area ALIGN HERE 2 CELL * ALLOT THEN \ Update the tail pointer with the address of this entry DUP ROT ! \ Store the word list identifier TUCK ORDER>WID ! \ Leave the address of the link field under n-1 for the next iteration ORDER>LINK SWAP 1- REPEAT \ Terminate the linked list 0 SWAP ! ; \ Create a new wordlist \ In this implementation a word list is just a pointer to the most recent word : WORDLIST ( -- wid ) ALIGN HERE 0 , ; \ Abstract away the internals of the search order implementation HIDE CURRENT HIDE CURRENT-ORDER HIDE ORDER-FREELIST HIDE ORDER>WID HIDE ORDER>LINK \ Make the first list in the search order the current compilation word list : DEFINITIONS ( -- ) GET-ORDER SWAP SET-CURRENT 1- NDROP ; \ Run a function for each word in the given wordlist \ xt Execution: ( x*i word-xt -- stop-flag x*j ) : WITH-WORDLIST ( x*i wid xt -- x*j ) >R @ BEGIN ?DUP WHILE >R 2R@ SWAP EXECUTE IF RDROP 0 ELSE R> >LINK @ THEN REPEAT RDROP ; \ Like WITH-WORDLIST but only runs the function for visible (non-hidden) words : WITH-VISIBLE ( x*i wid xt -- x*j ) SWAP { DUP HIDDEN? IF DROP FALSE ELSE SWAP DUP >R EXECUTE R> SWAP THEN } WITH-WORDLIST DROP ; \ Display the names of each visible word in the given word list : SHOW-WORDLIST ( wid -- ) { >NAME TYPE SPACE 0 } WITH-VISIBLE EOL ; \ Return the number of visible words in the given word list : COUNT-WORDLIST ( wid -- n ) 0 SWAP { DROP 1+ 0 } WITH-VISIBLE ; \ Alternative definition of SEARCH-WORDLIST using WITH-VISIBLE (for demonstration) : SEARCH-WORDLIST' ( c-addr u wid -- c-addr u 0 | xt 1 | xt -1 ) 0 SWAP { >R DROP 2DUP R@ >NAME =S IF 2DROP R> DUP IMMEDIATE? 1 OR TRUE ELSE RDROP 0 FALSE THEN } WITH-VISIBLE ; \ Search-Order extension words : ALSO GET-ORDER >R DUP R> 1+ SET-ORDER ; : FORTH GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ; : ONLY -1 SET-ORDER ; : ORDER GET-ORDER "ORDER:" TYPE BEGIN ?DUP WHILE 1- SWAP SPACE . REPEAT EOL "CURRENT: " TYPE GET-CURRENT . EOL ; : PREVIOUS ( -- ) GET-ORDER NIP 1- SET-ORDER ; \ Display the content of the data stack : .DS SP@ S0 CELL - 2DUP > IF 2DROP EXIT THEN DUP @ . BEGIN CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE . AGAIN ; \ Display the content of the return stack : .RS RSP@ CELL + R0 CELL - 2DUP > IF 2DROP EXIT THEN DUP @ . BEGIN CELL - 2DUP > IF 2DROP EXIT THEN DUP @ SPACE . AGAIN ; \ Display the content of the data and return stacks on separate lines : TRACE "DS: " TYPE .DS EOL "RS: " TYPE .RS EOL EOL ; \ Return the number of words on the data stack : DEPTH SP@ S0 SWAP - CELL / ; \ Attempt to locate a word whose execution token matches the given address \ If found return the word name and TRUE; otherwise just return FALSE : LOOKUP ( addr -- c-addr u TRUE | FALSE ) LATEST BEGIN ?DUP IF \ entry address is not zero 2DUP = IF \ entry matches given address NIP >NAME TRUE EXIT THEN \ get next entry address >LINK @ ELSE \ entry address is zero; end of list DROP FALSE EXIT THEN AGAIN ; \ Display the top of the stack as a word name if possible, or a number otherwise : .W ( addr -- "" | "" ) DUP LOOKUP IF TYPE DROP ELSE . THEN ; \ Display the first `u` words in the body of the given execution token with .W : UNTHREAD ( xt u -- ) SWAP >DFA @ SWAP BEGIN ?DUP WHILE SWAP DUP @ .W BL EMIT CELL + SWAP 1- REPEAT DROP ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ; BANNER