core/namespaces/namespaces.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs hashtables kernel kernel.private math
   4 sequences vectors ;
   5 IN: namespaces
   6
   7 <PRIVATE
   8
   9 TUPLE: global-hashtable
  10     { boxes hashtable read-only } ;
  11 TUPLE: global-box value ;
  12
  13 : (box-at) ( key globals -- box )
  14     boxes>> [ drop f global-box boa ] cache ; foldable
  15
  16 : box-at ( key globals -- box )
  17     (box-at) { global-box } declare ; inline
  18
  19 M: global-hashtable at*
  20     boxes>> at* [
  21         { global-box } declare value>> t
  22     ] [ drop f f ] if ; inline
  23
  24 M: global-hashtable set-at
  25     box-at value<< ; inline
  26
  27 M: global-hashtable delete-at
  28     box-at f swap value<< ; inline
  29
  30 : (get-namestack) ( -- namestack )
  31     CONTEXT-OBJ-NAMESTACK context-object { vector } declare ; inline
  32
  33 : (set-namestack) ( namestack -- )
  34     CONTEXT-OBJ-NAMESTACK set-context-object ; inline
  35
  36 : >n ( namespace -- ) (get-namestack) push ;
  37
  38 : ndrop ( -- ) (get-namestack) pop* ;
  39
  40 PRIVATE>
  41
  42 : global ( -- g )
  43     OBJ-GLOBAL special-object { global-hashtable } declare ; foldable
  44
  45 : namespace ( -- namespace ) (get-namestack) last ; inline
  46 : get-namestack ( -- namestack ) (get-namestack) clone ;
  47 : set-namestack ( namestack -- ) >vector (set-namestack) ;
  48 : init-namestack ( -- ) global 1vector (set-namestack) ;
  49
  50 : get-global ( variable -- value ) global box-at value>> ; inline
  51 : set-global ( value variable -- ) global set-at ; inline
  52 : change-global ( variable quot -- )
  53     [ [ get-global ] keep ] dip dip set-global ; inline
  54 : counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; inline
  55 : initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
  56
  57 : get ( variable -- value ) (get-namestack) assoc-stack ; inline
  58 : set ( value variable -- ) namespace set-at ;
  59 : change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
  60 : on ( variable -- ) t swap set ; inline
  61 : off ( variable -- ) f swap set ; inline
  62 : toggle ( variable -- ) [ not ] change ; inline
  63 : +@ ( n variable -- ) [ 0 or + ] change ; inline
  64 : inc ( variable -- ) 1 swap +@ ; inline
  65 : dec ( variable -- ) -1 swap +@ ; inline
  66
  67 : with-variables ( ns quot -- ) swap >n call ndrop ; inline
  68 : with-scope ( quot -- ) 5 <hashtable> swap with-variables ; inline
  69 : with-variable ( value key quot -- ) [ associate ] dip with-variables ; inline
  70 : with-global ( quot -- ) [ global ] dip with-variables ; inline