\ 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 ; \ 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 FINDERR \ Would be: DUP IMMEDIATE? IF COMPILE, EXIT THEN DUP IMMEDIATE? 0BRANCH [ 3 CELL * , ] COMPILE, EXIT [ ' 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. The original value of LATEST \ is restored at the end of the definition. 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 LATEST ! POSTPONE LITERAL POSTPONE ] ELSE SWAP LATEST ! 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 ) : CONSTANT : POSTPONE LITERAL POSTPONE ; ; \ 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 \ Separate division and modulus operators : / /MOD NIP ; : MOD /MOD DROP ; \ 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 ; \ 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 IF SWAP DUP @ .W BL EMIT CELL + SWAP 1- ELSE DROP EXIT THEN AGAIN ; : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ; BANNER