bb6b2dcd |
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 |