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.8.2.1 2000/07/06 23:51:46 obrien Exp $
   7 \ $DragonFly: src/sys/boot/ficl/softwords/softcore.fr,v 1.2 2003/06/17 04:28:18 dillon Exp $
   8
   9 \ ** Ficl USER variables
  10 \ ** See words.c for primitive def'n of USER
  11 \ #if FICL_WANT_USER
  12
  13 variable nUser  0 nUser !
  14 : user   \ name ( -- )
  15     nUser dup @ user 1 swap +! ;
  16
  17 \ #endif
  18
  19 \ ** ficl extras
  20 \ EMPTY cleans the parameter stack
  21 : empty   ( xn..x1 -- ) depth 0 ?do drop loop ;
  22 \ CELL- undoes CELL+
  23 : cell-   ( addr -- addr )  [ 1 cells ] literal -  ;
  24 : -rot   ( a b c -- c a b )  2 -roll ;
  25
  26 \ ** CORE
  27 : abs   ( x -- x )
  28     dup 0< if negate endif ;
  29 decimal 32 constant bl
  30
  31 : space   ( -- )     bl emit ;
  32
  33 : spaces  ( n -- )   0 ?do space loop ;
  34
  35 : abort"
  36     state @ if
  37         postpone if
  38         [char] " parse
  39         postpone sliteral
  40         postpone type
  41         postpone cr
  42         -2
  43         postpone literal
  44         postpone throw
  45         postpone endif
  46     else
  47         [char] " parse
  48         rot if
  49             type
  50             cr
  51             -2 throw
  52         else
  53             2drop
  54         then
  55     then
  56 ; immediate
  57
  58
  59 \ ** CORE EXT
  60 0 constant false
  61 false invert constant true
  62 : <>   = 0= ;
  63 : 0<>  0= 0= ;
  64 : compile,  , ;
  65 : erase   ( addr u -- )    0 fill ;
  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 \
 103 : wordlist   ( -- )
 104     1 ficl-wordlist ;
 105
 106 \ DO_VOCABULARY handles the DOES> part of a VOCABULARY
 107 \ When executed, new voc replaces top of search stack
 108 : do-vocabulary   ( -- )
 109     does>  @ search> drop >search ;
 110
 111 : vocabulary   ( name -- )
 112     wordlist create ,  do-vocabulary ;
 113
 114 : ficl-vocabulary   ( nBuckets name -- )
 115     ficl-wordlist create ,  do-vocabulary ;
 116
 117 \ ALSO dups the search stack...
 118 : also   ( -- )
 119     search> dup >search >search ;
 120
 121 \ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
 122 : forth   ( -- )
 123     search> drop
 124     forth-wordlist >search ;
 125
 126 \ ONLY sets the search order to a default state
 127 : only   ( -- )
 128     -1 set-order ;
 129
 130 \ ORDER displays the compile wid and the search order list
 131 : order   ( -- )
 132     ." Search: "
 133     get-order  0 ?do x. loop cr
 134    ." Compile: " get-current x. cr  ;
 135
 136 \ PREVIOUS drops the search order stack
 137 : previous  ( --  )  search> drop ;
 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 wordlist constant hidden
 144 : hide   hidden dup >search ficl-set-current ;
 145
 146 \ ** E N D   S O F T C O R E . F R
 147