1S" 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
16also oop definitions
17
18object 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
121end-class
122
123c-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
145end-class
146
147previous definitions
148
149[endif]
150