freebsd-dev/stand/ficl/softwords/string.fr

\ #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