afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** FICL soft extensions
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** John Sadler (john_sadler@alum.mit.edu)
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** September, 1998
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** ficl extras
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ EMPTY cleans the parameter stack
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: empty ( xn..x1 -- ) depth 0 ?do drop loop ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ CELL- undoes CELL+
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: cell- ( addr -- addr ) [ 1 cells ] literal - ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: -rot ( a b c -- c a b ) 2 -roll ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: abs ( x -- x )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome dup 0< if negate endif ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soomedecimal 32 constant bl
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: space ( -- ) bl emit ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: spaces ( n -- ) 0 ?do space loop ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome postpone literal
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome postpone throw
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome postpone endif
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome [char] " parse
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** CORE EXT
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome.( loading CORE EXT words ) cr
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome0 constant false
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soomefalse invert constant true
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: 0<> 0= 0= ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: compile, , ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: convert char+ 65535 >number drop ; \ cribbed from DPANS A.6.2.0970
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: erase ( addr u -- ) 0 fill ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soomevariable span
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: expect ( c-addr u1 -- ) accept span ! ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ see marker.fr for MARKER implementation
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: nip ( y x -- x ) swap drop ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: tuck ( y x -- x y x) swap over ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: within ( test low high -- flag ) over - >r - r> u< ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: dnegate ( d -- -d ) invert swap negate tuck 0= - ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: dabs ( d -- ud ) dup 0< if dnegate endif ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: .r ( n +n -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome swap dup abs 0 <# #s rot sign #>
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome rot over - dup 0< if
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome drop else spaces
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: u.r ( n +n -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome swap 0 <# #s #>
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome rot over - dup 0< if
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome drop else spaces
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d. ( d -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome swap over dabs <# #s rot sign #> type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d.r ( d +n -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome -rot swap over dabs <# #s rot sign #>
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome rot over - dup 0< if
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome drop else spaces
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: du. ( d -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome <# #s #> type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: du.r ( d +n -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome -rot <# #s #> rot over - dup 0< if drop else spaces then type space ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d>s ( d -- n ) drop ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d0= ( d -- flag ) or 0= ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d= ( d1 d2 -- flag ) rot = -rot = and ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d0< ( d -- f ) nip 0< ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d< ( d1 d2 -- flag )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: dmax ( d1 d2 -- d3 )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: dmin ( d1 d2 -- d3 )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d+ ( d1 d2 -- d3 ) rot + >r tuck + tuck swap u< r> swap - ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d- ( d1 d2 -- d3 ) dnegate d+ ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d2* ( d1 -- d2 ) 2dup d+ ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: d2/ ( d1 -- d2 )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] literal and
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome [ 1 8 cells 1- lshift ] literal +
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: m+ ( d1 +n -- d2 ) s>d d+ ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** TOOLS word set...
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ? ( addr -- ) @ . ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas SoomeVariable /dump
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: i' ( R:w R:w2 -- R:w R:w2 w )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome r> r> r> dup >r swap >r swap >r ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: .4 ( addr -- addr' )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome 4 0 DO -1 /dump +! /dump @ 0<
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome IF 3 spaces ELSE dup c@ 0 <# # # #> type space THEN
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome char+ LOOP ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: .chars ( addr -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome /dump @ over + swap
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome ?DO I c@ dup 127 bl within
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome IF drop [char] . THEN emit
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: .line ( addr -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome dup .4 space .4 ." - " .4 space .4 drop 16 /dump +! space .chars ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: dump ( addr u -- ) \ tools dump
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome cr base @ >r hex \ save base on return stack
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome 0 ?DO I' I - 16 min /dump !
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome dup 8 u.r ." : " dup .line cr 16 +
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome drop r> base ! ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** SEARCH+EXT words and ficl helpers
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome.( loading SEARCH & SEARCH-EXT words ) cr
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ wordlist dup create , brand-wordlist
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ gets the name of the word made by create and applies it to the wordlist...
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: brand-wordlist ( wid -- ) last-word >name drop wid-set-name ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ficl-named-wordlist \ ( hash-size name -- ) run: ( -- wid )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome ficl-wordlist dup create , brand-wordlist does> @ ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: wordlist ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome 1 ficl-wordlist ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ficl-set-current ( wid -- old-wid )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome get-current swap set-current ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ When executed, new voc replaces top of search stack
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: do-vocabulary ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome does> @ search> drop >search ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: ficl-vocabulary ( nBuckets name -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome ficl-named-wordlist do-vocabulary ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: vocabulary ( name -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome 1 ficl-vocabulary ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ PREVIOUS drops the search order stack
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: previous ( -- ) search> drop ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ <definitions to hide>
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ set-current
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ <words that use hidden defs>
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ previous ( pop HIDDEN off the search order )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome1 ficl-named-wordlist hidden
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: hide hidden dup >search ficl-set-current ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ALSO dups the search stack...
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: also ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome search> dup >search >search ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ FORTH drops the top of the search stack and pushes FORTH-WORDLIST
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: forth ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome search> drop
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome forth-wordlist >search ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ONLY sets the search order to a default state
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: only ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome -1 set-order ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ORDER displays the compile wid and the search order list
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: list-wid ( wid -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome dup wid-get-name ( wid c-addr u )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome drop ." (unnamed wid) " x.
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soomeset-current \ stop hiding words
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: order ( -- )
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome ." Search:" cr
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome get-order 0 ?do 3 spaces list-wid loop cr
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome ." Compile: " get-current list-wid cr
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: debug ' debug-xt ; immediate
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome: on-step ." S: " .s-simple cr ;
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soomeprevious \ lose hidden words from search order
afc2ba1deb75b323afde536f2dd18bcafdaa308dToomas Soome\ ** E N D S O F T C O R E . F R