softcore.fr revision 43598
1\ ** ficl/softwords/softcore.fr 2\ ** FICL soft extensions 3\ ** John Sadler (john_sadler@alum.mit.edu) 4\ ** September, 1998 5 6\ ** Ficl USER variables 7\ ** See words.c for primitive def'n of USER 8\ #if FICL_WANT_USER 9 10variable nUser 0 nUser ! 11: user \ name ( -- ) 12 nUser dup @ user 1 swap +! ; 13 14\ #endif 15 16\ ** ficl extras 17\ EMPTY cleans the parameter stack 18: empty ( xn..x1 -- ) depth 0 ?do drop loop ; 19\ CELL- undoes CELL+ 20: cell- ( addr -- addr ) [ 1 cells ] literal - ; 21: -rot ( a b c -- c a b ) 2 -roll ; 22 23\ ** CORE 24: abs ( x -- x ) 25 dup 0< if negate endif ; 26decimal 32 constant bl 27 28: space ( -- ) bl emit ; 29 30: spaces ( n -- ) 0 ?do space loop ; 31 32: abort" 33 postpone if 34 postpone ." 35 postpone cr 36 -2 37 postpone literal 38 postpone throw 39 postpone endif 40; immediate 41 42 43\ ** CORE EXT 440 constant false 45-1 constant true 46: <> = invert ; 47: 0<> 0= invert ; 48: compile, , ; 49: erase ( addr u -- ) 0 fill ; 50: nip ( y x -- x ) swap drop ; 51: tuck ( y x -- x y x) swap over ; 52 53\ ** LOCAL EXT word set 54\ #if FICL_WANT_LOCALS 55: locals| ( name...name | -- ) 56 begin 57 bl word count 58 dup 0= abort" where's the delimiter??" 59 over c@ 60 [char] | - over 1- or 61 while 62 (local) 63 repeat 2drop 0 0 (local) 64; immediate 65 66: local ( name -- ) bl word count (local) ; immediate 67 68: end-locals ( -- ) 0 0 (local) ; immediate 69 70\ #endif 71 72\ ** TOOLS word set... 73: ? ( addr -- ) @ . ; 74: dump ( addr u -- ) 75 0 ?do 76 dup c@ . 1+ 77 i 7 and 7 = if cr endif 78 loop drop 79; 80 81\ ** Some TOOLS EXT words, straight from the standard 82: [else] ( -- ) 83 1 begin \ level 84 begin 85 bl word count dup while \ level adr len 86 2dup s" [IF]" compare 0= >r 87 2dup s" [if]" compare 0= r> or 88 if \ level adr len 89 2drop 1+ \ level' 90 else \ level adr len 91 2dup s" [ELSE]" compare 0= >r 92 2dup s" [else]" compare 0= r> or 93 if \ level adr len 94 2drop 1- dup if 1+ then \ level' 95 else \ level adr len 96 2dup 97 s" [THEN]" compare 0= >r \ level adr len 98 s" [then]" compare 0= r> or 99 if \ level 100 1- \ level' 101 then 102 then 103 then ?dup 0= if exit then \ level' 104 repeat 2drop \ level 105 refill 0= until \ level 106 drop 107; immediate 108 109: [if] ( flag -- ) 1100= if postpone [else] then ; immediate 111 112: [then] ( -- ) ; immediate 113\ ** SEARCH+EXT words and ficl helpers 114\ 115: wordlist ( -- ) 116 1 ficl-wordlist ; 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: vocabulary ( name -- ) 124 wordlist create , do-vocabulary ; 125 126: ficl-vocabulary ( nBuckets name -- ) 127 ficl-wordlist create , do-vocabulary ; 128 129\ ALSO dups the search stack... 130: also ( -- ) 131 search> dup >search >search ; 132 133\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 134: forth ( -- ) 135 search> drop 136 forth-wordlist >search ; 137 138\ ONLY sets the search order to a default state 139: only ( -- ) 140 -1 set-order ; 141 142\ ORDER displays the compile wid and the search order list 143: order ( -- ) 144 ." Search: " 145 get-order 0 ?do x. loop cr 146 ." Compile: " get-current x. cr ; 147 148\ PREVIOUS drops the search order stack 149: previous ( -- ) search> drop ; 150 151\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 152: ficl-set-current ( wid -- old-wid ) 153 get-current swap set-current ; 154 155wordlist constant hidden 156: hide hidden dup >search ficl-set-current ; 157 158\ ** E N D S O F T C O R E . F R 159 160