git.gag.com Git - debian/pforth/blob - 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 1000 ,  ( default for SUN )
  46 : msec ( #msecs -- )
  47     0
  48     do  msec-delay @ 0
  49         do loop
  50     loop
  51 ;
  52
  53 : SHIFT ( val n -- val<<n )
  54         dup 0<
  55         IF negate arshift
  56         ELSE lshift
  57         THEN
  58 ;
  59
  60
  61 variable rand-seed here rand-seed !
  62 : random ( -- random_number )
  63     rand-seed @
  64     31421 * 6927 +
  65     65535 and dup rand-seed !
  66 ;
  67 : choose  ( range -- random_number , in range )
  68     random * -16 shift
  69 ;
  70
  71 : wchoose ( hi lo -- random_number )
  72     tuck - choose +
  73 ;
  74
  75
  76 \ sort top two items on stack.
  77 : 2sort ( a b -- a<b | b<a , largest on top of stack)
  78     2dup >
  79     if swap
  80     then
  81 ;
  82
  83 \ sort top two items on stack.
  84 : -2sort ( a b -- a>b | b>a , smallest on top of stack)
  85     2dup <
  86     if swap
  87     then
  88 ;
  89
  90 : barray  ( #bytes -- ) ( index -- addr )
  91     create allot
  92     does>  +
  93 ;
  94
  95 : warray  ( #words -- ) ( index -- addr )
  96     create 2* allot
  97     does> swap 2* +
  98 ;
  99
 100 : array  ( #cells -- ) ( index -- addr )
 101     create cell* allot
 102     does> swap cell* +
 103 ;
 104
 105 : .bin  ( n -- , print in binary )
 106     base @ binary swap . base !
 107 ;
 108 : .dec  ( n -- )
 109     base @ decimal swap . base !
 110 ;
 111 : .hex  ( n -- )
 112     base @ hex swap . base !
 113 ;
 114
 115 : B->S ( c -- c' , sign extend byte )
 116         dup $ 80 and
 117         IF
 118                 $ FFFFFF00 or
 119         ELSE
 120                 $ 000000FF and
 121         THEN
 122 ;
 123 : W->S ( 16bit-signed -- 32bit-signed )
 124         dup $ 8000 and
 125         if
 126                 $ FFFF0000 or
 127         ELSE
 128                 $ 0000FFFF and
 129         then
 130 ;
 131
 132 : WITHIN { n1 n2 n3 -- flag }
 133         n2 n3 <=
 134         IF
 135                 n2 n1 <=
 136                 n1 n3 <  AND
 137         ELSE
 138                 n2 n1 <=
 139                 n1 n3 <  OR
 140         THEN
 141 ;
 142
 143 : MOVE ( src dst num -- )
 144         >r 2dup - 0<
 145         IF
 146                 r> CMOVE>
 147         ELSE
 148                 r> CMOVE
 149         THEN
 150 ;
 151
 152 : ERASE ( caddr num -- )
 153         dup 0>
 154         IF
 155                 0 fill
 156         ELSE
 157                 2drop
 158         THEN
 159 ;
 160
 161 : BLANK ( addr u -- , set memory to blank )
 162         DUP 0>
 163         IF
 164                 BL FILL
 165         ELSE
 166                 2DROP
 167         THEN
 168 ;
 169
 170 \ Obsolete but included for CORE EXT word set.
 171 : QUERY REFILL DROP ;
 172 VARIABLE SPAN
 173 : EXPECT accept span ! ;
 174 : TIB source drop ;
 175
 176
 177 : UNUSED ( -- unused , dictionary space )
 178         CODELIMIT HERE -
 179 ;
 180
 181 : MAP  ( -- , dump interesting dictionary info )
 182         ." Code Segment" cr
 183         ."    CODEBASE           = " codebase .hex cr
 184         ."    HERE               = " here .hex cr
 185         ."    CODELIMIT          = " codelimit .hex cr
 186         ."    Compiled Code Size = " here codebase - . cr
 187         ."    CODE-SIZE          = " code-size @ . cr
 188         ."    Code Room UNUSED   = " UNUSED . cr
 189         ." Name Segment" cr
 190         ."    NAMEBASE           = " namebase .hex cr
 191         ."    HEADERS-PTR @      = " headers-ptr @ .hex cr
 192         ."    NAMELIMIT          = " namelimit .hex cr
 193         ."    CONTEXT @          = " context @ .hex cr
 194         ."    LATEST             = " latest .hex  ."  = " latest id. cr
 195         ."    Compiled Name size = " headers-ptr @ namebase - . cr
 196         ."    HEADERS-SIZE       = " headers-size @ . cr
 197         ."    Name Room Left     = " namelimit headers-ptr @ - . cr
 198 ;
 199
 200
 201 \ Search for substring S2 in S1
 202 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }
 203 \ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr
 204 \ if true, s1 contains s2 at addr3 with cnt3 chars remaining
 205 \ if false, s3 = s1
 206         addr1 -> addr3
 207         cnt1 -> cnt3
 208         cnt1 cnt2 < not
 209         IF
 210             cnt1 cnt2 - 1+ 0
 211                 DO
 212                         true -> flag
 213                         cnt2 0
 214                         ?DO
 215                                 addr2 i chars + c@
 216                                 addr1 i j + chars + c@ <> \ mismatch?
 217                                 IF
 218                                         false -> flag
 219                                         LEAVE
 220                                 THEN
 221                         LOOP
 222                         flag
 223                         IF
 224                                 addr1 i chars + -> addr3
 225                                 cnt1 i - -> cnt3
 226                                 LEAVE
 227                         THEN
 228                 LOOP
 229         THEN
 230         addr3 cnt3 flag
 231 ;
 232