core/growable/growable.factor

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