basis/hashtables/identity/identity.factor

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