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