[pforth] / fth / numberio.fth

\ @(#) numberio.fth 98/01/26 1.2\r
\ numberio.fth\r
\\r
\ numeric conversion\r
\ \r
\ Author: Phil Burk\r
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
\\r
\ The pForth software code is dedicated to the public domain,\r
\ and any third party may reproduce, distribute and modify\r
\ the pForth software code or any derivative works thereof\r
\ without any compensation or license.  The pForth software\r
\ code is provided on an "as is" basis without any warranty\r
\ of any kind, including, without limitation, the implied\r
\ warranties of merchantability and fitness for a particular\r
\ purpose and their equivalents under the laws of any jurisdiction.\r
\r
anew task-numberio.fth\r
decimal\r
\r
\ ------------------------ INPUT -------------------------------\r
\ Convert a single character to a number in the given base.\r
: DIGIT   ( char base -- n true | char false )\r
	>r\r
\ convert lower to upper\r
	dup ascii a < not\r
	IF\r
		ascii a - ascii A +\r
	THEN\r
\\r
	dup dup ascii A 1- >\r
	IF ascii A - ascii 9 + 1+\r
	ELSE ( char char )\r
		dup ascii 9 >\r
		IF\r
			( between 9 and A is bad )\r
			drop 0 ( trigger error below )\r
		THEN\r
	THEN\r
	ascii 0 -\r
	dup r> <\r
	IF dup 1+ 0>\r
		IF nip true\r
		ELSE drop FALSE\r
		THEN\r
	ELSE drop FALSE\r
	THEN\r
;\r
\r
: >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )\r
	>r\r
	BEGIN\r
		r@ 0>    \ any characters left?\r
		IF\r
			dup c@ base @\r
			digit ( ud1 c-addr , n true | char false )\r
			IF\r
				TRUE\r
			ELSE\r
				drop FALSE\r
			THEN\r
		ELSE\r
			false\r
		THEN\r
	WHILE ( -- ud1 c-addr n  )\r
		swap >r  ( -- ud1lo ud1hi n  )\r
		swap  base @ ( -- ud1lo n ud1hi base  )\r
		um* drop ( -- ud1lo n ud1hi*baselo  )\r
		rot  base @ ( -- n ud1hi*baselo ud1lo base )\r
		um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )\r
		d+  ( -- ud2 )\r
		r> 1+     \ increment char*\r
		r> 1- >r  \ decrement count\r
	REPEAT\r
	r>\r
;\r
\r
\ obsolete\r
: CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )\r
	256 >NUMBER DROP\r
;\r
\r
0 constant NUM_TYPE_BAD\r
1 constant NUM_TYPE_SINGLE\r
2 constant NUM_TYPE_DOUBLE\r
\r
\ This is similar to the F83 NUMBER? except that it returns a number type\r
\ and then either a single or double precision number.\r
: ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )\r
	dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?\r
	\r
\ prepare for >number\r
	0 0 2swap ( 0 0 c-addr cnt )\r
\r
\ check for '-' at beginning, skip if present\r
	over c@ ascii - = \ is it a '-'\r
	dup >r            \ save flag\r
	IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )\r
	THEN\r
\\r
	>number dup 0=   \ convert as much as we can\r
	IF\r
		2drop    \ drop addr cnt\r
		drop     \ drop hi part of num\r
		r@       \ check flag to see if '-' sign used\r
		IF  negate\r
		THEN\r
		NUM_TYPE_SINGLE\r
	ELSE  ( -- d addr cnt )\r
		1 = swap             \ if final character is '.' then double\r
		c@ ascii . =  AND\r
		IF\r
			r@      \ check flag to see if '-' sign used\r
			IF  dnegate\r
			THEN\r
			NUM_TYPE_DOUBLE\r
		ELSE\r
			2drop\r
			NUM_TYPE_BAD\r
		THEN\r
	THEN\r
	rdrop\r
;\r
\r
: (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )\r
	count ((number?))\r
;\r
\r
' (number?) is number?\r
\ hex\r
\ 0sp c" xyz" (number?) .s\r
\ 0sp c" 234" (number?) .s\r
\ 0sp c" -234" (number?) .s\r
\ 0sp c" 234." (number?) .s\r
\ 0sp c" -234." (number?) .s\r
\ 0sp c" 1234567855554444." (number?) .s\r
\r
\r
\ ------------------------ OUTPUT ------------------------------\r
\ Number output based on F83\r
variable HLD    \ points to last character added \r
\r
: hold   ( char -- , add character to text representation)\r
	-1 hld  +!\r
	hld @  c!\r
;\r
: <#     ( -- , setup conversion )\r
	pad hld !\r
;\r
: #>     ( d -- addr len , finish conversion )\r
	2drop  hld @  pad  over -\r
;\r
: sign   ( n -- , add '-' if negative )\r
	0<  if  ascii - hold  then\r
;\r
: #      ( d -- d , convert one digit )\r
   base @  mu/mod rot 9 over <\r
   IF  7 +\r
   THEN\r
   ascii 0 + hold\r
;\r
: #s     ( d -- d , convert remaining digits )\r
	BEGIN  #  2dup or 0=\r
	UNTIL\r
;\r
\r
\r
: (UD.) ( ud -- c-addr cnt )\r
	<# #s #>\r
;\r
: UD.   ( ud -- , print unsigned double number )\r
	(ud.)  type space\r
;\r
: UD.R  ( ud n -- )\r
	>r  (ud.)  r> over - spaces type\r
;\r
: (D.)  ( d -- c-addr cnt )\r
	tuck dabs <# #s rot sign #>\r
;\r
: D.    ( d -- )\r
	(d.)  type space\r
;\r
: D.R   ( d n -- , right justified )\r
	>r  (d.)  r>  over - spaces  type\r
;\r
\r
: (U.)  ( u -- c-addr cnt )\r
	0 (ud.)\r
;\r
: U.    ( u -- , print unsigned number )\r
	0 ud.\r
;\r
: U.R   ( u n -- , print right justified )\r
	>r  (u.)  r> over - spaces  type\r
;\r
: (.)   ( n -- c-addr cnt )\r
	dup abs 0 <# #s rot sign #>\r
;\r
: .     ( n -- , print signed number)\r
   (.)  type space\r
;\r
: .R    ( n l -- , print right justified)\r
	>r  (.)  r> over - spaces type\r
;\r
Commit	Line	Data
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 ud1hibaselo ud1lobasello 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