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