-\ @(#) 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
+\ @(#) numberio.fth 98/01/26 1.2
+\ numberio.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-numberio.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
+
+\ Like >number, but temporarily switch BASE.
+: (>number-with-base) ( ud c-addr u base -- ud' c-addr' u' )
+ base @ >r base ! >number r> base !
+;
+
+\ 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 2drop NUM_TYPE_BAD exit THEN \ any chars?
+
+ base @ -rot ( base c-addr u )
+
+ \ Regonize prefixes and change base if needed
+ over c@ >r ( base c-addr u ) ( r: char )
+ r@ [char] # = if rot drop 10 -rot 1 /string then
+ r@ [char] $ = if rot drop 16 -rot 1 /string then
+ r@ [char] % = if rot drop 2 -rot 1 /string then
+ r@ [char] ' = if
+ \ Recognize '<char>'
+ dup 3 = if
+ over 2 chars + c@ [char] ' = if
+ drop nip rdrop
+ char+ c@ NUM_TYPE_SINGLE exit
+ then
+ then
+ then
+ r> drop
+
+\ check for '-' at beginning, skip if present
+ over c@ ascii - = \ is it a '-'
+ dup >r \ save flag
+ IF 1 /string ( -- base c-addr+1 cnt-1 , skip past minus sign )
+ THEN
+
+ ( base c-addr cnt ) ( r: minus-flag )
+ rot >r 0 0 2swap r>
+ (>number-with-base) 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
+;
projects / pforth / blobdiff