LithosAnanake/v4/capsule/forth.v4

\ forth.v4 -- the first words of the FORTH vocabulary: the ones that are
\ opcodes or short runs of them, and the variables that are in-line addresses.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18).
\ A word flagged inline is copied into a definition in place of a call; the
\ ones that touch the return stack are compile-only as well.  Rests on core.v4,
\ compile.v4's loader constants, and quit.v4, which the division words leave
\ through when the divisor is zero.  (F) is seven cells of scratch for
\ this file.

\ ---- stack ----
header DUP inline       : DUP     dup ;
header DROP inline      : DROP    drop ;
header OVER inline      : OVER    over ;
header SWAP inline      : SWAP'   SWAP ;
header ROT inline       : ROT'    ROT ;
header -ROT inline      : -ROT    SWAP push SWAP pop ;
header ?DUP             : ?DUP    if Z  dup ;   Z: ;
header 2DUP inline      : 2DUP    over over ;
header 2DROP inline     : 2DROP   drop drop ;

\ ---- the stack as a whole (D-16) ----
\ DEPTH reads the stack register.  PICK and ROLL reach under the top of a
\ stack that has no addresses: the values above the one wanted are set aside
\ in (S), and put back.  (F)+3 how many are still to set aside, (F)+4 where
\ the next goes, (F)+5 the value wanted, (F)+6 how many are set aside.  With nine values and n on the
\ stack it is full, so until a value has been set aside nothing here pushes
\ anything while n is still there, and never more than one cell after.

\ FORTH-79: how many values were on the stack before DEPTH
header DEPTH
: DEPTH   DSTACK-DEPTH b! @b ;

\ ( name -- )   "xxxx: Invalid index", and the line ends with ERROR
: (INDEX)
  R-CLEAR  (EMIT4)  $6E49203A (EMIT4) $696C6176 (EMIT4) $6E692064 (EMIT4) $786564 (EMIT4) CR
  2 jump (REPL)

\ ( x1 .. xn-1 -- )   A: n, which is 2 or more.  Set the n-1 values above
\ the n-th aside.  If there are not that many, the pop that finds the stack
\ empty is a fault: "Stack underflow".  The count is taken down only after a
\ value has been set aside, when there is room to do the arithmetic.
: (DIG)
  (F)+3 b!  a !b
  (F)+4 b!  (S) !b
  (F)+6 b!  0 !b
  L: (F)+4 b! @b a!  !+
     a (F)+4 b! !b
     (F)+6 b! @b 1 + !b
     (F)+3 b! @b -1 + dup !b
     -1 + if DONE  drop jump L
  DONE: drop ;
\ ( -- x1 .. xk )   put them back.  The test that ends it pushes one cell:
\ after the last value is back the stack may be one short of full.
: (BURY)
  L: (F)+6 b! @b if DONE  -1 + !b
     (F)+4 a! @ -1 + dup !  a! @
     jump L
  DONE: drop ;

\ ( n -- x )   FORTH-79: a copy of the n-th value, not counting n itself.
\ 1 PICK is DUP, 2 PICK is OVER.  n less than one is an error.
header PICK
: PICK
  -if POS  jump BAD
  POS: if BAD
  a!  a 2/ if ONE  drop                      \ n is 1 when half of it is 0
  (DIG)  dup (F)+5 a! !  (BURY)  (F)+5 a! @ ;
  ONE: drop dup ;
  BAD: drop  $4B434950 jump (INDEX)

\ ( n -- )   FORTH-79: the n-th value, not counting n itself, is taken out
\ and put on top.  3 ROLL is ROT, 2 ROLL is SWAP, 1 ROLL does nothing.  n
\ less than one is an error.
header ROLL
: ROLL
  -if POS  jump BAD
  POS: if BAD
  a!  a 2/ if ONE  drop
  (DIG)  (F)+5 a! !  (BURY)  (F)+5 a! @ ;
  ONE: drop ;
  BAD: drop  $4C4C4F52 jump (INDEX)

\ ---- return stack: in line, and only inside a definition ----
header >R inline compile-only   : >R    push ;
header R> inline compile-only   : R>    pop ;
header R@ inline compile-only   : R@    pop dup push ;
header I inline compile-only    : I     pop dup push ;
header J inline compile-only    : J     pop pop  pop dup push a!  push push  a ;
header LEAVE inline compile-only    : LEAVE    pop pop drop dup push push ;
header UNLOOP inline compile-only   : UNLOOP   pop drop pop drop ;

\ ---- memory ----
header @ inline         : FETCH   a! @ ;
header ! inline         : STORE   a! ! ;
header +! inline        : +!      a! @ + ! ;
header CELLS inline     : CELLS   ;                    \ an address unit is a cell (D-1)

\ ---- arithmetic ----
header + inline         : PLUS    + ;
header - inline         : MINUS   - ;
\ The low cell of the product, by N steps of +* with nothing but the count on
\ the return stack.  UM* drop gives the same cell but needs two more return
\ entries, which a word inside two DO loops does not have (D-2).  The low
\ cell is exact: what +* loses at the top of T (D-3) takes N shifts to reach
\ the bit that moves into A, and the loop ends first.
header * : STAR    a!  0  N-1 FOR +* UNEXT  drop drop a ;
header NEGATE inline    : NEGATE' NEGATE ;
header 1+ inline        : 1+      1 + ;
header 1- inline        : 1-      -1 + ;
header 2+ inline        : 2+      2 + ;
header 2- inline        : 2-      -2 + ;
header 2* inline        : TWO*    2* ;
header 2/ inline        : TWO/    2/ ;

\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
\ does anything else, and a zero divisor prints v3's message --
\     /: Division by zero
\ -- and ends the line with ERROR, from however deep, as an address fault
\ does.  The word's operands are taken off the stack, as v3 takes them, and
\ its caller is not returned to.

\ ( name2 name1 -- )   the word's name: its first four characters, and the
\ rest or 0 (EMIT4).  The return stack is emptied before anything is called:
\ the word may have been run with it full.
: (DIV0)
  R-CLEAR  (EMIT4) (EMIT4)  $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4)      \ ": Division b"
  $657A2079 (EMIT4) $6F72 (EMIT4) CR                                  \ "y zero"
  2 jump (REPL)

\ ( d n -- rem quot )   truncating toward zero: the quotient has the sign of
\ d xor n, the remainder the sign of d.  This is section 4's SM/REM with its
\ UM/MOD -- restoring division, one step a bit, the divisor in A -- written
\ into it, and the two signs kept in (F) where section 4 has them on the
\ return stack.  A word that divides is then four return entries deep, not
\ eight, so division can be used inside words that other words call (D-2).
\ The answer is the same.  Exact when the quotient fits a cell; its callers
\ have seen to it that n is not zero.
: SM/REM
  over over xor (F) a! !                     \ the quotient's sign, in its top bit
  over (F)+1 a! !                            \ the remainder's
  -if L0  inv 1 +  L0:  a!                   \ A: |n|
  -if L1  DNEGATE  L1:                       \ |d|
  N-1 FOR
    -if S0
      2* over -if S1  drop 1 + jump S2
      S1: drop  S2: push 2* pop
      jump SUB
    S0:
      2* over -if S3  drop 1 + jump S4
      S3: drop  S4: push 2* pop
      dup a xor -if S5
        drop -if NOSUB  jump SUB
      S5: drop dup inv a + inv -if S6
        drop jump NOSUB
      S6: push drop pop jump SETBIT
    SUB:    inv a + inv
    SETBIT: push 1 + pop
    NOSUB:
  NEXT
  over push push drop pop pop                \ urem uquot
  (F)+1 a! @ -if L2  drop push inv 1 + pop jump L3   L2: drop  L3:
  (F) a! @ -if L4  drop inv 1 + ;   L4: drop ;

header S>D
: S>D   ( n -- d )   dup -if P  drop -1 ;   P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
header M*
: M*    ( n1 n2 -- d )
  over over xor (F) a! !  -if A inv 1 + A:  push  -if B inv 1 + B:  pop  UM*
  (F) a! @ -if P  drop jump DNEGATE   P: drop ;

\ ( n1 n2 n3 -- rem quot )   n1 * n2 as a double, divided by n3, which is
\ not zero.  M* is written in, and n3 waits in (F)+2, so that the multiply
\ is as few return entries down as it can be.
: (*/MOD)
  (F)+2 a! !
  over over xor (F) a! !  -if A inv 1 + A:  push  -if B inv 1 + B:  pop  UM*
  (F) a! @ -if P  drop DNEGATE jump Q   P: drop   Q:
  (F)+2 a! @  jump SM/REM

header /MOD
: /MOD  ( n1 n2 -- rem quot )
  if Z  push S>D pop jump SM/REM
  Z: drop drop  0 $444F4D2F jump (DIV0)
header /
: /     ( n1 n2 -- quot )
  if Z  push S>D pop SM/REM  NIP ;
  Z: drop drop  0 $2F jump (DIV0)
header MOD
: MOD   ( n1 n2 -- rem )
  if Z  push S>D pop SM/REM  drop ;
  Z: drop drop  0 $444F4D jump (DIV0)
header */MOD
: */MOD ( n1 n2 n3 -- rem quot )
  if Z  jump (*/MOD)
  Z: drop drop drop  $44 $4F4D2F2A jump (DIV0)
header */
: */    ( n1 n2 n3 -- quot )
  if Z  (*/MOD)  NIP ;
  Z: drop drop drop  0 $2F2A jump (DIV0)
header M/MOD
: M/MOD ( d n -- rem quot )
  if Z  jump SM/REM
  Z: drop drop drop  $44 $4F4D2F4D jump (DIV0)

\ ---- logic and comparison ----
header AND inline       : AND     and ;
header XOR inline       : XOR     xor ;
header OR inline        : OR'     OR ;
header 0= : 0=    if L1  drop 0 ;   L1: drop -1 ;
header 0< : 0<    -if L1  drop -1 ;   L1: drop 0 ;
header NOT : NOT   jump 0=
header = : EQUALS  xor jump 0=
header < : LESS
  over over xor -if SAME  drop drop jump 0<
  SAME: drop - jump 0<
header > : GREATER   SWAP jump LESS

\ ---- in-line addresses and constants ----
header BL inline        : BL'     BL ;
header TIB inline       : TIB'    TIB ;
header >IN inline       : >IN'    >IN ;
header SPAN inline      : SPAN'   SPAN ;
header BASE inline      : BASE'   BASE ;
header PAD inline       : PAD'    PAD ;
header STATE inline     : STATE'  STATE ;