core/growable/growable.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel math math.private sequences
   4 sequences.private ;
   5 IN: growable
   6
   7 MIXIN: growable
   8
   9 SLOT: length
  10 SLOT: underlying
  11
  12 M: growable length length>> ; inline
  13 M: growable nth-unsafe underlying>> nth-unsafe ; inline
  14 M: growable set-nth-unsafe underlying>> set-nth-unsafe ; inline
  15
  16 <PRIVATE
  17
  18 : push-unsafe ( elt seq -- )
  19     [ length integer>fixnum-strict ] keep
  20     [ set-nth-unsafe ] [ [ 1 fixnum+fast ] dip length<< ] 2bi ; inline
  21
  22 : push-all-unsafe ( from to src dst -- )
  23     [ over - swap ] 2dip pickd [ length integer>fixnum-strict ] keep
  24     [ [ fixnum+fast ] dip length<< ] 2keep <copier> (copy) drop ; inline
  25
  26 PRIVATE>
  27
  28 : capacity ( seq -- n ) underlying>> length ; inline
  29
  30 : expand ( len seq -- )
  31     [ resize ] change-underlying drop ; inline
  32
  33 GENERIC: contract ( len seq -- )
  34
  35 M: growable contract
  36     [ length ] keep
  37     [ [ 0 ] 2dip set-nth-unsafe ] curry
  38     each-integer-from ; inline
  39
  40 M: growable set-length
  41     bounds-check-head
  42     2dup length < [
  43         2dup contract
  44     ] [
  45         2dup capacity > [ 2dup expand ] when
  46     ] if
  47     length<< ;
  48
  49 : new-size ( old -- new ) 1 + 2 * ; inline
  50
  51 : ensure ( n seq -- n seq )
  52     bounds-check-head
  53     2dup length >= [
  54         2dup capacity >= [ over new-size over expand ] when
  55         [ integer>fixnum-strict ] dip
  56         over 1 fixnum+fast >>length
  57     ] [
  58         [ integer>fixnum-strict ] dip
  59     ] if ; inline
  60
  61 M: growable set-nth ensure set-nth-unsafe ; inline
  62
  63 M: growable clone (clone) [ clone ] change-underlying ; inline
  64
  65 M: growable lengthen
  66     2dup length > [
  67         2dup capacity > [ over new-size over expand ] when
  68         2dup length<<
  69     ] when 2drop ; inline
  70
  71 M: growable shorten
  72     bounds-check-head
  73     2dup length < [
  74         2dup contract
  75         2dup length<<
  76     ] when 2drop ; inline
  77
  78 M: growable new-resizable new-sequence 0 over set-length ; inline
  79
  80 INSTANCE: growable sequence