Annotation of gforth/contrib/strings.fs, revision 1.1

1.1     ! anton       1: \ strings.fs
        !             2: \
        !             3: \ Gforth Version of the kForth string utility words
        !             4: \
        !             5: \ Copyright (c) 1999--2004 Krishna Myneni
        !             6: \
        !             7: \ This software is provided under the terms of the
        !             8: \ GNU General Public License.
        !             9: \
        !            10: \ Revisions:
        !            11: \
        !            12: \      03-24-1999  created  km
        !            13: \      03-25-1999  added number to string conversions  km
        !            14: \      08-12-1999  fixed f>string  km
        !            15: \      10-11-1999  added blank  km
        !            16: \      12-12-1999  fixed f>string for zero case  km
        !            17: \      12-22-1999  added -trailing, scan, and skip  km
        !            18: \      01-23-2000  replaced char with [char] for ANS Forth compatibility  km
        !            19: \      06-16-2000  added isdigit and modified string>s and string>f  km
        !            20: \      09-02-2000  fixed u>string to work over full range  km
        !            21: \      07-12-2001  used built-in Forth words <# #s #> for conversions,
        !            22: \                    added ud>string and d>string. f>string now can handle
        !            23: \                     decimal places greater than 8  km
        !            24: \      09-21-2001  changed occurences of DO to ?DO  km
        !            25: \      10-02-2001  added parse_args  km
        !            26: \      10-10-2001  fixed problem with f>string when number is 0e  km
        !            27: \      10-15-2001  added /STRING  km
        !            28: \      03-28-2002  added SEARCH, PARSE_TOKEN, PARSE_LINE, IS_LC_ALPHA  km
        !            29: \      07-31-2002  added SLITERAL; removed SEARCH since SEARCH and
        !            30: \                    COMPARE are now part of kForth  km
        !            31: \       04-12-2003  ported to PFE, gforth. removed defs of intrinsic words,
        !            32: \                    recoded for separate fp stack  km
        !            33: 
        !            34: : parse_token ( a u -- a2 u2 a3 u3)
        !            35:        \ parse next token from the string; a3 u3 is the token string
        !            36:        BL SKIP 2DUP BL SCAN 2>R R@ - 2R> 2SWAP ;
        !            37: 
        !            38: : parse_line ( a u -- a1 u1 a2 u2 ... n )
        !            39:        ( -trailing)
        !            40:        0 >r
        !            41:        begin
        !            42:          parse_token
        !            43:          dup
        !            44:        while
        !            45:          r> 1+ >r
        !            46:          2swap
        !            47:        repeat  
        !            48:        2drop 2drop r> ;
        !            49: 
        !            50: : is_lc_alpha ( n -- flag | true if n is a lower case alphabetical character)
        !            51:        DUP 96 > SWAP 123 < AND ;       
        !            52:        
        !            53: : isdigit ( n -- flag | return true if n is ascii value of '0' through '9' )
        !            54:        dup [char] / > swap [char] : < and ;
        !            55: 
        !            56: : strcpy ( ^str addr -- | copy a counted string to addr )
        !            57:        >r dup c@ 1+ r> swap cmove ;
        !            58: 
        !            59: : strlen ( addr -- len | determine length of a null terminated string )
        !            60:        \ This word is not intended for use on counted strings;
        !            61:        \ Use "count" to obtain the length of a counted string.
        !            62:        0
        !            63:        begin
        !            64:          over c@ 0= dup invert if -rot 1+ swap 1+ swap rot then 
        !            65:        until
        !            66:        nip ;
        !            67: 
        !            68: 
        !            69: 16384 constant STR_BUF_SIZE
        !            70: create string_buf STR_BUF_SIZE allot   \ dynamic string buffer
        !            71: variable str_buf_ptr
        !            72: string_buf str_buf_ptr !
        !            73: 
        !            74: : adjust_str_buf_ptr ( u -- | adjust pointer to accomodate u bytes )
        !            75:        str_buf_ptr @ swap +
        !            76:        string_buf STR_BUF_SIZE + >=
        !            77:        if
        !            78:          string_buf str_buf_ptr !      \ wrap pointer
        !            79:        then ;
        !            80: 
        !            81: : strbufcpy ( ^str1 -- ^str2 | copy a counted string to the dynamic string buffer )
        !            82:        dup c@ 1+ dup adjust_str_buf_ptr
        !            83:        swap str_buf_ptr @ strcpy
        !            84:        str_buf_ptr @ dup rot + str_buf_ptr ! ;
        !            85: 
        !            86: : strcat ( addr1 u1 addr2 u2 -- addr3 u3 )
        !            87:        rot 2dup + 1+ adjust_str_buf_ptr 
        !            88:        -rot
        !            89:        2swap dup >r
        !            90:        str_buf_ptr @ swap cmove
        !            91:        str_buf_ptr @ r@ +
        !            92:        swap dup r> + >r
        !            93:        cmove 
        !            94:        str_buf_ptr @
        !            95:        dup r@ + 0 swap c!
        !            96:        dup r@ + 1+ str_buf_ptr !
        !            97:        r> ;
        !            98: 
        !            99: : strpck ( addr u -- ^str | create counted string )
        !           100:        255 min dup 1+ adjust_str_buf_ptr 
        !           101:        dup str_buf_ptr @ c!
        !           102:        tuck str_buf_ptr @ 1+ swap cmove
        !           103:        str_buf_ptr @ over + 1+ 0 swap c!
        !           104:        str_buf_ptr @
        !           105:        dup rot 1+ + str_buf_ptr ! ;
        !           106: 
        !           107: \
        !           108: \ Base 10 number to string conversions and vice-versa
        !           109: \
        !           110: 
        !           111: 32 constant NUMBER_BUF_LEN
        !           112: create number_buf NUMBER_BUF_LEN allot
        !           113: 
        !           114: create fnumber_buf 64 allot
        !           115: variable number_sign
        !           116: variable number_val
        !           117: variable fnumber_sign
        !           118: fvariable fnumber_val
        !           119: fvariable fnumber_divisor
        !           120: variable fnumber_power
        !           121: variable fnumber_digits
        !           122: variable fnumber_whole_part
        !           123: 
        !           124: variable number_count
        !           125: 
        !           126: : u>string ( u -- ^str | create counted string to represent u in base 10 )
        !           127:        base @ swap decimal 0 <# #s #> strpck swap base ! ;
        !           128: 
        !           129: : ud>string ( ud -- ^str | create counted string to represent ud in base 10 )
        !           130:        base @ >r decimal <# #s #> strpck r> base ! ;
        !           131: 
        !           132: : d>string ( d -- ^str | create counted string to represent d in base 10 )
        !           133:        dup >r dabs ud>string r> 0< if s" -" rot count strcat strpck then ;
        !           134: 
        !           135: : s>string ( n -- ^str | create counted string to represent n in  base 10 )
        !           136:        dup >r abs u>string
        !           137:        r> 0< if
        !           138:          s" -" rot count strcat strpck
        !           139:        then ;
        !           140: 
        !           141: : string>s ( ^str -- n | always interpret in base 10 )
        !           142:        0 number_val !
        !           143:        false number_sign !
        !           144:        count
        !           145:        0 ?do
        !           146:          dup c@
        !           147:          case
        !           148:            [char] -  of true number_sign ! endof 
        !           149:            [char] +  of false number_sign ! endof 
        !           150:            dup isdigit 
        !           151:            if
        !           152:              dup [char] 0 - number_val @ 10 * + number_val !
        !           153:            then
        !           154:          endcase
        !           155:          1+
        !           156:        loop
        !           157:        drop
        !           158:        number_val @ number_sign @ if negate then ;
        !           159: 
        !           160:   \ conversion is in exponential format with n places 
        !           161: 
        !           162: : f>string ( n -- ^str ) ( F: f -- )
        !           163:        fdup f0=
        !           164:        if
        !           165:          f>d <# rot 0 ?do # loop #> s" e0" strcat 
        !           166:          s"  0." 2swap strcat strpck exit        
        !           167:        then
        !           168:        dup 16 swap u< if drop fdrop c" ******" exit then  \ test for invalid n
        !           169:        fnumber_digits !
        !           170:        0 fnumber_power !
        !           171:        fdup 0e f< fnumber_sign ! 
        !           172:        fabs
        !           173:        fdup 1e f<
        !           174:        if
        !           175:          fdup 0e f>
        !           176:          if
        !           177:            begin
        !           178:              10e f* -1 fnumber_power +!
        !           179:              fdup 1e f>=
        !           180:            until
        !           181:          then
        !           182:        else
        !           183:          fdup 
        !           184:          10e f>=
        !           185:          if
        !           186:            begin
        !           187:              10e f/ 1 fnumber_power +!
        !           188:              fdup 10e f<
        !           189:            until
        !           190:          then
        !           191:        then
        !           192:        10e fnumber_digits @ ( s>f) s>d d>f  f**
        !           193:        f* floor f>d d>string
        !           194:        count drop dup fnumber_buf
        !           195:        fnumber_sign @ 
        !           196:        if [char] - else bl then 
        !           197:        swap c!
        !           198:        fnumber_buf 1+ 1 cmove
        !           199:        1+
        !           200:        [char] . fnumber_buf 2 + c!
        !           201:        fnumber_buf 3 + fnumber_digits @ cmove
        !           202:        fnumber_buf fnumber_digits @ 3 +        
        !           203:        s" e" strcat
        !           204:        fnumber_power @ s>string count strcat
        !           205:        strpck  ;
        !           206: 
        !           207:         
        !           208: : string>f ( ^str -- f )
        !           209:        true fnumber_whole_part !
        !           210:        0e fnumber_val f!
        !           211:        1e fnumber_divisor f!
        !           212:        false fnumber_sign !
        !           213:        count 2dup + 1- nip swap
        !           214:        begin
        !           215:          dup c@
        !           216:          case  
        !           217:            [char] - of true fnumber_sign ! endof
        !           218:            [char] + of false fnumber_sign ! endof
        !           219:            [char] . of false fnumber_whole_part ! endof
        !           220:            dup isdigit
        !           221:            if  
        !           222:              dup [char] 0 - ( s>f) s>d d>f
        !           223:              fnumber_whole_part @
        !           224:              if
        !           225:                fnumber_val f@ 10e f*
        !           226:              else
        !           227:                fnumber_divisor f@ 10e f*
        !           228:                fdup fnumber_divisor f!
        !           229:                f/ fnumber_val f@
        !           230:              then
        !           231:              f+ fnumber_val f!
        !           232:            else
        !           233:              dup dup [char] E = swap [char] e = or
        !           234:              if
        !           235:                drop 2dup
        !           236:                - 
        !           237:                dup 0>
        !           238:                if
        !           239:                  number_buf c!
        !           240:                  dup 1+ number_buf 1+ number_buf c@ cmove
        !           241:                  2drop
        !           242:                  number_buf string>s ( s>f) s>d d>f 10e fswap f**
        !           243:                else
        !           244:                  drop 2drop 1e
        !           245:                then
        !           246:                fnumber_val f@ f* fnumber_sign @ if fnegate then
        !           247:                exit
        !           248:              then
        !           249:            then
        !           250:          endcase
        !           251:          1+ 2dup <
        !           252:        until                 
        !           253:        2drop
        !           254:        fnumber_val f@ 
        !           255:        fnumber_sign @ if fnegate then ;         
        !           256: 
        !           257: 
        !           258: \ parse a string delimited by spaces into fp args 
        !           259: 
        !           260: : parse_args ( a u -- n ) ( F: -- f1 ... fn )
        !           261:        0 >r 
        !           262:        begin
        !           263:          dup 0>
        !           264:        while
        !           265:          bl skip 
        !           266:          2dup 
        !           267:          bl scan 2>r
        !           268:          r@ - dup 0= 
        !           269:          if drop r> 0 >r then
        !           270:          strpck string>f
        !           271:          2r> r> 
        !           272:          1+ >r
        !           273:        repeat
        !           274:        2drop r> ;
        !           275:          

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>