| 1\ #if (FICL_WANT_OOP)
|
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\
| 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\
|
13\ $FreeBSD: head/sys/boot/ficl/softwords/string.fr 61177 2000-06-02 13:49:09Z dcs $
| 14\ $FreeBSD: head/sys/boot/ficl/softwords/string.fr 76116 2001-04-29 02:36:36Z dcs $
|
14
| 15
|
15.( loading ficl string class ) cr
| |
16also oop definitions
17
18object subclass c-string
| 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
| 19 c-cell obj: .count
20 c-cell obj: .buflen
21 c-ptr obj: .buf
22 32 constant min-buf
|
23
| 23
|
24 : get-count ( 2this -- count ) c-string => .count c-4byte => get ;
25 : set-count ( count 2this -- ) c-string => .count c-4byte => set ;
| 24 : get-count ( 2:this -- count ) my=[ .count get ] ;
25 : set-count ( count 2:this -- ) my=[ .count set ] ;
|
26
| 26
|
27 : ?empty ( 2this -- flag ) --> get-count 0= ;
| 27 : ?empty ( 2:this -- flag ) --> get-count 0= ;
|
28
| 28
|
29 : get-buflen ( 2this -- len ) c-string => .buflen c-4byte => get ;
30 : set-buflen ( len 2this -- ) c-string => .buflen c-4byte => set ;
| 29 : get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
30 : set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
|
31
| 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
| 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
| 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
| 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
| 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
| 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
| 51 endif
52 ;
53
54 \ guarantee buffer is large enough to hold size chars
|
55 : size-buf { size 2this -- }
| 55 : size-buf { size 2:this -- }
|
56 size 0< abort" need positive size for size-buf"
| 56 size 0< abort" need positive size for size-buf"
|
57 size 0= if
58 2this --> free-buf exit
| 57 size 0= if
58 this --> free-buf exit
|
59 endif
60
61 \ force buflen to be a positive multiple of min-buf chars
| 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
| 62 my=> min-buf size over / 1+ * chars to size
|
63
64 \ if buffer is null, allocate one, else resize it
| 63
64 \ if buffer is null, allocate one, else resize it
|
65 2this --> get-buflen 0=
| 65 this --> get-buflen 0=
|
66 if
| 66 if
|
67 size allocate
| 67 size allocate
|
68 abort" out of memory"
| 68 abort" out of memory"
|
69 size 2this --> set-buf
70 size 2this --> set-buflen
| 69 size this --> set-buf
70 size this --> set-buflen
|
71 exit
72 endif
73
| 71 exit
72 endif
73
|
74 size 2this --> get-buflen > if
75 2this --> get-buf size resize
| 74 size this --> get-buflen > if
75 this --> get-buf size resize
|
76 abort" out of memory"
| 76 abort" out of memory"
|
77 size 2this --> set-buf
| 77 size this --> set-buf
|
78 endif
79 ;
80
| 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
| 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
| 85 ;
86
|
87 : get { 2this -- c-addr u }
88 2this --> get-buf
89 2this --> get-count
| 87 : get { 2:this -- c-addr u }
88 this --> get-buf
89 this --> get-count
|
90 ;
91
92 \ append string to existing one
| 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
| 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
| 98 ;
99
|
100 : type { 2this -- }
101 2this --> ?empty if ." (empty) " exit endif
102 2this --> .buf --> get-ptr
103 2this --> .count --> get
104 type
| 100 : type { 2:this -- }
101 this --> ?empty if ." (empty) " exit endif
102 this --> .buf --> get-ptr
103 this --> .count --> get
104 type
|
105 ;
106
| 105 ;
106
|
107 : compare ( 2string 2this -- n )
108 c-string => get
109 2swap
110 c-string => get
| 107 : compare ( 2string 2:this -- n )
108 --> get
109 2swap
110 --> get
|
111 2swap compare
112 ;
113
| 111 2swap compare
112 ;
113
|
114 : hashcode ( 2this -- hashcode )
115 c-string => get hash
| 114 : hashcode ( 2:this -- hashcode )
115 --> get hash
|
116 ;
117
| 116 ;
117
|
118 \ destructor method (overrides object --> free)
119 : free ( 2this -- ) 2dup c-string => free-buf object => free ;
| 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
| 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
| 126 : set-hashcode { 2:this -- }
127 this --> super --> hashcode
128 this --> .hashcode --> set
|
129 ;
130
| 129 ;
130
|
131 : get-hashcode ( 2this -- hashcode )
| 131 : get-hashcode ( 2:this -- hashcode )
|
132 --> .hashcode --> get
133 ;
134
| 132 --> .hashcode --> get
133 ;
134
|
135 : set ( c-addr u 2this -- )
| 135 : set ( c-addr u 2:this -- )
|
136 2swap 2over --> super --> set
137 --> set-hashcode
138 ;
139
| 136 2swap 2over --> super --> set
137 --> set-hashcode
138 ;
139
|
140 : cat ( c-addr u 2this -- )
| 140 : cat ( c-addr u 2:this -- )
|
141 2swap 2over --> super --> cat
142 --> set-hashcode
143 ;
144
145end-class
146
147previous definitions
| 141 2swap 2over --> super --> cat
142 --> set-hashcode
143 ;
144
145end-class
146
147previous definitions
|
148
| 148\ #endif
|
| |