[pforth] / fth / misc2.fth

\ @(#) 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
\
\ Permission to use, copy, modify, and/or distribute this
\ software for any purpose with or without fee is hereby granted.
\
\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
\
\ 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
Commit	Line	Data
8e9db35f PB	1	\ @(#) misc2.fth 98/01/26 1.2
	2	\ Utilities for PForth extracted from HMSL
	3	\
	4	\ Author: Phil Burk
1a088514	5	\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
8e9db35f	6	\
1f99f95d S	7	\ Permission to use, copy, modify, and/or distribute this
	8	\ software for any purpose with or without fee is hereby granted.
	9	\
	10	\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
	11	\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
	12	\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
	13	\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
	14	\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
	15	\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
	16	\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
	17	\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
8e9db35f PB	18	\
	19	\ 00001 9/14/92 Added call, 'c w->s
	20	\ 00002 11/23/92 Moved redef of : to loadcom.fth
	21
	22	anew task-misc2.fth
	23
	24	: 'N ( <name> -- , make 'n state smart )
	25	bl word find
	26	IF
	27	state @
	28	IF namebase - ( make nfa relocatable )
	29	[compile] literal ( store nfa of word to be compiled )
	30	compile namebase+
	31	THEN
	32	THEN
	33	; IMMEDIATE
	34
	35	: ?LITERAL ( n -- , do literal if compiling )
	36	state @
	37	IF [compile] literal
	38	THEN
	39	;
	40
	41	: 'c ( <name> -- xt , state sensitive ' )
	42	' ?literal
	43	; immediate
	44
	45	variable if-debug
	46
19ed2c32 PB	47	: ? ( address -- , fatch from address and print value )
	48	@ .
	49	;
	50
8e9db35f PB	51	decimal
	52	create msec-delay 10000 , ( default for SUN )
	53	: (MSEC) ( #msecs -- )
	54	0
	55	do msec-delay @ 0
	56	do loop
	57	loop
	58	;
	59
	60	defer msec
	61	' (msec) is msec
	62
	63	: SHIFT ( val n -- val<<n )
	64	dup 0<
	65	IF negate arshift
	66	ELSE lshift
	67	THEN
	68	;
	69
	70
	71	variable rand-seed here rand-seed !
	72	: random ( -- random_number )
	73	rand-seed @
	74	31421 * 6927 +
	75	65535 and dup rand-seed !
	76	;
	77	: choose ( range -- random_number , in range )
	78	random * -16 shift
	79	;
	80
	81	: wchoose ( hi lo -- random_number )
	82	tuck - choose +
	83	;
	84
	85
	86	\ sort top two items on stack.
	87	: 2sort ( a b -- a<b \| b<a , largest on top of stack)
	88	2dup >
	89	if swap
	90	then
	91	;
	92
	93	\ sort top two items on stack.
	94	: -2sort ( a b -- a>b \| b>a , smallest on top of stack)
	95	2dup <
	96	if swap
	97	then
	98	;
	99
	100	: barray ( #bytes -- ) ( index -- addr )
	101	create allot
	102	does> +
	103	;
	104
	105	: warray ( #words -- ) ( index -- addr )
	106	create 2* allot
	107	does> swap 2* +
	108	;
	109
	110	: array ( #cells -- ) ( index -- addr )
	111	create cell* allot
	112	does> swap cell* +
	113	;
	114
115	: .bin ( n -- , print in binary )
116	base @ binary swap . base !
117	;
118	: .dec ( n -- )
119	base @ decimal swap . base !
120	;
121	: .hex ( n -- )
122	base @ hex swap . base !
123	;
124
125	: B->S ( c -- c' , sign extend byte )
126	dup $ 80 and
127	IF
e14f2533	128	[ $ 0FF invert ] literal or
8e9db35f	129	ELSE
e14f2533	130	$ 0FF and
8e9db35f PB	131	THEN
8e9db35f PB	132	;
e14f2533	133	: W->S ( 16bit-signed -- cell-signed )
8e9db35f	134	dup $ 8000 and
e14f2533 PB	135	IF
e14f2533 PB	136	[ $ 0FFFF invert ] literal or
8e9db35f	137	ELSE
e14f2533 PB	138	$ 0FFFF and
e14f2533 PB	139	THEN
8e9db35f PB	140	;
	141
	142	: WITHIN { n1 n2 n3 -- flag }
	143	n2 n3 <=
	144	IF
	145	n2 n1 <=
	146	n1 n3 < AND
	147	ELSE
	148	n2 n1 <=
	149	n1 n3 < OR
	150	THEN
	151	;
	152
	153	: MOVE ( src dst num -- )
	154	>r 2dup - 0<
	155	IF
	156	r> CMOVE>
	157	ELSE
	158	r> CMOVE
	159	THEN
	160	;
	161
	162	: ERASE ( caddr num -- )
	163	dup 0>
	164	IF
	165	0 fill
	166	ELSE
	167	2drop
	168	THEN
	169	;
	170
	171	: BLANK ( addr u -- , set memory to blank )
	172	DUP 0>
	173	IF
	174	BL FILL
	175	ELSE
	176	2DROP
	177	THEN
	178	;
	179
	180	\ Obsolete but included for CORE EXT word set.
	181	: QUERY REFILL DROP ;
	182	VARIABLE SPAN
	183	: EXPECT accept span ! ;
	184	: TIB source drop ;
	185
	186
	187	: UNUSED ( -- unused , dictionary space )
	188	CODELIMIT HERE -
	189	;
	190
	191	: MAP ( -- , dump interesting dictionary info )
	192	." Code Segment" cr
	193	." CODEBASE = " codebase .hex cr
	194	." HERE = " here .hex cr
	195	." CODELIMIT = " codelimit .hex cr
	196	." Compiled Code Size = " here codebase - . cr
	197	." CODE-SIZE = " code-size @ . cr
	198	." Code Room UNUSED = " UNUSED . cr
	199	." Name Segment" cr
	200	." NAMEBASE = " namebase .hex cr
	201	." HEADERS-PTR @ = " headers-ptr @ .hex cr
	202	." NAMELIMIT = " namelimit .hex cr
	203	." CONTEXT @ = " context @ .hex cr
204	." LATEST = " latest .hex ." = " latest id. cr
205	." Compiled Name size = " headers-ptr @ namebase - . cr
206	." HEADERS-SIZE = " headers-size @ . cr
207	." Name Room Left = " namelimit headers-ptr @ - . cr
208	;
209
210
211	\ Search for substring S2 in S1
212	: SEARCH { addr1 cnt1 addr2 cnt2 \| addr3 cnt3 flag -- addr3 cnt3 flag }
213	\ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
214	\ if true, s1 contains s2 at addr3 with cnt3 chars remaining
215	\ if false, s3 = s1
216	addr1 -> addr3
217	cnt1 -> cnt3
218	cnt1 cnt2 < not
219	IF
220	cnt1 cnt2 - 1+ 0
221	DO
222	true -> flag
223	cnt2 0
224	?DO
225	addr2 i chars + c@
226	addr1 i j + chars + c@ <> \ mismatch?
227	IF
228	false -> flag
229	LEAVE
230	THEN
231	LOOP
232	flag
233	IF
234	addr1 i chars + -> addr3
235	cnt1 i - -> cnt3
236	LEAVE
237	THEN
238	LOOP
239	THEN
240	addr3 cnt3 flag
241	;
242
29bf5876 HE	243	private{
	244
	245	: env= ( c-addr u c-addr1 u1 x -- x true true \| c-addr u false )
	246	{ x } 2over compare 0= if 2drop x true true else false then
	247	;
	248
	249	: 2env= ( c-addr u c-addr1 u1 x y -- x y true true \| c-addr u false )
	250	{ x y } 2over compare 0= if 2drop x y true true else false then
	251	;
	252
	253	0 invert constant max-u
	254	0 invert 1 rshift constant max-n
	255
	256	}private
	257
	258	: ENVIRONMENT? ( c-addr u -- false \| i*x true )
	259	s" /COUNTED-STRING" 255 env= if exit then
	260	s" /HOLD" 128 env= if exit then \ same as PAD
	261	s" /PAD" 128 env= if exit then
	262	s" ADDRESS-UNITS-BITS" 8 env= if exit then
	263	s" FLOORED" false env= if exit then
	264	s" MAX-CHAR" 255 env= if exit then
	265	s" MAX-D" max-n max-u 2env= if exit then
	266	s" MAX-N" max-n env= if exit then
	267	s" MAX-U" max-u env= if exit then
	268	s" MAX-UD" max-u max-u 2env= if exit then
	269	s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH
	270	s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH
47126cac HE	271	\ FIXME: maybe define those:
	272	\ s" FLOATING-STACK"
	273	\ s" MAX-FLOAT"
	274	\ s" #LOCALS"
	275	\ s" WORDLISTS"
29bf5876 HE	276	2drop false
	277	;
	278
	279	privatize