Commit | Line | Data |
---|---|---|
8e9db35f PB |
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 | ||
40c6f87f HE |
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 | ||
8e9db35f PB |
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 | ||
40c6f87f HE |
97 | base @ -rot ( base c-addr u ) |
98 | ||
f7548536 | 99 | \ Recognize prefixes and change base if needed |
40c6f87f HE |
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 | |
8e9db35f PB |
114 | |
115 | \ check for '-' at beginning, skip if present | |
116 | over c@ ascii - = \ is it a '-' | |
117 | dup >r \ save flag | |
40c6f87f | 118 | IF 1 /string ( -- base c-addr+1 cnt-1 , skip past minus sign ) |
8e9db35f | 119 | THEN |
40c6f87f HE |
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 | |
8e9db35f PB |
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 | ; |