\ Do not use this file except in compliance with the License. You may \ obtain a copy of the License at http://www.microcore.org/MPL/ \ Software distributed under the License is distributed on an "AS IS" basis, \ WITHOUT WARRANTY OF ANY KIND, either express or implied. \ See the License for the specific language governing rights and limitations \ under the License. \ \ The Original Code is: FORTH.FS \ \ Last change: KS 21.10.2015 21:02:34 \ \ The Initial Developer of the Original Code is Klaus.Schleisiek AT microcore.org. \ Port to the gforth system and extensions by Ulrich.E.Hoffmann AT xlerb.de \ \ Standard Forth words composed of primitives \ Variable Dp \ must be set to the value of Tdp in the cold boot routine : (do ( limit start -- count end ) under - 1- swap 1- ; : (?do ( limit start -- count end ) under - swap 1- ; Host: DO ( n1 n2 -- ) ( R: -- n3 n4 ) ?comp T (do >r FOR H ; Host: ?DO ( n1 n2 -- ) ( R: -- n3 n4 ) ?comp T (?do >r ?FOR H ; Host: LOOP ( -- ) ( R: n1 n2 -- n1 n2 ) ( R: n1 0 -- ) ?comp T NEXT rdrop H ; Macro: bounds ( start len -- limit start ) ?comp T over >r + r> H ; : >= ( n1 n2 -- f ) < 0= ; : <= ( n1 n2 -- f ) > 0= ; : within ( w [low [high -- flag ) over - >r - r> ;noexit \ fall into u< : u< ( n1 n2 -- f ) - drop carry? 0= ; : u> ( n1 n2 -- f ) swap - drop carry? 0= ; : case? ( n1 n2 -- n1 ff | tf ) \ Selection Operator. over - IF false EXIT THEN drop true ; : max ( n1 n2 -- max ) 2dup < IF nip EXIT THEN drop ; : min ( n1 n2 -- min ) 2dup < IF drop EXIT THEN nip ; : umin ( n1 n2 -- max ) 2dup - drop carry? IF nip EXIT THEN drop ; : umax ( n1 n2 -- min ) 2dup - drop carry? IF drop EXIT THEN nip ; : abs ( n -- u ) dup 0< 0= ?EXIT negate ; : rotate ( n1 n2 -- n3 ) >r 0 r@ 0< IF swap THEN r> dshift or ; : m+ ( d n -- d ) swap >r + r> 0 +c ; SAT_ARITH [IF] \ d+ d- are incomplete, because nothing is done on a double number overflow! : d+ ( d1 d2 -- d3 ) >r swap >r carry-reset +c r> r> +c ; : d- ( d1 d2 -- d3 ) >r swap >r invert carry-set +c r> r> invert +c ; [ELSE] : d+ ( d1 d2 -- d3 ) >r swap >r + r> r> +c ; : d- ( d1 d2 -- d3 ) >r swap >r - r> r> invert +c ; [THEN] : extend ( n -- d ) dup 0< ; : dabs ( d -- +d ) dup 0< 0= ?EXIT ;noexit \ fall into dnegate : dnegate ( d1 -- d2 ) swap negate swap invert 0 +c ; : d2* ( d1 -- d2 ) 1 dshift ; : d2/ ( d1 -- d2 ) -1 dshift ; : ud2/ ( ud1 -- ud2 ) 1 dashift ; : d= ( d1 d2 -- f ) d- ;noexit \ fall into d0= : d0= ( d -- f ) or 0= ; : 2swap ( d1 d2 -- d2 d1 ) rot >r rot r> ; : 2over ( d1 d2 -- d1 d2 d1 ) >r >r 2dup r> -rot r> -rot ; WITH_MULT [IF] [ELSE] : um* ( u1 u2 -- udprod ) umultiply ; : * ( n1 n2 -- prod ) umultiply multl ; Host: * ( n1 n2 -- prod ) dbg? IF t> t> * >t EXIT THEN exec? IF * EXIT THEN T * H ; immediate : m* ( n1 n2 -- dprod ) 2dup xor >r abs swap abs um* r> 0< 0= ?EXIT dnegate ; : ud* ( ud u -- udprod ) tuck um* drop >r um* r> + ; [THEN] : u/mod ( u1 u2 -- urem uquot ) 0 swap ;noexit \ fall into um/mod : um/mod ( ud u -- urem uquot ) udivide ; : u/ ( u1 u2 -- uquot ) u/mod nip ; : umod ( u1 u2 -- urem ) u/mod drop ; : ud/mod ( ud u -- urem udquot ) tuck u/mod >r swap um/mod r> ; : /mod ( n1 n2 -- rem quot ) >r extend r> ;noexit \ fall into m/mod : m/mod ( d n -- rem quot ) sdivide ; \ : fm/mod ( d n -- rem quot ) \ dup >r abs >r dup 0< IF r@ + THEN r> um/mod \ r@ 0< IF negate over IF swap r@ + swap 1- THEN THEN rdrop \ ; \ : m/mod ( d u -- rem quot ) \ over 0< IF tuck + swap THEN um/mod ; : / ( n1 n2 -- quot ) /mod nip ; : mod ( n1 n2 -- urem ) /mod drop ; : */mod ( n1 n2 n3 -- n4 n5 ) >r m* r> m/mod ; : */ ( n1 n2 n3 -- n4 ) */mod nip ; : 2** ( n -- 2**n ) 1 swap shift ; Host: 2** ( n -- 2**n ) dbg? IF t> 2** >t EXIT THEN exec? IF 2** EXIT THEN T 2** H ; immediate WITH_FLOAT [IF] : sqrt ( u -- urem uroot ) uroot ; : log2 ( u -- u' ) ulog ; : >float ( n exp -- r ) normalize (>float ; [ELSE] \ : sqrt ( u -- urem uroot ) \ 0 tuck [ data_width 2/ 1- ] Literal \ FOR d2* d2* swap >r swap 2* 2* 1+ \ 2dup - 0< 0= IF tuck - swap 2 + THEN \ u2/ swap r> swap \ NEXT nip swap \ ; \ : log2 ( frac -- log2[frac] ) \ Logarithmus nach K.S./U.Lange \ 0 data_width \ ?FOR 2* >r dup um* \ dup 0< IF r> 1+ >r ELSE d2* THEN \ correction of 'B(i)' and 'A(i)' \ round r> \ A(i+1):=A(i)*2^(B(i)-1) \ NEXT nip \ ; [THEN] : inc ( addr -- ) 1 swap +! ; : dec ( addr -- ) -1 swap +! ; : on ( addr -- ) -1 swap ! ; : off ( addr -- ) 0 swap ! ; : erase ( addr len -- ) 0 ;noexit \ fall into fill : fill ( addr len u -- ) swap >r swap 1- r> ?FOR over swap 1 + st NEXT 2drop ; : move ( addr_from addr_to ucount -- ) >r 2dup u< IF ( cmove> ) r@ + swap r@ + r> ?FOR 1- ld >r swap 1- st r> NEXT 2drop EXIT THEN ( cmove ) 1 - swap 1 - r> ?FOR 1+ ld >r swap 1+ st r> NEXT 2drop ; : place ( addr len to -- ) over swap st 1+ swap move ; : ahead ( ticks -- time.ahead ) timer @ + ; : sleep ( n -- ) ahead ;noexit \ fall into continue : continue ( time.ahead -- ) BEGIN dup time? UNTIL drop ; : time ( -- time ) timer @ ; : elapsed ( time -- ticks ) timer @ swap - ; Host: ms ( msec -- ticks ) comp? IF ticks_per_ms lit, T * H EXIT THEN dbg? IF t> ticks_per_ms * >t EXIT THEN ticks_per_ms * ; immediate Host: sec ( sec -- ticks ) [ ticks_per_ms &1000 * ] Literal comp? IF lit, T * H EXIT THEN dbg? IF t> * >t EXIT THEN * ; immediate Macro: set ( mask -- ) T ctrl! H ; Host: reset ( mask -- ) T invert ctrl! H ; Macro: int_enable ( mask -- ) T ie! H ; Host: int_disable ( mask -- ) T invert ie! H ; : init ( -- ) ; \ This is used as the "anchor" of all subsequent init routines \ which will be executed as part of the boot code. \ Later on, define : init ( -- ) init ; \ This way, init routines of different modules are chained together \ and the : boot routine is the last definition of the load file : ctrl? ( mask -- f ) ctrl@ and ; : flag? ( mask -- f ) flags@ and ;