usr/src/common/ficl/softcore/string.fr

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