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