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

   1 \ @(#) numberio.fth 98/01/26 1.2\r
   2 \ numberio.fth\r
   3 \\r
   4 \ numeric conversion\r
   5 \ \r
   6 \ Author: Phil Burk\r
   7 \ Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom\r
   8 \\r
   9 \ The pForth software code is dedicated to the public domain,\r
  10 \ and any third party may reproduce, distribute and modify\r
  11 \ the pForth software code or any derivative works thereof\r
  12 \ without any compensation or license.  The pForth software\r
  13 \ code is provided on an "as is" basis without any warranty\r
  14 \ of any kind, including, without limitation, the implied\r
  15 \ warranties of merchantability and fitness for a particular\r
  16 \ purpose and their equivalents under the laws of any jurisdiction.\r
  17 \r
  18 anew task-numberio.fth\r
  19 decimal\r
  20 \r
  21 \ ------------------------ INPUT -------------------------------\r
  22 \ Convert a single character to a number in the given base.\r
  23 : DIGIT   ( char base -- n true | char false )\r
  24         >r\r
  25 \ convert lower to upper\r
  26         dup ascii a < not\r
  27         IF\r
  28                 ascii a - ascii A +\r
  29         THEN\r
  30 \\r
  31         dup dup ascii A 1- >\r
  32         IF ascii A - ascii 9 + 1+\r
  33         ELSE ( char char )\r
  34                 dup ascii 9 >\r
  35                 IF\r
  36                         ( between 9 and A is bad )\r
  37                         drop 0 ( trigger error below )\r
  38                 THEN\r
  39         THEN\r
  40         ascii 0 -\r
  41         dup r> <\r
  42         IF dup 1+ 0>\r
  43                 IF nip true\r
  44                 ELSE drop FALSE\r
  45                 THEN\r
  46         ELSE drop FALSE\r
  47         THEN\r
  48 ;\r
  49 \r
  50 : >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 , convert till bad char , CORE )\r
  51         >r\r
  52         BEGIN\r
  53                 r@ 0>    \ any characters left?\r
  54                 IF\r
  55                         dup c@ base @\r
  56                         digit ( ud1 c-addr , n true | char false )\r
  57                         IF\r
  58                                 TRUE\r
  59                         ELSE\r
  60                                 drop FALSE\r
  61                         THEN\r
  62                 ELSE\r
  63                         false\r
  64                 THEN\r
  65         WHILE ( -- ud1 c-addr n  )\r
  66                 swap >r  ( -- ud1lo ud1hi n  )\r
  67                 swap  base @ ( -- ud1lo n ud1hi base  )\r
  68                 um* drop ( -- ud1lo n ud1hi*baselo  )\r
  69                 rot  base @ ( -- n ud1hi*baselo ud1lo base )\r
  70                 um* ( -- n ud1hi*baselo ud1lo*basello ud1lo*baselhi )\r
  71                 d+  ( -- ud2 )\r
  72                 r> 1+     \ increment char*\r
  73                 r> 1- >r  \ decrement count\r
  74         REPEAT\r
  75         r>\r
  76 ;\r
  77 \r
  78 \ obsolete\r
  79 : CONVERT  ( ud1 c-addr1 -- ud2 c-addr2 , convert till bad char , CORE EXT )\r
  80         256 >NUMBER DROP\r
  81 ;\r
  82 \r
  83 0 constant NUM_TYPE_BAD\r
  84 1 constant NUM_TYPE_SINGLE\r
  85 2 constant NUM_TYPE_DOUBLE\r
  86 \r
  87 \ This is similar to the F83 NUMBER? except that it returns a number type\r
  88 \ and then either a single or double precision number.\r
  89 : ((NUMBER?))   ( c-addr u -- 0 | n 1 | d 2 , convert string to number )\r
  90         dup 0= IF 2drop NUM_TYPE_BAD exit THEN   \ any chars?\r
  91         \r
  92 \ prepare for >number\r
  93         0 0 2swap ( 0 0 c-addr cnt )\r
  94 \r
  95 \ check for '-' at beginning, skip if present\r
  96         over c@ ascii - = \ is it a '-'\r
  97         dup >r            \ save flag\r
  98         IF 1- >r 1+ r>  ( -- 0 0 c-addr+1 cnt-1 , skip past minus sign )\r
  99         THEN\r
 100 \\r
 101         >number dup 0=   \ convert as much as we can\r
 102         IF\r
 103                 2drop    \ drop addr cnt\r
 104                 drop     \ drop hi part of num\r
 105                 r@       \ check flag to see if '-' sign used\r
 106                 IF  negate\r
 107                 THEN\r
 108                 NUM_TYPE_SINGLE\r
 109         ELSE  ( -- d addr cnt )\r
 110                 1 = swap             \ if final character is '.' then double\r
 111                 c@ ascii . =  AND\r
 112                 IF\r
 113                         r@      \ check flag to see if '-' sign used\r
 114                         IF  dnegate\r
 115                         THEN\r
 116                         NUM_TYPE_DOUBLE\r
 117                 ELSE\r
 118                         2drop\r
 119                         NUM_TYPE_BAD\r
 120                 THEN\r
 121         THEN\r
 122         rdrop\r
 123 ;\r
 124 \r
 125 : (NUMBER?)   ( $addr -- 0 | n 1 | d 2 , convert string to number )\r
 126         count ((number?))\r
 127 ;\r
 128 \r
 129 ' (number?) is number?\r
 130 \ hex\r
 131 \ 0sp c" xyz" (number?) .s\r
 132 \ 0sp c" 234" (number?) .s\r
 133 \ 0sp c" -234" (number?) .s\r
 134 \ 0sp c" 234." (number?) .s\r
 135 \ 0sp c" -234." (number?) .s\r
 136 \ 0sp c" 1234567855554444." (number?) .s\r
 137 \r
 138 \r
 139 \ ------------------------ OUTPUT ------------------------------\r
 140 \ Number output based on F83\r
 141 variable HLD    \ points to last character added \r
 142 \r
 143 : hold   ( char -- , add character to text representation)\r
 144         -1 hld  +!\r
 145         hld @  c!\r
 146 ;\r
 147 : <#     ( -- , setup conversion )\r
 148         pad hld !\r
 149 ;\r
 150 : #>     ( d -- addr len , finish conversion )\r
 151         2drop  hld @  pad  over -\r
 152 ;\r
 153 : sign   ( n -- , add '-' if negative )\r
 154         0<  if  ascii - hold  then\r
 155 ;\r
 156 : #      ( d -- d , convert one digit )\r
 157    base @  mu/mod rot 9 over <\r
 158    IF  7 +\r
 159    THEN\r
 160    ascii 0 + hold\r
 161 ;\r
 162 : #s     ( d -- d , convert remaining digits )\r
 163         BEGIN  #  2dup or 0=\r
 164         UNTIL\r
 165 ;\r
 166 \r
 167 \r
 168 : (UD.) ( ud -- c-addr cnt )\r
 169         <# #s #>\r
 170 ;\r
 171 : UD.   ( ud -- , print unsigned double number )\r
 172         (ud.)  type space\r
 173 ;\r
 174 : UD.R  ( ud n -- )\r
 175         >r  (ud.)  r> over - spaces type\r
 176 ;\r
 177 : (D.)  ( d -- c-addr cnt )\r
 178         tuck dabs <# #s rot sign #>\r
 179 ;\r
 180 : D.    ( d -- )\r
 181         (d.)  type space\r
 182 ;\r
 183 : D.R   ( d n -- , right justified )\r
 184         >r  (d.)  r>  over - spaces  type\r
 185 ;\r
 186 \r
 187 : (U.)  ( u -- c-addr cnt )\r
 188         0 (ud.)\r
 189 ;\r
 190 : U.    ( u -- , print unsigned number )\r
 191         0 ud.\r
 192 ;\r
 193 : U.R   ( u n -- , print right justified )\r
 194         >r  (u.)  r> over - spaces  type\r
 195 ;\r
 196 : (.)   ( n -- c-addr cnt )\r
 197         dup abs 0 <# #s rot sign #>\r
 198 ;\r
 199 : .     ( n -- , print signed number)\r
 200    (.)  type space\r
 201 ;\r
 202 : .R    ( n l -- , print right justified)\r
 203         >r  (.)  r> over - spaces type\r
 204 ;\r