xref: /freebsd/stand/ficl/softwords/string.fr (revision 26a58599) 
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
15also oop definitions
16
17object 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
120end-class
121
122c-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
144end-class
145
146previous definitions
147\ #endif
148