jumpforth/startup.4th

\ Read the next word and return the first character
( "<spaces>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 ( "<spaces>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 <name>
: HIDE ' >FLAGS DUP C@ F_HIDDEN OR SWAP C! ;

\ Our first control-flow primitive: <cond> IF <true> {ELSE <false>} 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. "{ <code> }" has the runtime effect
\ of placing the execution token for an anonymous function with the runtime
\ effect of <code> 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 <code> 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 <code> AGAIN
\ BEGIN places the offset of the start of <code> on the stack.
\ AGAIN creates a relative branch back to the start of <code>.
: BEGIN HERE ; IMMEDIATE
: AGAIN POSTPONE BRANCH HERE - , ; IMMEDIATE

\ Conditional loop: BEGIN <cond> WHILE <code> REPEAT
: WHILE POSTPONE IF SWAP ; IMMEDIATE
: REPEAT POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE

\ Alternate conditional loop: BEGIN <code> 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: <limit> <index> DO <code> LOOP
\             <limit> <index> DO <code> <step> +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:
\   <x> CASE
\     <x0> OF <code0> ENDOF
\     <x1> OF <code1> ENDOF
\     ...
\   ENDCASE
\
\ When <x> equals <x0> execute <code0>, when <x> equals <x1> execute <code1>, 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 "<spaces>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: ( "<spaces>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 "<spaces>name" -- )
\   name execution: ( -- value )
: VALUE CREATE , POSTPONE DOES> POSTPONE @ POSTPONE ; ;

\ 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 "<spaces>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 -- "<minussign?><digits>" )
   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 -- "<name>" | "<digits>" )
   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