780ebb4b00
this will allow us to manage bloat in the loader by using a bytecoded HLL rather than lots of C code. It also offers an opportunity for vendors or others with special applications to significantly customise the boot process without having to commit to a divergent code branch. This early commit is to allow others to experiment with the most effective mechanisms for integrating FICL with the loader as it currently stands. Ficl is distributed with the following license conditions: "Ficl is freeware. Use it in any way that you like, with the understanding that the code is not supported." All source files contain authorship attributions. Obtained from: John Sadler (john_sadler@alum.mit.edu)
126 lines
2.7 KiB
Forth
126 lines
2.7 KiB
Forth
\ ** ficl/softwords/softcore.fr
|
|
\ ** FICL soft extensions
|
|
\ ** John Sadler (john_sadler@alum.mit.edu)
|
|
\ ** September, 1998
|
|
|
|
\ ** Ficl USER variables
|
|
\ ** See words.c for primitive def'n of USER
|
|
\ #if FICL_WANT_USER
|
|
|
|
variable nUser 0 nUser !
|
|
: user \ name ( -- )
|
|
nUser dup @ user 1 swap +! ;
|
|
|
|
\ #endif
|
|
|
|
\ ** ficl extras
|
|
\ EMPTY cleans the parameter stack
|
|
: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
|
|
\ CELL- undoes CELL+
|
|
: cell- ( addr -- addr ) [ 1 cells ] literal - ;
|
|
: -rot ( a b c -- c a b ) 2 -roll ;
|
|
|
|
\ ** CORE
|
|
: abs ( x -- x )
|
|
dup 0< if negate endif ;
|
|
decimal 32 constant bl
|
|
|
|
: space ( -- ) bl emit ;
|
|
|
|
: spaces ( n -- ) 0 ?do space loop ;
|
|
|
|
: abort"
|
|
postpone if
|
|
postpone ."
|
|
postpone cr
|
|
postpone abort
|
|
postpone endif
|
|
; immediate
|
|
|
|
|
|
\ ** CORE EXT
|
|
0 constant false
|
|
-1 constant true
|
|
: <> = invert ;
|
|
: 0<> 0= invert ;
|
|
: compile, , ;
|
|
: erase ( addr u -- ) 0 fill ;
|
|
: nip ( y x -- x ) swap drop ;
|
|
: tuck ( y x -- x y x) swap over ;
|
|
|
|
\ ** LOCAL EXT word set
|
|
\ #if FICL_WANT_LOCALS
|
|
: locals| ( name...name | -- )
|
|
begin
|
|
bl word count
|
|
dup 0= abort" where's the delimiter??"
|
|
over c@
|
|
[char] | - over 1- or
|
|
while
|
|
(local)
|
|
repeat 2drop 0 0 (local)
|
|
; immediate
|
|
|
|
: local ( name -- ) bl word count (local) ; immediate
|
|
|
|
: end-locals ( -- ) 0 0 (local) ; immediate
|
|
|
|
\ #endif
|
|
|
|
\ ** TOOLS word set...
|
|
: ? ( addr -- ) @ . ;
|
|
: dump ( addr u -- )
|
|
0 ?do
|
|
dup c@ . 1+
|
|
i 7 and 7 = if cr endif
|
|
loop drop
|
|
;
|
|
|
|
\ ** SEARCH+EXT words and ficl helpers
|
|
\
|
|
: wordlist ( -- )
|
|
1 ficl-wordlist ;
|
|
|
|
\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
|
|
\ When executed, new voc replaces top of search stack
|
|
: do-vocabulary ( -- )
|
|
does> @ search> drop >search ;
|
|
|
|
: vocabulary ( name -- )
|
|
wordlist create , do-vocabulary ;
|
|
|
|
: ficl-vocabulary ( nBuckets name -- )
|
|
ficl-wordlist create , do-vocabulary ;
|
|
|
|
\ ALSO dups the search stack...
|
|
: also ( -- )
|
|
search> dup >search >search ;
|
|
|
|
\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
|
|
: forth ( -- )
|
|
search> drop
|
|
forth-wordlist >search ;
|
|
|
|
\ ONLY sets the search order to a default state
|
|
: only ( -- )
|
|
-1 set-order ;
|
|
|
|
\ ORDER displays the compile wid and the search order list
|
|
: order ( -- )
|
|
." Search: "
|
|
get-order 0 ?do x. loop cr
|
|
." Compile: " get-current x. cr ;
|
|
|
|
\ PREVIOUS drops the search order stack
|
|
: previous ( -- ) search> drop ;
|
|
|
|
\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
|
|
: ficl-set-current ( wid -- old-wid )
|
|
get-current swap set-current ;
|
|
|
|
wordlist constant hidden
|
|
: hide hidden dup >search ficl-set-current ;
|
|
|
|
\ ** E N D S O F T C O R E . F R
|
|
|