S" FICL_WANT_OOP" ENVIRONMENT? drop [if]
\ 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
\
.( loading ficl string class ) cr
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]