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