├── README.md ├── docgen.fs ├── docgen.sh ├── fp.fs ├── fp.test.fs ├── list.fs ├── list.test.fs ├── string.fs ├── string.test.fs └── test.fs /README.md: -------------------------------------------------------------------------------- 1 | # forth-libs 2 | 3 | Collection of words to help with writing high level applications with 4 | Forth language. The source code here is tested using 5 | gforth. Suggestions are welcome. 6 | 7 | Allocations are done on Dictionary, use marker to free after usage. 8 | 9 | Check test files for example usage. 10 | 11 | Current revision: e0fe90ddd4bb087da8be75c3eae34839da3a5f46. 12 | 13 | This file is generated by docgen.fs with docgen.sh runner. 14 | 15 | ## require list.fs also list.fs 16 | 17 | ### `list:create ( -- list ) 18 | ` 19 | allot new list object 20 | 21 | 22 | ### `list:node:create ( data -- node ) 23 | ` 24 | allot new node and set data to u 25 | 26 | 27 | ### `list:append ( list data -- list ) 28 | ` 29 | allot new node with data and append to list return list 30 | 31 | 32 | ### `list:for-each ( xt list -- ) 33 | ` 34 | execute xt on every element of list 35 | 36 | 37 | ### `list:map ( list1 xt -- list2 ) 38 | ` 39 | execute xt on every element of list1 and create a new list2 and return 40 | 41 | 42 | ### `list:length ( list -- n ) 43 | ` 44 | return list length 45 | 46 | 47 | ### `list:nth ( list n -- data ) 48 | ` 49 | return the nth data from list 50 | 51 | 52 | ### `list:reduce ( list acc xt -- acc ) 53 | ` 54 | apply func xt on every element accumulating result in acc. xt is called with ( acc element -- acc ) 55 | 56 | 57 | ### `list:some ( list xt -- t ) 58 | ` 59 | execute xt on every node and return true if at least one returns true. xt is called with ( element -- t ) 60 | 61 | 62 | ## require string.fs also string.fs 63 | 64 | ### `string:raw ( string -- caddr u ) 65 | ` 66 | return counted string from string 67 | 68 | 69 | ### `string:caddr ( string -- caddr ) ` 70 | return caddr from string 71 | 72 | 73 | ### `string:create ( caddr u -- string ) 74 | ` 75 | make a string from the string at counted string 76 | 77 | 78 | ### `string:to-number ( string -- u ) 79 | ` 80 | convert string into number 81 | 82 | 83 | ### `string:print ( string -- ) 84 | ` 85 | print string 86 | 87 | 88 | ### `string:tokenize ( d string -- tokens ) 89 | ` 90 | tokenize string delimited by d into list of tokens 91 | 92 | 93 | ### `string:nth ( string n -- c ) 94 | ` 95 | return nth character in string 96 | 97 | 98 | ### `string:reduce ( string acc xt -- acc ) 99 | ` 100 | execute xt on every node accumulating result in acc. xt is called with ( acc char -- acc ) 101 | 102 | 103 | ### `string:some ( string xt -- t ) 104 | ` 105 | execute xt on every node and return true if at least one returns true 106 | 107 | 108 | ### `string:every ( string xt -- t ) 109 | ` 110 | execute xt on every node and return true if all returns true 111 | 112 | 113 | ### `string:append ( string1 string2 -- string3 ) 114 | ` 115 | append string2 to string1 and return string3 116 | 117 | 118 | ### `string:compare ( string1 string2 -- t ) 119 | ` 120 | compare string1 with string2 and return boolean 121 | 122 | 123 | ### `string:from-char ( c -- string ) 124 | ` 125 | make string for char 126 | 127 | 128 | ### `string:substring ( string1 a b -- string2 ) 129 | ` 130 | exctract string2 from string1 with offsets [a,b) 131 | 132 | 133 | ### `string:index-of ( string1 string2 -- b ) 134 | ` 135 | return the index of string2 within string1 otherwise -1 136 | 137 | 138 | ### `string:replace ( string1 string2 string3 -- string4 ) 139 | ` 140 | replace string2 in string1 with string3 and return string4 141 | 142 | 143 | ### `string:ends-with ( string1 string2 -- t ) 144 | ` 145 | returns true if string1 ends with string2 146 | 147 | 148 | ## require fp.fs also fp.fs 149 | 150 | ### `i>fp ( n -- fp ) ` 151 | convert integer to fixed point 152 | 153 | 154 | ### `fp>i ( fp -- n ) ` 155 | convert fixed point to integer (rounded down) 156 | 157 | 158 | ### `fp* ( n0 n1 -- n2 ) ` 159 | multiply two fixed point numbers 160 | 161 | 162 | ### `fp/ ( n0 n1 -- n2 ) ` 163 | divide two fixed point numbers 164 | 165 | 166 | ### `i3>fp3 ( a b c -- a b c ) ` 167 | vector3 helper: convert 3 integers to 3 fixed point numbers 168 | 169 | 170 | ### `fp3>i3 ( a b c -- a b c ) ` 171 | vector3 helper: convert 3 fixed point numbers to 3 integers 172 | 173 | 174 | ### `fpfloor ( n0 -- n1 ) ` 175 | floor down fixed point number to nearest integer 176 | 177 | 178 | ### `fpceil ( n0 -- n1 ) ` 179 | ceil up fixed point number to nearest integer 180 | 181 | 182 | ### `fpround ( n0 -- n1 ) ` 183 | round fixed point number to nearest integer 184 | 185 | 186 | ### `c10s ( a -- b ) ` 187 | return base 10 digits 188 | 189 | 190 | ### `if>fp ( i f -- fp ) 191 | ` 192 | convert a decimal fractional number in the form integer fractional 193 | 194 | 195 | ### `if2>fp ( i f c -- fp ) 196 | ` 197 | supply the fractional digit count 198 | 199 | 200 | -------------------------------------------------------------------------------- /docgen.fs: -------------------------------------------------------------------------------- 1 | 0 warnings ! 2 | ( argv0 ) constant input-file-len 3 | ( count ) constant input-file 4 | 5 | require string.fs 6 | require list.fs 7 | require fp.fs 8 | 9 | also list.fs 10 | also string.fs 11 | also fp.fs 12 | 13 | 0 14 | dup constant doc:word cell + 15 | dup constant doc:comment cell + 16 | dup constant doc:stack-effect cell + 17 | constant doc:struct 18 | 19 | variable fd 20 | variable src 21 | variable #src 22 | 23 | : read begin here 4096 fd @ read-file throw dup allot 0= until ; 24 | : open input-file input-file-len r/o open-file throw fd ! ; 25 | : close fd @ close-file throw ; 26 | : start here src ! ; 27 | : finish here src @ - #src ! ; 28 | : load-file open start read finish close src @ #src @ ; 29 | 30 | \ returns a string marking the beginning of a docgen item; newline followed by a "\" character. 31 | : docgen-marker s\" \n\\ " string:create ; 32 | 33 | : doc-allot here doc:struct allot ; 34 | 35 | \ Make a doc:struct from the provided word-name, comment and stack-effect 36 | : doc-make ( word-name comment stack-effect -- doc ) 37 | doc-allot dup >r doc:stack-effect + ! r@ doc:comment + ! r@ doc:word + ! r> ; 38 | 39 | : doc-render-title ( caddr u -- ) 40 | ." ## require " input-file input-file-len 2dup type ." also " type cr cr ; 41 | 42 | \ Takes a doc:struct and prints it in markdown 43 | : doc-render-item ( doc -- ) 44 | ." ### `" dup doc:word + @ string:print space 45 | dup doc:stack-effect + @ string:print ." `" cr 46 | 47 | doc:comment + @ string:print cr cr 48 | ; 49 | 50 | \ return the index of docgen marker from the given source string 51 | : find-docgen-marker ( src -- index ) docgen-marker string:index-of ; 52 | 53 | variable src 54 | variable index 55 | : parse-comment 56 | index ! src ! 57 | 58 | src @ index @ src @ string:length + @ string:substring src ! 59 | 60 | \ find index of char after newline 61 | src @ 10 string:from-char string:index-of 1+ index ! 62 | 63 | src @ index @ 64 | src @ 0 index @ string:substring 65 | ; 66 | 67 | variable src 68 | variable index 69 | variable index1 70 | variable index2 71 | : parse-word-name 72 | index ! src ! 73 | 74 | \ skip newline and comma after comment line 75 | index @ 2 + index ! 76 | 77 | src @ index @ src @ string:length + @ string:substring src ! 78 | 79 | \ find index of space or newline 80 | src @ 32 string:from-char string:index-of index1 ! 81 | src @ 10 string:from-char string:index-of index2 ! 82 | 83 | \ use nearest 84 | index1 @ index2 @ min index ! 85 | 86 | src @ index @ 87 | src @ 0 index @ 1+ string:substring 88 | ; 89 | 90 | variable src 91 | variable index 92 | : parse-stack-effect 93 | index ! src ! 94 | index @ 1+ index ! 95 | \ if not "(" then exit early 96 | src @ index @ string:nth 40 <> if src @ index @ s" " string:create exit then 97 | src @ index @ src @ string:length + @ string:substring src ! 98 | src @ 41 string:from-char string:index-of 2 + index ! 99 | src @ index @ 100 | src @ 0 index @ string:substring 101 | ; 102 | 103 | : doc-render 104 | doc-render-title 105 | ['] doc-render-item over list:for-each ; 106 | 107 | variable src 108 | variable word-list 109 | variable index 110 | variable comment 111 | variable word-name 112 | variable stack-effect 113 | variable doc 114 | : parse-words 115 | word-list ! src ! 116 | begin 117 | src @ find-docgen-marker index ! 118 | index @ -1 <> 119 | while 120 | \ skip over the marker 121 | index @ docgen-marker string:length + @ + index ! 122 | src @ index @ parse-comment comment ! index ! src ! 123 | src @ index @ parse-word-name word-name ! index ! src ! 124 | src @ index @ parse-stack-effect stack-effect ! index ! src ! 125 | word-name @ comment @ stack-effect @ doc-make doc ! 126 | word-list @ doc @ list:append 127 | repeat 128 | ; 129 | 130 | variable src 131 | variable #src 132 | variable word-list 133 | : docgen 134 | load-file #src ! src ! 135 | src @ #src @ string:create src ! 136 | list:create word-list ! 137 | src @ word-list @ parse-words 138 | word-list @ doc-render @ 139 | ; 140 | 141 | docgen 142 | 143 | bye 144 | -------------------------------------------------------------------------------- /docgen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cat < README.md 4 | # forth-libs 5 | 6 | Collection of words to help with writing high level applications with 7 | Forth language. The source code here is tested using 8 | gforth. Suggestions are welcome. 9 | 10 | Allocations are done on Dictionary, use marker to free after usage. 11 | 12 | Check test files for example usage. 13 | 14 | Current revision: `git rev-parse HEAD`. 15 | 16 | This file is generated by docgen.fs with docgen.sh runner. 17 | 18 | EOF 19 | 20 | gforth -e "s\" list.fs\"" docgen.fs >> README.md 21 | gforth -e "s\" string.fs\"" docgen.fs >> README.md 22 | gforth -e "s\" fp.fs\"" docgen.fs >> README.md 23 | -------------------------------------------------------------------------------- /fp.fs: -------------------------------------------------------------------------------- 1 | [undefined] fp.fs [if] 2 | 3 | vocabulary fp.fs also fp.fs definitions 4 | 5 | 8 constant point \ fractional point 6 | 1 point lshift constant fp-bitmask 7 | fp-bitmask 1- constant fp-fmask \ fractional bit mask 8 | fp-fmask invert constant fp-imask \ integer bit mask 9 | fp-bitmask 1 rshift constant fp.bit/2 \ 0.5 in fp 10 | fp-bitmask negate fp-bitmask * constant max-fp \ maximum value 11 | fp-bitmask negate fp-bitmask * constant min-fp \ minimum value 12 | 10 point lshift constant fp10 13 | 14 | \ convert integer to fixed point 15 | : i>fp ( n -- fp ) point lshift ; 16 | 17 | \ convert fixed point to integer (rounded down) 18 | : fp>i ( fp -- n ) point rshift ; 19 | 20 | \ multiply two fixed point numbers 21 | : fp* ( n0 n1 -- n2 ) fp-bitmask */ ; 22 | 23 | \ divide two fixed point numbers 24 | : fp/ ( n0 n1 -- n2 ) fp-bitmask swap */ ; 25 | 26 | \ vector3 helper: convert 3 integers to 3 fixed point numbers 27 | : i3>fp3 ( a b c -- a b c ) i>fp rot i>fp rot i>fp rot ; 28 | 29 | \ vector3 helper: convert 3 fixed point numbers to 3 integers 30 | : fp3>i3 ( a b c -- a b c ) fp>i rot fp>i rot fp>i rot ; 31 | 32 | \ floor down fixed point number to nearest integer 33 | : fpfloor ( n0 -- n1 ) fp-imask and ; 34 | 35 | \ ceil up fixed point number to nearest integer 36 | : fpceil ( n0 -- n1 ) fp-bitmask + fpfloor ; 37 | 38 | \ round fixed point number to nearest integer 39 | : fpround ( n0 -- n1 ) fp.bit/2 + fpfloor ; 40 | 41 | \ return base 10 digits 42 | : c10s ( a -- b ) 0 begin 1+ swap 10 / swap over 0> 0= 43 | until swap drop ; 44 | 45 | \ convert a decimal fractional number in the form integer fractional 46 | : if>fp ( i f -- fp ) 47 | dup i>fp swap 48 | c10s ( i f 10s ) 49 | 0 do ( i f ) 50 | fp10 fp/ 51 | loop 52 | swap i>fp + 53 | ; 54 | 55 | \ supply the fractional digit count 56 | : if2>fp ( i f c -- fp ) 57 | >r ( i f ) 58 | i>fp 59 | r> 0 do ( i f ) 60 | fp10 fp/ 61 | loop 62 | swap i>fp + 63 | ; 64 | 65 | previous definitions 66 | 67 | [endif] 68 | -------------------------------------------------------------------------------- /fp.test.fs: -------------------------------------------------------------------------------- 1 | require fp.fs 2 | 3 | also fp.fs 4 | 5 | : must-equal <> if abort" " else ." OK " then ; 6 | 7 | : run-test 8 | cr 8 i>fp 2048 must-equal 9 | cr 2048 fp>i 8 must-equal 10 | cr 3 i>fp 4 i>fp fp* fp>i 12 must-equal 11 | cr 9 i>fp 3 i>fp fp/ fp>i 3 must-equal 12 | cr 13 i>fp 5 i>fp fp/ 2 6 if>fp must-equal 13 | cr 12345 c10s 5 must-equal 14 | cr 2 3 if>fp fpfloor 2 i>fp must-equal 15 | cr 2 3 if>fp fpceil 3 i>fp must-equal 16 | cr 2 3 if>fp fpround 2 i>fp must-equal 17 | cr 2 6 if>fp fpround 3 i>fp must-equal 18 | ; 19 | 20 | run-test 21 | -------------------------------------------------------------------------------- /list.fs: -------------------------------------------------------------------------------- 1 | [undefined] list.fs [if] 2 | 3 | vocabulary list.fs also list.fs definitions 4 | 5 | 0 6 | dup constant list:node:next cell + 7 | dup constant list:node:data cell + 8 | constant list:node:struct 9 | 10 | : list:node:nend? list:node:next + @ 0<> ; 11 | 12 | 0 13 | dup constant list:tail cell + 14 | dup constant list:head cell + 15 | constant list:struct 16 | 17 | ( list:node:struct ) 18 | ( +-----------+ +-----------+ +-----------+ ) 19 | ( | next |------->| next |------->| next |--> 0 ) 20 | ( +-----------+ +-----------+ +-----------+ ) 21 | ( | data | | data | | data | ) 22 | ( +-----------+ +-----------+ +-----------+ ) 23 | ( ^---------+ ^ ) 24 | ( | | ) 25 | ( list:struct | | ) 26 | ( +-----------+ | | ) 27 | ( | tail |<--+ | ) 28 | ( +-----------+ | ) 29 | ( | head |<----------------------------------+ ) 30 | ( +-----------+ ) 31 | 32 | : list:.node ( node -- ) 33 | hex 34 | ." node: { " 35 | dup list:node:next + @ . 36 | list:node:data + @ . 37 | ." } " 38 | decimal 39 | ; 40 | 41 | \ allot new list object 42 | : list:create ( -- list ) 43 | here 44 | dup list:struct allot 45 | list:struct erase 46 | ; 47 | 48 | \ allot new node and set data to u 49 | : list:node:create ( data -- node ) 50 | here dup >r 51 | list:node:struct allot 52 | dup list:node:struct erase 53 | list:node:data + ! 54 | r> 55 | ; 56 | 57 | \ allot new node with data and append to list return list 58 | : list:append ( list data -- list ) 59 | dup list:node:create dup >r 60 | 61 | list:node:data + ! 62 | 63 | dup list:tail + @ 0= if 64 | r@ over list:tail + ! 65 | then 66 | 67 | dup list:head + @ 0<> if 68 | r@ over list:head + @ list:node:next + ! 69 | then 70 | 71 | r> over list:head + ! 72 | ; 73 | 74 | \ execute xt on every element of list 75 | : list:for-each ( xt list -- ) 76 | list:tail + @ >r 77 | 78 | begin 79 | r@ list:node:data + @ over execute 80 | r@ list:node:nend? 81 | while 82 | r> list:node:next + @ >r 83 | repeat 84 | rdrop drop 85 | ; 86 | 87 | \ execute xt on every element of list1 and create a new list2 and return 88 | : list:map ( list1 xt -- list2 ) 89 | swap list:tail + @ >r 90 | list:create ( xt list2 ) 91 | 92 | begin 93 | over r@ list:node:data + @ swap execute ( xt list2 result ) 94 | 2dup list:append 2drop 95 | r@ list:node:nend? 96 | while 97 | r> list:node:next + @ >r 98 | repeat 99 | rdrop nip 100 | ; 101 | 102 | \ return list length 103 | : list:length ( list -- n ) 104 | 0 105 | swap list:tail + @ >r 106 | 107 | begin 108 | 1+ 109 | r@ list:node:nend? 110 | while 111 | r> list:node:next + @ >r 112 | repeat 113 | rdrop 114 | ; 115 | 116 | \ return the nth data from list 117 | : list:nth ( list n -- data ) 118 | 0 119 | rot list:tail + @ >r 120 | 121 | begin 122 | 2dup <> 123 | while 124 | r> list:node:next + @ >r 125 | 1+ 126 | repeat 127 | 2drop 128 | r> list:node:data + @ 129 | ; 130 | 131 | \ apply func xt on every element accumulating result in acc. xt is called with ( acc element -- acc ) 132 | : list:reduce ( list acc xt -- acc ) 133 | rot list:tail + @ >r ( acc xt ) ( R: iter ) 134 | 135 | r@ 0= if rdrop drop exit then 136 | 137 | begin 138 | r@ list:node:data + @ swap dup >r execute r> ( acc xt ) 139 | r@ list:node:nend? 140 | while 141 | r> list:node:next + @ >r 142 | repeat 143 | rdrop drop 144 | ; 145 | 146 | \ execute xt on every node and return true if at least one returns true. xt is called with ( element -- t ) 147 | : list:some ( list xt -- t ) 148 | swap list:tail + @ >r ( xt ) ( R: iter ) 149 | 150 | begin 151 | r@ list:node:nend? 152 | while 153 | r@ list:node:data + @ over execute ( xt t ) 154 | 0<> if rdrop drop true exit then 155 | r> list:node:next + @ >r 156 | repeat 157 | rdrop false 158 | ; 159 | 160 | previous definitions 161 | 162 | [endif] 163 | -------------------------------------------------------------------------------- /list.test.fs: -------------------------------------------------------------------------------- 1 | require list.fs 2 | 3 | also list.fs 4 | 5 | : must-equal <> if abort" " else ." OK " then ; 6 | 7 | variable list1 8 | variable list2 9 | : run-test 10 | list:create list1 ! 11 | 12 | list1 @ 1 list:append list1 ! 13 | list1 @ 2 list:append list1 ! 14 | list1 @ 3 list:append list1 ! 15 | list1 @ 4 list:append list1 ! 16 | list1 @ 5 list:append list1 ! 17 | list1 @ 6 list:append list1 ! 18 | 19 | ." list:for-each -> " 20 | [: . ;] list1 @ list:for-each ." visually assert: 1 2 3 4 5 6" cr 21 | 22 | ." list:nth -> " 23 | list1 @ 2 list:nth 3 must-equal cr 24 | 25 | ." list:reduce -> " 26 | list1 @ 1 [: * ;] list:reduce 720 must-equal cr 27 | 28 | ." list:length -> " 29 | list1 @ list:length 6 must-equal cr 30 | 31 | ." list:map -> " 32 | list1 @ [: 2 * ;] list:map list2 ! 33 | 34 | list2 @ list:length list1 @ list:length must-equal 35 | list2 @ 0 list:nth list1 @ 0 list:nth 2 * must-equal 36 | list2 @ 1 list:nth list1 @ 1 list:nth 2 * must-equal 37 | list2 @ 2 list:nth list1 @ 2 list:nth 2 * must-equal 38 | list2 @ 3 list:nth list1 @ 3 list:nth 2 * must-equal cr 39 | 40 | ." list:some -> " 41 | list1 @ [: 3 = ;] list:some true must-equal cr 42 | ; 43 | 44 | run-test 45 | -------------------------------------------------------------------------------- /string.fs: -------------------------------------------------------------------------------- 1 | [undefined] string.fs [if] 2 | 3 | vocabulary string.fs also string.fs definitions 4 | 5 | require list.fs 6 | 7 | also list.fs 8 | 9 | 0 10 | dup constant string:length cell + 11 | dup constant string:data cell + 12 | constant string:struct 13 | 14 | : string:erase string:struct erase ; 15 | 16 | \ return counted string from string 17 | : string:raw ( string -- caddr u ) 18 | >r 19 | r@ string:data + @ 20 | r> string:length + @ 21 | ; 22 | 23 | \ return caddr from string 24 | : string:caddr ( string -- caddr ) string:raw drop ; 25 | 26 | \ make a string from the string at counted string 27 | : string:create ( caddr u -- string ) 28 | here >r ( caddr u ) ( R: string ) 29 | string:struct allot 30 | dup r@ string:length + ! 31 | here ( caddr u data ) 32 | over allot 33 | r@ string:data + ! ( caddr u ) 34 | r@ string:data + @ 35 | swap 36 | cmove 37 | r> 38 | ; 39 | 40 | \ convert string into number 41 | : string:to-number ( string -- u ) 42 | >r 43 | r@ string:data + @ ( caddr ) 44 | r> string:length + @ ( caddr len ) 45 | 0 0 2swap >number ( ud0 ud1 u1 u2 ) 46 | drop nip 47 | ; 48 | 49 | \ print string 50 | : string:print ( string -- ) 51 | >r 52 | r@ string:data + @ 53 | r@ string:length + @ 54 | type rdrop 55 | ; 56 | 57 | 58 | variable d 59 | variable string 60 | variable caddr 61 | variable prev-caddr 62 | variable tokens 63 | variable k 64 | \ tokenize string delimited by d into list of tokens 65 | : string:tokenize ( d string -- tokens ) 66 | string ! d ! 67 | 68 | string @ string:data + @ caddr ! 69 | string @ string:data + @ prev-caddr ! 70 | list:create tokens ! 71 | 0 k ! 72 | 73 | \ When current character equals the delimiter, push a string 74 | \ denoting the last caddr and current index k. Also set k to i and 75 | \ set prev caddr to _caddr. 76 | 77 | string @ string:length + @ 0 ?do 78 | caddr @ c@ d @ = if 79 | tokens @ 80 | prev-caddr @ k @ string:create 81 | list:append tokens ! 82 | 83 | caddr @ 1+ prev-caddr ! 84 | -1 k ! 85 | then 86 | 87 | k @ 1+ k ! 88 | caddr @ 1+ caddr ! 89 | loop 90 | 91 | tokens @ 92 | prev-caddr @ k @ string:create 93 | list:append tokens ! 94 | 95 | tokens @ 96 | ; 97 | 98 | \ return nth character in string 99 | : string:nth ( string n -- c ) 100 | swap 101 | string:data + @ + c@ 102 | ; 103 | 104 | \ execute xt on every node accumulating result in acc. xt is called with ( acc char -- acc ) 105 | : string:reduce ( string acc xt -- acc ) 106 | rot ( acc xt string ) 107 | 108 | dup string:length + @ 0 ?do 109 | dup string:data + @ i + c@ ( acc xt string c ) 110 | over >r nip 111 | over >r nip swap r@ ( xt acc c ) execute r> r> ( acc ) 112 | loop 113 | 2drop 114 | ; 115 | 116 | \ execute xt on every node and return true if at least one returns true 117 | : string:some ( string xt -- t ) 118 | swap ( xt string ) 119 | dup string:length + @ 0 ?do 120 | dup string:data + @ i + c@ ( xt string c ) 121 | rot dup >r execute 0<> if 122 | rdrop drop 123 | true 124 | unloop 125 | exit 126 | then 127 | r> swap 128 | loop 129 | 130 | 2drop 131 | false 132 | ; 133 | 134 | \ execute xt on every node and return true if all returns true 135 | : string:every ( string xt -- t ) 136 | over string:length + @ 0 ?do 137 | over string:data + @ i + c@ 138 | over execute invert if 139 | false 140 | unloop 141 | exit 142 | then 143 | loop 144 | 2drop true 145 | ; 146 | 147 | variable string1 148 | variable string2 149 | variable string3 150 | variable u 151 | \ append string2 to string1 and return string3 152 | : string:append ( string1 string2 -- string3 ) 153 | string2 ! string1 ! 154 | 155 | string1 @ string:length + @ 156 | string2 @ string:length + @ + u ! 157 | 158 | here u @ string:create string3 ! 159 | 160 | string1 @ string:caddr 161 | string3 @ string:caddr 162 | string1 @ string:length + @ 163 | cmove 164 | 165 | string2 @ string:caddr 166 | string3 @ string:caddr 167 | string1 @ string:length + @ + 168 | string2 @ string:length + @ 169 | cmove 170 | 171 | string3 @ 172 | ; 173 | 174 | variable string1 175 | variable string2 176 | \ compare string1 with string2 and return boolean 177 | : string:compare ( string1 string2 -- t ) 178 | string2 ! string1 ! 179 | 180 | string1 @ string:length + @ 181 | string2 @ string:length + @ <> if false exit then 182 | 183 | string1 @ string:length + @ 0 ?do 184 | string1 @ i string:nth 185 | string2 @ i string:nth <> if false unloop exit then 186 | loop 187 | 188 | true 189 | ; 190 | 191 | \ make string for char 192 | : string:from-char ( c -- string ) 193 | s" " string:create dup >r 194 | 195 | string:data + @ c! 196 | 197 | r> 198 | ; 199 | 200 | variable string1 201 | variable a 202 | variable b 203 | variable c 204 | variable length 205 | \ exctract string2 from string1 with offsets [a,b) 206 | : string:substring ( string1 a b -- string2 ) 207 | b ! a ! string1 ! 208 | 209 | b @ a @ - length ! 210 | here length @ string:create string2 ! 211 | 212 | length @ 0 ?do 213 | i a @ + string1 @ string:length + @ = if leave then 214 | 215 | string1 @ i a @ + string:nth c ! 216 | 217 | c @ string2 @ string:caddr i + c! 218 | loop 219 | 220 | string2 @ 221 | ; 222 | 223 | variable string1 224 | variable string2 225 | variable index 226 | variable caddr3 227 | variable u 228 | variable found 229 | \ return the index of string2 within string1 otherwise -1 230 | : string:index-of ( string1 string2 -- b ) 231 | string2 ! string1 ! 232 | 233 | -1 index ! 234 | 235 | string1 @ string:raw 236 | string2 @ string:raw 237 | search found ! u ! caddr3 ! 238 | 239 | found @ if 240 | caddr3 @ string1 @ string:caddr - index ! 241 | then 242 | 243 | index @ 244 | ; 245 | 246 | variable string1 247 | variable string2 248 | variable string3 249 | variable string4 250 | variable length 251 | variable index 252 | variable first 253 | variable remaining 254 | \ replace string2 in string1 with string3 and return string4 255 | : string:replace ( string1 string2 string3 -- string4 ) 256 | string3 ! string2 ! string1 ! 257 | 258 | string1 @ string:length + @ 259 | string2 @ string:length + @ 260 | min length ! 261 | 262 | string1 @ string2 @ string:index-of index ! 263 | 264 | index @ -1 = if 265 | string1 @ exit 266 | then 267 | 268 | string1 @ string:caddr index @ string:create first ! 269 | 270 | first @ string3 @ string:append string4 ! 271 | 272 | string1 @ string:caddr index @ + length @ + 273 | length @ index @ length @ - 1- - 274 | string:create remaining ! 275 | 276 | string4 @ remaining @ string:append string4 ! 277 | 278 | string4 @ 279 | ; 280 | 281 | variable string1 282 | variable string2 283 | variable string3-caddr 284 | variable offset 285 | \ returns true if string1 ends with string2 286 | : string:ends-with ( string1 string2 -- t ) 287 | string2 ! string1 ! 288 | 289 | string1 @ string:length + @ 290 | string2 @ string:length + @ 291 | < if false exit then 292 | 293 | string1 @ string:length + @ 294 | string2 @ string:length + @ 295 | - offset ! 296 | 297 | string1 @ string:caddr offset @ + string3-caddr ! 298 | 299 | string3-caddr @ string2 @ string:length + @ 300 | string2 @ string:raw 301 | compare 0= if true exit then 302 | 303 | false 304 | ; 305 | 306 | previous definitions 307 | 308 | [endif] 309 | -------------------------------------------------------------------------------- /string.test.fs: -------------------------------------------------------------------------------- 1 | require string.fs 2 | require list.fs 3 | 4 | also list.fs 5 | also string.fs 6 | 7 | : between ( a b c -- t ) 8 | rot dup >r 9 | swap <= 10 | swap r> swap >= 11 | and 12 | ; 13 | 14 | : must-equal <> if abort" " else ." OK" then ; 15 | 16 | variable str 17 | variable tokens 18 | 19 | : run-test 20 | ." string:print -> " 21 | s" Hello, world! " string:create string:print ." visually assert: Hello, world!" cr 22 | 23 | ." string:to-number -> " 24 | s" 123" string:create string:to-number drop 123 must-equal cr 25 | 26 | ." string:tokenize -> " 27 | s" A,BC,DEF,GHIJ" string:create str ! 28 | [char] , str @ string:tokenize tokens ! 29 | tokens @ list:length 4 must-equal cr 30 | 31 | ." string:for-each -> " 32 | tokens @ [: ." Token: " string:print space ;] swap list:for-each ." visually assert: A,BC,DEF,GHIJ" cr 33 | 34 | ." string:nth -> " 35 | s" Hello, world" string:create 4 string:nth [char] o must-equal cr 36 | 37 | ." string:compare -> " 38 | s" foo" string:create 39 | s" bar" string:create 40 | string:compare false must-equal cr 41 | 42 | ." string:compare -> " 43 | s" foo" string:create 44 | s" barz" string:create 45 | string:compare false must-equal cr 46 | 47 | ." string:compare -> " 48 | s" foo" string:create 49 | s" foo" string:create 50 | string:compare true must-equal cr 51 | 52 | ." string:append -> " 53 | s" foo" string:create s" bar" string:create string:append s" foobar" string:create string:compare true must-equal cr 54 | 55 | ." string:from-char -> " 56 | [char] x string:from-char s" x" string:create string:compare true must-equal cr 57 | 58 | ." string:substring -> " 59 | s" aabbbb" string:create 2 6 string:substring s" bbbb" string:create string:compare true must-equal cr 60 | 61 | ." string:substring -> " 62 | s" aabbbbaaaaaaaaaaa" string:create 2 6 string:substring s" bbbb" string:create string:compare true must-equal cr 63 | 64 | ." string:index-of -> " 65 | s" foobar" string:create 66 | s" bar" string:create 67 | string:index-of 3 must-equal cr 68 | 69 | ." string:index-of -> " 70 | s" foobar" string:create 71 | s" xxx" string:create 72 | string:index-of -1 must-equal cr 73 | 74 | ." string:replace -> " 75 | s" foobarbuzz" string:create 76 | s" bar" string:create 77 | s" xxx" string:create 78 | string:replace 79 | s" fooxxxbuzz" string:create string:compare true must-equal cr 80 | 81 | ." string:replace -> " 82 | s" foobarbuzz" string:create 83 | s" 123" string:create 84 | s" xxx" string:create 85 | string:replace 86 | s" foobarbuzz" string:create string:compare true must-equal cr 87 | 88 | ." string:some -> " 89 | s" fooxbar" string:create 90 | [: [char] x = ;] 91 | string:some true must-equal cr 92 | 93 | ." string:some -> " 94 | s" fooxbar" string:create 95 | [: [char] y = ;] 96 | string:some false must-equal cr 97 | 98 | ." string:every -> " 99 | s" 0123456789" string:create 100 | [: [char] 0 [char] 9 between ;] 101 | string:every true must-equal cr 102 | 103 | ." string:every -> " 104 | s" 0123456789a" string:create 105 | [: [char] 0 [char] 9 between ;] 106 | string:every false must-equal cr 107 | 108 | ." string:ends-with -> " 109 | s" 158cm" string:create 110 | s" cm" string:create 111 | string:ends-with true must-equal cr 112 | 113 | ." string:ends-with -> " 114 | s" foobar" string:create 115 | s" bar" string:create 116 | string:ends-with true must-equal cr 117 | 118 | ." string:ends-with -> " 119 | s" foobar" string:create 120 | s" ba" string:create 121 | string:ends-with false must-equal cr 122 | 123 | ." string:reduce -> " 124 | s" 1234" string:create 125 | 0 126 | [: [char] 0 - + ;] 127 | string:reduce 10 must-equal cr 128 | ; 129 | 130 | run-test 131 | -------------------------------------------------------------------------------- /test.fs: -------------------------------------------------------------------------------- 1 | 0 warnings ! 2 | marker free require list.test.fs free 3 | marker free require string.test.fs free 4 | 5 | bye 6 | --------------------------------------------------------------------------------