softcore.fr revision 60959
1\ ** ficl/softwords/softcore.fr 2\ ** FICL soft extensions 3\ ** John Sadler (john_sadler@alum.mit.edu) 4\ ** September, 1998 5 6\ $FreeBSD: head/sys/boot/ficl/softwords/softcore.fr 60959 2000-05-26 21:35:08Z dcs $ 7 8\ ** Ficl USER variables 9\ ** See words.c for primitive def'n of USER 10\ #if FICL_WANT_USER 11 12variable 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 ; 28decimal 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 460 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: 2local ( name -- ) bl word count (2local) ; immediate 73 74: end-locals ( -- ) 0 0 (local) ; immediate 75 76\ #endif 77 78\ ** TOOLS word set... 79: ? ( addr -- ) @ . ; 80: dump ( addr u -- ) 81 0 ?do 82 dup c@ . 1+ 83 i 7 and 7 = if cr endif 84 loop drop 85; 86 87\ ** SEARCH+EXT words and ficl helpers 88\ 89: wordlist ( -- ) 90 1 ficl-wordlist ; 91 92\ DO_VOCABULARY handles the DOES> part of a VOCABULARY 93\ When executed, new voc replaces top of search stack 94: do-vocabulary ( -- ) 95 does> @ search> drop >search ; 96 97: vocabulary ( name -- ) 98 wordlist create , do-vocabulary ; 99 100: ficl-vocabulary ( nBuckets name -- ) 101 ficl-wordlist create , do-vocabulary ; 102 103\ ALSO dups the search stack... 104: also ( -- ) 105 search> dup >search >search ; 106 107\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST 108: forth ( -- ) 109 search> drop 110 forth-wordlist >search ; 111 112\ ONLY sets the search order to a default state 113: only ( -- ) 114 -1 set-order ; 115 116\ ORDER displays the compile wid and the search order list 117: order ( -- ) 118 ." Search: " 119 get-order 0 ?do x. loop cr 120 ." Compile: " get-current x. cr ; 121 122\ PREVIOUS drops the search order stack 123: previous ( -- ) search> drop ; 124 125\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value 126: ficl-set-current ( wid -- old-wid ) 127 get-current swap set-current ; 128 129wordlist constant hidden 130: hide hidden dup >search ficl-set-current ; 131 132\ ** E N D S O F T C O R E . F R 133 134