usr/src/common/ficl/softcore/softcore.fr

   1 \ ** ficl/softwords/softcore.fr
   2 \ ** FICL soft extensions
   3 \ ** John Sadler (john_sadler@alum.mit.edu)
   4 \ ** September, 1998
   5
   6
   7 \ ** ficl extras
   8 \ EMPTY cleans the parameter stack
   9 : empty   ( xn..x1 -- ) depth 0 ?do drop loop ;
  10 \ CELL- undoes CELL+
  11 : cell-   ( addr -- addr )  [ 1 cells ] literal -  ;
  12 : -rot   ( a b c -- c a b )  2 -roll ;
  13
  14 \ ** CORE
  15 : abs   ( x -- x )
  16     dup 0< if negate endif ;
  17 decimal 32 constant bl
  18
  19 : space   ( -- )     bl emit ;
  20
  21 : spaces  ( n -- )   0 ?do space loop ;
  22
  23 : abort"
  24     state @ if
  25         postpone if
  26         postpone ."
  27         postpone cr
  28         -2
  29         postpone literal
  30         postpone throw
  31         postpone endif
  32     else
  33             [char] " parse
  34         rot if
  35             type
  36             cr
  37             -2 throw
  38         else
  39             2drop
  40         endif
  41     endif
  42 ; immediate
  43
  44 \ ** CORE EXT
  45 .( loading CORE EXT words ) cr
  46 0  constant false
  47 false invert constant true
  48 : <>   = 0= ;
  49 : 0<>  0= 0= ;
  50 : compile,  , ;
  51 : convert   char+ 65535 >number drop ;  \ cribbed from DPANS A.6.2.0970
  52 : erase   ( addr u -- )    0 fill ;
  53 variable span
  54 : expect  ( c-addr u1 -- ) accept span ! ;
  55 \ see marker.fr for MARKER implementation
  56 : nip     ( y x -- x )     swap drop ;
  57 : tuck    ( y x -- x y x)  swap over ;
  58 : within  ( test low high -- flag )   over - >r - r>  u<  ;
  59
  60 : dnegate ( d -- -d ) invert swap negate tuck 0= - ;
  61 : dabs   ( d -- ud ) dup 0< if dnegate endif ;
  62
  63 : .r ( n +n -- )
  64   swap dup abs 0 <# #s rot sign #>
  65   rot over - dup 0< if
  66     drop else spaces
  67   then
  68   type space ;
  69
  70 : u.r ( n +n -- )
  71   swap 0 <# #s #>
  72   rot over - dup 0< if
  73     drop else spaces
  74   then
  75   type space ;
  76
  77 : d. ( d -- )
  78   swap over dabs <# #s rot sign #> type space ;
  79
  80 : d.r ( d +n -- )
  81   -rot swap over dabs <# #s rot sign #>
  82   rot over - dup 0< if
  83     drop else spaces
  84   then
  85   type space ;
  86
  87 : du. ( d -- )
  88   <# #s #> type space ;
  89
  90 : du.r ( d +n -- )
  91   -rot <# #s #> rot over - dup 0< if drop else spaces then type space ;
  92
  93 : d>s ( d -- n ) drop ;
  94
  95 : d0= ( d -- flag ) or 0= ;
  96 : d= ( d1 d2 -- flag ) rot = -rot = and ;
  97 : d0< ( d -- f ) nip 0< ;
  98
  99 : d< ( d1 d2 -- flag )
 100   2 pick
 101   over
 102   = if
 103     rot 2drop
 104     <
 105   else
 106     swap drop
 107     <
 108     swap drop
 109   then
 110 ;
 111
 112 : du< d< ;
 113 : dmax ( d1 d2 -- d3 )
 114   2over 2over
 115   d< if
 116     2swap
 117   then
 118   2drop
 119 ;
 120
 121 : dmin ( d1 d2 -- d3 )
 122   2over 2over
 123   d< if
 124     2drop
 125   else
 126     2swap
 127     2drop
 128   then
 129 ;
 130
 131 : d+ ( d1 d2 -- d3 ) rot + >r tuck + tuck swap u<  r> swap - ;
 132 : d- ( d1 d2 -- d3 ) dnegate d+ ;
 133 : d2* ( d1 -- d2 ) 2dup d+ ;
 134 : d2/ ( d1 -- d2 )
 135   dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] literal and
 136   r> if
 137     [ 1 8 cells 1- lshift ] literal +
 138   then
 139   swap
 140 ;
 141
 142 : m+ ( d1 +n -- d2 ) s>d d+ ;
 143
 144 \ ** TOOLS word set...
 145 : ?     ( addr -- )  @ . ;
 146
 147 Variable /dump
 148
 149 : i' ( R:w R:w2 -- R:w R:w2 w )
 150   r> r> r> dup >r swap >r swap >r ;
 151
 152 : .4 ( addr -- addr' )
 153     4 0 DO  -1 /dump +!  /dump @ 0<
 154         IF 3 spaces  ELSE  dup c@ 0 <# # # #> type space  THEN
 155     char+ LOOP ;
 156
 157 : .chars ( addr -- )
 158     /dump @ over + swap
 159     ?DO I c@ dup 127 bl within
 160         IF  drop [char] .  THEN  emit
 161     LOOP ;
 162
 163 : .line ( addr -- )
 164   dup .4 space .4 ." - " .4 space .4 drop  16 /dump +!  space .chars ;
 165
 166 : dump  ( addr u -- ) \ tools dump
 167     cr base @ >r hex        \ save base on return stack
 168     0 ?DO  I' I - 16 min /dump !
 169         dup 8 u.r ." : " dup .line cr 16 +
 170         16 +LOOP
 171     drop r> base ! ;
 172
 173 \ ** SEARCH+EXT words and ficl helpers
 174 .( loading SEARCH & SEARCH-EXT words ) cr
 175 \ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
 176 \   wordlist dup create , brand-wordlist
 177 \ gets the name of the word made by create and applies it to the wordlist...
 178 : brand-wordlist  ( wid -- )   last-word >name drop wid-set-name ;
 179
 180 : ficl-named-wordlist  \ ( hash-size name -- ) run: ( -- wid )
 181     ficl-wordlist dup create , brand-wordlist does> @ ;
 182
 183 : wordlist   ( -- )
 184     1 ficl-wordlist ;
 185
 186 \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
 187 : ficl-set-current   ( wid -- old-wid )
 188     get-current swap set-current ;
 189
 190 \ DO_VOCABULARY handles the DOES> part of a VOCABULARY
 191 \ When executed, new voc replaces top of search stack
 192 : do-vocabulary   ( -- )
 193     does>  @ search> drop >search ;
 194
 195 : ficl-vocabulary   ( nBuckets name -- )
 196     ficl-named-wordlist do-vocabulary ;
 197
 198 : vocabulary   ( name -- )
 199     1 ficl-vocabulary ;
 200
 201 \ PREVIOUS drops the search order stack
 202 : previous  ( --  )  search> drop ;
 203
 204 \ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
 205 \ USAGE:
 206 \ hide
 207 \ <definitions to hide>
 208 \ set-current
 209 \ <words that use hidden defs>
 210 \ previous ( pop HIDDEN off the search order )
 211
 212 1 ficl-named-wordlist hidden
 213 : hide     hidden dup >search ficl-set-current ;
 214
 215 \ ALSO dups the search stack...
 216 : also   ( -- )
 217     search> dup >search >search ;
 218
 219 \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
 220 : forth   ( -- )
 221     search> drop
 222     forth-wordlist >search ;
 223
 224 \ ONLY sets the search order to a default state
 225 : only   ( -- )
 226     -1 set-order ;
 227
 228 \ ORDER displays the compile wid and the search order list
 229 hide
 230 : list-wid ( wid -- )
 231     dup wid-get-name   ( wid c-addr u )
 232     ?dup if
 233         type drop
 234     else
 235         drop ." (unnamed wid) " x.
 236     endif cr
 237 ;
 238 set-current   \ stop hiding words
 239
 240 : order   ( -- )
 241     ." Search:" cr
 242     get-order  0 ?do 3 spaces list-wid loop cr
 243    ." Compile: " get-current list-wid cr
 244 ;
 245
 246 : debug  ' debug-xt ; immediate
 247 : on-step   ." S: " .s-simple cr ;
 248
 249
 250 previous   \ lose hidden words from search order
 251
 252 \ ** E N D   S O F T C O R E . F R