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
  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     postpone if
  36     postpone ."
  37     postpone cr
  38     -2
  39     postpone literal
  40     postpone throw
  41     postpone endif
  42 ; immediate
  43
  44
  45 \ ** CORE EXT
  46 0  constant false
  47 -1 constant true
  48 : <>   = 0= ;
  49 : 0<>  0= 0= ;
  50 : compile,  , ;
  51 : erase   ( addr u -- )    0 fill ;
  52 : nip     ( y x -- x )     swap drop ;
  53 : tuck    ( y x -- x y x)  swap over ;
  54 : within  ( test low high -- flag )   over - >r - r>  u<  ;
  55
  56
  57 \ ** LOCAL EXT word set
  58 \ #if FICL_WANT_LOCALS
  59 : locals|  ( name...name | -- )
  60     begin
  61         bl word   count
  62         dup 0= abort" where's the delimiter??"
  63         over c@
  64         [char] | - over 1- or
  65     while
  66         (local)
  67     repeat 2drop   0 0 (local)
  68 ; immediate
  69
  70 : local  ( name -- )  bl word count (local) ;  immediate
  71
  72 : end-locals  ( -- )  0 0 (local) ;  immediate
  73
  74 \ #endif
  75
  76 \ ** TOOLS word set...
  77 : ?     ( addr -- )  @ . ;
  78 : dump  ( addr u -- )
  79     0 ?do
  80         dup c@ . 1+
  81         i 7 and 7 = if cr endif
  82     loop drop
  83 ;
  84
  85 \ ** SEARCH+EXT words and ficl helpers
  86 \
  87 : wordlist   ( -- )
  88     1 ficl-wordlist ;
  89
  90 \ DO_VOCABULARY handles the DOES> part of a VOCABULARY
  91 \ When executed, new voc replaces top of search stack
  92 : do-vocabulary   ( -- )
  93     does>  @ search> drop >search ;
  94
  95 : vocabulary   ( name -- )
  96     wordlist create ,  do-vocabulary ;
  97
  98 : ficl-vocabulary   ( nBuckets name -- )
  99     ficl-wordlist create ,  do-vocabulary ;
 100
 101 \ ALSO dups the search stack...
 102 : also   ( -- )
 103     search> dup >search >search ;
 104
 105 \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
 106 : forth   ( -- )
 107     search> drop
 108     forth-wordlist >search ;
 109
 110 \ ONLY sets the search order to a default state
 111 : only   ( -- )
 112     -1 set-order ;
 113
 114 \ ORDER displays the compile wid and the search order list
 115 : order   ( -- )
 116     ." Search: "
 117     get-order  0 ?do x. loop cr
 118    ." Compile: " get-current x. cr  ;
 119
 120 \ PREVIOUS drops the search order stack
 121 : previous  ( --  )  search> drop ;
 122
 123 \ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
 124 : ficl-set-current   ( wid -- old-wid )
 125     get-current swap set-current ;
 126
 127 wordlist constant hidden
 128 : hide   hidden dup >search ficl-set-current ;
 129
 130 \ ** E N D   S O F T C O R E . F R
 131