\ Everything I've made so far in the bootstrap forth. The 42 EMITs are just so
\ I can see how far everything successfully compiles. That, and the irony of
\ putting a loading screen on forth compilation. Not all of these are "canon"
\ forth words, but most of them are or work similarly. I'm pretty sure /MOD
\ works differently in ANS, but we can just overwrite it later. 

\ Wishlist: EXECUTE (given a code field address you would get with, for example,
\ "' +", execute it), file access primitives, and a boatload of bug fixes (I'd
\ love to split some of these definitions into separate lines...). So far the
\ list of bugs I've noticed that aren't currently resolved: Honor the "hidden"
\ flag when looking up words (that way I can redefine ; and get rid of all of
\ these EMITs!), and parsing edge cases like "blank line entered" being handled
\ properly (to see what's currently happening, enter a couple blank lines and
\ use .S).

\ Feel free to use anything in here that's useful to you, under the conditions
\ of the GPLv3+ and stuff.

\ Useful notes for people who want to try out forth stuff:
\ 1. Case absolutely matters, and pretty much everything is BEING SHOUTED.
\ 2. See above mentioned bugs
\ 3. If you're in an emacs shell buffer, you'll want to run ./bin/vm-production
\    instead of ./bin/vm. Worked better for me, anyway.
\ 4. If you're new to forth, I'd recommend the gforth tutorials.

\ Yes, I know it needs more comments.

\ - Reepca


: CELL   4 ;
42 EMIT
: CELLS  CELL * ;
42 EMIT
: >FLAGS   2 CELLS + ;
42 EMIT
: IMMEDIATE   LATEST >FLAGS DUP @ 0x2 OR SWAP ! ;
42 EMIT
: ALLOT   HERE + DP! ;
42 EMIT
\ Free the memory after using it to search
: '   HERE WORD DROP FIND >CFA SWAP DP! ;
42 EMIT
: [COMPILE]   ' , ; IMMEDIATE
42 EMIT
\ The literal code address of LIT. Don't think too hard about it.
: LITERAL   [ ' LIT DUP , , ] , , ;
42 EMIT
: [']   ' LITERAL ; IMMEDIATE

: IF   [ ' 0BRANCH LITERAL ] , HERE 0 , ; IMMEDIATE
42 EMIT
\ to-patch target --
: TARGET!   OVER - SWAP ! ;
42 EMIT
\ equivalent to "ENDIF".
: THEN   HERE TARGET! ; IMMEDIATE
42 EMIT
: ELSE   HERE 2 CELLS + TARGET! ['] BRANCH , HERE 0 , ; IMMEDIATE
42 EMIT
: BEGIN   HERE ; IMMEDIATE
42 EMIT
: WHILE   [COMPILE] IF ; IMMEDIATE
42 EMIT
: REPEAT   HERE 2 CELLS + TARGET! ['] BRANCH , HERE SWAP TARGET! CELL ALLOT ; IMMEDIATE
42 EMIT
: AGAIN   HERE SWAP TARGET! ; IMMEDIATE
42 EMIT
: .BOOL   IF 116 EMIT ELSE 102 EMIT THEN ;
42 EMIT
: C,   HERE C! 1 ALLOT ;
42 EMIT
: TYPE   OVER + SWAP BEGIN 2DUP > WHILE DUP C@ EMIT 1 + REPEAT 2DROP ;
42 EMIT
: CR   10 EMIT ;
42 EMIT
\ Currently this has to have something else on the same line or the parser
\ will put a 0 on top of its output.
: STR" HERE BEGIN KEY DUP 34 != WHILE C, REPEAT DROP HERE OVER - ;
42 EMIT
: S"   STATE IF ['] BRANCH , HERE 0 , STR" ROT HERE TARGET! SWAP LITERAL LITERAL ELSE STR" THEN ; IMMEDIATE
42 EMIT
: ."   [COMPILE] S" STATE IF ['] TYPE , ELSE TYPE THEN ; IMMEDIATE
42 EMIT
: MOD   % ;
42 EMIT
: /MOD   2DUP MOD >R / R> ;
42 EMIT
: NEXT-DIGIT   10 /MOD ;
42 EMIT
\ Transient storage 'n stuff
: PAD   HERE 100 CELLS + ;
42 EMIT
\ Assuming 2's complement
: NEGATE   NOT 1 + ;
42 EMIT
: CSWAP!   2DUP C@ SWAP C@ ROT C! SWAP C! ;
42 EMIT
\ addr n --
: REVERSE-STRING   OVER + 1 - BEGIN 2DUP < WHILE 2DUP CSWAP! 1 - SWAP 1 + SWAP REPEAT 2DROP ;
42 EMIT
: +C!   OVER C! 1 + ;
42 EMIT
\ num addr -- addr n (addr should have at least 10 free bytes).
: NUM>STRING   DUP >R OVER 0 < IF SWAP NEGATE SWAP 45 +C! THEN DUP >R SWAP BEGIN NEXT-DIGIT ROT SWAP 48 + +C! SWAP DUP WHILE REPEAT DROP R> 2DUP - REVERSE-STRING R> SWAP OVER - ;
42 EMIT
: .   PAD NUM>STRING TYPE ;
42 EMIT
: STACK-BASE   0x00090000 ;
42 EMIT
: .UNDERFLOW   ." Warning: stack is underflowed by " STACK-BASE SWAP - CELL / . ."  cells!" CR ;
42 EMIT
: .HEIGHT   STACK-BASE - CELL / ." <" . ." > " ;
42 EMIT
: .S   DSP@ DUP STACK-BASE < IF .UNDERFLOW ELSE DUP .HEIGHT STACK-BASE BEGIN 2DUP > WHILE DUP @ . 32 EMIT CELL + REPEAT 2DROP THEN ;
42 EMIT
: CLEAR-STACK   STACK-BASE DSP! ;
42 EMIT
CLEAR-STACK