| 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, David 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 | |
| 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 |
| 264 | \ FIXME: maybe define those: |
| 265 | \ s" FLOATING-STACK" |
| 266 | \ s" MAX-FLOAT" |
| 267 | \ s" #LOCALS" |
| 268 | \ s" WORDLISTS" |
| 269 | 2drop false |
| 270 | ; |
| 271 | |
| 272 | privatize |