home: hub: 9ficl

ref: 95b4ab0e4c91aace77aba972819a12c4f430e8f1
dir: /softwords/string.fr/

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

.( 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   ( 2this -- count )  c-string => .count  c-4byte => get ;
    : set-count   ( count 2this -- )  c-string => .count  c-4byte => set ;

    : ?empty   ( 2this -- flag )  --> get-count 0= ;

    : get-buflen   ( 2this -- len )  c-string => .buflen  c-4byte => get ;
    : set-buflen   ( len 2this -- )  c-string => .buflen  c-4byte => set ;

    : get-buf   ( 2this -- ptr )  c-string => .buf  c-ptr => get-ptr ;
    : set-buf   { ptr len 2this -- }  
        ptr this c-string => .buf  c-ptr => set-ptr 
        len this c-string => set-buflen 
    ;

    \ set buffer to null and buflen to zero
    : clr-buf   ( 2this -- )
        0 0 2over  c-string => set-buf 
        0 -rot     c-string => set-count
    ;

    \ free the buffer if there is one, set buf pointer to null
    : free-buf   { 2this -- }
        this c-string => get-buf 
        ?dup if 
            free 
			abort" c-string free failed"
			this  c-string => clr-buf
        endif
    ;

    \ guarantee buffer is large enough to hold size chars
    : size-buf  { size 2this -- }
        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
        c-string => 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 2this -- }
        u this --> size-buf
        u this --> set-count
        c-addr this --> get-buf  u move  
    ;

    : get   { 2this -- c-addr u }
        this --> get-buf
        this --> get-count
    ;

    \ append string to existing one
    : cat   { c-addr u 2this -- }
        this --> get-count u +  dup >r
        this --> size-buf
        c-addr  this --> get-buf this --> get-count +  u move
        r> this --> set-count
    ;

    : type   { 2this -- }
	    this --> ?empty if ." (empty) " exit endif
        this --> .buf --> get-ptr 
        this --> .count --> get 
        type  
    ;

    : compare   ( 2string 2this -- n )
        --> get 
        2swap 
        --> get 
        2swap compare
    ;

    : hashcode   ( 2this -- hashcode )
        --> get  hash
    ;

    \ destructor method (overrides object --> free) 
    : free   ( 2this -- )  2dup --> free-buf  object => free ;

end-class

c-string subclass c-hashstring
    c-2byte obj: .hashcode

    : set-hashcode   { 2this -- }
        this  --> super --> hashcode 
        this  --> .hashcode --> set
    ;

    : get-hashcode   ( 2this -- hashcode )
        --> .hashcode --> get
    ;

    : set   ( c-addr u 2this -- )
        2swap 2over --> super --> set
        --> set-hashcode
    ;

    : cat   ( c-addr u 2this -- )
        2swap 2over --> super --> cat
        --> set-hashcode
    ;

end-class

previous definitions