stand/ficl/softwords/string.fr

   1 \ #if (FICL_WANT_OOP)
   2 \ ** ficl/softwords/string.fr
   3 \ A useful dynamic string class
   4 \ John Sadler 14 Sep 1998
   5 \
   6 \ ** C - S T R I N G
   7 \ counted string, buffer sized dynamically
   8 \ Creation example:
   9 \   c-string --> new str
  10 \   s" arf arf!!" str --> set
  11 \   s" woof woof woof " str --> cat
  12 \   str --> type  cr
  13 \
  14
  15 also oop definitions
  16
  17 object subclass c-string
  18     c-cell obj: .count
  19     c-cell obj: .buflen
  20     c-ptr  obj: .buf
  21     32 constant min-buf
  22
  23     : get-count   ( 2:this -- count )  my=[ .count  get ] ;
  24     : set-count   ( count 2:this -- )  my=[ .count  set ] ;
  25
  26     : ?empty   ( 2:this -- flag )  --> get-count 0= ;
  27
  28     : get-buflen   ( 2:this -- len )  my=[ .buflen  get ] ;
  29     : set-buflen   ( len 2:this -- )  my=[ .buflen  set ] ;
  30
  31     : get-buf   ( 2:this -- ptr )     my=[ .buf get-ptr ] ;
  32     : set-buf   { ptr len 2:this -- }
  33         ptr this my=[ .buf set-ptr ]
  34         len this my=> set-buflen
  35     ;
  36
  37     \ set buffer to null and buflen to zero
  38     : clr-buf   ( 2:this -- )
  39         0 0 2over  my=> set-buf
  40         0 -rot     my=> set-count
  41     ;
  42
  43     \ free the buffer if there is one, set buf pointer to null
  44     : free-buf   { 2:this -- }
  45         this my=> get-buf
  46         ?dup if
  47             free
  48                         abort" c-string free failed"
  49                         this  my=> clr-buf
  50         endif
  51     ;
  52
  53     \ guarantee buffer is large enough to hold size chars
  54     : size-buf  { size 2:this -- }
  55         size 0< abort" need positive size for size-buf"
  56         size 0= if
  57             this --> free-buf exit
  58         endif
  59
  60         \ force buflen to be a positive multiple of min-buf chars
  61         my=> min-buf size over / 1+ * chars to size
  62
  63         \ if buffer is null, allocate one, else resize it
  64         this --> get-buflen  0=
  65         if
  66             size allocate
  67             abort" out of memory"
  68             size this --> set-buf
  69             size this --> set-buflen
  70             exit
  71         endif
  72
  73         size this --> get-buflen > if
  74             this --> get-buf size resize
  75             abort" out of memory"
  76             size this --> set-buf
  77         endif
  78     ;
  79
  80     : set   { c-addr u 2:this -- }
  81         u this --> size-buf
  82         u this --> set-count
  83         c-addr this --> get-buf  u move
  84     ;
  85
  86     : get   { 2:this -- c-addr u }
  87         this --> get-buf
  88         this --> get-count
  89     ;
  90
  91     \ append string to existing one
  92     : cat   { c-addr u 2:this -- }
  93         this --> get-count u +  dup >r
  94         this --> size-buf
  95         c-addr  this --> get-buf this --> get-count +  u move
  96         r> this --> set-count
  97     ;
  98
  99     : type   { 2:this -- }
 100             this --> ?empty if ." (empty) " exit endif
 101         this --> .buf --> get-ptr
 102         this --> .count --> get
 103         type
 104     ;
 105
 106     : compare   ( 2string 2:this -- n )
 107         --> get
 108         2swap
 109         --> get
 110         2swap compare
 111     ;
 112
 113     : hashcode   ( 2:this -- hashcode )
 114         --> get  hash
 115     ;
 116
 117     \ destructor method (overrides object --> free)
 118     : free   ( 2:this -- )  2dup --> free-buf  object => free ;
 119
 120 end-class
 121
 122 c-string subclass c-hashstring
 123     c-2byte obj: .hashcode
 124
 125     : set-hashcode   { 2:this -- }
 126         this  --> super --> hashcode
 127         this  --> .hashcode --> set
 128     ;
 129
 130     : get-hashcode   ( 2:this -- hashcode )
 131         --> .hashcode --> get
 132     ;
 133
 134     : set   ( c-addr u 2:this -- )
 135         2swap 2over --> super --> set
 136         --> set-hashcode
 137     ;
 138
 139     : cat   ( c-addr u 2:this -- )
 140         2swap 2over --> super --> cat
 141         --> set-hashcode
 142     ;
 143
 144 end-class
 145
 146 previous definitions
 147 \ #endif