private vocabulary chains

 Strings Library ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2010,        Charles Childers                 )
( Copyright [c] 2009 - 2010, Luke Parrish                     )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( str-pos                                                     )
(   Search a string 'haystack' for a substring 'needle'       )
(   haystack needle - flag                                    )
(                                                             )
( trim-left                                                   )
(   Return a string sans leading spaces.                      )
(   string - string                                           )
(                                                             )
( trim-right                                                  )
(   Return a string sans trailing spaces.                     )
(   string - string                                           )
(                                                             )
( char-pos                                                    )
(   Return the address of a character in a string             )
(   string character - string                                 )
(                                                             )
( substr                                                      )
(   Return the address of a subset of a string                )
(   string left right - string                                )
(                                                             )
( strmid                                                      )
(   Return a subset from the middle of a string               )
(   string start length - string                              )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

{{
  4 elements length needle haystack flag
  : place  ( $$n- ) dup push copy 0 pop here + ! ;
  : prep   (  $$- ) dup getLength !length !needle !haystack ;
  : move   (    - ) @haystack here @length place @haystack 1+ !haystack ;
  : cmp    (    - ) @needle   here compare if @haystack 1- !flag then ;
---reveal---
  : str-pos ( $$-f )
    flag off prep @haystack getLength for move cmp next @flag ;
}}

: char-pos ( $c-a )
  push
  repeat @+
    dup 0 =if rdrop 2drop 0 ;then
    r =if rdrop 1- ;then
  again ;


{{
  4 elements right left src len
  create buffer 1024 allot
  : trim   ( $-$ )
    dup dup getLength + 1-
    dup @ 32 =if 0 swap ! dup 1- -- trim ;then drop ;
---reveal---
  : substr ( $nn-$ )
    buffer 0 1024 fill
    !right !left !src
    @src @left + @right buffer swap copy buffer ;
  : strmid ( $nn-$ )
    !right !left dup getLength !len
    @left @len @right - @left - substr ;
  : trim-left ( $-$ )
    dup !src dup getLength
    for dup @ 32 !if rdrop ;then 1+ next drop @src ;
  : trim-right ( $-$ )
    buffer 0 1024 fill
    buffer over getLength copy
    buffer trim ;
}}


( Vocabulary Chains ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2010, Charles Childers                        )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( A lightweight alternative to full-blown vocabularies        )
(                                                             )
( chain: name                                                 )
( Create a new chain.                                         )
(                                                             )
( +link                                                       )
( Move the last defined word into the newest chain            )
(                                                             )
( seal                                                        )
( Close a chain off                                           )
(                                                             )
( \chain.wordname                                             )
( Access a word in a chain.                                   )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )

{{
  2 elements root link
---reveal---
  : chain: create here !root 0 , here !link 2 allot ;
  : +link here push @link , @last , pop !link @@last !last ;
  : seal  @link @root ! ;
}}

{{
  3 elements flag dt name
  : (init    ( $-   ) 0 !flag 0 !dt tempString !name ;
  : cleanup) ( n-af ) @dt @flag ;
  : search   ( a-   )
   repeat
     dup @1+ d->name @name
     compare if @1+ !dt -1 !flag ;then
     @ 0;
   again ;
---reveal---
  : search-chain ( a$-af ) (init search cleanup) ;
}}

{
  : split    (  $-$$ )
    dup s" ." str-pos dup push over - 0 swap substr pop 1+ ;
  : inChain? ( $a-af ) @d->xt swap search-chain ;
  : expand   (  d-aa ) dup @d->xt swap @d->class ;
  : __\      (  "-   )
    split swap find
    if inChain? if expand with-class ;then ;then 2drop ; parsing prefix
}


( ~~~~~~~~ TEST ~~~~~~~~~~ )
chain: test
  318 variable: fiz ' fiz . +link
  : foo 1 . ; ' foo . +link
  : bar ." Hello from 'bar'" cr ; ' bar . +link
seal

\test.foo

: hello \test.bar ;