extra/memory/pools/pools.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors arrays bit-arrays classes
   3 classes.tuple.private fry kernel locals math parser
   4 sequences sequences.private vectors words ;
   5 IN: memory.pools
   6
   7 TUPLE: pool
   8     prototype
   9     { objects vector } ;
  10
  11 : <pool> ( size class -- pool )
  12     [ nip new ]
  13     [ '[ _ new ] V{ } replicate-as ] 2bi
  14     pool boa ;
  15
  16 : pool-size ( pool -- size )
  17     objects>> length ;
  18
  19 <PRIVATE
  20
  21 :: copy-tuple ( from to -- to )
  22     from tuple-size :> size
  23     size [| n | n from array-nth n to set-array-nth ] each-integer
  24     to ; inline
  25
  26 : (pool-new) ( pool -- object )
  27     objects>> [ f ] [ pop ] if-empty ;
  28
  29 : (pool-init) ( pool object -- object )
  30     [ prototype>> ] dip copy-tuple ; inline
  31
  32 PRIVATE>
  33
  34 : pool-new ( pool -- object )
  35     dup (pool-new) [ (pool-init) ] [ drop f ] if* ; inline
  36
  37 : pool-free ( object pool -- )
  38     objects>> push ;
  39
  40 : class-pool ( class -- pool )
  41     "pool" word-prop ;
  42
  43 : set-class-pool ( class pool -- )
  44     "pool" set-word-prop ;
  45
  46 : new-from-pool ( class -- object )
  47     class-pool pool-new ;
  48
  49 : free-to-pool ( object -- )
  50     dup class-of class-pool pool-free ;
  51
  52 SYNTAX: POOL:
  53     scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;