| 1 | \ @(#) numberio.fth 98/01/26 1.2 |
| 2 | \ numberio.fth |
| 3 | \ |
| 4 | \ numeric conversion |
| 5 | \ |
| 6 | \ Author: Phil Burk |
| 7 | \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom |
| 8 | \ |
| 9 | \ The pForth software code is dedicated to the public domain, |
| 10 | \ and any third party may reproduce, distribute and modify |
| 11 | \ the pForth software code or any derivative works thereof |
| 12 | \ without any compensation or license. The pForth software |
| 13 | \ code is provided on an "as is" basis without any warranty |
| 14 | \ of any kind, including, without limitation, the implied |
| 15 | \ warranties of merchantability and fitness for a particular |
| 16 | \ purpose and their equivalents under the laws of any jurisdiction. |
| 17 | |
| 18 | anew task-numberio.fth |
| 19 | decimal |
| 20 | |
| 21 | \ ------------------------ INPUT ------------------------------- |
| 22 | \ Convert a single character to a number in the given base. |
| 23 | : DIGIT ( char base -- n true | char false ) |
| 24 | >r |
| 25 | \ convert lower to upper |
| 26 | dup ascii a < not |
| 27 | IF |
| 28 | ascii a - ascii A + |
| 29 | THEN |
| 30 | \ |
| 31 | dup dup ascii A 1- > |
| 32 | IF ascii A - ascii 9 + 1+ |
| 33 | ELSE ( char char ) |
| 34 | dup ascii 9 > |
| 35 | IF |
| 36 | ( between 9 and A is bad ) |
| 37 | drop 0 ( trigger error below ) |
| 38 | THEN |
| 39 | THEN |
| 40 | ascii 0 - |
| 41 | dup r> < |
| 42 | IF dup 1+ 0> |
| 43 | IF nip true |
| 44 | ELSE drop FALSE |
| 45 | THEN |
| 46 | ELSE drop FALSE |
| 47 | THEN |
| 48 | ; |
| 49 | |
| 50 | : >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE ) |
| 51 | >r |
| 52 | BEGIN |
| 53 | r@ 0> \ any characters left? |
| 54 | IF |
| 55 | dup c@ base @ |
| 56 | digit ( ud1 c-addr , n true | char false ) |
| 57 | IF |
| 58 | TRUE |
| 59 | ELSE |
| 60 | drop FALSE |
| 61 | THEN |
| 62 | ELSE |
| 63 | false |
| 64 | THEN |
| 65 | WHILE ( -- ud1 c-addr n ) |
| 66 | swap >r ( -- ud1lo ud1hi n ) |
| 67 | swap base @ ( -- ud1lo n ud1hi base ) |
| 68 | um* drop ( -- ud1lo n ud1hi*baselo ) |
| 69 | rot base @ ( -- n ud1hi*baselo ud1lo base ) |
| 70 | um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi ) |
| 71 | d+ ( -- ud2 ) |
| 72 | r> 1+ \ increment char* |
| 73 | r> 1- >r \ decrement count |
| 74 | REPEAT |
| 75 | r> |
| 76 | ; |
| 77 | |
| 78 | \ obsolete |
| 79 | : CONVERT ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT ) |
| 80 | 256 >NUMBER DROP |
| 81 | ; |
| 82 | |
| 83 | 0 constant NUM_TYPE_BAD |
| 84 | 1 constant NUM_TYPE_SINGLE |
| 85 | 2 constant NUM_TYPE_DOUBLE |
| 86 | |
| 87 | \ Like >number, but temporarily switch BASE. |
| 88 | : (>number-with-base) ( ud c-addr u base -- ud' c-addr' u' ) |
| 89 | base @ >r base ! >number r> base ! |
| 90 | ; |
| 91 | |
| 92 | \ This is similar to the F83 NUMBER? except that it returns a number type |
| 93 | \ and then either a single or double precision number. |
| 94 | : ((NUMBER?)) ( c-addr u -- 0 | n 1 | d 2 , convert string to number ) |
| 95 | dup 0= IF 2drop NUM_TYPE_BAD exit THEN \ any chars? |
| 96 | |
| 97 | base @ -rot ( base c-addr u ) |
| 98 | |
| 99 | \ Recognize prefixes and change base if needed |
| 100 | over c@ >r ( base c-addr u ) ( r: char ) |
| 101 | r@ [char] # = if rot drop 10 -rot 1 /string then |
| 102 | r@ [char] $ = if rot drop 16 -rot 1 /string then |
| 103 | r@ [char] % = if rot drop 2 -rot 1 /string then |
| 104 | r@ [char] ' = if |
| 105 | \ Recognize '<char>' |
| 106 | dup 3 = if |
| 107 | over 2 chars + c@ [char] ' = if |
| 108 | drop nip rdrop |
| 109 | char+ c@ NUM_TYPE_SINGLE exit |
| 110 | then |
| 111 | then |
| 112 | then |
| 113 | r> drop |
| 114 | |
| 115 | \ check for '-' at beginning, skip if present |
| 116 | over c@ ascii - = \ is it a '-' |
| 117 | dup >r \ save flag |
| 118 | IF 1 /string ( -- base c-addr+1 cnt-1 , skip past minus sign ) |
| 119 | THEN |
| 120 | |
| 121 | ( base c-addr cnt ) ( r: minus-flag ) |
| 122 | rot >r 0 0 2swap r> |
| 123 | (>number-with-base) dup 0= \ convert as much as we can |
| 124 | IF |
| 125 | 2drop \ drop addr cnt |
| 126 | drop \ drop hi part of num |
| 127 | r@ \ check flag to see if '-' sign used |
| 128 | IF negate |
| 129 | THEN |
| 130 | NUM_TYPE_SINGLE |
| 131 | ELSE ( -- d addr cnt ) |
| 132 | 1 = swap \ if final character is '.' then double |
| 133 | c@ ascii . = AND |
| 134 | IF |
| 135 | r@ \ check flag to see if '-' sign used |
| 136 | IF dnegate |
| 137 | THEN |
| 138 | NUM_TYPE_DOUBLE |
| 139 | ELSE |
| 140 | 2drop |
| 141 | NUM_TYPE_BAD |
| 142 | THEN |
| 143 | THEN |
| 144 | rdrop |
| 145 | ; |
| 146 | |
| 147 | : (NUMBER?) ( $addr -- 0 | n 1 | d 2 , convert string to number ) |
| 148 | count ((number?)) |
| 149 | ; |
| 150 | |
| 151 | ' (number?) is number? |
| 152 | \ hex |
| 153 | \ 0sp c" xyz" (number?) .s |
| 154 | \ 0sp c" 234" (number?) .s |
| 155 | \ 0sp c" -234" (number?) .s |
| 156 | \ 0sp c" 234." (number?) .s |
| 157 | \ 0sp c" -234." (number?) .s |
| 158 | \ 0sp c" 1234567855554444." (number?) .s |
| 159 | |
| 160 | |
| 161 | \ ------------------------ OUTPUT ------------------------------ |
| 162 | \ Number output based on F83 |
| 163 | variable HLD \ points to last character added |
| 164 | |
| 165 | : hold ( char -- , add character to text representation) |
| 166 | -1 hld +! |
| 167 | hld @ c! |
| 168 | ; |
| 169 | : <# ( -- , setup conversion ) |
| 170 | pad hld ! |
| 171 | ; |
| 172 | : #> ( d -- addr len , finish conversion ) |
| 173 | 2drop hld @ pad over - |
| 174 | ; |
| 175 | : sign ( n -- , add '-' if negative ) |
| 176 | 0< if ascii - hold then |
| 177 | ; |
| 178 | : # ( d -- d , convert one digit ) |
| 179 | base @ mu/mod rot 9 over < |
| 180 | IF 7 + |
| 181 | THEN |
| 182 | ascii 0 + hold |
| 183 | ; |
| 184 | : #s ( d -- d , convert remaining digits ) |
| 185 | BEGIN # 2dup or 0= |
| 186 | UNTIL |
| 187 | ; |
| 188 | |
| 189 | |
| 190 | : (UD.) ( ud -- c-addr cnt ) |
| 191 | <# #s #> |
| 192 | ; |
| 193 | : UD. ( ud -- , print unsigned double number ) |
| 194 | (ud.) type space |
| 195 | ; |
| 196 | : UD.R ( ud n -- ) |
| 197 | >r (ud.) r> over - spaces type |
| 198 | ; |
| 199 | : (D.) ( d -- c-addr cnt ) |
| 200 | tuck dabs <# #s rot sign #> |
| 201 | ; |
| 202 | : D. ( d -- ) |
| 203 | (d.) type space |
| 204 | ; |
| 205 | : D.R ( d n -- , right justified ) |
| 206 | >r (d.) r> over - spaces type |
| 207 | ; |
| 208 | |
| 209 | : (U.) ( u -- c-addr cnt ) |
| 210 | 0 (ud.) |
| 211 | ; |
| 212 | : U. ( u -- , print unsigned number ) |
| 213 | 0 ud. |
| 214 | ; |
| 215 | : U.R ( u n -- , print right justified ) |
| 216 | >r (u.) r> over - spaces type |
| 217 | ; |
| 218 | : (.) ( n -- c-addr cnt ) |
| 219 | dup abs 0 <# #s rot sign #> |
| 220 | ; |
| 221 | : . ( n -- , print signed number) |
| 222 | (.) type space |
| 223 | ; |
| 224 | : .R ( n l -- , print right justified) |
| 225 | >r (.) r> over - spaces type |
| 226 | ; |