core/strings/strings.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors byte-arrays kernel
   4 kernel.private math math.private sequences sequences.private
   5 slots.private ;
   6 IN: strings
   7
   8 BUILTIN: string { length array-capacity read-only initial: 0 } aux ;
   9
  10 PRIMITIVE: <string> ( n ch -- string )
  11 PRIMITIVE: resize-string ( n str -- newstr )
  12
  13 <PRIVATE
  14 PRIMITIVE: set-string-nth-fast ( ch n string -- )
  15 PRIMITIVE: string-nth-fast ( n string -- ch )
  16
  17 : string-hashcode ( str -- n ) 3 slot ; inline
  18
  19 : set-string-hashcode ( n str -- ) 3 set-slot ; inline
  20
  21 : reset-string-hashcode ( str -- )
  22     f swap set-string-hashcode ; inline
  23
  24 : rehash-string ( str -- )
  25     0 over [
  26         swap [
  27             [ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
  28             fixnum+fast fixnum+fast
  29         ] keep fixnum-bitxor
  30     ] each swap set-string-hashcode ; inline
  31
  32 : (aux) ( n string -- byte-array m )
  33     aux>> { byte-array } declare swap 1 fixnum-shift-fast ; inline
  34
  35 : small-char? ( ch -- ? )
  36     dup 0 fixnum>= [ 0x7f fixnum<= ] [ drop f ] if ; inline
  37
  38 : string-nth ( n string -- ch )
  39     2dup string-nth-fast dup small-char?
  40     [ 2nip ] [
  41         [ (aux) alien-unsigned-2 7 fixnum-shift-fast ] dip
  42         fixnum-bitxor
  43     ] if ; inline
  44
  45 : ensure-aux ( string -- string )
  46     dup aux>> [ dup length 2 * (byte-array) >>aux ] unless ; inline
  47
  48 : set-string-nth-slow ( ch n string -- )
  49     [ [ 0x80 fixnum-bitor ] 2dip set-string-nth-fast ]
  50     [
  51         ensure-aux
  52         [ -7 fixnum-shift-fast 1 fixnum-bitxor ] 2dip
  53         (aux) set-alien-unsigned-2
  54     ] 3bi ;
  55
  56 : set-string-nth ( ch n string -- )
  57     pick small-char?
  58     [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
  59
  60 PRIVATE>
  61
  62 M: string equal?
  63     over string? [
  64         ! faster during bootstrap than ``[ hashcode ] bi@``
  65         over hashcode over hashcode eq?
  66         [ sequence= ] [ 2drop f ] if
  67     ] [
  68         2drop f
  69     ] if ;
  70
  71 M: string hashcode*
  72     nip
  73     dup string-hashcode
  74     [ ] [ dup rehash-string string-hashcode ] ?if ;
  75
  76 M: string length
  77     length>> ; inline
  78
  79 M: string nth-unsafe
  80     [ integer>fixnum ] dip string-nth ; inline
  81
  82 M: string set-nth-unsafe
  83     dup reset-string-hashcode
  84     [ integer>fixnum ] [ integer>fixnum ] [ ] tri* set-string-nth ; inline
  85
  86 M: string clone
  87     (clone) [ clone ] change-aux ; inline
  88
  89 M: string clone-like
  90     over string? [ drop clone ] [ call-next-method ] if ; inline
  91
  92 M: string resize resize-string ; inline
  93
  94 : 1string ( ch -- str ) 1 swap <string> ; inline
  95
  96 : >string ( seq -- str ) "" clone-like ; inline
  97
  98 M: string new-sequence drop 0 <string> ; inline
  99
 100 INSTANCE: string sequence