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, David Rosenboom
   8 \
   9 \ Permission to use, copy, modify, and/or distribute this
  10 \ software for any purpose with or without fee is hereby granted.
  11 \
  12 \ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  13 \ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  14 \ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  15 \ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  16 \ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  17 \ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  18 \ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  19 \ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  20
  21 anew task-numberio.fth
  22 decimal
  23
  24 \ ------------------------ INPUT -------------------------------
  25 \ Convert a single character to a number in the given base.
  26 : DIGIT   ( char base -- n true | char false )
  27     >r
  28 \ convert lower to upper
  29     dup ascii a < not
  30     IF
  31         ascii a - ascii A +
  32     THEN
  33 \
  34     dup dup ascii A 1- >
  35     IF ascii A - ascii 9 + 1+
  36     ELSE ( char char )
  37         dup ascii 9 >
  38         IF
  39             ( between 9 and A is bad )
  40             drop 0 ( trigger error below )
  41         THEN
  42     THEN
  43     ascii 0 -
  44     dup r> <
  45     IF dup 1+ 0>
  46         IF nip true
  47         ELSE drop FALSE
  48         THEN
  49     ELSE drop FALSE
  50     THEN
  51 ;
  52
  53 : >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )
  54     >r
  55     BEGIN
  56         r@ 0>    \ any characters left?
  57         IF
  58             dup c@ base @
  59             digit ( ud1 c-addr , n true | char false )
  60             IF
  61                 TRUE
  62             ELSE
  63                 drop FALSE
  64             THEN
  65         ELSE
  66             false
  67         THEN
  68     WHILE ( -- ud1 c-addr n  )
  69         swap >r  ( -- ud1lo ud1hi n  )
  70         swap  base @ ( -- ud1lo n ud1hi base  )
  71         um* drop ( -- ud1lo n ud1hi*baselo  )
  72         rot  base @ ( -- n ud1hi*baselo ud1lo base )
  73         um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )
  74         d+  ( -- ud2 )
  75         r> 1+     \ increment char*
  76         r> 1- >r  \ decrement count
  77     REPEAT
  78     r>
  79 ;
  80
  81 \ obsolete
  82 : CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )
  83     256 >NUMBER DROP
  84 ;
  85
  86 0 constant NUM_TYPE_BAD
  87 1 constant NUM_TYPE_SINGLE
  88 2 constant NUM_TYPE_DOUBLE
  89
  90 \ Like >number, but temporarily switch BASE.
  91 : (>number-with-base) ( ud c-addr u base -- ud' c-addr' u' )
  92         base @ >r base ! >number r> base !
  93 ;
  94
  95 \ This is similar to the F83 NUMBER? except that it returns a number type
  96 \ and then either a single or double precision number.
  97 : ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )
  98     dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?
  99
 100     base @ -rot                 ( base c-addr u )
 101
 102     \ Recognize prefixes and change base if needed
 103     over c@ >r                  ( base c-addr u  ) ( r: char )
 104     r@ [char] # = if rot drop 10 -rot 1 /string then
 105     r@ [char] $ = if rot drop 16 -rot 1 /string then
 106     r@ [char] % = if rot drop  2 -rot 1 /string then
 107     r@ [char] ' = if
 108             \ Recognize '<char>'
 109             dup 3 = if
 110                     over 2 chars + c@ [char] ' = if
 111                             drop nip rdrop
 112                             char+ c@ NUM_TYPE_SINGLE exit
 113                     then
 114             then
 115     then
 116     r> drop
 117
 118 \ check for '-' at beginning, skip if present
 119     over c@ ascii - = \ is it a '-'
 120     dup >r            \ save flag
 121     IF 1 /string  ( -- base c-addr+1 cnt-1 , skip past minus sign )
 122     THEN
 123
 124     ( base c-addr cnt ) ( r: minus-flag )
 125     rot >r 0 0 2swap r>
 126     (>number-with-base) dup 0=   \ convert as much as we can
 127     IF
 128         2drop    \ drop addr cnt
 129         drop     \ drop hi part of num
 130         r@       \ check flag to see if '-' sign used
 131         IF  negate
 132         THEN
 133         NUM_TYPE_SINGLE
 134     ELSE  ( -- d addr cnt )
 135         1 = swap             \ if final character is '.' then double
 136         c@ ascii . =  AND
 137         IF
 138             r@      \ check flag to see if '-' sign used
 139             IF  dnegate
 140             THEN
 141             NUM_TYPE_DOUBLE
 142         ELSE
 143             2drop
 144             NUM_TYPE_BAD
 145         THEN
 146     THEN
 147     rdrop
 148 ;
 149
 150 : (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )
 151     count ((number?))
 152 ;
 153
 154 ' (number?) is number?
 155 \ hex
 156 \ 0sp c" xyz" (number?) .s
 157 \ 0sp c" 234" (number?) .s
 158 \ 0sp c" -234" (number?) .s
 159 \ 0sp c" 234." (number?) .s
 160 \ 0sp c" -234." (number?) .s
 161 \ 0sp c" 1234567855554444." (number?) .s
 162
 163
 164 \ ------------------------ OUTPUT ------------------------------
 165 \ Number output based on F83
 166 variable HLD    \ points to last character added
 167
 168 : hold   ( char -- , add character to text representation)
 169     -1 hld  +!
 170     hld @  c!
 171 ;
 172 : <#     ( -- , setup conversion )
 173     pad hld !
 174 ;
 175 : #>     ( d -- addr len , finish conversion )
 176     2drop  hld @  pad  over -
 177 ;
 178 : sign   ( n -- , add '-' if negative )
 179     0<  if  ascii - hold  then
 180 ;
 181 : #      ( d -- d , convert one digit )
 182    base @  mu/mod rot 9 over <
 183    IF  7 +
 184    THEN
 185    ascii 0 + hold
 186 ;
 187 : #s     ( d -- d , convert remaining digits )
 188     BEGIN  #  2dup or 0=
 189     UNTIL
 190 ;
 191
 192
 193 : (UD.) ( ud -- c-addr cnt )
 194     <# #s #>
 195 ;
 196 : UD.   ( ud -- , print unsigned double number )
 197     (ud.)  type space
 198 ;
 199 : UD.R  ( ud n -- )
 200     >r  (ud.)  r> over - spaces type
 201 ;
 202 : (D.)  ( d -- c-addr cnt )
 203     tuck dabs <# #s rot sign #>
 204 ;
 205 : D.    ( d -- )
 206     (d.)  type space
 207 ;
 208 : D.R   ( d n -- , right justified )
 209     >r  (d.)  r>  over - spaces  type
 210 ;
 211
 212 : (U.)  ( u -- c-addr cnt )
 213     0 (ud.)
 214 ;
 215 : U.    ( u -- , print unsigned number )
 216     0 ud.
 217 ;
 218 : U.R   ( u n -- , print right justified )
 219     >r  (u.)  r> over - spaces  type
 220 ;
 221 : (.)   ( n -- c-addr cnt )
 222     dup abs 0 <# #s rot sign #>
 223 ;
 224 : .     ( n -- , print signed number)
 225    (.)  type space
 226 ;
 227 : .R    ( n l -- , print right justified)
 228     >r  (.)  r> over - spaces type
 229 ;