git.gag.com Git - debian/pforth/blob - fth/numberio.fth

   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
  87 \ This is similar to the F83 NUMBER? except that it returns a number type
  88 \ and then either a single or double precision number.
  89 : ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
  90     dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?
  91
  92 \ prepare for >number
  93     0 0 2swap ( 0 0 c-addr cnt )
  94
  95 \ check for '-' at beginning, skip if present
  96     over c@ ascii - = \ is it a '-'
  97     dup >r            \ save flag
  98     IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )
  99     THEN
 100 \
 101     >number dup 0=   \ convert as much as we can
 102     IF
 103         2drop    \ drop addr cnt
 104         drop     \ drop hi part of num
 105         r@       \ check flag to see if '-' sign used
 106         IF  negate
 107         THEN
 108         NUM_TYPE_SINGLE
 109     ELSE  ( -- d addr cnt )
 110         1 = swap             \ if final character is '.' then double
 111         c@ ascii . =  AND
 112         IF
 113             r@      \ check flag to see if '-' sign used
 114             IF  dnegate
 115             THEN
 116             NUM_TYPE_DOUBLE
 117         ELSE
 118             2drop
 119             NUM_TYPE_BAD
 120         THEN
 121     THEN
 122     rdrop
 123 ;
 124
 125 : (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )
 126     count ((number?))
 127 ;
 128
 129 ' (number?) is number?
 130 \ hex
 131 \ 0sp c" xyz" (number?) .s
 132 \ 0sp c" 234" (number?) .s
 133 \ 0sp c" -234" (number?) .s
 134 \ 0sp c" 234." (number?) .s
 135 \ 0sp c" -234." (number?) .s
 136 \ 0sp c" 1234567855554444." (number?) .s
 137
 138
 139 \ ------------------------ OUTPUT ------------------------------
 140 \ Number output based on F83
 141 variable HLD    \ points to last character added
 142
 143 : hold   ( char -- , add character to text representation)
 144     -1 hld  +!
 145     hld @  c!
 146 ;
 147 : <#     ( -- , setup conversion )
 148     pad hld !
 149 ;
 150 : #>     ( d -- addr len , finish conversion )
 151     2drop  hld @  pad  over -
 152 ;
 153 : sign   ( n -- , add '-' if negative )
 154     0<  if  ascii - hold  then
 155 ;
 156 : #      ( d -- d , convert one digit )
 157    base @  mu/mod rot 9 over <
 158    IF  7 +
 159    THEN
 160    ascii 0 + hold
 161 ;
 162 : #s     ( d -- d , convert remaining digits )
 163     BEGIN  #  2dup or 0=
 164     UNTIL
 165 ;
 166
 167
 168 : (UD.) ( ud -- c-addr cnt )
 169     <# #s #>
 170 ;
 171 : UD.   ( ud -- , print unsigned double number )
 172     (ud.)  type space
 173 ;
 174 : UD.R  ( ud n -- )
 175     >r  (ud.)  r> over - spaces type
 176 ;
 177 : (D.)  ( d -- c-addr cnt )
 178     tuck dabs <# #s rot sign #>
 179 ;
 180 : D.    ( d -- )
 181     (d.)  type space
 182 ;
 183 : D.R   ( d n -- , right justified )
 184     >r  (d.)  r>  over - spaces  type
 185 ;
 186
 187 : (U.)  ( u -- c-addr cnt )
 188     0 (ud.)
 189 ;
 190 : U.    ( u -- , print unsigned number )
 191     0 ud.
 192 ;
 193 : U.R   ( u n -- , print right justified )
 194     >r  (u.)  r> over - spaces  type
 195 ;
 196 : (.)   ( n -- c-addr cnt )
 197     dup abs 0 <# #s rot sign #>
 198 ;
 199 : .     ( n -- , print signed number)
 200    (.)  type space
 201 ;
 202 : .R    ( n l -- , print right justified)
 203     >r  (.)  r> over - spaces type
 204 ;