( Tcl structures D. Zoss July 2011 )
( updated for FlashForth Dec 2011 )
( implemented so far: )
( set varname )
( set varname $varname2 )
( set varname [Forth word list] )
( puts text $varname [Forth words])
( ANS Forth words not in FlashForth )
: ?dup ( ? -- ? ? or -- ? )
 dup if dup then ;
: 2swap ( a b c d -- c d a b )
 rot >r rot r> ;
: count ( a -- # a+1 )
 dup 1 + swap c@ ;
: 0> ( # -- ? ) 0 > ;
: 0< ( # -- ? ) 0 < ;
: >= ( #1 #2 -- ? ) 1- > ;
: <= ( #1 #2 -- ? ) 1+ < ;
: between ( # #1 #2 -- ? )
 rot swap over >= rot rot <= and ;
: lead- ( a # -- ? a1 #1 )
 over c@ [char] - = rot ( # ? a )
 over - swap rot over + rot swap ;
: number ( s -- n 0 )
 count lead- 0 rot rot for ( ? n a )
 swap over c@ ( -) dup emit ( -) ( ? a n c )
 dup [char] a [char] z between if
 [char] a - #10 + [char] 0 +
 else dup [char] A [char] Z between if
 [char] A - #10 + [char] 0 +
 then then
 [char] 0 - dup 0 base @ 1- between ( ? a n # ? )
 if swap base @ * + else leave then
 swap 1+ ( ? n2 a2 )
 next drop swap if negate then 0 ;

( forthtcl words start here )
: tcl-buf ( -- a0 )
 tib ;
: tcl>in+ ( -- a0 )
 tcl-buf >in @ + ;
: tcl-rew ( a0 -- )
 tcl-buf - >in ! ;
: tcl-rel ( n -- )
 tcl>in+ + tcl-rew ;
: tcl-go- ( c -- )
 begin tcl>in+ c@ over <> ( c ? )
tcl>in+ c@ .
 while -1 tcl-rel repeat drop ( -) cr ( -) ;
: tcl-eol ( -- n )
 tcl>in+ bl word count swap ( a n s)
 drop swap tcl-rew ;
: tcl-rec ( n -- )
 bl swap tcl>in+ bl over c! + c!
 interpret ;
: tcl-var ( -- n )
 tcl>in+ dup c@ [char] $ = if ( a0 )
 1 >in +! bl word count swap drop
 over over over 1+ ( a0 n a0 n a1 )
 rot rot cmove swap ( n a0 )
 over over + bl swap c! ( n a0 )
 tcl-rew else drop 0 then ;
variable #tcl
: tcl-top ( -- ) 1 #tcl +! ;
: tcl-bot ( n -- n )
 #tcl @ 1- dup #tcl ! 0= if ( n )
 dup cr . then ;
: tcl-ech ( n -- ) #tcl +! ;
: tcl-ini ( -- ) 0 #tcl ! ;
tcl-ini
: tcl-tal ( n a c n1 ? -- n2 a ? )
 if drop drop true else ( n a c n1 )
 rot rot over c@ = if ( n n1 a )
 rot rot + swap true ( n2 a true )
 else swap drop false then then ;
: tcl-fun ( -- # )
 tcl>in+ dup c@ [char] [ = if ( a0 )
 0 begin bl word count ( a0 n a # )
 dup 2swap rot for ( <a0 #> n a )
 [char] [ 1 0 tcl-tal ( n a ? )
 [char] ] -1 rot tcl-tal ( n a ?)
 if over 0= if ( >a0 #< n a )
 rot r@ swap - tcl-rel ( a0 n a)
 [char] ] tcl-go- ( a0 n a )
 0 rot rot leave ( a0 0 n a )
 then then 1+ next drop ( a0 # n)
 ?dup 0> while swap drop ( a0 n )
 repeat drop tcl>in+ over - ( a0 #)
 swap tcl-rew else drop 0 then ;
: tcl-set ( -- n )
 ' execute ( a )
 tcl-eol if dup ( a a )
 tcl-var if ( a a )
 ' execute @ ( a a n )
 else tcl-fun ?dup if ( a a # )
 tcl-rec ( a a n )
 else bl word number drop ( a a n )
 then then swap ! then @ ;
: set ( -- n )
 tcl-top tcl-set tcl-bot ;
: tcl-put ( -- )
 cr begin tcl>in+ bl word count
 while drop tcl-rew ( -- )
 tcl-var ?dup if ( # )
 tcl-var if [char] $ emit drop 2
 else ' execute @ . ( # )
 then tcl-rel ( -- )
 else tcl-fun ?dup if tcl-rec .
 else tcl>in+ dup c@ emit 1+ ( a )
 tcl-rew then then repeat ;
: puts ( -- )
 1 tcl-ech tcl-put -1 tcl-ech cr ;
: [set ( -- )
 [char] [ tcl-go- tcl-fun tcl-rec ;
Advertisements