sys/boot/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
  71 \ ** LOCAL EXT word set
  72 \ #if FICL_WANT_LOCALS
  73 : locals|  ( name...name | -- )
  74     begin
  75         bl word   count
  76         dup 0= abort" where's the delimiter??"
  77         over c@
  78         [char] | - over 1- or
  79     while
  80         (local)
  81     repeat 2drop   0 0 (local)
  82 ; immediate
  83
  84 : local  ( name -- )  bl word count (local) ;  immediate
  85
  86 : 2local  ( name -- ) bl word count (2local) ; immediate
  87
  88 : end-locals  ( -- )  0 0 (local) ;  immediate
  89
  90 \ #endif
  91
  92 \ ** TOOLS word set...
  93 : ?     ( addr -- )  @ . ;
  94 : dump  ( addr u -- )
  95     0 ?do
  96         dup c@ . 1+
  97         i 7 and 7 = if cr endif
  98     loop drop
  99 ;
 100
 101 \ ** SEARCH+EXT words and ficl helpers
 102 \ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
 103 \   wordlist dup create , brand-wordlist
 104 \ gets the name of the word made by create and applies it to the wordlist...
 105 : brand-wordlist  ( wid -- )   last-word >name drop wid-set-name ;
 106
 107 : ficl-named-wordlist  \ ( hash-size name -- ) run: ( -- wid )
 108     ficl-wordlist dup create , brand-wordlist does> @ ;
 109
 110 : wordlist   ( -- )
 111     1 ficl-wordlist ;
 112
 113 \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
 114 : ficl-set-current   ( wid -- old-wid )
 115     get-current swap set-current ;
 116
 117 \ DO_VOCABULARY handles the DOES> part of a VOCABULARY
 118 \ When executed, new voc replaces top of search stack
 119 : do-vocabulary   ( -- )
 120     does>  @ search> drop >search ;
 121
 122 : ficl-vocabulary   ( nBuckets name -- )
 123     ficl-named-wordlist do-vocabulary ;
 124
 125 : vocabulary   ( name -- )
 126     1 ficl-vocabulary ;
 127
 128 \ PREVIOUS drops the search order stack
 129 : previous  ( --  )  search> drop ;
 130
 131 \ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
 132 \ USAGE:
 133 \ hide
 134 \ <definitions to hide>
 135 \ set-current
 136 \ <words that use hidden defs>
 137 \ previous ( pop HIDDEN off the search order )
 138
 139 1 ficl-named-wordlist hidden
 140 : hide     hidden dup >search ficl-set-current ;
 141
 142 \ ALSO dups the search stack...
 143 : also   ( -- )
 144     search> dup >search >search ;
 145
 146 \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
 147 : forth   ( -- )
 148     search> drop
 149     forth-wordlist >search ;
 150
 151 \ ONLY sets the search order to a default state
 152 : only   ( -- )
 153     -1 set-order ;
 154
 155 \ ORDER displays the compile wid and the search order list
 156 hide
 157 : list-wid ( wid -- )
 158     dup wid-get-name   ( wid c-addr u )
 159     ?dup if
 160         type drop
 161     else
 162         drop ." (unnamed wid) " x.
 163     endif cr
 164 ;
 165 set-current   \ stop hiding words
 166
 167 : order   ( -- )
 168     ." Search:" cr
 169     get-order  0 ?do 3 spaces list-wid loop cr
 170    ." Compile: " get-current list-wid cr
 171 ;
 172
 173 : debug  ' debug-xt ; immediate
 174 : on-step   ." S: " .s cr ;
 175
 176
 177 \ Submitted by lch.
 178 : strdup ( c-addr length -- c-addr2 length2 ior )
 179         0 locals| addr2 length c-addr | end-locals
 180         length 1 + allocate
 181         0= if
 182                 to addr2
 183                 c-addr addr2 length move
 184                 addr2 length 0
 185         else
 186                 0  -1
 187         endif
 188         ;
 189
 190 : strcat ( 2:a 2:b -- 2:new-a )
 191         0 locals|  b-length b-u b-addr a-u a-addr | end-locals
 192         b-u  to b-length
 193         b-addr a-addr a-u + b-length  move
 194         a-addr a-u b-length +
 195         ;
 196
 197 : strcpy ( 2:a 2:b -- 2:new-a )
 198         locals| b-u b-addr a-u a-addr | end-locals
 199         a-addr 0  b-addr b-u  strcat
 200         ;
 201
 202
 203 previous   \ lose hidden words from search order
 204
 205 \ ** E N D   S O F T C O R E . F R
 206