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