core/collections/namespaces.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: kernel-internals
   4 USING: vectors sequences ;
   5
   6 : namestack* ( -- namestack )
   7     3 getenv { vector } declare ; inline
   8 : >n ( namespace -- ) namestack* push ;
   9 : n> ( -- namespace ) namestack* pop ;
  10
  11 IN: namespaces
  12 USING: arrays hashtables kernel kernel-internals math strings
  13 words ;
  14
  15 : namestack ( -- namestack ) namestack* clone ; inline
  16 : set-namestack ( namestack -- ) >vector 3 setenv ; inline
  17 : namespace ( -- namespace ) namestack* peek ;
  18 : ndrop ( -- ) namestack* pop* ;
  19 : global ( -- g ) 4 getenv { hashtable } declare ; inline
  20 : get ( variable -- value ) namestack* hash-stack ;
  21 : set ( value variable -- ) namespace set-hash ; inline
  22 : on ( variable -- ) t swap set ; inline
  23 : off ( variable -- ) f swap set ; inline
  24 : get-global ( variable -- value ) global hash ; inline
  25 : set-global ( value variable -- ) global set-hash ; inline
  26
  27 : nest ( variable -- namespace )
  28     dup namespace hash [ ] [ >r H{ } clone dup r> set ] ?if ;
  29
  30 : change ( variable quot -- )
  31     >r dup get r> rot slip set ; inline
  32
  33 : +@ ( n variable -- ) [ [ 0 ] unless* + ] change ;
  34
  35 : inc ( variable -- ) 1 swap +@ ; inline
  36
  37 : dec ( variable -- ) -1 swap +@ ; inline
  38
  39 : bind ( ns quot -- ) swap >n call ndrop ; inline
  40
  41 : counter ( variable -- n ) global [ dup inc get ] bind ;
  42
  43 : make-hash ( quot -- hash ) H{ } clone >n call n> ; inline
  44
  45 : with-scope ( quot -- ) H{ } clone >n call ndrop ; inline
  46
  47 ! Building sequences
  48 SYMBOL: building
  49
  50 : make ( quot exemplar -- seq )
  51     >r
  52     [ V{ } clone building set call building get ] with-scope
  53     r> like ; inline
  54
  55 : , ( elt -- ) building get push ;
  56
  57 : % ( seq -- ) building get swap nappend ;
  58
  59 : init-namespaces ( -- ) global 1array set-namestack ;
  60
  61 IN: sequences
  62
  63 : join ( seq glue -- newseq )
  64     [ swap [ % ] [ dup % ] interleave drop ] over make ;