/test/hrc/forth/full/fth.misc2.fth
Forth | 232 lines | 203 code | 29 blank | 0 comment | 9 complexity | ea784ab7fedb57f01d872dcd0da90bed MD5 | raw file
- \ @(#) misc2.fth 98/01/26 1.2
- \ Utilities for PForth extracted from HMSL
- \
- \ Author: Phil Burk
- \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
- \
- \ The pForth software code is dedicated to the public domain,
- \ and any third party may reproduce, distribute and modify
- \ the pForth software code or any derivative works thereof
- \ without any compensation or license. The pForth software
- \ code is provided on an "as is" basis without any warranty
- \ of any kind, including, without limitation, the implied
- \ warranties of merchantability and fitness for a particular
- \ purpose and their equivalents under the laws of any jurisdiction.
- \
- \ 00001 9/14/92 Added call, 'c w->s
- \ 00002 11/23/92 Moved redef of : to loadcom.fth
- anew task-misc2.fth
- : 'N ( <name> -- , make 'n state smart )
- bl word find
- IF
- state @
- IF namebase - ( make nfa relocatable )
- [compile] literal ( store nfa of word to be compiled )
- compile namebase+
- THEN
- THEN
- ; IMMEDIATE
- : ?LITERAL ( n -- , do literal if compiling )
- state @
- IF [compile] literal
- THEN
- ;
- : 'c ( <name> -- xt , state sensitive ' )
- ' ?literal
- ; immediate
- variable if-debug
- decimal
- create msec-delay 1000 , ( default for SUN )
- : msec ( #msecs -- )
- 0
- do msec-delay @ 0
- do loop
- loop
- ;
- : SHIFT ( val n -- val<<n )
- dup 0<
- IF negate arshift
- ELSE lshift
- THEN
- ;
- variable rand-seed here rand-seed !
- : random ( -- random_number )
- rand-seed @
- 31421 * 6927 +
- 65535 and dup rand-seed !
- ;
- : choose ( range -- random_number , in range )
- random * -16 shift
- ;
- : wchoose ( hi lo -- random_number )
- tuck - choose +
- ;
- \ sort top two items on stack.
- : 2sort ( a b -- a<b | b<a , largest on top of stack)
- 2dup >
- if swap
- then
- ;
- \ sort top two items on stack.
- : -2sort ( a b -- a>b | b>a , smallest on top of stack)
- 2dup <
- if swap
- then
- ;
- : barray ( #bytes -- ) ( index -- addr )
- create allot
- does> +
- ;
- : warray ( #words -- ) ( index -- addr )
- create 2* allot
- does> swap 2* +
- ;
- : array ( #cells -- ) ( index -- addr )
- create cell* allot
- does> swap cell* +
- ;
- : .bin ( n -- , print in binary )
- base @ binary swap . base !
- ;
- : .dec ( n -- )
- base @ decimal swap . base !
- ;
- : .hex ( n -- )
- base @ hex swap . base !
- ;
- : B->S ( c -- c' , sign extend byte )
- dup $ 80 and
- IF
- $ FFFFFF00 or
- ELSE
- $ 000000FF and
- THEN
- ;
- : W->S ( 16bit-signed -- 32bit-signed )
- dup $ 8000 and
- if
- $ FFFF0000 or
- ELSE
- $ 0000FFFF and
- then
- ;
- : WITHIN { n1 n2 n3 -- flag }
- n2 n3 <=
- IF
- n2 n1 <=
- n1 n3 < AND
- ELSE
- n2 n1 <=
- n1 n3 < OR
- THEN
- ;
- : MOVE ( src dst num -- )
- >r 2dup - 0<
- IF
- r> CMOVE>
- ELSE
- r> CMOVE
- THEN
- ;
- : ERASE ( caddr num -- )
- dup 0>
- IF
- 0 fill
- ELSE
- 2drop
- THEN
- ;
- : BLANK ( addr u -- , set memory to blank )
- DUP 0>
- IF
- BL FILL
- ELSE
- 2DROP
- THEN
- ;
- \ Obsolete but included for CORE EXT word set.
- : QUERY REFILL DROP ;
- VARIABLE SPAN
- : EXPECT accept span ! ;
- : TIB source drop ;
- : UNUSED ( -- unused , dictionary space )
- CODELIMIT HERE -
- ;
- : MAP ( -- , dump interesting dictionary info )
- ." Code Segment" cr
- ." CODEBASE = " codebase .hex cr
- ." HERE = " here .hex cr
- ." CODELIMIT = " codelimit .hex cr
- ." Compiled Code Size = " here codebase - . cr
- ." CODE-SIZE = " code-size @ . cr
- ." Code Room UNUSED = " UNUSED . cr
- ." Name Segment" cr
- ." NAMEBASE = " namebase .hex cr
- ." HEADERS-PTR @ = " headers-ptr @ .hex cr
- ." NAMELIMIT = " namelimit .hex cr
- ." CONTEXT @ = " context @ .hex cr
- ." LATEST = " latest .hex ." = " latest id. cr
- ." Compiled Name size = " headers-ptr @ namebase - . cr
- ." HEADERS-SIZE = " headers-size @ . cr
- ." Name Room Left = " namelimit headers-ptr @ - . cr
- ;
- \ Search for substring S2 in S1
- : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }
- \ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
- \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
- \ if false, s3 = s1
- addr1 -> addr3
- cnt1 -> cnt3
- cnt1 cnt2 < not
- IF
- cnt1 cnt2 - 1+ 0
- DO
- true -> flag
- cnt2 0
- ?DO
- addr2 i chars + c@
- addr1 i j + chars + c@ <> \ mismatch?
- IF
- false -> flag
- LEAVE
- THEN
- LOOP
- flag
- IF
- addr1 i chars + -> addr3
- cnt1 i - -> cnt3
- LEAVE
- THEN
- LOOP
- THEN
- addr3 cnt3 flag
- ;