: immediate 1 last @ 0c + c! ;
: \ 100 word drop ; immediate

\ The above lines implement the immediate and \ words to allow for comments.
\ All numbers are in hex at this point.

\ DEFINE CELL SIZE
: cellsize 4 ;
: cellmask 3 ;

\ BASIC STACK WORDS
: dup 0 pick ;
: rot 2 roll ;
: swap 1 roll ;
: over 1 pick ;
: 2dup over over ;
: 2drop drop drop ;
: 2swap 3 roll 3 roll ;
: 2over 3 pick 3 pick ;

\ DEFINE BASIC WORD BUILDERS
: source tib #tib @ ;
: compile, , ;
: ' 20 word find 0 = 0 = and ;
: _does r> dup >r 4 + last @ 8 + ! ;
: _setjmp 0a last @ 0c + c! ;
: >body 0d + dup c@ + 4 + fffffffc and ;
: literal 0 , , ; immediate 
  last @ >body dup @ swap 4 + ! \ Patch in address of _lit
: postpone ' , ; immediate
: ['] ' postpone literal ; immediate
: [compile] ' postpone literal ['] , , ; immediate
: does> [compile] _does [compile] exit ; immediate

\ CONDITIONAL EXECUTION AND LOOPING
: if r> ['] _jz , here >r 4 allot >r ; immediate
: else r> ['] _jmp , here 4 + r> ! here >r 4 allot >r ; immediate
: then r> here r> ! >r ; immediate
: begin r> here >r >r ; immediate
: until r> ['] _jz , r> , >r ; immediate
: again r> ['] _jmp , r> , >r ; immediate
: while r> ['] _jz , here >r 4 allot >r ; immediate
: repeat r> ['] _jmp ,  here 4 + r> ! r> , >r ; immediate
: do  r> ['] _lit , here >r 4 allot ['] drop ,
         ['] swap , ['] >r , ['] >r , here >r >r ; immediate
: ?do r> ['] 2dup , ['] > , ['] _jz , here >r 4 allot
         ['] swap , ['] >r , ['] >r , here >r >r ; immediate
: _loop r> swap r> + r> dup >r swap dup >r > 0 = swap >r ;
: loop r> ['] _lit , 1 , ['] _loop , ['] _jz , r> , ['] r> ,
          ['] r> , here r> ! ['] 2drop , >r ; immediate
: +loop r> ['] _loop , ['] _jz , r> , ['] r> ,
           ['] r> , here r> ! ['] 2drop , >r ; immediate
: leave r> r> drop r> dup >r >r >r ;
: i r> r> dup >r swap >r ;
: j r> r> r> r> dup >r swap >r swap >r swap >r ;

\ DEFINE "(" COMMENT WORD NOW THAT WE CAN LOOP
: ( begin
      #tib @ >in @
      ?do tib i + c@ 29 = if i 1 + >in ! r> r> drop drop exit then loop
      refill 0 =
    until ; immediate

( PAD AND PRINT SUPPORT )
create pad 100 allot
create printptr 4 allot
: _d2a dup 0a < if 30 else 57 then + ;
: _a2d dup 30 <
  if
    drop ffffffff
  else
    dup 39 >
    if
      dup 41 <
      if
         drop ffffffff
      else
        dup 5a >
        if
          dup 61 <
          if
            drop ffffffff
          else
            dup 7a >
            if
              drop ffffffff
            else
              57 -
            then
          then
        else
          37 -
        then
      then
    else
      30 -
    then
  then
  dup base @ < 0 =
  if
    drop ffffffff
  then
;
: c!-- dup >r c! r> 1 - ;
: cprint printptr @ c! printptr @ 1 - printptr ! ;

( DOUBLE WORDS )
: s>d 0 pick 0 < ;
: m* * s>d ;
: um* * 0 ;
: d+ drop 1 roll drop + s>d ;
: d- drop 1 roll drop - s>d ;
: d* drop 1 roll drop * s>d ;
: d/ drop 1 roll drop / s>d ;
: dmod drop 1 roll drop mod s>d ;
: ud/ drop 1 roll drop / 0 ;
: udmod drop 1 roll drop mod 0 ;

( CORE WORDS )
: +! dup @ rot + swap ! ;
: /mod over over >r >r mod r> r> / ;
: [ state 0 ! ;
: ] state 1 ! ;
: r@ r> r> dup >r swap >r ;
: sm/rem >r 2dup r@ s>d d/ drop r> swap >r s>d dmod drop r> ;
: um/mod >r 2dup r@ s>d ud/ drop r> swap >r s>d udmod drop r> ;
: fm/mod over over xor 80000000 and if sm/rem else sm/rem then ; ( TODO )
: */mod >r m* r> sm/rem ;
: */ */mod swap drop ;
: <# pad ff + printptr ! ;
: hold cprint ;
: # over over base @ 0 udmod drop _d2a cprint base @ 0 d/ ;
: #s begin # over over or 0 = until ;
: #> drop drop printptr @ 1 + dup pad 100 + swap - ;
: sign 0 < if 2d hold then ;
: abs dup 0 < if 0 swap - then ;
: type 0 ?do dup c@ emit 1 + loop drop ;
: ._ dup abs 0 <# #s rot sign #> type ;
: . ._ 20 emit ;
: >number dup 0 ?do >r dup c@ _a2d dup 0 < if drop r> leave else swap >r >r
  base @ 0 d* r> 0 d+ r> 1 + r> 1 - then loop ;
: 0= 0 = ;
: 0< 0 < ;
: 1+ 1 + ;
: 1- 1 - ;
: 2! swap over ! cellsize + ! ;
: 2* dup + ;
: 2/ dup 80000000 and swap 1 rshift or ;
: 2@ dup cellsize + @ swap @ ;
: ?dup dup if dup then ;
: aligned cellmask + 0 cellsize - and ;
: align here aligned here - allot ;
: bl 20 ;
: c, here c! 1 allot ;
: cell+ cellsize + ;
: cells cellsize * ;
: char+ 1 + ;
: chars ;
\ : count dup char+ swap c@ ;
: char 20 word count 0= if drop 0 else c@ then ;
: [char] char postpone literal ; immediate
: constant create here ! cellsize allot does> @ ;
: cr 0d emit ;
: decimal 0a base ! ;
: environment? drop drop 0 ;
: fill swap >r swap r> 0 ?do 2dup c! 1 + loop 2drop ;
: hex 10 base ! ;
: invert ffffffff xor ;
: max 2dup < if swap then drop ;
: min 2dup > if swap then drop ;
: cmove >r swap r> 0 ?do 2dup c@ swap c! 1+ swap 1+ swap loop 2drop ;
: cmove> >r swap r> dup >r 1- dup >r + swap r> + swap r> ?do 2dup c@ swap c!
  1- swap 1- swap loop 2drop ;
: move r> 2dup > if r> cmove else r> cmove> then ;
: negate 0 swap - ;
: recurse last @ , ; immediate
: _lit" r> dup 1 + swap dup c@ dup fffffffc and rot + 4 + >r ;
4 last @ 0c + c! ( Set STRING flag )
: s" ['] _lit" , [char] " word count dup >r dup >r c, here r> cmove r> allot
  align ; immediate
: ." postpone s" ['] type , ; immediate
: _abort" if type abort else drop drop then ;
: abort" postpone s" ['] _abort" , ; immediate
: space 20 emit ;
: spaces 0 ?do space loop ;
: u._ 0 <# #s #> type ;
: u. u._ 20 emit ;
: u< over over xor 80000000 and if swap then < ;
: unloop r> drop r> drop ;
: variable create cellsize allot ;

( CORE EXT )
: 0<> 0= invert ;
: 0> 0 > ;
: 2>r r> rot >r swap >r >r ;
: 2r> r> r> r> rot >r swap ;
: 2r@ r> r> r> 2dup >r >r swap rot >r ;
: <> = 0= ;
: erase 0 ?do dup 0 swap ! 1 + loop drop ;
variable span
: expect accept span ! ;
: false 0 ;
: marker create last @ , does> @ dup dp ! @ last ! ;
: nip swap drop ;
: parse word count ;
: true ffffffff ;
: tuck swap over ;
: to ' >body state @ if postpone literal [compile] ! else ! then ; immediate
: value create here ! cellsize allot does> @ ;
: within over - >r - r> u< ;
: .r_ >r dup abs 0 <# #s rot sign #> dup r> swap - spaces type ;
: .r .r_ 20 emit ;
: u.r_ >r 0 <# #s #> dup r> swap - spaces type ;
: u.r .r_ 20 emit ;
: u> over over xor 80000000 and if swap then > ;
: unused 8000 here - ;

( DOUBLE )
: d= rot = rot rot = and ;
: d0= or 0 = ;
: 2constant create swap , , does> dup @ swap cellsize + @ ;

( STRING )
: blank 0 ?do dup bl swap c! 1+ loop drop ;
: -trailing dup 0 ?do 2dup + 1- c@ bl = if 1- else leave then loop ;

( TOOLS )
: ? @ . ;
: .s 3c emit depth ._ 3e emit 20 emit depth 0 ?do depth i - 1 - pick . loop ;
: dump 0 ?do i 0f and 0 = if cr dup . then dup c@ 3 .r 1 + loop drop cr ;
: forget 20 word find if dup dp ! @ last ! else abort" ?" then ;
: .name dup 0d + count type space ;
: ?newline dup >r 0d + c@ dup rot + 1 + dup 4e > if cr else swap then drop r> ;
: words 0 last @ begin dup while ?newline .name @ repeat 2drop ;

( UTILITY )
: at-xy 2 emit swap emit emit ;
: page 0 emit ;

create evalmode 0 ,
0 value source-id
create srcstk 12 allot

: _savesrc tib srcstk ! #tib @ srcstk 4 + ! >in @ srcstk 8 + ! ;
: _loadsrc srcstk @ to tib srcstk 4 + @ #tib ! srcstk 8 + @ >in ! ;
: evaluate _savesrc ffffffff to source-id #tib ! to tib 0 >in ! ;

: resetstack depth 0 <
  if
    begin depth while 0 repeat
  else
    begin depth while drop repeat
  then
;

: getnumber 2dup >r >r swap dup c@ [char] - =
  if
    swap
    dup 1 <
    if
      2drop 2drop r> r> 1
    else
      swap 1 + swap 1 - 
      >number dup
      if
        2drop 2drop r> r> 1
      else
        2drop drop negate 0 r> r> 2drop
      then
    then
  else
    swap
    >number dup
    if
      2drop 2drop r> r> 1
    else
      2drop drop 0 r> r> 2drop
    then
  then
;

( INTERPRETER )
: interpret
begin
  begin
    20 word dup c@
  while
    find dup
    if
      state @ =
      if
        ,
      else
        execute
      then
    else
      dup rot count getnumber
      if
        type ." ?" cr
      else
        state @
        if
          ['] _lit , ,
        then
      then
    then
  repeat
  drop
  depth 0 <
  if
    ." Stack Underflow" cr
    resetstack
  else
    source-id
    if
      _loadsrc
      0 to source-id
    else
      ."  ok" cr
      refill
    then
  then
again
;

decimal
interpret