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