
\ -----------------------------------------------------------------------------
\   Nucleus for Mecrisp-Ternary
\ -----------------------------------------------------------------------------

header execute             : execute >r ;
header nop                 : nop noop ;

header-1-foldable dup      :noname  dup     ;
header-2-foldable over     :noname  over    ;
header-3-foldable third    :noname  third   ;
header-2-foldable 2drop    :noname  2drop   ;
header-2-foldable swap     :noname  swap    ;
header-1-foldable drop     :noname  drop    ;
header-2-foldable nip      :noname  nip     ;

header depth               :noname  depth   ;
header rdepth              :noname  rdepth  ;

header @                   :noname  @       ;
header io@                 :noname  io@     ;
header !                   :noname  !       ;
header io!                 :noname  io!     ;
header +! ( n addr -- )    : +!  dup>r @ + r> ! ;

header-2-foldable +        :noname  +       ;
header-2-foldable +carry   :noname  +carry  ;
header-2-foldable -        :noname  -       ;
header-2-foldable =        :noname  =       ;
header-2-foldable <        :noname  <       ;
header-1-foldable 3sign    :noname  3sign   ;

header-2-foldable lshift   :noname  lshift  ;
header-2-foldable rshift   :noname  rshift  ;

header-1-foldable 3rdn     :noname  3rdn    ;
header-1-foldable 3rup     :noname  3rup    ;
header-1-foldable not      :noname  not     ;
header-1-foldable negate   : negate not     ;

header-2-foldable and      : and 3min       ;
header-2-foldable or       : or  3max       ;
header-2-foldable xor      : xor 3mul not   ;

header-0-foldable true     : true  ( -- true  ) d# 0 3rup ;
header-0-foldable zero     : zero  ( -- zero  ) d# 0      ;
header-0-foldable false    : false ( -- false ) d# 0 3rdn ;

header-2-foldable 3any     :noname  3any    ;
header-2-foldable 3con     :noname  3con    ;
header-2-foldable 3equ     :noname  3equ    ;
header-2-foldable 3min     :noname  3min    ;
header-2-foldable 3max     :noname  3max    ;
header-2-foldable 3mul     :noname  3mul    ;
header-2-foldable 3sum     :noname  3sum    ;

header-0-foldable WIDTH    :noname  WIDTH   ;

header-1-foldable 3*       :noname  3*      ;
header-1-foldable 3/       :noname  3/      ;
header-1-foldable 1+       :noname  1+      ;
header-1-foldable 1-       :noname  1-      ;

header-2-foldable <>       : <>   = not     ;
header-2-foldable >        : >    swap <    ;
header-2-foldable <=       : <=  > not      ;
header-2-foldable >=       : >=  < not      ;
header-1-foldable 0<       : 0<   d# 0 <    ;
header-1-foldable 0=       : 0=   d# 0 =    ;
header-1-foldable 0>       : 0>   d# 0 >    ;
header-1-foldable 0<>      : 0<>  d# 0 <>   ;


header-3-foldable rot      : rot   >r swap r> swap ;
header-3-foldable -rot     : -rot  swap >r swap r> ;

header-2-foldable tuck     : tuck  swap over ;
header-1-foldable ?dup     : ?dup  dup if dup then ;
header-2-foldable 2dup     : 2dup  over over ;
header-4-foldable 2swap    : 2swap rot >r rot r> ;
header-4-foldable 2over    : 2over >r >r 2dup r> r> 2swap ;

header-2-foldable min      : min  2dup< if drop else nip then ;
header-2-foldable max      : max  2dup< if nip else drop then ;
header-1-foldable abs      : abs ( n -- |n| ) dup 3sign 3mul ;

header-2-foldable bounds   : bounds ( a n -- a+n a ) over+ swap ;

\ -----------------------------------------------------------------------------
\  Double numbers
\ -----------------------------------------------------------------------------

header-4-foldable d+
: d+ ( l1 h1 l2 h2 -- l1+l2 h1+h2+carry )

  >r          ( l1 h1 l2 R: h2 )
  swap >r     ( l1 l2 R: h1 h2 )
  2dup +carry ( l1 l2 carry R: h1 h2 )
  >r          ( l1 l2 R: h1 h2 carry )
  +           ( l1+l2 R: h1 h2 carry )
  r> r> r> + +
;

header-2-foldable dnegate
: dnegate ( d -- -d )
  swap not swap not
;

header-4-foldable d-
: d- ( l1 h1 l2 h2 -- l1-l2 h1-h2-borrow )
  dnegate d+
;

header-0-foldable s>d   : s>d  ( n -- d )    d# 0 ;  \ s>d is always foldable because it just puts a zero on the stack in ternary, like a constant.
header-3-foldable m+    : m+   ( d n -- d' ) s>d d+ ;
header-2-foldable d0=   : d0=  ( d -- flag ) 3any 0= ;
header-2-foldable d0<>  : d0<> ( d -- flag ) 3any 0<> ;
header-2-foldable d0<   : d0<  ( d -- flag ) dup 0= if drop 0< else nip 0< then ;
header-2-foldable d0>   : d0>  ( d -- flag ) dup 0= if drop 0> else nip 0> then ;
header-2-foldable dabs  : dabs ( d -- |d|  ) 2dup d0< if dnegate then ;

header-4-foldable d=    : d=  ( d1 d2 -- flag ) d- d0= ;
header-4-foldable d<>   : d<> ( d1 d2 -- flag ) d= not ;
header-4-foldable d<    : d<  ( d1 d2 -- flag ) d- d0< ;
header-4-foldable d>    : d>  ( d1 d2 -- flag ) d- d0> ;

header-2-foldable d3*
: d3* ( d -- 3*d )

  >r                  ( low R: high )
  dup WIDTH 1- rshift ( low lowrshift11 R: high )
  r>                  ( low lowrshift11 high )
  3*                  ( low lowrshift11 highlshift1 )
  3any                ( low high'lshift1 )
  swap 3* swap
;

header-2-foldable d3/
: d3/ ( d -- d/3 )
  >r                 ( low R: high )
  3/                 ( lowrshift1 R: high )
  r@ WIDTH 1- lshift ( lowrshift1 highlshift11 R: high )
  3any               ( low'rshift1 R: high )
  r> 3/              ( low'rshift1 highrshift1 )
;

\ -----------------------------------------------------------------------------
\  Multiplication
\ -----------------------------------------------------------------------------

: mulstep ( d n1 n2 -- d n1 n2 )

  >r         (   d R: n2 )
  >r d3*     ( 3*d R: n2 n1 )
  r>         ( 3*d n1 R: n2 )
  dup
  WIDTH 1- rshift
  3sign  ( 3*d n1 sign1 R: n2 )

    r@ 3mul  ( 3*d n1 sign1MULn2 R: n2 )
    swap >r  ( 3*d n2    R: n2 n1 )
     d# 0    ( 3*d n2 0  R: n2 n1 )
     d+      ( 3*d+n2    R: n2 n1 )
     r>      ( 3*d+n2 n1 R: n2 )

  3*         ( 3*d+n2 3*n1 R: n2 )
  r>         ( 3*d+n2 3*n1 n2 )
;

header-2-foldable m*
: m*  ( n1 n2 -- d )
  >r >r d# 0. r> r>

  WIDTH
  begin
    >r
    mulstep
    r> 1- dup 0=
  until
  drop

  drop drop
;

header-2-foldable *  : * ( n1 n2 -- n ) m* drop ;

\ -----------------------------------------------------------------------------
\  Terminal IO
\ -----------------------------------------------------------------------------

header pause
: pause ( -- ) nop ;

header emit?
: emit? ( -- ? ) pause d# -1 io@ t# +0 3mul t# +0 = ;

header key?
: key?  ( -- ? ) pause d# -1 io@ t# 0+ 3mul t# 0+ = ;

header key
: key  ( -- c ) begin key?  until d# 1 io@ ;

header emit
: emit ( c -- ) begin emit? until d# 1 io! ;

\ -----------------------------------------------------------------------------
\  Strings
\ -----------------------------------------------------------------------------

header space : space ( -- ) d# 32 emit ;
header cr    : cr    ( -- ) d# 10 emit ;

header-0-foldable bl : bl ( -- 32 ) d# 32 ;

header count
: count ( addr -- addr+1 n )
    d# 1 over+ swap @
;

header type
: type ( addr len -- )
    bounds
    begin
        2dup= not
    while
        count emit
    repeat
    2drop
;

header /string ( addr len n -- addr+n len-n )
: /string
    dup>r - swap r> + swap
;

: 1/string ( addr len -- addr+1 len-1 )
    d# 1
    /string
;

\ -----------------------------------------------------------------------------
\  Debug number output
\ -----------------------------------------------------------------------------

: (t.)  ( t -- )
  t# + 3mul

  dup  d# -1 = if [char] - emit then
  dup  d#  0 = if [char] 0 emit then
       d#  1 = if [char] + emit then
;

header t.
: t. ( x -- )

  WIDTH
  begin
    1-
    2dup rshift (t.)
    dup 0=
  until
  2drop

  space
;

\ -----------------------------------------------------------------------------
\  Core variables
\ -----------------------------------------------------------------------------

create base     $a ,
create forth    0 ,
create dp       0 ,         \ Data pointer, grows up
create lastword 0 ,
create thisxt   0 ,
create sourceC  0 , 0 ,
create >in      0 ,
create state    0 ,
create leaves   0 ,
create init     0 ,
create constantfoldingpointer 0 ,
create fineforoptimisation 0 ,
create tib      #128 allot

header-0-foldable base  :noname base ;
header-0-foldable forth :noname forth ;
header-0-foldable dp    :noname dp ;
header-0-foldable >in   :noname >in  ;
header-0-foldable state :noname state ;
header-0-foldable init  :noname init ;
header-0-foldable tib   :noname tib ;

header here             : here  dp @ ;

\ -----------------------------------------------------------------------------
\  Dictionary handling
\ -----------------------------------------------------------------------------

\ Dictionary structure:
\   1 word  link
\   1 word  flags
\   1 word  name length
\   n words name
\ Executable code.

header words
: words ( -- )
    cr
    forth @
    begin
        dup 0<>
    while
        dup d# 2 +  \ Skip link and flags
        count type
        space
        @
    repeat
    drop
;

: lower ( c1 -- c2 ) \ c2 is the lower-case of c1
   dup d# 65 >= over d# 90 <= and
   if d# 32 + then
;

: i<> ( c1 c2 -- f ) \ case-insensitive difference
  lower swap lower <>
;

: sameword ( c-addr u wp -- c-addr u wp flag )
    2dup d# 2 + @ = if              \ lengths match?
        third third third           \ 3dup
        d# 3 + >r                   \ R: word in dictionary
        bounds
        begin
            2dup= not
        while
            dup @ r@ @ i<> if
                2droprdrop false ;
            then
            1+
            r> 1+ >r
        repeat
        drop droprdrop true
    else
        false
    then
;

: >xt ( addr -- xt )
    d# 2 +  \ Skip link and flags
    count +  \ Skip name string
;

header sfind ( addr len -- addr len false | xt flags true )
: sfind
    forth @
    begin
        dup 0<>
    while
        sameword
        if
            nip nip
            dup >xt
            swap        ( xt wp )
            1+ @        ( xt flags )
            true
            ;
        then
        @
    repeat
    drop false
;

\ -----------------------------------------------------------------------------
\  Memory
\ -----------------------------------------------------------------------------

header fill
: fill ( addr n x -- ) ( 6.1.1540 )
  >r bounds
  begin
    2dup= not
  while
    r@ over ! 1+
  repeat
  droprdrop drop
;

header cmove
: cmove ( addr1 addr2 n -- )
    bounds rot >r
    begin
        2dup= not
    while
        r@ @ over !
        r> 1+ >r
        1+
    repeat
    droprdrop drop
;

header cmove>
: cmove> \ ( addr1 addr2 n -- )
    begin
        dup 0<>
    while
        1- >r
        over r@ + @
        over r@ + !
        r>
    repeat
    drop 2drop
;

header 2@
: 2@ \ ( addr -- low high )
  dup 1+ @ swap @
;

header 2!
: 2! \ ( low high addr -- )
  tuck! 1+ !
;

\ -----------------------------------------------------------------------------
\  Input buffer and parsing
\ -----------------------------------------------------------------------------

header source ( -- addr n )
: source
    sourceC 2@
;

: source! ( addr n -- ) \ Set the source
    sourceC 2!
;

\ From Forth200x - public domain

: isspace? ( c -- f )
    d# 33 < ;

: isnotspace? ( c -- f )
    isspace? not ;

: xt-skip   ( addr1 n1 xt -- addr2 n2 ) \ gforth
    \ skip all characters satisfying xt ( c -- f )
    >r ( addr n R: xt )
    BEGIN
        over @ r@ execute ( addr n flag R: xt )
        over 0> and \ Still characters left
    WHILE
        1/string
    REPEAT
    r> drop ;

header parse-name
: parse-name ( "name" -- c-addr u )
    source >in @ /string
    ['] isspace? xt-skip over >r
    ['] isnotspace?
;fallthru
: _parse
    xt-skip ( end-word restlen R: start-word )
    2dup d# 1 min + source drop - >in !
    dropr>
    tuck -
;

create scratch 0 ,

: isnotdelim
    scratch @ <>
;

header parse
: parse ( "ccc<char" -- c-addr u )
    scratch !
    source >in @ /string
    over >r
    ['] isnotdelim
    _parse
;

\ -----------------------------------------------------------------------------
\  Compiler
\ -----------------------------------------------------------------------------

header allot
: tallot ( n -- )
    dp +!
;

header ,
: w, ( x -- )
    here !
    d# 1 tallot
;

: prev ( -- addr ) dp @ d# 1 - ;
: isliteral ( addr -- f ) @ t# 00000000000+ 3mul t# 000000000000 = ; \ Literal opcodes detection

header compile,
: compile, ( xt -- )

  \ Inline positive literals
  dup isliteral \ Points to a literal opcode ?
  if
    dup 1+ @ t# 000000000-++ = \ Which is directly followed with an exit ?
    if
      @ jmp w, \ Inline it !
    then
  then

  dup @ t# 000000000+++ 3mul t# 000000000-++ = \ ALU Opcode with ret bits set ?
  if  @ t# 000000000--0 3rup 3mul  \ Inline it with ret bits removed.
  else
    d# 2 lshift t# 0000000000+- 3any \ Compile classically as a simple call opcode
  then
  w,
;

\ -----------------------------------------------------------------------------
\  String literals
\ -----------------------------------------------------------------------------

header s,
: s, ( addr len -- )
    dup w,
    bounds
    begin
        2dup= not
    while
        dup @ w,
        1+
    repeat
    2drop
;

header (sliteral)
: (sliteral)
    r> \ TODO: Remove interrupt signaling here, iff I add interrupts later.
    count
    2dup+
    >r
;

header-imm sliteral
:noname ( "string" -- ) ( addr len -- )
    ['] (sliteral) compile,
    s,
;

\ -----------------------------------------------------------------------------
\  Flags and headers
\ -----------------------------------------------------------------------------

: mkheader ( -- )
    here lastword !
    forth @ w,  \ Link
    d# 0 w,     \ Flags
    parse-name
    s,          \ Name
    dp @ thisxt !
;

header foldable
: foldable ( u -- )
  1+ d# 1 lshift
: setflags ( x -- )
  lastword @ 1+ \ Skip link field
  dup>r @        \ Fetch flags
  3any
  r> !
;

header immediate
:noname ( -- )
  t# + setflags
;

\ Format of flag field:
\   Foldability Immediate

header-1-foldable flags>immediate    : flags>immediate   ( x -- flag ) t# + 3mul t# + = ;
header-1-foldable flags>foldability  : flags>foldability ( x -- n    ) d# 1 rshift      ;

\ -----------------------------------------------------------------------------
\  Compiler essentials
\ -----------------------------------------------------------------------------

header inline:
: inline: \ TODO: Remove interrupt signaling here, iff I add interrupts later.
  r@ @ w,  \ Fetch and append opcode from the location pointed to by the return address
  r> 1+ >r  \ Change return to skip it
;

header-imm [
: t[ ( -- )
    false state !
;

header ]
: t] ( -- )
    false fineforoptimisation !  \  : --> No opcodes written yet - never recognize headers as opcodes!
    true  state !                 \ ] --> Something strange might just went on. Careful!
;

header :
:noname ( "name" -- )
    mkheader t]
;

header :noname
:noname ( "name" -- )
    dp @
    dup thisxt !
    d# 0 lastword !
    t]
;

header-imm exit
: texit ( -- )
    fineforoptimisation @
    if
      \ Tail-Call optimisation
      prev @
      t# 0000000000++ 3mul t# 0000000000+- =
      if
        prev @ t# 0000000000-0 3rup 3mul prev ! exit \ Switch from Call (+-) to Jmp (0-) opcode.
      then

      \ ALU + exit --> ALU with ret bits set
      prev @ t# 000000000+++ 3mul t# 00000000000+ = \ ALU opcode with neither ret nor return stack in opcode?
      if
        prev @ t# 000000000-+0 3any prev ! exit
      then
    then

    inline: exit
;

header-imm ;
:noname ( -- )
    lastword @ 0<> if lastword @ forth ! then
    texit
    t[
;

\ -----------------------------------------------------------------------------
\  Control structures
\ -----------------------------------------------------------------------------

\ Forward branches are represented by the two lowest trits for the branch type,
\ with all the other trits for the address.

header-imm ahead    ( -- addr )
: tahead
    here t# 0- w,
;

header-imm if       ( -- addr )
: tif
    here t# -- w,
;

header-imm then     ( addr -- )
: tthen
    here d# 2 lshift
    swap +!
;

header-imm begin
: tbegin
    dp @
;

header-imm again
: tagain
    d# 2 lshift t# 0- 3any w,
;

header-imm until
: tuntil
    d# 2 lshift t# -- 3any w,
;

header does>
:noname
    r> d# 2 lshift t# 0- 3any
    lastword @
    >xt 1+  \ ready to patch the RETURN
    !
;

header-imm recurse
:noname
    thisxt @ compile,
;

\ -----------------------------------------------------------------------------
\  Counted loops
\ -----------------------------------------------------------------------------

\
\ How DO...LOOP is implemented
\
\ It uses two elements on the return stack:
\    index-limit is the counter; it starts negative and counts up. When it reaches 0, loop exits
\    limit is the offset. I can be computed from (index-limit+limit)
\
\ So DO receives ( limit start ) on the stack.
\
\ E.g. for "13 3 DO"
\      index-limit = -10
\      limit       = 13
\
\ So the loop runs:
\      index-limit      -10 -9 -8 -7 -6 -5 -4 -3 -2 -1
\      I                  3  4  5  6  7  8  9 10 11 12
\

: (do)  ( limit start -- )
    over -   ( limit start-limit )
    swap     ( start-limit limit )
    r>       ( start-limit limit ret )
    swap >r  ( start-limit ret )
    swap >r  ( ret )
    >r
;

: (?do)  ( -- ?  R: start-limit -- start-limit )
    r> r@ 0= swap >r
;

: (loopnext)  ( -- ?  R: limit index-limit -- limit index+1-limit )
    r>         ( addr )
    r>         ( addr index-lim )
    1+         ( addr index+1-lim )
    dup>r      ( addr index+1-lim )
    swap >r    ( index+1-lim )
    d# 0 =
;

: (+loopnext) ( inc -- ?  R: limit index-limit -- limit index+inc-limit )
               ( inc )
    r> swap    ( addr inc )
    r>         ( addr inc index-limit )
    2dup+      ( addr inc index-limit index+inc-limit )
    >r         ( addr inc index-limit )
    false +    ( addr inc index-limit+minint )
    +carry 0<> ( addr flag )
    swap >r    ( flag )
;

: (loopdone)  ( -- )
    r> rdrop rdrop >r
;

: do-common     \ common prefix for DO and ?DO
    leaves @ d# 0 leaves !
    ['] (do) compile,
;

header-imm do
:noname
    do-common
: dotail
    tbegin
;

header-imm leave
: leave
: leave,
    dp @
    leaves @ w,
    leaves !
;

header-imm ?do
:noname
    do-common
    ['] (?do) compile,
    tif leave, tthen
    dotail
;

\ Finish compiling DO..LOOP
\ resolve each LEAVE by walking the chain starting at 'leaves'
\ compile a call to (loopdone)

: resolveleaves
    leaves @
    begin
        dup 0<>
    while
        dup @ swap  ( next leaveptr )
        here
        d# 2 lshift t# 0- 3any \ Create a jump instruction
        swap !
    repeat
    drop
    leaves !
    ['] (loopdone) compile,
;

header-imm loop
:noname
    ['] (loopnext) compile,
    tuntil
    resolveleaves
;

header-imm +loop
:noname
    ['] (+loopnext) compile,
    tuntil
    resolveleaves
;

header i  ( -- index  R: limit index-limit -- limit index-limit )
: i
  r>           ( addr )
  r>           ( addr index-lim )
  r@           ( addr index-lim lim )
  over+        ( addr index-lim index )
  swap >r
  swap >r
;

header j  ( -- indexb  R: limitb indexb-limitb limita indexa-limita -- limitb indexb-limitb limita indexa-limita )
: j

  r>           ( addr )
  r>           ( addr index-lima )
  r>           ( addr index-lima lima )

  r>           ( addr index-lima lima index-limb )
  r@           ( addr index-lima lima index-limb limb )
  over+        ( addr index-lima lima index-limb indexb )

  swap >r
  swap >r
  swap >r
  swap >r
;

header-imm unloop
:noname
    ['] (loopdone) compile,
;

\ -----------------------------------------------------------------------------
\  Number IO base
\ -----------------------------------------------------------------------------

header decimal : decimal ( -- ) d# 10 : setbase base ! ;
header binary  : binary  ( -- ) d# 2    setbase ;
header hex     : hex     ( -- ) d# 16   setbase ;
header ternary : ternary ( -- ) d# -3   setbase ;

\ -----------------------------------------------------------------------------
\  Return stack jugglers
\ -----------------------------------------------------------------------------

header-imm >r    :noname inline: >r ;
header-imm r>    :noname inline: r> ;
header-imm r@    :noname inline: r@ ;
header-imm rdrop :noname inline: rdrop ;

\ -----------------------------------------------------------------------------
\  Compilation tools
\ -----------------------------------------------------------------------------

header abort
: abort
    [char] ? emit
    [ tdp @ dup insertquit ! tcell + org ]
;

header-imm literal
: tliteral

  dup WIDTH 1- rshift ( literal R: MST )

  dup t# + = if drop 3rdn d# 1 lshift w, inline: 3rup else
      t# - = if      3rup d# 1 lshift w, inline: 3rdn else
                          d# 1 lshift w, then then
;

header-imm postpone
:noname
    parse-name sfind
    jzn abort
    flags>immediate not
    if
        tliteral
        ['] compile,
    then
    compile,
;

header '
:noname
    parse-name
    sfind
    jzn abort
    drop \ Flags
;

header char
:noname
    parse-name drop @
;

header-imm-0-foldable \
:noname
    sourceC @ >in !
;

\ -----------------------------------------------------------------------------
\  Number input
\ -----------------------------------------------------------------------------

header digit
: digit? ( c -- u f )

  base @ d# -3 =
  if
    dup [char] + = if drop d#  1 true exit then
    dup [char] 0 = if drop d#  0 true exit then
    dup [char] - = if drop d# -1 true exit then
  else

    lower

    \ [char] 0 to [char] 9 -->  0 to  9
    \ [char] a to [char] z --> 10 to 35

    dup d# 48 >= over d# 57 <= and
    if
      d# 48 - dup base @ < exit
    then

    dup d# 97 >= over d# 122 <= and
    if
      d# 87 - dup base @ < exit
    then

  then
  false
;

create resultsign 0 ,
create doubleresult 0 ,

header number
: number ( addr len -- 0 )
         (             n 1 )
         (             d-low d-high 2 )


  d# 3 over= if
    over dup d# 2 + @ [char] ' =
         swap       @ [char] ' = and
         if
           drop 1+ @ d# 1 exit
         then
  then


  false doubleresult !
  false resultsign !
  base @ >r

  d# 0 d# 0 2swap

  ( d-low d-high addr len )

  begin
    dup
  while

    \ Character from the beginning of the string
              ( addr len )
    1- >r     ( addr R: len-1 )
    dup 1+ >r ( addr R: len-1 addr+1 )
    @

    ( d-low d-high c )

    [char] $ over= if drop hex             else
    [char] # over= if drop decimal         else
    [char] % over= if drop binary          else
    [char] & over= if drop ternary         else

    [char] - over= base @ d# -3 <> and
                   if drop true resultsign !   else
    [char] . over= if drop true doubleresult ! else

     digit? if ( d-low d-high u )
              >r base @ abs
              tuck * >r m* r> +
              r> m+
            else \ Unknown digit
              2drop drop rdrop rdrop
              r> base !
              false exit
            then

    then then then then then then

    r> r>
  repeat
  2drop

  resultsign @ if dnegate then
  doubleresult @ if d# 2 else drop d# 1 then

  r> base !
;

\ -----------------------------------------------------------------------------
\  Interpreter
\ -----------------------------------------------------------------------------

: flushconstants ( n*x count -- {n-1}*x count-1 ) \ Recursive to write them out in reverse order
  dup 0<> if \ Do nothing if count is zero
    dup d# 1 > if 1- swap >r flushconstants r> swap then
    swap tliteral
    true fineforoptimisation !
  then
;

: interpret
    begin
        parse-name
        dup 0<>
    while
      constantfoldingpointer @ true =  \ If it is not set, initialise constant folding pointer
      if depth d# 2 - constantfoldingpointer ! then \ Do not include the values of parse-name

      sfind \ Try to find the definition in dictionary
      if ( xt flags ) \ Found.

        state @
        if    \ Compile mode

          >r >r \ Move xt and flags out of the way

          \ Calculate how many constants are available
          depth                       \ Calculate how many
          constantfoldingpointer @ -   \ constants are available now
          ( #constants R: xt flags )    \ Number of constants available now on stack

          dup r> r@ swap >r flags>foldability 1- < not \ Check if there are enough constants left
              r> r@ swap >r flags>foldability 0<>       \ Check if the current definition is foldable
          and
          if \ Fold it !
            drop
            r> rdrop execute
          else \ Not foldable or not enough constants available

            \ Write the constants into memory
            flushconstants drop

            \ No folding allowed over classic compilation
            true constantfoldingpointer !

            r> r> ( xt flags )

            \ Do classic compilation
            flags>immediate if execute false fineforoptimisation ! else compile, true fineforoptimisation ! then
          then

        else  \ Execute mode
          drop
          true constantfoldingpointer !
          execute
        then

      else ( addr len ) \ Not found ? Perhaps it is a number.
        number jzn abort \ Leave the literal(s) on the stack
      then

    repeat
    2drop
;

\ -----------------------------------------------------------------------------
\  Terminal input
\ -----------------------------------------------------------------------------

: delchar ( addr len -- addr' len' )
    dup if d# 8 emit d# 32 emit d# 8 emit then

    \ For plain 8 bit encodings instead of UTF-8 Unicode:
    \ dup 0= if exit then
    \ 1-

    begin
        dup 0= if exit then
        1- 2dup+ @
        dup d# 128 < swap d# 192 >= or
    until
;

header accept
: accept ( addr maxlen -- len )

    >r d# 0  ( addr len R: maxlen )

    begin
        key    ( addr len key R: maxlen )

        d# 9 over= if drop d# 32 then
        d# 127 over= if drop d# 8 then

        dup d# 31 >
        if
            over r@ <
            if
                dup emit
                >r 2dup+ r@ swap ! 1+ r>
            then
        then

        d# 8 over= if >r delchar r> then

        d# 10 over= swap d# 13 = or
    until

    niprdrop
    space
;

header refill
: refill ( -- true )
    tib dup d# 128 accept
    source!
    d# 0 >in !
    true
;

header evaluate
:noname ( addr len -- )
    source >r >r >in @ >r
    source! d# 0 >in !
    interpret
    r> >in !r> r> source!
;

\ -----------------------------------------------------------------------------
\  Main loop of Forth
\ -----------------------------------------------------------------------------

header quit
: quit
    begin rdepth 0<> while rdrop repeat \ Clear the return stack
    begin  depth 0<> while  drop repeat \ Clear the stack
    decimal
    false state !
    true constantfoldingpointer !

    cr
    begin
        refill drop
        interpret
        (sliteral) string"  ok." type cr
    again
;

\ -----------------------------------------------------------------------------
\  Welcome message
\ -----------------------------------------------------------------------------

header welcome
: welcome ( -- )
  cr
  (sliteral)
  string" Mecrisp-Ternary 00+"
  type
  cr
;

\ -----------------------------------------------------------------------------
\  Boot here
\ -----------------------------------------------------------------------------

: main ( -- )
  \ dint     \ Disable interrupts -- not implemented yet :-)
    welcome   \ Emit welcome message
    quit       \ Enter Forth
;

meta
  link @ 4 / 2>3 t' forth tw!
  there  4 / 2>3 t' dp    tw!
target
