git.gag.com Git - debian/pforth/blob - fth/misc2.fth

   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 \ Permission to use, copy, modify, and/or distribute this
   8 \ software for any purpose with or without fee is hereby granted.
   9 \
  10 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  11 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  12 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  13 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  14 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  15 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  16 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  17 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  18 \
  19 \ 00001 9/14/92 Added call, 'c w->s
  20 \ 00002 11/23/92 Moved redef of : to loadcom.fth
  21
  22 anew task-misc2.fth
  23
  24 : 'N  ( <name> -- , make 'n state smart )
  25     bl word find
  26     IF
  27         state @
  28         IF  namebase - ( make nfa relocatable )
  29             [compile] literal   ( store nfa of word to be compiled )
  30             compile namebase+
  31         THEN
  32     THEN
  33 ; IMMEDIATE
  34
  35 : ?LITERAL  ( n -- , do literal if compiling )
  36     state @
  37     IF [compile] literal
  38     THEN
  39 ;
  40
  41 : 'c ( <name> -- xt , state sensitive ' )
  42     ' ?literal
  43 ; immediate
  44
  45 variable if-debug
  46
  47 : ? ( address -- , fatch from address and print value )
  48     @ .
  49 ;
  50
  51 decimal
  52 create MSEC-DELAY 100000 ,   \ calibrate this for your system
  53 : (MSEC.SPIN) ( #msecs -- , busy wait, not accurate )
  54     0 max   \ avoid endless loop
  55     0
  56     ?do  msec-delay @ 0
  57         do loop
  58     loop
  59 ;
  60
  61 : (MSEC) ( millis -- )
  62     dup (sleep) \ call system sleep in kernel
  63     IF
  64         ." (SLEEP) failed or not implemented! Using (MSEC.SPIN)" CR
  65         (msec.spin)
  66     ELSE
  67         drop
  68     THEN
  69 ;
  70
  71 defer msec
  72
  73 \ (SLEEP) uses system sleep functions to actually sleep.
  74 \ Use (MSEC.SPIN) on embedded systems that do not support Win32 Sleep() posix usleep().
  75 1 (SLEEP) [IF]
  76     ." (SLEEP) failed or not implemented! Use (MSEC.SPIN) for MSEC" CR
  77     ' (msec.spin) is msec
  78 [ELSE]
  79     ' (msec) is msec
  80 [THEN]
  81
  82 : MS ( msec -- , sleep, ANS standard )
  83     msec
  84 ;
  85
  86 : SHIFT ( val n -- val<<n )
  87     dup 0<
  88     IF negate arshift
  89     ELSE lshift
  90     THEN
  91 ;
  92
  93 variable rand-seed here rand-seed !
  94 : random ( -- random_number )
  95     rand-seed @
  96     31421 * 6927 +
  97     65535 and dup rand-seed !
  98 ;
  99 : choose  ( range -- random_number , in range )
 100     random * -16 shift
 101 ;
 102
 103 : wchoose ( hi lo -- random_number )
 104     tuck - choose +
 105 ;
 106
 107
 108 \ sort top two items on stack.
 109 : 2sort ( a b -- a<b | b<a , largest on top of stack)
 110     2dup >
 111     if swap
 112     then
 113 ;
 114
 115 \ sort top two items on stack.
 116 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
 117     2dup <
 118     if swap
 119     then
 120 ;
 121
 122 : barray  ( #bytes -- ) ( index -- addr )
 123     create allot
 124     does>  +
 125 ;
 126
 127 : warray  ( #words -- ) ( index -- addr )
 128     create 2* allot
 129     does> swap 2* +
 130 ;
 131
 132 : array  ( #cells -- ) ( index -- addr )
 133     create cell* allot
 134     does> swap cell* +
 135 ;
 136
 137 : .bin  ( n -- , print in binary )
 138     base @ binary swap . base !
 139 ;
 140 : .dec  ( n -- )
 141     base @ decimal swap . base !
 142 ;
 143 : .hex  ( n -- )
 144     base @ hex swap . base !
 145 ;
 146
 147 : B->S ( c -- c' , sign extend byte )
 148     dup $ 80 and
 149     IF
 150         [ $ 0FF invert ] literal or
 151     ELSE
 152         $ 0FF and
 153     THEN
 154 ;
 155 : W->S ( 16bit-signed -- cell-signed )
 156     dup $ 8000 and
 157     IF
 158         [ $ 0FFFF invert ] literal or
 159     ELSE
 160         $ 0FFFF and
 161     THEN
 162 ;
 163
 164 : WITHIN { n1 n2 n3 -- flag }
 165     n2 n3 <=
 166     IF
 167         n2 n1 <=
 168         n1 n3 <  AND
 169     ELSE
 170         n2 n1 <=
 171         n1 n3 <  OR
 172     THEN
 173 ;
 174
 175 : MOVE ( src dst num -- )
 176     >r 2dup - 0<
 177     IF
 178         r> CMOVE>
 179     ELSE
 180         r> CMOVE
 181     THEN
 182 ;
 183
 184 : ERASE ( caddr num -- )
 185     dup 0>
 186     IF
 187         0 fill
 188     ELSE
 189         2drop
 190     THEN
 191 ;
 192
 193 : BLANK ( addr u -- , set memory to blank )
 194     DUP 0>
 195     IF
 196         BL FILL
 197     ELSE
 198         2DROP
 199     THEN
 200 ;
 201
 202 \ Obsolete but included for CORE EXT word set.
 203 : QUERY REFILL DROP ;
 204 VARIABLE SPAN
 205 : EXPECT accept span ! ;
 206 : TIB source drop ;
 207
 208
 209 : UNUSED ( -- unused , dictionary space )
 210     CODELIMIT HERE -
 211 ;
 212
 213 : MAP  ( -- , dump interesting dictionary info )
 214     ." Code Segment" cr
 215     ."    CODEBASE           = " codebase .hex cr
 216     ."    HERE               = " here .hex cr
 217     ."    CODELIMIT          = " codelimit .hex cr
 218     ."    Compiled Code Size = " here codebase - . cr
 219     ."    CODE-SIZE          = " code-size @ . cr
 220     ."    Code Room UNUSED   = " UNUSED . cr
 221     ." Name Segment" cr
 222     ."    NAMEBASE           = " namebase .hex cr
 223     ."    HEADERS-PTR @      = " headers-ptr @ .hex cr
 224     ."    NAMELIMIT          = " namelimit .hex cr
 225     ."    CONTEXT @          = " context @ .hex cr
 226     ."    LATEST             = " latest .hex  ."  = " latest id. cr
 227     ."    Compiled Name size = " headers-ptr @ namebase - . cr
 228     ."    HEADERS-SIZE       = " headers-size @ . cr
 229     ."    Name Room Left     = " namelimit headers-ptr @ - . cr
 230 ;
 231
 232
 233 \ Search for substring S2 in S1
 234 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }
 235 \ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr
 236 \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
 237 \ if false, s3 = s1
 238     addr1 -> addr3
 239     cnt1 -> cnt3
 240     cnt1 cnt2 < not
 241     IF
 242         cnt1 cnt2 - 1+ 0
 243         DO
 244             true -> flag
 245             cnt2 0
 246             ?DO
 247                 addr2 i chars + c@
 248                 addr1 i j + chars + c@ <> \ mismatch?
 249                 IF
 250                     false -> flag
 251                     LEAVE
 252                 THEN
 253             LOOP
 254             flag
 255             IF
 256                 addr1 i chars + -> addr3
 257                 cnt1 i - -> cnt3
 258                 LEAVE
 259             THEN
 260         LOOP
 261     THEN
 262     addr3 cnt3 flag
 263 ;
 264
 265 private{
 266
 267 : env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
 268     { x } 2over compare 0= if 2drop x true true else false then
 269 ;
 270
 271 : 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
 272     { x y } 2over compare 0= if 2drop x y true true else false then
 273 ;
 274
 275 0 invert constant max-u
 276 0 invert 1 rshift constant max-n
 277
 278 }private
 279
 280 : ENVIRONMENT? ( c-addr u -- false | i*x true )
 281     s" /COUNTED-STRING"      255 env= if exit then
 282     s" /HOLD"                128 env= if exit then \ same as PAD
 283     s" /PAD"                 128 env= if exit then
 284     s" ADDRESS-UNITS-BITS"     8 env= if exit then
 285     s" FLOORED"            false env= if exit then
 286     s" MAX-CHAR"             255 env= if exit then
 287     s" MAX-D"       max-n max-u 2env= if exit then
 288     s" MAX-N"              max-n env= if exit then
 289     s" MAX-U"              max-u env= if exit then
 290     s" MAX-UD"      max-u max-u 2env= if exit then
 291     s" RETURN-STACK-CELLS"   512 env= if exit then \ DEFAULT_RETURN_DEPTH
 292     s" STACK-CELLS"          512 env= if exit then \ DEFAULT_USER_DEPTH
 293     \ FIXME: maybe define those:
 294     \ s" FLOATING-STACK"
 295     \ s" MAX-FLOAT"
 296     \ s" #LOCALS"
 297     \ s" WORDLISTS"
 298     2drop false
 299 ;
 300
 301 privatize