\ @(#) misc2.fth 98/01/26 1.2
\ Utilities for PForth extracted from HMSL
\ 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
: 'N ( <name> -- , make 'n state smart )
IF namebase - ( make nfa relocatable )
[compile] literal ( store nfa of word to be compiled )
: ?LITERAL ( n -- , do literal if compiling )
: 'c ( <name> -- xt , state sensitive ' )
create msec-delay 10000 , ( default for SUN )
: SHIFT ( val n -- val<<n )
variable rand-seed here rand-seed !
: random ( -- random_number )
65535 and dup rand-seed !
: choose ( range -- random_number , in range )
: wchoose ( hi lo -- random_number )
\ sort top two items on stack.
: 2sort ( a b -- a<b | b<a , largest on top of stack)
\ sort top two items on stack.
: -2sort ( a b -- a>b | b>a , smallest on top of stack)
: barray ( #bytes -- ) ( index -- addr )
: warray ( #words -- ) ( index -- addr )
: array ( #cells -- ) ( index -- addr )
: .bin ( n -- , print in binary )
base @ binary swap . base !
base @ decimal swap . base !
: B->S ( c -- c' , sign extend byte )
: W->S ( 16bit-signed -- 32bit-signed )
: WITHIN { n1 n2 n3 -- flag }
: MOVE ( src dst num -- )
: BLANK ( addr u -- , set memory to blank )
\ Obsolete but included for CORE EXT word set.
: UNUSED ( -- unused , dictionary space )
: MAP ( -- , dump interesting dictionary info )
." CODEBASE = " codebase .hex cr
." CODELIMIT = " codelimit .hex cr
." Compiled Code Size = " here codebase - . cr
." CODE-SIZE = " code-size @ . cr
." Code Room UNUSED = " UNUSED . 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
addr1 i j + chars + c@ <> \ mismatch?