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 \ 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 : ? ( address -- , fatch from address and print value )
  45     @ .
  46 ;
  47
  48 decimal
  49 create msec-delay 10000 ,  ( default for SUN )
  50 : (MSEC) ( #msecs -- )
  51     0
  52     do  msec-delay @ 0
  53         do loop
  54     loop
  55 ;
  56
  57 defer msec
  58 ' (msec) is msec
  59
  60 : SHIFT ( val n -- val<<n )
  61     dup 0<
  62     IF negate arshift
  63     ELSE lshift
  64     THEN
  65 ;
  66
  67
  68 variable rand-seed here rand-seed !
  69 : random ( -- random_number )
  70     rand-seed @
  71     31421 * 6927 +
  72     65535 and dup rand-seed !
  73 ;
  74 : choose  ( range -- random_number , in range )
  75     random * -16 shift
  76 ;
  77
  78 : wchoose ( hi lo -- random_number )
  79     tuck - choose +
  80 ;
  81
  82
  83 \ sort top two items on stack.
  84 : 2sort ( a b -- a<b | b<a , largest on top of stack)
  85     2dup >
  86     if swap
  87     then
  88 ;
  89
  90 \ sort top two items on stack.
  91 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
  92     2dup <
  93     if swap
  94     then
  95 ;
  96
  97 : barray  ( #bytes -- ) ( index -- addr )
  98     create allot
  99     does>  +
 100 ;
 101
 102 : warray  ( #words -- ) ( index -- addr )
 103     create 2* allot
 104     does> swap 2* +
 105 ;
 106
 107 : array  ( #cells -- ) ( index -- addr )
 108     create cell* allot
 109     does> swap cell* +
 110 ;
 111
 112 : .bin  ( n -- , print in binary )
 113     base @ binary swap . base !
 114 ;
 115 : .dec  ( n -- )
 116     base @ decimal swap . base !
 117 ;
 118 : .hex  ( n -- )
 119     base @ hex swap . base !
 120 ;
 121
 122 : B->S ( c -- c' , sign extend byte )
 123     dup $ 80 and
 124     IF
 125         $ FFFFFF00 or
 126     ELSE
 127         $ 000000FF and
 128     THEN
 129 ;
 130 : W->S ( 16bit-signed -- 32bit-signed )
 131     dup $ 8000 and
 132     if
 133         $ FFFF0000 or
 134     ELSE
 135         $ 0000FFFF and
 136     then
 137 ;
 138
 139 : WITHIN { n1 n2 n3 -- flag }
 140     n2 n3 <=
 141     IF
 142         n2 n1 <=
 143         n1 n3 <  AND
 144     ELSE
 145         n2 n1 <=
 146         n1 n3 <  OR
 147     THEN
 148 ;
 149
 150 : MOVE ( src dst num -- )
 151     >r 2dup - 0<
 152     IF
 153         r> CMOVE>
 154     ELSE
 155         r> CMOVE
 156     THEN
 157 ;
 158
 159 : ERASE ( caddr num -- )
 160     dup 0>
 161     IF
 162         0 fill
 163     ELSE
 164         2drop
 165     THEN
 166 ;
 167
 168 : BLANK ( addr u -- , set memory to blank )
 169     DUP 0>
 170     IF
 171         BL FILL
 172     ELSE
 173         2DROP
 174     THEN
 175 ;
 176
 177 \ Obsolete but included for CORE EXT word set.
 178 : QUERY REFILL DROP ;
 179 VARIABLE SPAN
 180 : EXPECT accept span ! ;
 181 : TIB source drop ;
 182
 183
 184 : UNUSED ( -- unused , dictionary space )
 185     CODELIMIT HERE -
 186 ;
 187
 188 : MAP  ( -- , dump interesting dictionary info )
 189     ." Code Segment" cr
 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
 196     ." Name Segment" 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
 205 ;
 206
 207
 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
 212 \ if false, s3 = s1
 213     addr1 -> addr3
 214     cnt1 -> cnt3
 215     cnt1 cnt2 < not
 216     IF
 217         cnt1 cnt2 - 1+ 0
 218         DO
 219             true -> flag
 220             cnt2 0
 221             ?DO
 222                 addr2 i chars + c@
 223                 addr1 i j + chars + c@ <> \ mismatch?
 224                 IF
 225                     false -> flag
 226                     LEAVE
 227                 THEN
 228             LOOP
 229             flag
 230             IF
 231                 addr1 i chars + -> addr3
 232                 cnt1 i - -> cnt3
 233                 LEAVE
 234             THEN
 235         LOOP
 236     THEN
 237     addr3 cnt3 flag
 238 ;
 239
 240 private{
 241
 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
 244 ;
 245
 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
 248 ;
 249
 250 0 invert constant max-u
 251 0 invert 1 rshift constant max-n
 252
 253 }private
 254
 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:
 269     \ s" FLOATING-STACK"
 270     \ s" MAX-FLOAT"
 271     \ s" #LOCALS"
 272     \ s" WORDLISTS"
 273     2drop false
 274 ;
 275
 276 privatize