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 ;

\ 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 ( "<spaces>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 <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, which is removed from the
\ current word list upon completion. 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
      GET-CURRENT !
      POSTPONE LITERAL
      POSTPONE ]
   ELSE
      SWAP GET-CURRENT !
   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 )
\ 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: ( "<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 , 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 "<spaces>name" -- )
: TO ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE ! ELSE ! THEN ; IMMEDIATE

\ 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
;

\ 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 -- "<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
   WHILE
      SWAP DUP @ .W BL EMIT
      CELL + SWAP 1-
   REPEAT
   DROP
;

: BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald" TYPE EOL ;

BANNER