1 files changed, 152 insertions, 0 deletions
diff --git a/softcore/softcore.fr b/softcore/softcore.fr
new file mode 100644
index 000000000000..6cce6589a831
--- /dev/null
+++ b/softcore/softcore.fr
@@ -0,0 +1,152 @@
+\ ** ficl/softwords/softcore.fr
+\ ** FICL soft extensions
+\ ** John Sadler (john_sadler@alum.mit.edu)
+\ ** September, 1998
+
+
+\ ** 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"  
+    state @ if
+        postpone if
+        postpone ."
+        postpone cr
+        -2
+        postpone literal
+        postpone throw
+        postpone endif
+    else
+	    [char] " parse
+        rot if
+            type
+            cr
+            -2 throw
+        else
+            2drop
+        endif
+    endif
+; immediate
+
+
+\ ** CORE EXT
+.( loading CORE EXT words ) cr
+0  constant false 
+false invert constant true 
+: <>   = 0= ; 
+: 0<>  0= 0= ; 
+: compile,  , ; 
+: convert   char+ 65535 >number drop ;  \ cribbed from DPANS A.6.2.0970
+: erase   ( addr u -- )    0 fill ; 
+variable span
+: expect  ( c-addr u1 -- ) accept span ! ;
+\ see marker.fr for MARKER implementation
+: nip     ( y x -- x )     swap drop ; 
+: tuck    ( y x -- x y x)  swap over ; 
+: within  ( test low high -- flag )   over - >r - r>  u<  ;
+
+
+
+\ ** 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
+.( loading SEARCH & SEARCH-EXT words ) cr 
+\ BRAND-WORDLIST is a helper for ficl-named-wordlist. Usage idiom:
+\   wordlist dup create , brand-wordlist
+\ gets the name of the word made by create and applies it to the wordlist...
+: brand-wordlist  ( wid -- )   last-word >name drop wid-set-name ;
+
+: ficl-named-wordlist  \ ( hash-size name -- ) run: ( -- wid )
+    ficl-wordlist dup create , brand-wordlist does> @ ;
+
+: wordlist   ( -- )  
+    1 ficl-wordlist ;
+
+\ FICL-SET-CURRENT sets the compile wordlist and pushes the previous value
+: ficl-set-current   ( wid -- old-wid )  
+    get-current swap set-current ; 
+
+\ DO_VOCABULARY handles the DOES> part of a VOCABULARY
+\ When executed, new voc replaces top of search stack
+: do-vocabulary   ( -- ) 
+    does>  @ search> drop >search ;
+
+: ficl-vocabulary   ( nBuckets name -- )  
+    ficl-named-wordlist do-vocabulary ; 
+
+: vocabulary   ( name -- )  
+    1 ficl-vocabulary ; 
+
+\ PREVIOUS drops the search order stack
+: previous  ( --  )  search> drop ; 
+
+\ HIDDEN vocabulary is a place to keep helper words from cluttering the namespace
+\ USAGE:
+\ hide
+\ <definitions to hide>
+\ set-current
+\ <words that use hidden defs>
+\ previous ( pop HIDDEN off the search order )
+
+1 ficl-named-wordlist hidden
+: hide     hidden dup >search ficl-set-current ;
+
+\ 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
+hide
+: list-wid ( wid -- )   
+    dup wid-get-name   ( wid c-addr u )
+    ?dup if 
+        type drop 
+    else 
+        drop ." (unnamed wid) " x.
+    endif cr 
+; 
+set-current   \ stop hiding words
+
+: order   ( -- )  
+    ." Search:" cr
+    get-order  0 ?do 3 spaces list-wid loop cr 
+   ." Compile: " get-current list-wid cr  
+; 
+
+: debug  ' debug-xt ; immediate
+: on-step   ." S: " .s-simple cr ;
+
+
+previous   \ lose hidden words from search order
+
+\ ** E N D   S O F T C O R E . F R
+