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