stand/ficl/softwords/softcore.fr

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