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