1 \ @(#) misc2.fth 98/01/26 1.2
\r
2 \ Utilities for PForth extracted from HMSL
\r
5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
\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
16 \ 00001 9/14/92 Added call, 'c w->s
\r
17 \ 00002 11/23/92 Moved redef of : to loadcom.fth
\r
21 : 'N ( <name> -- , make 'n state smart )
\r
25 IF namebase - ( make nfa relocatable )
\r
26 [compile] literal ( store nfa of word to be compiled )
\r
32 : ?LITERAL ( n -- , do literal if compiling )
\r
34 IF [compile] literal
\r
38 : 'c ( <name> -- xt , state sensitive ' )
\r
45 create msec-delay 10000 , ( default for SUN )
\r
46 : (MSEC) ( #msecs -- )
\r
56 : SHIFT ( val n -- val<<n )
\r
64 variable rand-seed here rand-seed !
\r
65 : random ( -- random_number )
\r
68 65535 and dup rand-seed !
\r
70 : choose ( range -- random_number , in range )
\r
74 : wchoose ( hi lo -- random_number )
\r
79 \ sort top two items on stack.
\r
80 : 2sort ( a b -- a<b | b<a , largest on top of stack)
\r
86 \ sort top two items on stack.
\r
87 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
\r
93 : barray ( #bytes -- ) ( index -- addr )
\r
98 : warray ( #words -- ) ( index -- addr )
\r
103 : array ( #cells -- ) ( index -- addr )
\r
108 : .bin ( n -- , print in binary )
\r
109 base @ binary swap . base !
\r
112 base @ decimal swap . base !
\r
115 base @ hex swap . base !
\r
118 : B->S ( c -- c' , sign extend byte )
\r
126 : W->S ( 16bit-signed -- 32bit-signed )
\r
135 : WITHIN { n1 n2 n3 -- flag }
\r
146 : MOVE ( src dst num -- )
\r
155 : ERASE ( caddr num -- )
\r
164 : BLANK ( addr u -- , set memory to blank )
\r
173 \ Obsolete but included for CORE EXT word set.
\r
174 : QUERY REFILL DROP ;
\r
176 : EXPECT accept span ! ;
\r
177 : TIB source drop ;
\r
180 : UNUSED ( -- unused , dictionary space )
\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
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
219 addr1 i j + chars + c@ <> \ mismatch?
\r
227 addr1 i chars + -> addr3
\r