sys/boot/ficl/softwords/string.fr

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