
\ Definitions in high-level Forth that can be compiled by the small
\ nucleus itself. They are included for default.

\ ------------------------------------------------------------------------------
\  Definitions for "CORE" standard words
\ ------------------------------------------------------------------------------

: [']
    '
; immediate 0 foldable

: [char]
    char
; immediate 0 foldable

: (
    [char] ) parse 2drop
; immediate 0 foldable

: else
    postpone ahead
    swap
    postpone then
; immediate

: while
    postpone if
    swap
; immediate

: repeat
     postpone again
     postpone then
; immediate

: create ( "<name>" -- ; -- addr )
    :
    here 2 + postpone literal
    postpone ;
;

: buffer: ( u "<name>" -- ; -- addr )
   create allot 0 foldable
;

: >body ( addr -- addr' )
    @ 1 rshift \ Remove the literal opcode trit
;

: variable ( x "name" -- ; -- addr )
    create ,
    0 foldable
;

: constant ( x "name" -- ; -- x )
    :
    postpone literal postpone ;
    0 foldable
;

: spaces ( n -- )
    begin
        dup 0>
    while
        space 1-
    repeat
    drop
;

: ."
    [char] " parse
    state @ if
        postpone sliteral
        postpone type
    else
        type
    then
; immediate 0 foldable

( Memory operations                          JCB 18:02 05/31/15)

: move ( addr1 addr2 u -- )
    >r 2dup < if
        r> cmove>
    else
        r> cmove
    then
;

\ ------------------------------------------------------------------------------
\  Double division
\ ------------------------------------------------------------------------------

: 2variable ( d -- ) create , , 0 foldable ;
: 2constant ( d -- ) swap : postpone literal postpone literal postpone ; 0 foldable ;

0. 2variable dividend
0. 2variable remainder
0. 2variable divisor
0. 2variable quotient

0. 2variable lowhigh
0   variable one

: divstep ( -- )
  \ Shift the long chain of four cells.

     dividend  1+ @ dup WIDTH 1- rshift >r 3*      dividend  1+ !
  r> dividend     @ dup WIDTH 1- rshift >r 3* 3any dividend     !
  r> remainder 1+ @ dup WIDTH 1- rshift >r 3* 3any remainder 1+ !
  r> remainder    @                        3* 3any remainder    !

\ remainder @ t. remainder 1+ @ t. dividend @ t. dividend 1+ @ t. cr

  quotient 2@ d3* quotient 2!  \ Shift result.

  remainder 2@ d0>
  if  \ rem > 0

    remainder 2@ divisor 2@ d- lowhigh 2!

    lowhigh 2@ dnegate remainder 2@ d=   dividend 2@ d0>   and
    lowhigh 2@ dnegate remainder 2@ d<                     or

    if
      lowhigh 2@ remainder 2!
      quotient 2@ one @ 0 d+ quotient 2!
    then

  else
  remainder 2@ d0<
  if  \ rem < 0

    remainder 2@ divisor 2@ d+ lowhigh 2!

    lowhigh 2@ dnegate remainder 2@ d=   dividend 2@ d0<   and
    lowhigh 2@ dnegate remainder 2@ d>                     or

    if
      lowhigh 2@ remainder 2!
      quotient 2@ one @ 0 d- quotient 2!
    then

  then
  then
;

\ ------------------------------------------------------------------------------
\  A short break if executable space is really small...
\ ------------------------------------------------------------------------------

\ In 10 trit variant, we are somewhat short on executable memory space.
\ Start over with a negative dictionary pointer then...

dp @ t.

dp @
&--------
WIDTH 10 =

  ( a b flag )
  tuck ( a flag b flag )
  3rup not 3mul ( a flag 0|b )
  -rot  ( 0|b a flag )
  not 3rup not 3mul ( 0|b a|0 )
  3any ( a|b )

dp !

\ This does not compile anything, and will not change dictionary pointer if WIDTH is not 10.

dp @ t.

\ ------------------------------------------------------------------------------

: d/mod ( d1 d2 -- d-rem d-div )

  2dup d0<
  if
    dnegate   \ Take absolute value of divisor
    -1 one !  \ Determines whether to negate bits of quotient
  else
     1 one !
  then

     divisor   2!
  2dup d0< >r      \ Save sign of dividend
     dividend  2!
  0. remainder 2!
  0. quotient  2!

  ( -- R: dividend<0 )

  WIDTH 2 *
  begin
    divstep
    1- dup 0=
  until
  drop

  r@ remainder 2@ d0< <>  \ Do signs of original dividend and remainder differ?
     remainder 2@ d0<> and
  if

    \ Divisor is always positive here. Check which "direction" to adjust:
    remainder 2@ d0<
    if
      remainder 2@ divisor 2@ d+
      quotient  2@ 1. d-
    else
      remainder 2@ divisor 2@ d-
      quotient  2@ 1. d+
    then

  else
    remainder 2@
    quotient  2@
  then
  rdrop

; 4 foldable

\ ------------------------------------------------------------------------------
\  Some more division, much shorter ones :-)
\ ------------------------------------------------------------------------------

: */mod ( n1 n2 n3 -- n4 n5 ) >r m* r> 0 d/mod drop nip ; 3 foldable
: */    ( n1 n2 n3 -- n4 ) */mod nip ; 3 foldable
: / ( n1 n2 ) 0 swap 0 d/mod drop nip nip ; 2 foldable

\ ------------------------------------------------------------------------------
\  Print numbers beautifully
\ ------------------------------------------------------------------------------

( Pictured numeric output                    JCB 08:06 07/18/14)
\ Adapted from hForth

\ "The size of the pictured numeric output string buffer shall
\ be at least (2*n) + 2 characters, where n is the number of
\ bits in a cell."

create BUF0
WIDTH 2 + 128 max
allot here constant BUF

0 variable hld

: <# ( -- )
    BUF hld !
;

: hold ( c -- )
    hld @ 1- dup hld ! !
;

: sign ( n -- )
    0< if
        [char] - hold
    then
;

: .digit ( n -- c )
  base @ -3 =
  if
    1 3mul
    dup -1 = if drop [char] - then
    dup  0 = if drop [char] 0 then
    dup  1 = if drop [char] + then
  else
    9 over < if 7 + then 48 +
  then
;

: # ( ud -- ud* )
  base @ -3 =
  if
    over >r d3/ r>
    .digit hold
  else
    base @ 0 d/mod >r >r
    drop .digit hold
    r> r>
  then
;

: #s ( d -- 0 0 )
    begin
        #
        2dup d0=
    until
;

: #> ( d -- addr len )
    2drop hld @ BUF over -
;

: (d.) ( d -- addr len )
  base @ -3 =
  if
                        <# #s         #>
  else
    2dup d0< not >r dabs <# #s r> sign #>
  then
;

: d. ( d -- )
    (d.) type space
;

: . ( n -- )
    s>d d.
;

: rtype ( addr len n -- ) \ Display character string specified by addr len
                           \ in a field n characters wide.
  2dup < if over - spaces else drop then
  type
;

: d.r ( d length -- )
    >r (d.)
    r> rtype
;

: .r ( n length -- )
    >r s>d r> d.r
;

: ltype ( addr len n -- ) \ Display character string specified by addr len
                           \ in a field n characters wide.
  2dup < if over - -rot type spaces else drop type then
;

: d.l ( d length -- )
    >r (d.)
    r> ltype
;

: .l ( n length -- )
    >r s>d r> d.l
;

\ ------------------------------------------------------------------------------
\  Definitions for "CORE EXT" standard words
\ ------------------------------------------------------------------------------

: pad ( -- addr )
    here
;

: within ( n1 n2 n3 -- flag )
  >r   ( n1 n2        R: n3 )
  over ( n1 n2 n1     R: n3 )
  <=   ( n1 n1>=n2    R: n3 )
  swap ( n1>=n2 n1    R: n3 )
  r>   ( n1>=n2 n1 n3       )
  <=   ( n1>=n2 n1<=n3      )
  and
;

: s"
    [char] " parse
    state @ if
        postpone sliteral
    then
; immediate

( CASE                                       JCB 09:15 07/18/14)
\ From ANS specification A.3.2.3.2

: case ( -- 0 ) 0 ; immediate  ( init count of ofs )

: of  ( #of -- orig #of+1 / x -- )
    1+    ( count ofs )
    >r    ( move off the stack in case the control-flow )
          ( stack is the data stack. )
    postpone over  postpone = ( copy and test case value)
    postpone if    ( add orig to control flow stack )
    postpone drop  ( discards case value if = )
    r>             ( we can bring count back now )
; immediate

: endof ( orig1 #of -- orig2 #of )
    >r   ( move off the stack in case the control-flow )
         ( stack is the data stack. )
    postpone else
    r>   ( we can bring count back now )
; immediate

: endcase  ( orig1..orign #of -- )
    postpone drop  ( discard case value )
    0 ?do
      postpone then
    loop
; immediate

\ ------------------------------------------------------------------------------
\  Insight into stacks and dictionary structure
\ ------------------------------------------------------------------------------

: .s ( -- )
  \ Save initial depth
  depth dup >r

  \ Flush stack contents to temporary storage
  begin
    dup
  while
    1-
    swap
    over pad + !
  repeat
  drop

  \ Print original depth
  ." [ "
  r@ .
  ." ] "

  \ Print all elements in reverse order
  r@
  begin
    dup
  while
    r@ over - pad + @ .
    1-
  repeat
  drop

  \ Restore original stack
  0
  begin
    dup r@ <
  while
    dup pad + @ swap
    1+
  repeat
  rdrop
  drop
  \ ." *> "
;

: insight ( -- )
    base @ decimal cr
    forth @
    begin
        dup 0<>
    while
          ." Addr: "     dup             5 .r
        ."   Link: "     dup @           5 .r
        ."   Flags: "    dup 1+ @ dup flags>immediate        if ." I " else ." - " then
                                      flags>foldability ?dup if 1- .   else ." - " then
         ."  Code: "     dup 2 + count + 5 .r
        ."   "           dup 2 + count type
        @ cr
    repeat
    drop
    base !
;

\ ------------------------------------------------------------------------------
\  Disassembler
\ ------------------------------------------------------------------------------

0 variable disasm-$
0 variable disasm-cont

: name. ( addr -- )

  >r
  forth @
  begin
      dup 0<>
  while
      dup 2 + count +
      r@ =
       if ."   --> " dup 2 + count type then
      @
  repeat
  drop r>

  dup ['] (sliteral) = \ Is this a string literal?
  if
    ."   s" [char] " emit space
    disasm-$ @ count type
    [char] " emit

    disasm-$ @ @ 1+ disasm-$ +!
  then
  drop
;


: alu. ( Opcode -- )

  dup &00--0000-+0+ = if ." >r"    drop exit then
  dup &00-0-00++00+ = if ." r@"    drop exit then
  dup &00-0-00++-0+ = if ." r>"    drop exit then
  dup &00---0000-0+ = if ." rdrop" drop exit then

  &+++++++++00+ 3mul \ Searching for single-opcode definitions that have this instruction
  &000000000-+0 3any  \ with exit trits set... So set these before the search, too.

  >r

  forth @
  begin
      dup 0<>
  while
      dup 2 + count +  \ Advance to code start address
      @                 \ Get first opcode of the definition
      r@ =               \ Compare with the ALU opcode that shall be identified.
      if
        dup 2 +
        count type
        space
      then

      @
  repeat
  rdrop drop
;

: memstamp ( Addr -- ) dup 6 .l ." :  " @ t. ."   " ;

: disasm-step ( -- )

  disasm-$ @ memstamp
  disasm-$ @ @        ( Fetch next opcode )
  1 disasm-$ +!       ( Increment position )

  dup  &+ 3mul  &0 = if ." Imm  " dup 1 rshift                                         .        then
  dup &++ 3mul &-- = if ." JZN  " dup 2 rshift disasm-cont @ over max disasm-cont !    .        then
  dup &++ 3mul &0- = if ." Jmp  " dup 2 rshift                                   dup 6 .l name. then
  dup &++ 3mul &+- = if ." Call " dup 2 rshift                                   dup 6 .l name. then
  dup  &+ 3mul  &+ = if ." Alu  " dup alu.   dup &+++ 3mul &-++ = if ." exit" then              then

  drop
;

: seec ( -- ) ( Continues to see )
  base @ decimal cr
  false disasm-cont !

  begin
    disasm-$ @ @

    dup  &+++ 3mul &-++ =          \ Loop terminates with ret
    swap  &++ 3mul  &0- =  or       \ or when an unconditional jump is reached.
    disasm-$ @ disasm-cont @ >= and  \ Do not stop when there has been a conditional jump further

    disasm-step cr
  until

  base !
;

: see ( -- )
  '
  disasm-$ !
  seec
;

\ ------------------------------------------------------------------------------
\  Cycle counter
\ ------------------------------------------------------------------------------

: cycles ( -- n ) 0 io@ ;

\ ------------------------------------------------------------------------------
\  Dictionary tricks
\ ------------------------------------------------------------------------------

: cornerstone ( "name" -- )
  create
    forth 2@    \ Preserve FORTH and DP after this
    , 2 + ,
  does>
    2@ forth 2! \ Restore FORTH and DP
;

cornerstone new

\ ------------------------------------------------------------------------------
\  May the ternary Forth be with you :-)
\ ------------------------------------------------------------------------------

welcome
words

