\ 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