core/namespaces/namespaces.factor

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