core/namespaces/namespaces.factor

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