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