softcore.fr revision 61584
141120Sjdp\ ** ficl/softwords/softcore.fr 241120Sjdp\ ** FICL soft extensions 341120Sjdp\ ** John Sadler (john_sadler@alum.mit.edu) 441120Sjdp\ ** September, 1998 541120Sjdp 641120Sjdp\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 61584 2000-06-12 16:42:02Z dcs $ 741120Sjdp 841120Sjdp\ ** Ficl USER variables 941120Sjdp\ ** See words.c for primitive def'n of USER 1041120Sjdp\ #if FICL_WANT_USER 1141120Sjdp 1241120Sjdpvariable nUser 0 nUser ! 1341120Sjdp: user \ name ( -- ) 1441120Sjdp nUser dup @ user 1 swap +! ; 1541120Sjdp 1641120Sjdp\ #endif 1741120Sjdp 1841120Sjdp\ ** ficl extras 1941120Sjdp\ EMPTY cleans the parameter stack 2041120Sjdp: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 2141120Sjdp\ CELL- undoes CELL+ 2241120Sjdp: cell- ( addr -- addr ) [ 1 cells ] literal - ; 2341120Sjdp: -rot ( a b c -- c a b ) 2 -roll ; 2441120Sjdp 2541120Sjdp\ ** CORE 2641120Sjdp: abs ( x -- x ) 2741120Sjdp dup 0< if negate endif ; 2841120Sjdpdecimal 32 constant bl 2941120Sjdp 3041120Sjdp: space ( -- ) bl emit ; 3141120Sjdp 3241120Sjdp: spaces ( n -- ) 0 ?do space loop ; 3341120Sjdp 3441120Sjdp: abort" 3541120Sjdp state @ if 3641120Sjdp postpone if 3741120Sjdp [char] " parse 3841120Sjdp postpone sliteral 3941120Sjdp postpone type 4041120Sjdp postpone cr 4141120Sjdp -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 590 constant false 60false 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 142wordlist 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 147