extra/tokyo/assoc-functor/assoc-functor.factor

   1 ! Copyright (C) 2009 Bruno Deferrari
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays assocs destructors fry functors
   4 kernel locals sequences serialize tokyo.alien.tcutil tokyo.utils vectors ;
   5 IN: tokyo.assoc-functor
   6
   7 FUNCTOR: define-tokyo-assoc-api ( T N -- )
   8
   9 DBGET      IS ${T}get
  10 DBPUT      IS ${T}put
  11 DBOUT      IS ${T}out
  12 DBDEL      IS ${T}del
  13 DBRNUM     IS ${T}rnum
  14 DBITERINIT IS ${T}iterinit
  15 DBITERNEXT IS ${T}iternext
  16 DBVANISH   IS ${T}vanish
  17
  18 DBKEYS DEFINES tokyo-${N}-keys
  19
  20 TYPE DEFINES-CLASS tokyo-${N}
  21
  22 WHERE
  23
  24 TUPLE: TYPE handle disposed ;
  25
  26 INSTANCE: TYPE assoc
  27
  28 M: TYPE dispose* [ DBDEL f ] change-handle drop ;
  29
  30 M: TYPE at* ( key db -- value/f ? )
  31     handle>> swap object>bytes dup length 0 int <ref>
  32     DBGET [ [ memory>object ] [ tcfree ] bi t ] [ f f ] if* ;
  33
  34 M: TYPE assoc-size ( db -- size ) handle>> DBRNUM ;
  35
  36 : DBKEYS ( db -- keys )
  37     [ assoc-size <vector> ] [ handle>> ] bi
  38     dup DBITERINIT drop 0 int <ref>
  39     [ 2dup DBITERNEXT dup ] [
  40         [ memory>object ] [ tcfree ] bi
  41         [ pick ] dip swap push
  42     ] while 3drop ;
  43
  44 M: TYPE >alist ( db -- alist )
  45     [ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ;
  46
  47 M: TYPE set-at ( value key db -- )
  48     handle>> swap rot [ object>bytes dup length ] bi@ DBPUT drop ;
  49
  50 M: TYPE delete-at ( key db -- )
  51     handle>> swap object>bytes dup length DBOUT drop ;
  52
  53 M: TYPE clear-assoc ( db -- ) handle>> DBVANISH drop ;
  54
  55 M: TYPE equal? assoc= ;
  56
  57 M: TYPE hashcode* assoc-hashcode ;
  58
  59 ;FUNCTOR