[pforth] / fth / misc2.fth

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