string.fr revision 61177 
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: head/sys/boot/ficl/softwords/string.fr 61177 2000-06-02 13:49:09Z dcs $
14
15.( loading ficl string class ) cr
16also oop definitions
17
18object 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
121end-class
122
123c-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
145end-class
146
147previous definitions
148
149