basis/hashtables/identity/identity.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors assocs hashtables hashtables.wrapped kernel
   3 parser vocabs.loader ;
   4 IN: hashtables.identity
   5
   6 <PRIVATE
   7
   8 TUPLE: identity-wrapper
   9     { underlying read-only } identity-hashcode ;
  10
  11 : <identity-wrapper> ( wrapped-key -- identity-wrapper )
  12     dup identity-hashcode identity-wrapper boa ; inline
  13
  14 M: identity-wrapper equal?
  15     over identity-wrapper?
  16     [ [ underlying>> ] bi@ eq? ]
  17     [ 2drop f ] if ; inline
  18
  19 M: identity-wrapper hashcode* nip identity-hashcode>> ; inline
  20
  21 PRIVATE>
  22
  23 TUPLE: identity-hashtable < wrapped-hashtable ;
  24
  25 : <identity-hashtable> ( n -- ihashtable )
  26     <hashtable> identity-hashtable boa ; inline
  27
  28 M: identity-hashtable wrap-key drop <identity-wrapper> ;
  29
  30 M: identity-hashtable clone
  31     underlying>> clone identity-hashtable boa ; inline
  32
  33 : identity-associate ( value key -- ihashtable )
  34     2 <identity-hashtable> [ set-at ] keep ; inline
  35
  36 : >identity-hashtable ( assoc -- ihashtable )
  37     [ assoc-size <identity-hashtable> ] keep assoc-union! ;
  38
  39 M: identity-hashtable assoc-like
  40     drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline
  41
  42 M: identity-hashtable new-assoc drop <identity-hashtable> ;
  43
  44 SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;
  45
  46 { "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when
  47 { "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when