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

   1 \ @(#) misc2.fth 98/01/26 1.2\r
   2 \ Utilities for PForth extracted from HMSL\r
   3 \\r
   4 \ Author: Phil Burk\r
   5 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
   6 \\r
   7 \ The pForth software code is dedicated to the public domain,\r
   8 \ and any third party may reproduce, distribute and modify\r
   9 \ the pForth software code or any derivative works thereof\r
  10 \ without any compensation or license.  The pForth software\r
  11 \ code is provided on an "as is" basis without any warranty\r
  12 \ of any kind, including, without limitation, the implied\r
  13 \ warranties of merchantability and fitness for a particular\r
  14 \ purpose and their equivalents under the laws of any jurisdiction.\r
  15 \\r
  16 \ 00001 9/14/92 Added call, 'c w->s\r
  17 \ 00002 11/23/92 Moved redef of : to loadcom.fth\r
  18 \r
  19 anew task-misc2.fth\r
  20 \r
  21 : 'N  ( <name> -- , make 'n state smart )\r
  22         bl word find\r
  23         IF\r
  24                 state @\r
  25                 IF      namebase - ( make nfa relocatable )\r
  26                         [compile] literal       ( store nfa of word to be compiled )\r
  27                         compile namebase+\r
  28                 THEN\r
  29         THEN\r
  30 ; IMMEDIATE\r
  31 \r
  32 : ?LITERAL  ( n -- , do literal if compiling )\r
  33         state @\r
  34         IF [compile] literal\r
  35         THEN\r
  36 ;\r
  37 \r
  38 : 'c ( <name> -- xt , state sensitive ' )\r
  39         ' ?literal\r
  40 ; immediate\r
  41 \r
  42 variable if-debug\r
  43 \r
  44 decimal\r
  45 create msec-delay 10000 ,  ( default for SUN )\r
  46 : (MSEC) ( #msecs -- )\r
  47     0\r
  48     do  msec-delay @ 0\r
  49         do loop\r
  50     loop\r
  51 ;\r
  52 \r
  53 defer msec\r
  54 ' (msec) is msec\r
  55 \r
  56 : SHIFT ( val n -- val<<n )\r
  57         dup 0<\r
  58         IF negate arshift\r
  59         ELSE lshift\r
  60         THEN\r
  61 ;\r
  62 \r
  63 \r
  64 variable rand-seed here rand-seed !\r
  65 : random ( -- random_number )\r
  66     rand-seed @\r
  67     31421 * 6927 + \r
  68     65535 and dup rand-seed !\r
  69 ;\r
  70 : choose  ( range -- random_number , in range )\r
  71     random * -16 shift\r
  72 ;\r
  73 \r
  74 : wchoose ( hi lo -- random_number )\r
  75     tuck - choose +\r
  76 ;\r
  77 \r
  78 \r
  79 \ sort top two items on stack.\r
  80 : 2sort ( a b -- a<b | b<a , largest on top of stack)\r
  81     2dup >\r
  82     if swap\r
  83     then\r
  84 ;\r
  85 \r
  86 \ sort top two items on stack.\r
  87 : -2sort ( a b -- a>b | b>a , smallest on top of stack)\r
  88     2dup <\r
  89     if swap\r
  90     then\r
  91 ;\r
  92 \r
  93 : barray  ( #bytes -- ) ( index -- addr )\r
  94     create allot\r
  95     does>  +\r
  96 ;\r
  97 \r
  98 : warray  ( #words -- ) ( index -- addr )\r
  99     create 2* allot\r
 100     does> swap 2* +\r
 101 ;\r
 102 \r
 103 : array  ( #cells -- ) ( index -- addr )\r
 104     create cell* allot\r
 105     does> swap cell* +\r
 106 ;\r
 107 \r
 108 : .bin  ( n -- , print in binary )\r
 109     base @ binary swap . base !\r
 110 ;\r
 111 : .dec  ( n -- )\r
 112     base @ decimal swap . base !\r
 113 ;\r
 114 : .hex  ( n -- )\r
 115     base @ hex swap . base !\r
 116 ;\r
 117 \r
 118 : B->S ( c -- c' , sign extend byte )\r
 119         dup $ 80 and \r
 120         IF\r
 121                 $ FFFFFF00 or\r
 122         ELSE\r
 123                 $ 000000FF and\r
 124         THEN\r
 125 ;\r
 126 : W->S ( 16bit-signed -- 32bit-signed )\r
 127         dup $ 8000 and\r
 128         if\r
 129                 $ FFFF0000 or\r
 130         ELSE\r
 131                 $ 0000FFFF and\r
 132         then\r
 133 ;\r
 134 \r
 135 : WITHIN { n1 n2 n3 -- flag }\r
 136         n2 n3 <=\r
 137         IF\r
 138                 n2 n1 <=\r
 139                 n1 n3 <  AND\r
 140         ELSE\r
 141                 n2 n1 <=\r
 142                 n1 n3 <  OR\r
 143         THEN\r
 144 ;\r
 145 \r
 146 : MOVE ( src dst num -- )\r
 147         >r 2dup - 0<\r
 148         IF\r
 149                 r> CMOVE>\r
 150         ELSE\r
 151                 r> CMOVE\r
 152         THEN\r
 153 ;\r
 154 \r
 155 : ERASE ( caddr num -- )\r
 156         dup 0>\r
 157         IF\r
 158                 0 fill\r
 159         ELSE\r
 160                 2drop\r
 161         THEN\r
 162 ;\r
 163 \r
 164 : BLANK ( addr u -- , set memory to blank )\r
 165         DUP 0>\r
 166         IF\r
 167                 BL FILL \r
 168         ELSE \r
 169                 2DROP \r
 170         THEN \r
 171 ;\r
 172 \r
 173 \ Obsolete but included for CORE EXT word set.\r
 174 : QUERY REFILL DROP ;\r
 175 VARIABLE SPAN\r
 176 : EXPECT accept span ! ;\r
 177 : TIB source drop ;\r
 178 \r
 179 \r
 180 : UNUSED ( -- unused , dictionary space )\r
 181         CODELIMIT HERE -\r
 182 ;\r
 183 \r
 184 : MAP  ( -- , dump interesting dictionary info )\r
 185         ." Code Segment" cr\r
 186         ."    CODEBASE           = " codebase .hex cr\r
 187         ."    HERE               = " here .hex cr\r
 188         ."    CODELIMIT          = " codelimit .hex cr\r
 189         ."    Compiled Code Size = " here codebase - . cr\r
 190         ."    CODE-SIZE          = " code-size @ . cr\r
 191         ."    Code Room UNUSED   = " UNUSED . cr\r
 192         ." Name Segment" cr\r
 193         ."    NAMEBASE           = " namebase .hex cr\r
 194         ."    HEADERS-PTR @      = " headers-ptr @ .hex cr\r
 195         ."    NAMELIMIT          = " namelimit .hex cr\r
 196         ."    CONTEXT @          = " context @ .hex cr\r
 197         ."    LATEST             = " latest .hex  ."  = " latest id. cr\r
 198         ."    Compiled Name size = " headers-ptr @ namebase - . cr\r
 199         ."    HEADERS-SIZE       = " headers-size @ . cr\r
 200         ."    Name Room Left     = " namelimit headers-ptr @ - . cr\r
 201 ;\r
 202 \r
 203 \r
 204 \ Search for substring S2 in S1\r
 205 : SEARCH { addr1 cnt1 addr2 cnt2 | addr3 cnt3 flag --  addr3 cnt3 flag }\r
 206 \ ." Search for " addr2 cnt2 type  ."  in "  addr1 cnt1 type cr\r
 207 \ if true, s1 contains s2 at addr3 with cnt3 chars remaining\r
 208 \ if false, s3 = s1     \r
 209         addr1 -> addr3\r
 210         cnt1 -> cnt3\r
 211         cnt1 cnt2 < not\r
 212         IF\r
 213             cnt1 cnt2 - 1+ 0\r
 214                 DO\r
 215                         true -> flag\r
 216                         cnt2 0\r
 217                         ?DO\r
 218                                 addr2 i chars + c@\r
 219                                 addr1 i j + chars + c@ <> \ mismatch?\r
 220                                 IF\r
 221                                         false -> flag\r
 222                                         LEAVE\r
 223                                 THEN\r
 224                         LOOP\r
 225                         flag\r
 226                         IF\r
 227                                 addr1 i chars + -> addr3\r
 228                                 cnt1 i - -> cnt3\r
 229                                 LEAVE\r
 230                         THEN\r
 231                 LOOP\r
 232         THEN\r
 233         addr3 cnt3 flag\r
 234 ;\r
 235 \r