: link>flags 2 + ;
: immediate 81 last @ link>flags c! ;
: \ 100 word drop ; immediate

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

\ DEFINE CELL SIZE
: cellsize 4 ;
: cellmask 3 ;
: compsize 2 ;
: compmask 1 ;

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

\ WORD HEADER ACCESSORS
: >does 2 + ;
: >body 4 + ;
: name>xt dup c@ + 4 + 0 4 - and ;
: link>name 3 + ;
: link>xt link>name name>xt ;
: link>does link>xt 2 + ;
: link>body link>xt 4 + ;

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

\ CONDITIONAL EXECUTION AND LOOPING
: if ['] _jz compile, here 2 allot ; immediate
: else ['] _jmp compile, here 2 + swap w! here 2 allot ; immediate
: then here swap w! ; immediate
: begin here ; immediate
: until ['] _jz compile, compile, ; immediate
: again ['] _jmp compile, compile, ; immediate
: while ['] _jz compile, here 2 allot ; immediate
: repeat ['] _jmp compile, here 2 + swap w! compile, ; immediate
: do  ['] _lit compile, here 2 allot ['] drop compile,
      ['] swap compile, ['] >r compile, ['] >r compile, here ; immediate
: ?do ['] 2dup compile, ['] > compile, ['] _jz compile, here 2 allot
      ['] swap compile, ['] >r compile, ['] >r compile, here ; immediate
\ : _loop r> swap r> + r> dup >r swap dup >r > 0 = swap >r ;
: loop    ['] _lit compile, 1 compile, ['] _loop compile, ['] _jz compile, compile, ['] r> compile,
          ['] r> compile, here swap w! ['] 2drop compile,    ; immediate
: +loop    ['] _loop compile, ['] _jz compile,    compile, ['] r> compile,
           ['] r> compile, here swap w! ['] 2drop compile,    ; 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 >FLAGS AND >LINK
: >flags begin 1 - dup c@ 80 and until ;
: >link >flags 2 - ;

\ DEFINE DEFER AND IS
\ Change code pointer from varfunc to deferfunc
: defer create last @ link>xt dup w@ 3 + swap w! ;
: is state @
  if [compile] >body ' >does postpone literal [compile] w!
  else >body ' >does w!
  then ; immediate

\ REDEFINE REFILL AS A DEFERRED WORD
' refill
defer refill
is refill

\ 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 0 1 -
  else
    dup 39 >
    if
      dup 41 <
      if
         drop 0 1 -
      else
        dup 5a >
        if
          dup 61 <
          if
            drop 0 1 -
          else
            dup 7a >
            if
              drop 0 1 -
            else
              57 -
            then
          then
        else
          37 -
        then
      then
    else
      30 -
    then
  then
  dup base @ < 0 =
  if
    drop 0 1 -
  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 ;
: _u/ over over swap 1 rshift swap / dup + dup >r over * rot swap - swap < 1 + r> + ;
: u/ over 0 < if _u/ else / then ;
: ud/ drop 1 roll drop u/ 0 ;
: _umod swap dup 1 rshift 2 pick mod dup + swap 1 and + swap mod ;
: umod over 0 < if _umod else mod then ;
: udmod drop 1 roll drop umod 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 1 31 lshift and if sm/rem else sm/rem then ; ( TODO )
: */mod >r m* r> sm/rem ;
: */ */mod swap drop ;
: <# pad ff + printptr ! ;
: hold cprint ;
: # drop dup base @ umod _d2a cprint base @ u/ 0 ;
: #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> @ ;
: constant create , last @ link>xt dup w@ 3 - swap w! ;
: cr 0a emit 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 0 1 - 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 rot + compsize + 0 compsize - and >r ;
  84 last @ link>flags c! ( Set STRING flag )
: _compile" [char] " word count dup >r dup >r c, here r> cmove r> allot
  compsize here - compmask and allot ; immediate
create s"buf 50 allot
: s" state @ if ['] _lit" compile, postpone _compile" else 
     [char] " word count >r s"buf r@ cmove s"buf r> then ; immediate
: ." postpone s" ['] type compile, ; immediate
: _abort" if type abort else drop drop then ;
\ : abort" postpone s" ['] _abort" compile, ; immediate
: abort" postpone s" ['] _abort" compile, ;
: space 20 emit ;
: spaces 0 ?do space loop ;
: u._ 0 <# #s #> type ;
: u. u._ 20 emit ;
: u< over over xor 1 31 lshift and if swap then < ;
: unloop r> r> r> drop drop >r ;
: 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 0 1 - ;
: tuck swap over ;
: to ' >body state @ if postpone literal [compile] ! else ! then ; immediate
\ : value create here ! cellsize allot does> @ ;
: value create , last @ link>xt dup w@ 3 - swap w! ;
: 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 - ;
: case 0 ; immediate
: of ['] over compile, ['] = compile,
     ['] _jz compile, here 4 allot ['] drop compile, ; immediate
: endof ['] _jmp compile, here 2 + swap w! here 2 allot ; immediate
: endcase ['] drop compile, begin ?dup while here swap w! repeat ; immediate
: c" ['] _lit" compile, postpone _compile" ['] drop compile, ['] 1- compile, ; immediate
: .( [char] ) word count type ; immediate
: :noname align here ['] words @ , [ ;

( 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 ;
: /string dup >r - swap r> + swap ;

( 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 >link dup dp ! w@ last ! else abort" ?" then ;
: .name dup link>name count type space ;
: ?newline dup >r link>name c@ dup rot + 1 + dup 4e > if cr else swap then drop r> ;
: words 0 last @ begin dup while ?newline .name w@ repeat 2drop ;

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

( VERSION STRING )
: pfthversion s" pfth 1.03" ;

create evalmode 0 ,
0 value source-id
create srcstk0 30 allot
srcstk0 value srcstk

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

: compilenumber
  dup ['] _lit compile, compile,
  dup ffff 10 lshift and
  if
    10 rshift
    ['] _lit compile, compile,
    ['] _lit compile, 10 compile,
    ['] lshift compile,
    ['] or compile,
  else
    drop
  then
;

: _interpret
  begin
    20 word dup c@
  while
    find dup
    if
      state @ =
      if
        compile,
      else
        execute
      then
    else
      dup rot count getnumber
      if
        type ." ?" cr
      else
        state @
        if
          compilenumber
        then
      then
    then
  repeat
  drop
;

: .savesrc ." _savesrc " srcstk0 . srcstk . cr ;
: .loadsrc ." _loadsrc " srcstk0 . srcstk . cr ;

: _savesrc ( .savesrc ) tib srcstk ! #tib @ srcstk 4 + ! >in @ srcstk 8 + ! source-id srcstk 0c + ! srcstk 10 + to srcstk ;
: _loadsrc srcstk 10 - to srcstk ( .loadsrc ) srcstk @ to tib srcstk 4 + @ #tib ! srcstk 8 + @ >in ! srcstk 0c + @ to source-id ;
: evaluate _savesrc 0 1 - to source-id #tib ! to tib 0 >in ! _interpret _loadsrc ;

( INTERPRETER )
: interpret
begin
  _interpret
  depth 0 <
  if
    ." Stack Underflow" cr
    resetstack
  else
    source-id 0 1 - =
    if
      _loadsrc
      \ 0 to source-id
    else
      source-id 0=
      if ."  ok" cr then
      refill
    then
  then
again
;

decimal
interpret