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, Devid 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