[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, 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 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
        $ 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
;

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