\ Easy4tH  V1.0b             A 4tH to ANS Forth interface

\ Typical usage:
\    4096 constant /string-space
\    s" easy4th.f" included

\ This is an ANS Forth program requiring:
\      1. The word NIP in the Core Ext. word set
\      2. The word /STRING in the String word set
\      3. The word D>S in the Double word set
\      4. The words MS and TIME&DATE in the Facility Ext. word set.

\ (c) Copyright 1997 Wil Baden, Hans Bezemer.  Permission is granted by the
\ authors to use this software for any application provided this
\ copyright notice is preserved.


\ Uncomment the next line if REFILL does not funtion properly
\ : refill query cr true ;

\ 4tH datatypes
: ARRAY CREATE CELLS ALLOT ;
: STRING CREATE CHARS ALLOT ;
: TABLE CREATE ;

\ 4tH constants
: (ERROR) S" MAX-N" ENVIRONMENT? DROP NEGATE 1- ;
: MAX-N S" MAX-N" ENVIRONMENT? DROP ;
: STACK-CELLS S" STACK-CELLS" ENVIRONMENT? DROP ;
: /PAD S" /PAD" ENVIRONMENT? DROP ;

\ 4tH wordset
: TH CELLS + ;
: @' @ ;
: COPY ( a b -- b ) >R  DUP C@ 1+ R@ SWAP MOVE  R> ;
: WAIT 1000 * MS ;

: NUMBER             ( a -- n)
  0. ROT DUP 1+ C@ [CHAR] - = >R COUNT R@ IF 1 /STRING THEN >NUMBER NIP 0=
  IF D>S R> IF NEGATE THEN ELSE R> DROP 2DROP (ERROR) THEN
;

\ 4tHs C" runtime semantics emulation

( Reserve  STRING-SPACE  in data-space. )
CREATE STRING-SPACE           /STRING-SPACE CHARS ALLOT
VARIABLE NEXT-STRING          0 NEXT-STRING !

( caddr n addr -- )
: PLACE OVER OVER >R >R CHAR+ SWAP CHARS MOVE R> R> C! ;

( " ccc" -- caddr )
: " [CHAR] " PARSE
  DUP 1+ NEXT-STRING @ + /STRING-SPACE >
        ABORT" String Space Exhausted. "
  STRING-SPACE NEXT-STRING @ CHARS + >R
  DUP 1+ NEXT-STRING +!
  R@ PLACE
  R>
;

\ 4tHs Random generator

( Default RNG from the C Standard.  `RAND' has reasonable
( properties, plus the advantage of being widely used. )
VARIABLE RANDSEED

32767 CONSTANT MAX-RAND

: RAND                                 ( -- random )
  RANDSEED @ ( random) 1103515245 *   12345 +   DUP RANDSEED !
  16 RSHIFT   MAX-RAND AND
;

: SRAND ( n -- ) RANDSEED ! ;  1 SRAND

( Don't mumble. )
: random        ( -- n )        RAND ;

: set-random    ( n -- )        SRAND ;

( Mix 'em up. )
: randomize                                     ( -- )
  TIME&DATE  12 * + 31 * + 24 * + 60 * + 60 * +  set-random
;

randomize