extra/memory/pools/pools.factor

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