/*      ^Forth:  Kernel Words
          File:  hfkernel.hf
Author/Deriver:  david.n.williams@umich.edu
       Version:  0.1.6
       License:  LGPL
 Last revision:  November 24, 2002

Copyright (C) 1995 Dirk Uwe Zoller
Copyright (C) 1998-2001 Tektronix, Inc.
Copyright (C) 2001-2002 David N. Williams

This library is part of ^Forth.  It is free software; you can
redistribute it and/or modify it under the terms of the GNU
Lesser General Public License as published by the Free Software
Foundation; either version 2.1 of the License, or (at your
option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

Please see the file POLITENESS included with this distribution.

Much code is copied from pfe.
*/

BEGIN-EXTERNAL
{"
/* Extra includes. */
#include <pfe/double-sub.h>
#include <string.h>
"}

/* No REQUIRES. */
END-EXTERNAL

MAKE-INDEX hfkernel "^Forth Kernel Word Set"
\ decimal

/* Words ********************************

\ *** Main Glossary
*/ ( Note that "*/" occurs here!
  !  !csp  *  */  */mod  *mod  +  +!  -  -!  -cell  .  /  /mod
  0!  0<  0<>  0=  0>  1+  1+!  1-  1-!  2!  2*  2+  2/  2>r  2@
  2dup  2drop  2r>  2r@  2rdrop  2cells+  2cells-  <  <=  <>
  <roll  <rot  =  >  >=  >r  >roll  >rot  ?dup  @ abort  abs
  align  aligned  and  bounds  c!  c@   cell+  cell-  cell 
  cells  char  char+  chars  cr  csp  decimal  depth  drop  dup
  emit  erase  false  fill  fm/mod  here  hex  invert  k  m*  m/
  m/mod  md/  md/mod  max  min  mmod  mod  move  negate  nip
  nip-nip  not  or  over  pad  pick  r>  r@  rdrop  roll  rot
  rshift  s->d  sm/rem  source  sp@  space  spaces  swap  toggle
  true  type  tuck  u<  u<=  u>  u>=  um*  um/  um/mod  umax 
  umd/ umd/mod  umin  ummod  within  xor
)

\ *** System Variables

\ CORE
ext-variable: >IN "TO_IN"
ext-variable: BASE "BASE"

\ FIG
ext-variable: csp "CSP"


\ *** Constants

 0 constant: ZERO "zero"   1 constant: ONE "one"
 2 constant: TWO "two"     3 constant: THREE "three"
 4 constant: FOUR "four"   5 constant: FIVE "five"
 6 constant: SIX "six"     7 constant: SEVEN "seven"
 8 constant: EIGHT "eight" 9 constant: NINE "nine"
10 constant: TEN "ten"    16 constant: SIXTEEN "sixteen"
-1 constant: -ONE "minus_one"      -2 constant: -TWO "minus_two"
-3 constant: -THREE "minus_three"  -4 constant: -FOUR "minus_four"
-5 constant: -FIVE "minus_five"

\ CORE
bl constant: BL "bl"

\ CORE EXT
-1 constant: TRUE "true"
 0 constant: FALSE "false"

\ COMMON
defm: CELL "cell"  ( -- PFE_SIZEOF_CELL ) 
  HF_PUSH (PFE_SIZEOF_CELL);
;defm

defm: -CELL "minus_cell"  ( -- -PFE_SIZEOF_CELL ) 
  HF_PUSH (-PFE_SIZEOF_CELL);
;defm


\ *** Glossary

\ FIG
defm: !CSP "store_csp"  ( -- )
  p4_CSP = SP;
;defm

\ CORE
defm: ! "store"  ( n addr -- )
  *(p4cell *) TOS = SP[1]; HF_DROP2;
;defm 

defm: @ "fetch"  ( addr -- n )
  TOS = *(p4cell *) TOS;
;defm

defm: * "star"  ( n1 n2 -- n )
  { p4cell res = TOS * SP[1]; SP++; TOS = res; }
;defm

defm: M* "m_star"  ( n1 n2 -- d )
  { p4dcell d = mmul (TOS, SP[1]); TOS = d.hi; SP[1] = d.lo;}
;defm

\ CORE
defm: */ "star_slash"  ( n1 n2 n3 -- n4 )
  { fdiv_t n4 = p4_d_fmdiv (p4_d_mmul (SP[2], SP[1]), TOS);
    SP += 2; TOS = n4.quot;}
;defm

defm: */MOD "star_slash_mod"  ( n1 n2 n3 -- rem quot )
  { fdiv_t res = p4_d_fmdiv (p4_d_mmul (SP[2], SP[1]), TOS);
    SP++; TOS = res.quot; SP[1] = res.rem; }
;defm

defm: + "plus"  ( n1 n2 -- n3 )
  { p4cell res = TOS + SP[1]; SP++; TOS = res; }
;defm

defm: +! "plus_store"  ( n addr -- )
  *(p4cell *) TOS += SP[1]; HF_DROP2;
;defm

defm: - "minus"  ( n1 n2 -- n3 )
  { p4cell res = SP[1] - TOS; SP++; TOS = res; }
;defm

\ COMMON
defm: -! "minus_store"  ( n addr -- )
  *(p4cell *) TOS -= SP[1]; HF_DROP2;
;defm

\ CORE
defm: / "slash"  ( n1 n2 -- quot )
  { fdiv_t n = p4_fdiv (SP[1], TOS); SP++; TOS = n.quot; }
;defm

defm: /MOD "slash_mod"  ( n1 n2 -- rem quot )
  { fdiv_t n = p4_fdiv (SP[1], TOS);
    TOS = n.quot; SP[1] = n.rem; }
;defm

\ COMMON
defm: 0! "zero_store"  ( addr -- )
  *(p4cell *) TOS = 0;  HF_DROP1;
;defm

\ CORE
defm: 0< "zero_less"  ( n -- flag )
  TOS = P4_FLAG (TOS < 0);
;defm

defm: 0= "zero_equals"  ( n -- flag )
  TOS = P4_FLAG (TOS == 0);
;defm

defm: < "less_than"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS > SP[1]); SP++; TOS = res; }
;defm

defm: = "equals"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS == SP[1]); SP++; TOS = res; }
;defm

defm: > "greater_than"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS < SP[1]); SP++; TOS = res; }
;defm

\ CORE EXT
defm: 0<> "zero_not_equals"  ( n -- flag )
  TOS = P4_FLAG (TOS != 0);
;defm

defm: 0> "zero_greater"  ( n -- flag )
  TOS = P4_FLAG (TOS > 0);
;defm

defm: <> "not_equals"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS != SP[1]); SP++; TOS = res; }
;defm

\ COMMON
defm: <= "less_than_or_equals"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS >= SP[1]); SP++; TOS = res; }
;defm

defm: >= "greater_than_or_equals"  ( n1 n2 -- flag )
  { p4cell res = P4_FLAG (TOS <= SP[1]); SP++; TOS = res; }
;defm

\ CORE
defm: >R "to_r"  ( n -- r: n )
  RP_PUSH (TOS); HF_DROP1;
;defm

ext-def: . "dot"  ( n -- )

defm: 1+ "one_plus"  ( n -- n+1 )
  ++TOS;
;defm

defm: 1- "one_minus"  ( n -- n-1 )
  --TOS;
;defm

\ COMMON
defm: 1+! "one_plus_store"  ( addr -- )
  ++*(p4cell *) TOS; SP++;
;defm

defm: 1-! "one_minus_store"  ( addr -- )
  --*(p4cell *) TOS; SP++;
;defm

\ CORE
defm:  2! "two_store"  ( n1 n2 addr -- )
  *(p4dcell *) TOS = *(p4dcell *) &SP[1];  SP += 3;
;defm

defm: 2* "two_star"  ( n -- 2*n )
  TOS <<= 1;
;defm

defm: 2/ "two_slash"  ( n -- n/2 )
  TOS >>= 1;
;defm

\ CORE EXT
defm: 2>R "two_to_r"  ( n1 n2 -- )  (r: -- n1 n2 )
  RP_PUSH (SP[1]);  RP_PUSH (TOS);  HF_DROP2;
;defm  \ COMPILE-ONLY (but not in pfe)

\ CORE
defm: 2@ "two_fetch"  ( addr -- n1 n2 )
#ifdef HF_TOSREG
  { p4cell *addr = (p4cell *)TOS;
    TOS = *addr; *SP-- = *(addr + 1); }
#else
  { p4dcell *addr = (p4dcell *) *SP--;
    *(p4dcell *) SP = *addr; }
#endif
;defm

defm: 2DROP "two_drop"  ( n1 n2 -- )
  HF_DROP2;
;defm

defm: 2DUP "two_dup"  ( n1 n2 -- n1 n2 n1 n2 )
#ifdef HF_TOSREG
  SP[0] = TOS; SP -= 2; SP[1] = SP[3];
#else
  SP -= 2;  SP[0] = SP[2];  SP[1] = SP[3];
#endif
;defm

\ CORE EXT
defm: 2R> "two_r_from"  (r: n1 n2 -- )  ( -- n1 n2 )
  HF_SPILL_TOS SP -= 2; TOS = RP_POP (); SP[1] = RP_POP ();
;defm
 
\ COMMON
defm: 2R@ "two_r_fetch"  (r: n1 n2 -- n1 n2 ) ( -- n1 n2 )
  HF_SPILL_TOS SP -= 2; TOS = FX_RP[0];  SP[1] = FX_RP[1];
;defm

defm: 2RDROP "two_r_drop"  (r: n1 n2 -- )
  P4_INCR ( p4RP, p4cell, 2);
;defm  \ COMPILE-ONLY (but not pfe)

\ CORE
ext-def: ABORT "abort"  ( -- )

defm: ABS "abs"  ( n -- |n| )
  if (TOS < 0) TOS = -TOS;
;defm

defm: ALIGN "align"  ( -- )
  while (!P4_ALIGNED (DP)) *DP++ = 0;
;defm

defm: ALIGNED "aligned"  ( addr -- addr' )
  TOS = p4_aligned (TOS);
;defm

defm: AND "and"  ( n1 n2 -- n1&n2 )
  { p4cell res = TOS & SP[1]; SP++; TOS = res; }
;defm

\ COMMON
defm: BOUNDS "bounds"  ( addr len -- addr+len addr )
  { p4cell h = SP[1];  SP[1] += TOS;  TOS = h; }
;defm

\ CORE
defm: C! "c_store"  ( byte addr -- )
  *(char *) TOS = SP[1];  HF_DROP2;
;defm

defm: C, "c_comma"  ( byte -- )
  *DP++ = (p4char) TOS; HF_DROP1;
;defm

defm: C@  "c_fetch"  ( addr -- byte )
  TOS = *(p4char *) TOS;
;defm

\ CORE
defm: CELL+ "cell_plus"  ( n -- n+SIZEOF_CELL )
  TOS += sizeof (p4cell);
;defm

\ COMMON
defm:  2CELLS+ "two_cells_plus"  ( n -- n+2*SIZEOF_CELL )
  TOS += 2 * sizeof (p4cell);
;defm

defm:  CELL- "cell_minus"  ( n -- n-SIZEOF_CELL )
  TOS -= sizeof (p4cell);
;defm

defm:  2CELLS- "two_cells_minus"  ( n -- n-2*SIZEOF_CELL )
  TOS -= 2 * sizeof (p4cell);
;defm

\ CORE
defm: CELLS "cells"  ( n -- n*SIZEOF_CELL )
  TOS *= sizeof (p4cell);
;defm

ext-def: CHAR "char"  ( "word" -- char )

defm: CHAR+ "char_plus"  ( n -- n' )
  TOS += sizeof (char);
;defm

defm: CHARS "chars"  ( n -- n' )
  TOS *= sizeof (char);
;defm

ext-def: CR "cr"  ( -- )

defm: DECIMAL "decimal"  ( -- )
  p4_BASE = 10;
;defm

defm: DEPTH "depth"  ( -- n )
#ifdef HF_TOSREG
  *SP = TOS; TOS = p4_S0 - SP; SP--; 
#else 
  { p4cell diff = p4_S0 - SP;
    *--SP = diff; }
#endif
;defm

defm: DROP "drop"  ( a -- )
  HF_DROP1;
;defm

defm: DUP "dup"  ( a -- a a )
#ifdef HF_TOSREG
 *SP-- = TOS;
#else
  SP--;  SP[0] = SP[1];
#endif
;defm

defm: ?DUP "q_dup"  ( n -- n n | 0 )
#ifdef HF_TOSREG
  if (TOS) *SP-- = TOS;
#else
  if (*SP) --SP, SP[0] = SP[1];
#endif
;defm

ext-def: EMIT "emit" ( char -- )

\ CORE EXT
defm: ERASE "erase"  ( addr len -- )
  memset ((void *) SP[1], 0, TOS);  HF_DROP2;
;defm

\ CORE
defm: FILL "fill"  ( addr len char -- )
  memset ((void *) SP[2], TOS, SP[1]);  SP += 3; HF_FILL_TOS
;defm

defm: FM/MOD "f_m_slash_mod"  ( dn1 n2 -- rem quot )
  { fdiv_t res = p4_d_fmdiv (*(p4dcell *) &SP[1], TOS);
    SP++; TOS = res.quot; SP[1] = res.rem;}
;defm

defm: HERE "here"  ( -- addr )
  HF_PUSH ((p4cell) DP);
;defm

\ CORE EXT
defm: HEX "hex"  ( -- )
  p4_BASE = 16;
;defm

\ CORE
defm: INVERT "invert"  ( a -- ~a )
  TOS = ~TOS;
;defm

defm: LSHIFT "l_shift"  ( x u -- x' )
  SP[1] <<= TOS; HF_DROP1;
;defm

defm: MAX "max"  ( n1 n2 -- n3 )
  { p4cell res = (TOS > SP[1]) ? TOS : SP[1]; SP++; TOS = res; }
;defm

defm: MIN "min"  ( n1 n2 -- n3 )
  { p4cell res = (TOS < SP[1]) ? TOS : SP[1]; SP++; TOS = res; }
;defm

defm: MOD "mod"  ( numer denom -- rem )
  { fdiv_t res = p4_fdiv (SP[1], TOS); SP++; TOS = res.rem; }
;defm

defm: MOVE "move"  ( &from &to u -- )
  memmove ((void *) SP[1], (void *) SP[2], (size_t) TOS);
  SP += 3; HF_FILL_TOS
;defm

defm: NEGATE "negate"  ( n -- -n )
  TOS = -TOS;
;defm

\ COMMON
defm: NOT "not"  ( n -- n' )
  TOS = P4_FLAG (TOS == 0);
;defm

\ CORE EXT
defm: NIP "nip"  ( a b -- b )
  { p4cell res = TOS; SP++; TOS = res; }
;defm

\ COMMON
defm: NIP-NIP "nip_nip"  ( a b c -- c )
  { p4cell res = TOS; SP += 2; TOS = res; }
;defm

\ CORE
defm: OR "or"  ( a b -- a|b )
  { p4cell res = TOS | SP[1]; SP++; TOS = res; }
;defm

defm: OVER "over"  ( a b -- a b a )
  HF_SPILL_TOS --SP; TOS = SP[2];
;defm

\ CORE EXT
defm: PAD "pad"  ( -- addr )
  HF_PUSH ((p4cell) p4_PAD);
;defm

defm: PICK "pick"  ( +n -- value )
  TOS = SP[TOS + 1];
;defm

defm: R>  "r_from"  (r: a -- ) ( -- a )
  HF_PUSH (RP_POP());
;defm

defm: R@  "r_fetch"  (r: a -- a ) ( -- a )
  HF_PUSH (*FX_RP);
;defm

\ COMMON
defm: RDROP "r_drop"  (r: a -- )
  P4_INC ( p4RP, p4cell);
;defm

\ CORE EXT
ext-def: ROLL "roll"  ( xn xm ... x1 n -- xm ... x1 xn )

defm: ROT "rot"   ( a b c -- b c a )
  { p4cell h = SP[2]; SP[2] = SP[1];
    SP[1] = TOS; TOS = h; }
;defm

\ COMMON
0 [IF]  \ need a ^Forth synonym mechanism for this
ext-def: <roll "roll"  ( xn xm ... x1 n -- xm ... x1 xn )
ext-def: <rot  "rot"  ( a b c -- b c a )
[THEN]

defm: RP@ "r_p_fetch"  ( -- rp )
  HF_PUSH ((p4cell) RP);
;defm

\ CORE
defm: RSHIFT "r_shift"  ( x u -- x' )
  *(p4ucell *) &SP[1] >>= TOS; HF_DROP1;
;defm

defm: S>D "s_to_d"  ( n -- dn )
  HF_SPILL_TOS SP--; TOS = SP[1] < 0 ? -1 : 0;
;defm

defm: SM/REM "s_m_slash_rem"  ( numer.d denom -- rem quot )
  { fdiv_t res = p4_d_smdiv (*(p4dcell *) &SP[1], TOS);
    SP++; TOS = res.quot; SP[1] = res.rem; }
;defm

ext-def: SOURCE "source"  ( -- addr len ) 

\ COMMON
defm: SP@ "s_p_fetch"  ( -- sp )
  HF_PUSH ((p4cell) (SP - 1));
;defm

\ CORE
ext-def: SPACE "space"
ext-def: SPACES "spaces"

defm: SWAP "swap"  ( a b -- b a )
  { p4cell h = SP[1]; SP[1] = TOS; TOS = h; }
;defm

\ FIG
\ NOTE:  We disagree with pfe on this!
defm: TOGGLE "toggle"  ( addr mask -- )
  *(p4cell *) SP[1] ^= TOS; HF_DROP2;
;defm

\ CORE
ext-def: TYPE "type"  ( addr len -- )

\ CORE EXT
defm: TUCK "tuck"  ( a b -- b a b )
  { p4cell h = TOS;
    --SP; TOS = h; SP[1] = SP[2]; SP[2] = h; } 
;defm

\ CORE
defm: U<  "u_less_than"  ( u1 u2 -- flag )
  { p4cell res = P4_FLAG ((p4ucell) TOS > (p4ucell) SP[1]);
    SP++; TOS = res; }
;defm

\ NANS
defm: U<=  "u_less_than_equals"  ( u1 u2 -- flag )
  { p4cell res = P4_FLAG ((p4ucell) TOS >= (p4ucell) SP[1]);
    SP++; TOS = res; }
;defm

\ CORE EXT
defm: U>  "u_greater_than"  ( u1 u2 -- flag )
  { p4cell res = P4_FLAG ((p4ucell) TOS < (p4ucell) SP[1]);
    SP++; TOS = res; }
;defm

\ NANS
defm: U>=  "u_greater_than_equals"  ( u1 u2 -- flag )
  { p4cell res = P4_FLAG ((p4ucell) TOS <= (p4ucell) SP[1]);
    SP++; TOS = res; }
;defm

\ CORE
defm: UM* "u_m_star"  ( u1 u2 -- (u1*u2).ud )
  { p4udcell res = p4_d_ummul ((p4ucell) TOS, (p4ucell) SP[1]);
    TOS = res.hi; SP[1] = res.lo;}
;defm

defm: UM/MOD "u_m_slash_mod"  ( numer.ud denom.u -- rem.u quot.u )
  { udiv_t res = p4_d_umdiv (*(p4udcell *) &SP[1], TOS);
    SP++; TOS = res.quot; SP[1] = res.rem;}
;defm

\ CORE EXT
defm: WITHIN "within"  ( n1|u1 n2|u2 n3|u3 -- flag )
  { p4cell res = P4_FLAG ( (p4ucell) (SP[2] - SP[1]) <
                      (p4ucell) (TOS - SP[1]) );
    SP += 2; TOS = res; }
;defm

\ CORE
defm: XOR "xor"  ( a b -- c )
  { p4cell res = TOS ^ SP[1]; SP++; TOS = res; }
;defm