Add something that was missing from the original 2.04 distribution.

1 files changed, 148 insertions, 0 deletions

diff --git a/sys/boot/ficl/softwords/string.fr b/sys/boot/ficl/softwords/string.fr
new file mode 100644
index 0000000..a78f4ea
--- /dev/null
+++ b/sys/boot/ficl/softwords/string.fr
@@ -0,0 +1,148 @@
+\ ** 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$
+
+.( loading ficl string class ) cr
+also oop definitions
+
+object subclass c-string
+    c-4byte obj: .count
+    c-4byte obj: .buflen
+      c-ptr obj: .buf
+    64 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 2this c-string => .buf  c-ptr => set-ptr
+        len 2this 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 -- }
+        2this c-string => get-buf
+        ?dup if
+            free
+                        abort" c-string free failed"
+                        2this  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
+            2this --> 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
+        2this --> get-buflen  0=
+        if
+            size allocate
+            abort" out of memory"
+            size 2this --> set-buf
+            size 2this --> set-buflen
+            exit
+        endif
+
+        size 2this --> get-buflen > if
+            2this --> get-buf size resize
+            abort" out of memory"
+            size 2this --> set-buf
+        endif
+    ;
+
+    : set   { c-addr u 2this -- }
+        u 2this --> size-buf
+        u 2this --> set-count
+        c-addr 2this --> get-buf  u move
+    ;
+
+    : get   { 2this -- c-addr u }
+        2this --> get-buf
+        2this --> get-count
+    ;
+
+    \ append string to existing one
+    : cat   { c-addr u 2this -- }
+        2this --> get-count u +  dup >r
+        2this --> size-buf
+        c-addr  2this --> get-buf 2this --> get-count +  u move
+        r> 2this --> set-count
+    ;
+
+    : type   { 2this -- }
+            2this --> ?empty if ." (empty) " exit endif
+        2this --> .buf --> get-ptr
+        2this --> .count --> get
+        type
+    ;
+
+    : compare   ( 2string 2this -- n )
+        c-string => get
+        2swap
+        c-string => get
+        2swap compare
+    ;
+
+    : hashcode   ( 2this -- hashcode )
+        c-string => get  hash
+    ;
+
+    \ destructor method (overrides object --> free)
+    : free   ( 2this -- )  2dup c-string => free-buf  object => free ;
+
+end-class
+
+c-string subclass c-hashstring
+    c-2byte obj: .hashcode
+
+    : set-hashcode   { 2this -- }
+        2this  --> super --> hashcode
+        2this  --> .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
+