176116Sdcs\ #if (FICL_WANT_OOP) 261177Sdcs\ ** ficl/softwords/string.fr 361177Sdcs\ A useful dynamic string class 461177Sdcs\ John Sadler 14 Sep 1998 561177Sdcs\ 661177Sdcs\ ** C - S T R I N G 761177Sdcs\ counted string, buffer sized dynamically 861177Sdcs\ Creation example: 961177Sdcs\ c-string --> new str 1061177Sdcs\ s" arf arf!!" str --> set 1161177Sdcs\ s" woof woof woof " str --> cat 1261177Sdcs\ str --> type cr 1361177Sdcs\ 1461177Sdcs\ $FreeBSD$ 1561177Sdcs 1661177Sdcsalso oop definitions 1761177Sdcs 1861177Sdcsobject subclass c-string 1976116Sdcs c-cell obj: .count 2076116Sdcs c-cell obj: .buflen 2176116Sdcs c-ptr obj: .buf 2276116Sdcs 32 constant min-buf 2361177Sdcs 2476116Sdcs : get-count ( 2:this -- count ) my=[ .count get ] ; 2576116Sdcs : set-count ( count 2:this -- ) my=[ .count set ] ; 2661177Sdcs 2776116Sdcs : ?empty ( 2:this -- flag ) --> get-count 0= ; 2861177Sdcs 2976116Sdcs : get-buflen ( 2:this -- len ) my=[ .buflen get ] ; 3076116Sdcs : set-buflen ( len 2:this -- ) my=[ .buflen set ] ; 3161177Sdcs 3276116Sdcs : get-buf ( 2:this -- ptr ) my=[ .buf get-ptr ] ; 3376116Sdcs : set-buf { ptr len 2:this -- } 3476116Sdcs ptr this my=[ .buf set-ptr ] 3576116Sdcs len this my=> set-buflen 3661177Sdcs ; 3761177Sdcs 3861177Sdcs \ set buffer to null and buflen to zero 3976116Sdcs : clr-buf ( 2:this -- ) 4076116Sdcs 0 0 2over my=> set-buf 4176116Sdcs 0 -rot my=> set-count 4261177Sdcs ; 4361177Sdcs 4461177Sdcs \ free the buffer if there is one, set buf pointer to null 4576116Sdcs : free-buf { 2:this -- } 4676116Sdcs this my=> get-buf 4776116Sdcs ?dup if 4876116Sdcs free 4976116Sdcs abort" c-string free failed" 5076116Sdcs this my=> clr-buf 5161177Sdcs endif 5261177Sdcs ; 5361177Sdcs 5461177Sdcs \ guarantee buffer is large enough to hold size chars 5576116Sdcs : size-buf { size 2:this -- } 5661177Sdcs size 0< abort" need positive size for size-buf" 5776116Sdcs size 0= if 5876116Sdcs this --> free-buf exit 5961177Sdcs endif 6061177Sdcs 6161177Sdcs \ force buflen to be a positive multiple of min-buf chars 6276116Sdcs my=> min-buf size over / 1+ * chars to size 6361177Sdcs 6461177Sdcs \ if buffer is null, allocate one, else resize it 6576116Sdcs this --> get-buflen 0= 6661177Sdcs if 6776116Sdcs size allocate 6861177Sdcs abort" out of memory" 6976116Sdcs size this --> set-buf 7076116Sdcs size this --> set-buflen 7161177Sdcs exit 7261177Sdcs endif 7361177Sdcs 7476116Sdcs size this --> get-buflen > if 7576116Sdcs this --> get-buf size resize 7661177Sdcs abort" out of memory" 7776116Sdcs size this --> set-buf 7861177Sdcs endif 7961177Sdcs ; 8061177Sdcs 8176116Sdcs : set { c-addr u 2:this -- } 8276116Sdcs u this --> size-buf 8376116Sdcs u this --> set-count 8476116Sdcs c-addr this --> get-buf u move 8561177Sdcs ; 8661177Sdcs 8776116Sdcs : get { 2:this -- c-addr u } 8876116Sdcs this --> get-buf 8976116Sdcs this --> get-count 9061177Sdcs ; 9161177Sdcs 9261177Sdcs \ append string to existing one 9376116Sdcs : cat { c-addr u 2:this -- } 9476116Sdcs this --> get-count u + dup >r 9576116Sdcs this --> size-buf 9676116Sdcs c-addr this --> get-buf this --> get-count + u move 9776116Sdcs r> this --> set-count 9861177Sdcs ; 9961177Sdcs 10076116Sdcs : type { 2:this -- } 10176116Sdcs this --> ?empty if ." (empty) " exit endif 10276116Sdcs this --> .buf --> get-ptr 10376116Sdcs this --> .count --> get 10476116Sdcs type 10561177Sdcs ; 10661177Sdcs 10776116Sdcs : compare ( 2string 2:this -- n ) 10876116Sdcs --> get 10976116Sdcs 2swap 11076116Sdcs --> get 11161177Sdcs 2swap compare 11261177Sdcs ; 11361177Sdcs 11476116Sdcs : hashcode ( 2:this -- hashcode ) 11576116Sdcs --> get hash 11661177Sdcs ; 11761177Sdcs 11876116Sdcs \ destructor method (overrides object --> free) 11976116Sdcs : free ( 2:this -- ) 2dup --> free-buf object => free ; 12061177Sdcs 12161177Sdcsend-class 12261177Sdcs 12361177Sdcsc-string subclass c-hashstring 12461177Sdcs c-2byte obj: .hashcode 12561177Sdcs 12676116Sdcs : set-hashcode { 2:this -- } 12776116Sdcs this --> super --> hashcode 12876116Sdcs this --> .hashcode --> set 12961177Sdcs ; 13061177Sdcs 13176116Sdcs : get-hashcode ( 2:this -- hashcode ) 13261177Sdcs --> .hashcode --> get 13361177Sdcs ; 13461177Sdcs 13576116Sdcs : set ( c-addr u 2:this -- ) 13661177Sdcs 2swap 2over --> super --> set 13761177Sdcs --> set-hashcode 13861177Sdcs ; 13961177Sdcs 14076116Sdcs : cat ( c-addr u 2:this -- ) 14161177Sdcs 2swap 2over --> super --> cat 14261177Sdcs --> set-hashcode 14361177Sdcs ; 14461177Sdcs 14561177Sdcsend-class 14661177Sdcs 14761177Sdcsprevious definitions 14876116Sdcs\ #endif 149