1S" FICL_WANT_OOP" ENVIRONMENT? drop [if] 2\ ** ficl/softwords/string.fr 3\ A useful dynamic string class 4\ John Sadler 14 Sep 1998 5\ 6\ ** C - S T R I N G 7\ counted string, buffer sized dynamically 8\ Creation example: 9\ c-string --> new str 10\ s" arf arf!!" str --> set 11\ s" woof woof woof " str --> cat 12\ str --> type cr 13\ 14 15.( loading ficl string class ) cr 16also oop definitions 17 18object subclass c-string 19 c-cell obj: .count 20 c-cell obj: .buflen 21 c-ptr obj: .buf 22 32 constant min-buf 23 24 : get-count ( 2:this -- count ) my=[ .count get ] ; 25 : set-count ( count 2:this -- ) my=[ .count set ] ; 26 27 : ?empty ( 2:this -- flag ) --> get-count 0= ; 28 29 : get-buflen ( 2:this -- len ) my=[ .buflen get ] ; 30 : set-buflen ( len 2:this -- ) my=[ .buflen set ] ; 31 32 : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ; 33 : set-buf { ptr len 2:this -- } 34 ptr this my=[ .buf set-ptr ] 35 len this my=> set-buflen 36 ; 37 38 \ set buffer to null and buflen to zero 39 : clr-buf ( 2:this -- ) 40 0 0 2over my=> set-buf 41 0 -rot my=> set-count 42 ; 43 44 \ free the buffer if there is one, set buf pointer to null 45 : free-buf { 2:this -- } 46 this my=> get-buf 47 ?dup if 48 free 49 abort" c-string free failed" 50 this my=> clr-buf 51 endif 52 ; 53 54 \ guarantee buffer is large enough to hold size chars 55 : size-buf { size 2:this -- } 56 size 0< abort" need positive size for size-buf" 57 size 0= if 58 this --> free-buf exit 59 endif 60 61 \ force buflen to be a positive multiple of min-buf chars 62 my=> min-buf size over / 1+ * chars to size 63 64 \ if buffer is null, allocate one, else resize it 65 this --> get-buflen 0= 66 if 67 size allocate 68 abort" out of memory" 69 size this --> set-buf 70 size this --> set-buflen 71 exit 72 endif 73 74 size this --> get-buflen > if 75 this --> get-buf size resize 76 abort" out of memory" 77 size this --> set-buf 78 endif 79 ; 80 81 : set { c-addr u 2:this -- } 82 u this --> size-buf 83 u this --> set-count 84 c-addr this --> get-buf u move 85 ; 86 87 : get { 2:this -- c-addr u } 88 this --> get-buf 89 this --> get-count 90 ; 91 92 \ append string to existing one 93 : cat { c-addr u 2:this -- } 94 this --> get-count u + dup >r 95 this --> size-buf 96 c-addr this --> get-buf this --> get-count + u move 97 r> this --> set-count 98 ; 99 100 : type { 2:this -- } 101 this --> ?empty if ." (empty) " exit endif 102 this --> .buf --> get-ptr 103 this --> .count --> get 104 type 105 ; 106 107 : compare ( 2string 2:this -- n ) 108 --> get 109 2swap 110 --> get 111 2swap compare 112 ; 113 114 : hashcode ( 2:this -- hashcode ) 115 --> get hash 116 ; 117 118 \ destructor method (overrides object --> free) 119 : free ( 2:this -- ) 2dup --> free-buf object => free ; 120 121end-class 122 123c-string subclass c-hashstring 124 c-2byte obj: .hashcode 125 126 : set-hashcode { 2:this -- } 127 this --> super --> hashcode 128 this --> .hashcode --> set 129 ; 130 131 : get-hashcode ( 2:this -- hashcode ) 132 --> .hashcode --> get 133 ; 134 135 : set ( c-addr u 2:this -- ) 136 2swap 2over --> super --> set 137 --> set-hashcode 138 ; 139 140 : cat ( c-addr u 2:this -- ) 141 2swap 2over --> super --> cat 142 --> set-hashcode 143 ; 144 145end-class 146 147previous definitions 148 149[endif] 150