149 lines
3.5 KiB
Forth
149 lines
3.5 KiB
Forth
\ #if (FICL_WANT_OOP)
|
|
\ ** ficl/softwords/string.fr
|
|
\ A useful dynamic string class
|
|
\ John Sadler 14 Sep 1998
|
|
\
|
|
\ ** C - S T R I N G
|
|
\ counted string, buffer sized dynamically
|
|
\ Creation example:
|
|
\ c-string --> new str
|
|
\ s" arf arf!!" str --> set
|
|
\ s" woof woof woof " str --> cat
|
|
\ str --> type cr
|
|
\
|
|
\ $FreeBSD$
|
|
|
|
also oop definitions
|
|
|
|
object subclass c-string
|
|
c-cell obj: .count
|
|
c-cell obj: .buflen
|
|
c-ptr obj: .buf
|
|
32 constant min-buf
|
|
|
|
: get-count ( 2:this -- count ) my=[ .count get ] ;
|
|
: set-count ( count 2:this -- ) my=[ .count set ] ;
|
|
|
|
: ?empty ( 2:this -- flag ) --> get-count 0= ;
|
|
|
|
: get-buflen ( 2:this -- len ) my=[ .buflen get ] ;
|
|
: set-buflen ( len 2:this -- ) my=[ .buflen set ] ;
|
|
|
|
: get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ;
|
|
: set-buf { ptr len 2:this -- }
|
|
ptr this my=[ .buf set-ptr ]
|
|
len this my=> set-buflen
|
|
;
|
|
|
|
\ set buffer to null and buflen to zero
|
|
: clr-buf ( 2:this -- )
|
|
0 0 2over my=> set-buf
|
|
0 -rot my=> set-count
|
|
;
|
|
|
|
\ free the buffer if there is one, set buf pointer to null
|
|
: free-buf { 2:this -- }
|
|
this my=> get-buf
|
|
?dup if
|
|
free
|
|
abort" c-string free failed"
|
|
this my=> clr-buf
|
|
endif
|
|
;
|
|
|
|
\ guarantee buffer is large enough to hold size chars
|
|
: size-buf { size 2:this -- }
|
|
size 0< abort" need positive size for size-buf"
|
|
size 0= if
|
|
this --> free-buf exit
|
|
endif
|
|
|
|
\ force buflen to be a positive multiple of min-buf chars
|
|
my=> min-buf size over / 1+ * chars to size
|
|
|
|
\ if buffer is null, allocate one, else resize it
|
|
this --> get-buflen 0=
|
|
if
|
|
size allocate
|
|
abort" out of memory"
|
|
size this --> set-buf
|
|
size this --> set-buflen
|
|
exit
|
|
endif
|
|
|
|
size this --> get-buflen > if
|
|
this --> get-buf size resize
|
|
abort" out of memory"
|
|
size this --> set-buf
|
|
endif
|
|
;
|
|
|
|
: set { c-addr u 2:this -- }
|
|
u this --> size-buf
|
|
u this --> set-count
|
|
c-addr this --> get-buf u move
|
|
;
|
|
|
|
: get { 2:this -- c-addr u }
|
|
this --> get-buf
|
|
this --> get-count
|
|
;
|
|
|
|
\ append string to existing one
|
|
: cat { c-addr u 2:this -- }
|
|
this --> get-count u + dup >r
|
|
this --> size-buf
|
|
c-addr this --> get-buf this --> get-count + u move
|
|
r> this --> set-count
|
|
;
|
|
|
|
: type { 2:this -- }
|
|
this --> ?empty if ." (empty) " exit endif
|
|
this --> .buf --> get-ptr
|
|
this --> .count --> get
|
|
type
|
|
;
|
|
|
|
: compare ( 2string 2:this -- n )
|
|
--> get
|
|
2swap
|
|
--> get
|
|
2swap compare
|
|
;
|
|
|
|
: hashcode ( 2:this -- hashcode )
|
|
--> get hash
|
|
;
|
|
|
|
\ destructor method (overrides object --> free)
|
|
: free ( 2:this -- ) 2dup --> free-buf object => free ;
|
|
|
|
end-class
|
|
|
|
c-string subclass c-hashstring
|
|
c-2byte obj: .hashcode
|
|
|
|
: set-hashcode { 2:this -- }
|
|
this --> super --> hashcode
|
|
this --> .hashcode --> set
|
|
;
|
|
|
|
: get-hashcode ( 2:this -- hashcode )
|
|
--> .hashcode --> get
|
|
;
|
|
|
|
: set ( c-addr u 2:this -- )
|
|
2swap 2over --> super --> set
|
|
--> set-hashcode
|
|
;
|
|
|
|
: cat ( c-addr u 2:this -- )
|
|
2swap 2over --> super --> cat
|
|
--> set-hashcode
|
|
;
|
|
|
|
end-class
|
|
|
|
previous definitions
|
|
\ #endif
|