ref: e5f0c0798b44ffaa03772477138ff0ae4df4763b
parent: 5a81e15d663cfea8832155f39f0e8f3557ff3fae
author: jsadler <jsadler@ficl.sf.net>
date: Tue Jun 6 23:24:19 CDT 2000
*** empty log message ***
--- /dev/null
+++ b/softwords/ficllocal.fr
@@ -1,0 +1,46 @@
+\ ** ficl/softwords/ficllocal.fr
+\ ** stack comment style local syntax...
+\ {{ a b c -- d e }}+\ variables before the "--" are initialized in reverse order
+\ from the stack. Those after the "--" are zero initialized
+\ Uses locals...
+\ locstate: 0 = looking for -- or }}
+\ 1 = found --
+hide
+0 constant zero
+
+: ?-- s" --" compare 0= ;
+: ?}} s" }}" compare 0= ;
+
+set-current
+
+: {{+ 0 dup locals| nLocs locstate |
+ begin
+ parse-word
+ ?dup 0= abort" Error: out of text without seeing }}"
+ 2dup 2dup ?-- -rot ?}} or 0=
+ while
+ nLocs 1+ to nLocs
+ repeat
+
+ ?-- if 1 to locstate endif
+
+ nLocs 0 do
+ (local)
+ loop
+
+ locstate 1 = if
+ begin
+ parse-word
+ 2dup ?}} 0=
+ while
+ postpone zero (local)
+ repeat
+ 2drop
+ endif
+
+ 0 0 (local)
+; immediate compile-only
+
+previous
--- /dev/null
+++ b/softwords/forml.fr
@@ -1,0 +1,70 @@
+\ examples from FORML conference paper Nov 98
+\ sadler
+.( loading FORML examples ) cr
+object --> sub c-example
+ cell: .cell0
+ c-4byte obj: .nCells
+ 4 c-4byte array: .quad
+ c-byte obj: .length
+ 79 chars: .name
+
+ : init ( inst class -- )
+ 2dup object => init
+ s" aardvark" 2swap --> set-name
+ ;
+
+ : get-name ( inst class -- c-addr u )
+ 2dup
+ --> .name -rot ( c-addr inst class )
+ --> .length --> get
+ ;
+
+ : set-name { c-addr u inst class -- }+ u inst class --> .length --> set
+ c-addr inst class --> .name u move
+ ;
+
+ : ? ( inst class ) c-example => get-name type cr ;
+end-class
+
+
+: test ." this is a test" cr ;
+' test
+c-word --> ref testref
+
+\ add a method to c-word...
+c-word --> get-wid ficl-set-current
+\ list dictionary thread
+: list ( inst class )
+ begin
+ 2dup --> get-name type cr
+ --> next over
+ 0= until
+ 2drop
+;
+set-current
+
+object subclass c-led
+ c-byte obj: .state
+
+ : on { led# inst class -- }+ inst class --> .state --> get
+ 1 led# lshift or dup !oreg
+ inst class --> .state --> set
+ ;
+
+ : off { led# inst class -- }+ inst class --> .state --> get
+ 1 led# lshift invert and dup !oreg
+ inst class --> .state --> set
+ ;
+
+end-class
+
+
+object subclass c-switch
+
+ : ?on { bit# inst class -- bit }+ ;
+end-class
+
--- /dev/null
+++ b/softwords/jhlocal.fr
@@ -1,0 +1,77 @@
+\ #if FICL_WANT_LOCALS
+\ ** ficl/softwords/jhlocal.fr
+\ ** stack comment style local syntax...
+\ { a b c | cleared -- d e }+\ variables before the "|" are initialized in reverse order
+\ from the stack. Those after the "|" are zero initialized.
+\ Anything between "--" and "}" is treated as comment
+\ Uses locals...
+\ locstate: 0 = looking for | or -- or }}
+\ 1 = found |
+\ 2 = found --
+hide
+0 constant zero
+
+: ?-- ( c-addr u -- c-addr u flag )
+ 2dup s" --" compare 0= ;
+: ?} ( c-addr u -- c-addr u flag )
+ 2dup s" }" compare 0= ;
+: ?| ( c-addr u -- c-addr u flag )
+ 2dup s" |" compare 0= ;
+
+: ?delim ( c-addr u -- state | c-addr u 0 )
+ ?| if
+ 2drop 1
+ else
+ ?-- if
+ 2drop 2
+ else
+ ?} if 2drop 3 else 0 endif
+ endif
+ endif
+;
+
+set-current
+
+: {+ 0 dup locals| locstate |
+
+ \ stack locals until we hit a delimiter
+ begin
+ parse-word \ ( nLocals c-addr u )
+ ?delim dup to locstate
+ 0= while
+ rot 1+ \ ( c-addr u ... c-addr u nLocals )
+ repeat
+
+ \ now unstack the locals
+ 0 do (local) loop \ ( )
+
+ \ zero locals until -- or }
+ locstate 1 = if
+ begin
+ parse-word
+ ?delim dup to locstate
+ 0= while
+ postpone zero (local)
+ repeat
+ endif
+
+ 0 0 (local)
+
+ \ toss words until }
+ locstate 2 = if
+ begin
+ parse-word
+ ?delim dup to locstate
+ 0= while
+ 2drop
+ repeat
+ endif
+
+ locstate 3 <> abort" syntax error in { } local line"+; immediate compile-only
+
+previous
+\ #endif
+
--- /dev/null
+++ b/softwords/marker.fr
@@ -1,0 +1,25 @@
+\ ** ficl/softwords/marker.fr
+\ ** Ficl implementation of CORE EXT MARKER
+\ John Sadler, 4 Oct 98
+\ Requires ficl 2.02 FORGET-WID !!
+
+: marker ( "name" -- )
+ create
+ get-current ,
+ get-order dup ,
+ 0 ?do , loop
+ does>
+ 0 set-order \ clear search order
+ dup body> >name drop
+ here - allot \ reset HERE to my xt-addr
+ dup @ ( pfa current-wid )
+ dup set-current forget-wid ( pfa )
+ cell+ dup @ swap ( count count-addr )
+ over cells + swap ( last-wid-addr count )
+ 0 ?do
+ dup @ dup ( wid-addr wid wid )
+ >search forget-wid ( wid-addr )
+ cell-
+ loop
+ drop
+;
--- /dev/null
+++ b/test/ficltest.fr
@@ -1,0 +1,29 @@
+\ test file for ficl
+\ test ANSI CORE stuff first...
+-1 set-order
+load tester.fr
+load core.fr
+
+\ Now test ficl extras and optional word-sets
+testing :noname
+{ -> }+{ :noname 1 ; execute -> 1 }+{ 1 2 3 -rot -> 3 1 2 }+
+testing default search order
+{ get-order -> forth-wordlist 1 }+{ only definitions get-order -> forth-wordlist 1 }+
+testing forget
+here constant fence
+{ fence forget fence -> here }+
+testing within
+{ -1 1 0 within -> true }+{ 0 1s 2 within -> true }+{ -100 0 -1 within -> true }+{ -1 1 2 within -> false }+{ -1 1 -2 within -> false }+{ 1 -5 5 within -> true }+{ 33000 32000 34000 within -> true }+{ 0x80000000 0x7f000000 0x81000000 within -> true }