1 files changed, 148 insertions, 0 deletions
diff --git a/stand/ficl/softwords/string.fr b/stand/ficl/softwords/string.fr
new file mode 100644
index 000000000000..dabb3900892f
--- /dev/null
+++ b/stand/ficl/softwords/string.fr
@@ -0,0 +1,148 @@
+\ #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