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

   1 \ @(#) numberio.fth 98/01/26 1.2
   2 \ numberic_io.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-numeric_io.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 drop 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 ;