1 \ @(#) misc2.fth 98/01/26 1.2
2 \ Utilities for PForth extracted from HMSL
5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
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.
16 \ 00001 9/14/92 Added call, 'c w->s
17 \ 00002 11/23/92 Moved redef of : to loadcom.fth
21 : 'N ( <name> -- , make 'n state smart )
25 IF namebase - ( make nfa relocatable )
26 [compile] literal ( store nfa of word to be compiled )
32 : ?LITERAL ( n -- , do literal if compiling )
38 : 'c ( <name> -- xt , state sensitive ' )
44 : ? ( address -- , fatch from address and print value )
49 create msec-delay 10000 , ( default for SUN )
50 : (MSEC) ( #msecs -- )
60 : SHIFT ( val n -- val<<n )
68 variable rand-seed here rand-seed !
69 : random ( -- random_number )
72 65535 and dup rand-seed !
74 : choose ( range -- random_number , in range )
78 : wchoose ( hi lo -- random_number )
83 \ sort top two items on stack.
84 : 2sort ( a b -- a<b | b<a , largest on top of stack)
90 \ sort top two items on stack.
91 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
97 : barray ( #bytes -- ) ( index -- addr )
102 : warray ( #words -- ) ( index -- addr )
107 : array ( #cells -- ) ( index -- addr )
112 : .bin ( n -- , print in binary )
113 base @ binary swap . base !
116 base @ decimal swap . base !
119 base @ hex swap . base !
122 : B->S ( c -- c' , sign extend byte )
130 : W->S ( 16bit-signed -- 32bit-signed )
139 : WITHIN { n1 n2 n3 -- flag }
150 : MOVE ( src dst num -- )
159 : ERASE ( caddr num -- )
168 : BLANK ( addr u -- , set memory to blank )
177 \ Obsolete but included for CORE EXT word set.
178 : QUERY REFILL DROP ;
180 : EXPECT accept span ! ;
184 : UNUSED ( -- unused , dictionary space )
188 : MAP ( -- , dump interesting dictionary info )
190 ." CODEBASE = " codebase .hex cr
191 ." HERE = " here .hex cr
192 ." CODELIMIT = " codelimit .hex cr
193 ." Compiled Code Size = " here codebase - . cr
194 ." CODE-SIZE = " code-size @ . cr
195 ." Code Room UNUSED = " UNUSED . cr
197 ." NAMEBASE = " namebase .hex cr
198 ." HEADERS-PTR @ = " headers-ptr @ .hex cr
199 ." NAMELIMIT = " namelimit .hex cr
200 ." CONTEXT @ = " context @ .hex cr
201 ." LATEST = " latest .hex ." = " latest id. cr
202 ." Compiled Name size = " headers-ptr @ namebase - . cr
203 ." HEADERS-SIZE = " headers-size @ . cr
204 ." Name Room Left = " namelimit headers-ptr @ - . cr
208 \ Search for substring S2 in S1
209 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag -- addr3 cnt3 flag }
210 \ ." Search for " addr2 cnt2 type ." in " addr1 cnt1 type cr
211 \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
223 addr1 i j + chars + c@ <> \ mismatch?
231 addr1 i chars + -> addr3
242 : env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
243 { x } 2over compare 0= if 2drop x true true else false then
246 : 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
247 { x y } 2over compare 0= if 2drop x y true true else false then
250 0 invert constant max-u
251 0 invert 1 rshift constant max-n
255 : ENVIRONMENT? ( c-addr u -- false | i*x true )
256 s" /COUNTED-STRING" 255 env= if exit then
257 s" /HOLD" 128 env= if exit then \ same as PAD
258 s" /PAD" 128 env= if exit then
259 s" ADDRESS-UNITS-BITS" 8 env= if exit then
260 s" FLOORED" false env= if exit then
261 s" MAX-CHAR" 255 env= if exit then
262 s" MAX-D" max-n max-u 2env= if exit then
263 s" MAX-N" max-n env= if exit then
264 s" MAX-U" max-u env= if exit then
265 s" MAX-UD" max-u max-u 2env= if exit then
266 s" RETURN-STACK-CELLS" 512 env= if exit then \ DEFAULT_RETURN_DEPTH
267 s" STACK-CELLS" 512 env= if exit then \ DEFAULT_USER_DEPTH
268 \ FIXME: maybe define those: