\ @(#) misc2.fth 98/01/26 1.2
\ Utilities for PForth extracted from HMSL
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David 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
: ? ( address -- , fatch from address and print value )
@ .
;
decimal
create msec-delay 10000 , ( default for SUN )
: (MSEC) ( #msecs -- )
0
do msec-delay @ 0
do loop
loop
;
defer msec
' (msec) is msec
: 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
[ $ 0FF invert ] literal or
ELSE
$ 0FF and
THEN
;
: W->S ( 16bit-signed -- cell-signed )
dup $ 8000 and
IF
[ $ 0FFFF invert ] literal or
ELSE
$ 0FFFF 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
;
private{
: env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
{ x } 2over compare 0= if 2drop x true true else false then
;
: 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
{ x y } 2over compare 0= if 2drop x y true true else false then
;
0 invert constant max-u
0 invert 1 rshift constant max-n
}private
: ENVIRONMENT? ( c-addr u -- false | i*x true )
s" /COUNTED-STRING" 255 env= if exit then
s" /HOLD" 128 env= if exit then \ same as PAD
s" /PAD" 128 env= if exit then
s" ADDRESS-UNITS-BITS" 8 env= if exit then
s" FLOORED" false env= if exit then
s" MAX-CHAR" 255 env= if exit then
s" MAX-D" max-n max-u 2env= if exit then
s" MAX-N" max-n env= if exit then
s" MAX-U" max-u env= if exit then
s" MAX-UD" max-u max-u 2env= if exit then
s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH
s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH
\ FIXME: maybe define those:
\ s" FLOATING-STACK"
\ s" MAX-FLOAT"
\ s" #LOCALS"
\ s" WORDLISTS"
2drop false
;
privatize