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