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 10000 ,  ( default for SUN )
  53 : (MSEC) ( #msecs -- )
  54     0
  55     do  msec-delay @ 0
  56         do loop
  57     loop
  58 ;
  59
  60 defer msec
  61 ' (msec) is msec
  62
  63 : SHIFT ( val n -- val<<n )
  64     dup 0<
  65     IF negate arshift
  66     ELSE lshift
  67     THEN
  68 ;
  69
  70
  71 variable rand-seed here rand-seed !
  72 : random ( -- random_number )
  73     rand-seed @
  74     31421 * 6927 +
  75     65535 and dup rand-seed !
  76 ;
  77 : choose  ( range -- random_number , in range )
  78     random * -16 shift
  79 ;
  80
  81 : wchoose ( hi lo -- random_number )
  82     tuck - choose +
  83 ;
  84
  85
  86 \ sort top two items on stack.
  87 : 2sort ( a b -- a<b | b<a , largest on top of stack)
  88     2dup >
  89     if swap
  90     then
  91 ;
  92
  93 \ sort top two items on stack.
  94 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
  95     2dup <
  96     if swap
  97     then
  98 ;
  99
 100 : barray  ( #bytes -- ) ( index -- addr )
 101     create allot
 102     does>  +
 103 ;
 104
 105 : warray  ( #words -- ) ( index -- addr )
 106     create 2* allot
 107     does> swap 2* +
 108 ;
 109
 110 : array  ( #cells -- ) ( index -- addr )
 111     create cell* allot
 112     does> swap cell* +
 113 ;
 114
 115 : .bin  ( n -- , print in binary )
 116     base @ binary swap . base !
 117 ;
 118 : .dec  ( n -- )
 119     base @ decimal swap . base !
 120 ;
 121 : .hex  ( n -- )
 122     base @ hex swap . base !
 123 ;
 124
 125 : B->S ( c -- c' , sign extend byte )
 126     dup $ 80 and
 127     IF
 128         [ $ 0FF invert ] literal or
 129     ELSE
 130         $ 0FF and
 131     THEN
 132 ;
 133 : W->S ( 16bit-signed -- cell-signed )
 134     dup $ 8000 and
 135     IF
 136         [ $ 0FFFF invert ] literal or
 137     ELSE
 138         $ 0FFFF and
 139     THEN
 140 ;
 141
 142 : WITHIN { n1 n2 n3 -- flag }
 143     n2 n3 <=
 144     IF
 145         n2 n1 <=
 146         n1 n3 <  AND
 147     ELSE
 148         n2 n1 <=
 149         n1 n3 <  OR
 150     THEN
 151 ;
 152
 153 : MOVE ( src dst num -- )
 154     >r 2dup - 0<
 155     IF
 156         r> CMOVE>
 157     ELSE
 158         r> CMOVE
 159     THEN
 160 ;
 161
 162 : ERASE ( caddr num -- )
 163     dup 0>
 164     IF
 165         0 fill
 166     ELSE
 167         2drop
 168     THEN
 169 ;
 170
 171 : BLANK ( addr u -- , set memory to blank )
 172     DUP 0>
 173     IF
 174         BL FILL
 175     ELSE
 176         2DROP
 177     THEN
 178 ;
 179
 180 \ Obsolete but included for CORE EXT word set.
 181 : QUERY REFILL DROP ;
 182 VARIABLE SPAN
 183 : EXPECT accept span ! ;
 184 : TIB source drop ;
 185
 186
 187 : UNUSED ( -- unused , dictionary space )
 188     CODELIMIT HERE -
 189 ;
 190
 191 : MAP  ( -- , dump interesting dictionary info )
 192     ." Code Segment" cr
 193     ."    CODEBASE           = " codebase .hex cr
 194     ."    HERE               = " here .hex cr
 195     ."    CODELIMIT          = " codelimit .hex cr
 196     ."    Compiled Code Size = " here codebase - . cr
 197     ."    CODE-SIZE          = " code-size @ . cr
 198     ."    Code Room UNUSED   = " UNUSED . cr
 199     ." Name Segment" cr
 200     ."    NAMEBASE           = " namebase .hex cr
 201     ."    HEADERS-PTR @      = " headers-ptr @ .hex cr
 202     ."    NAMELIMIT          = " namelimit .hex cr
 203     ."    CONTEXT @          = " context @ .hex cr
 204     ."    LATEST             = " latest .hex  ."  = " latest id. cr
 205     ."    Compiled Name size = " headers-ptr @ namebase - . cr
 206     ."    HEADERS-SIZE       = " headers-size @ . cr
 207     ."    Name Room Left     = " namelimit headers-ptr @ - . cr
 208 ;
 209
 210
 211 \ Search for substring S2 in S1
 212 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }
 213 \ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr
 214 \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
 215 \ if false, s3 = s1
 216     addr1 -> addr3
 217     cnt1 -> cnt3
 218     cnt1 cnt2 < not
 219     IF
 220         cnt1 cnt2 - 1+ 0
 221         DO
 222             true -> flag
 223             cnt2 0
 224             ?DO
 225                 addr2 i chars + c@
 226                 addr1 i j + chars + c@ <> \ mismatch?
 227                 IF
 228                     false -> flag
 229                     LEAVE
 230                 THEN
 231             LOOP
 232             flag
 233             IF
 234                 addr1 i chars + -> addr3
 235                 cnt1 i - -> cnt3
 236                 LEAVE
 237             THEN
 238         LOOP
 239     THEN
 240     addr3 cnt3 flag
 241 ;
 242
 243 private{
 244
 245 : env= ( c-addr u c-addr1 u1 x -- x true true | c-addr u false )
 246     { x } 2over compare 0= if 2drop x true true else false then
 247 ;
 248
 249 : 2env= ( c-addr u c-addr1 u1 x y -- x y true true | c-addr u false )
 250     { x y } 2over compare 0= if 2drop x y true true else false then
 251 ;
 252
 253 0 invert constant max-u
 254 0 invert 1 rshift constant max-n
 255
 256 }private
 257
 258 : ENVIRONMENT? ( c-addr u -- false | i*x true )
 259     s" /COUNTED-STRING"      255 env= if exit then
 260     s" /HOLD"                128 env= if exit then \ same as PAD
 261     s" /PAD"                 128 env= if exit then
 262     s" ADDRESS-UNITS-BITS"     8 env= if exit then
 263     s" FLOORED"            false env= if exit then
 264     s" MAX-CHAR"             255 env= if exit then
 265     s" MAX-D"       max-n max-u 2env= if exit then
 266     s" MAX-N"              max-n env= if exit then
 267     s" MAX-U"              max-u env= if exit then
 268     s" MAX-UD"      max-u max-u 2env= if exit then
 269     s" RETURN-STACK-CELLS"   512 env= if exit then \ DEFAULT_RETURN_DEPTH
 270     s" STACK-CELLS"          512 env= if exit then \ DEFAULT_USER_DEPTH
 271     \ FIXME: maybe define those:
 272     \ s" FLOATING-STACK"
 273     \ s" MAX-FLOAT"
 274     \ s" #LOCALS"
 275     \ s" WORDLISTS"
 276     2drop false
 277 ;
 278
 279 privatize