home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / numpar.scm < prev    next >
Text File  |  1999-01-02  |  15KB  |  402 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: numpar.scm,v 14.17 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Number Parser
  23. ;;; package: (runtime number-parser)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (string->number string #!optional radix)
  28.   (if (not (string? string))
  29.       (error:wrong-type-argument string "string" 'STRING->NUMBER))
  30.   (parse-number string 0 (string-length string)
  31.         (if (default-object? radix) #f radix)
  32.         'STRING->NUMBER))
  33.  
  34. (define (substring->number string start end #!optional radix)
  35.   (if (not (string? string))
  36.       (error:wrong-type-argument string "string" 'SUBSTRING->NUMBER))
  37.   (if (not (index-fixnum? start))
  38.       (error:wrong-type-argument start "string index" 'SUBSTRING->NUMBER))
  39.   (if (not (index-fixnum? end))
  40.       (error:wrong-type-argument end "string index" 'SUBSTRING->NUMBER))
  41.   (if (not (fix:<= end (string-length string)))
  42.       (error:bad-range-argument end 'SUBSTRING->NUMBER))
  43.   (if (not (fix:<= start end))
  44.       (error:bad-range-argument start 'SUBSTRING->NUMBER))
  45.   (parse-number string start end
  46.         (if (default-object? radix) #f radix)
  47.         'SUBSTRING->NUMBER))
  48.  
  49. (define (parse-number string start end default-radix name)
  50.   (if (not (or (eq? #f default-radix) (eq? 2 default-radix)
  51.            (eq? 8 default-radix) (eq? 10 default-radix)
  52.            (eq? 16 default-radix)))
  53.       (error:bad-range-argument default-radix name))
  54.   (let loop ((start start) (exactness #f) (radix #f))
  55.     (and (fix:< start end)
  56.      (if (char=? #\# (string-ref string start))
  57.          (let ((start (fix:+ start 1)))
  58.            (and (fix:< start end)
  59.             (let ((char (string-ref string start))
  60.               (start (fix:+ start 1)))
  61.               (let ((do-radix
  62.                  (lambda (r)
  63.                    (and (not radix) (loop start exactness r))))
  64.                 (do-exactness
  65.                  (lambda (e)
  66.                    (and (not exactness) (loop start e radix)))))
  67.             (cond ((or (char=? #\b char) (char=? #\B char))
  68.                    (do-radix 2))
  69.                   ((or (char=? #\o char) (char=? #\O char))
  70.                    (do-radix 8))
  71.                   ((or (char=? #\d char) (char=? #\D char))
  72.                    (do-radix 10))
  73.                   ((or (char=? #\x char) (char=? #\X char))
  74.                    (do-radix 16))
  75.                   ((or (char=? #\e char) (char=? #\E char))
  76.                    (do-exactness 'EXACT))
  77.                   ((or (char=? #\i char) (char=? #\I char))
  78.                    (do-exactness 'INEXACT))
  79.                   (else #f))))))
  80.          (parse-top-level string start end exactness
  81.                   (or radix default-radix))))))
  82.  
  83. (define (parse-top-level string start end exactness radix)
  84.   (and (fix:< start end)
  85.        (let ((char (string-ref string start))
  86.          (start (fix:+ start 1)))
  87.      (cond ((sign? char)
  88.         (find-leader string start end
  89.                  exactness (or radix 10)
  90.                  char))
  91.            ((char=? #\. char)
  92.         (and (or (not radix) (fix:= 10 radix))
  93.              (parse-decimal-1 string start end
  94.                       (or exactness 'IMPLICIT-INEXACT) #f)))
  95.            ((char->digit char (or radix 10))
  96.         => (lambda (digit)
  97.              (parse-integer string start end digit
  98.                     exactness (or radix 10) #f)))
  99.            (else #f)))))
  100.  
  101. (define (find-leader string start end exactness radix sign)
  102.   ;; State: leading sign has been seen.
  103.   (and (fix:< start end)
  104.        (let ((char (string-ref string start))
  105.          (start (fix:+ start 1)))
  106.      (cond ((char->digit char radix)
  107.         => (lambda (digit)
  108.              (parse-integer string start end digit
  109.                     exactness radix sign)))
  110.            ((char=? #\. char)
  111.         (and (fix:= 10 radix)
  112.              (parse-decimal-1 string start end
  113.                       (or exactness 'IMPLICIT-INEXACT) sign)))
  114.            ((i? char)
  115.         (and (fix:= start end)
  116.              (if (eq? #\- sign) -i +i)))
  117.            (else #f)))))
  118.  
  119. (define (parse-integer string start end integer exactness radix sign)
  120.   ;; State: at least one digit has been seen.
  121.   (parse-digits string start end integer exactness radix
  122.     (lambda (start integer exactness sharp?)
  123.       (if (fix:< start end)
  124.       (let ((char (string-ref string start))
  125.         (start+1 (fix:+ start 1)))
  126.         (cond ((char=? #\/ char)
  127.            (parse-denominator-1 string start+1 end
  128.                     integer exactness radix sign))
  129.           ((char=? #\. char)
  130.            (and (fix:= radix 10)
  131.             (if sharp?
  132.                 (parse-decimal-3 string start+1 end
  133.                          integer 0 exactness sign)
  134.                 (parse-decimal-2 string start+1 end
  135.                          integer 0
  136.                          (or exactness 'IMPLICIT-INEXACT)
  137.                          sign))))
  138.           ((exponent-marker? char)
  139.            (and (fix:= radix 10)
  140.             (parse-exponent-1 string start+1 end
  141.                       integer 0
  142.                       (or exactness 'IMPLICIT-INEXACT)
  143.                       sign)))
  144.           (else
  145.            (parse-complex string start end
  146.                   (finish-integer integer exactness sign)
  147.                   exactness radix sign))))
  148.       (finish-integer integer exactness sign)))))
  149.  
  150. (define (parse-digits string start end integer exactness radix k)
  151.   (let loop ((start start) (integer integer))
  152.     (if (fix:< start end)
  153.     (let ((char (string-ref string start)))
  154.       (cond ((char->digit char radix)
  155.          => (lambda (digit)
  156.               (loop (fix:+ start 1)
  157.                 (+ (* integer radix) digit))))
  158.         ((char=? #\# char)
  159.          (do ((start (fix:+ start 1) (fix:+ start 1))
  160.               (integer (* integer radix) (* integer radix)))
  161.              ((not (and (fix:< start end)
  162.                 (char=? #\# (string-ref string start))))
  163.               (k start integer (or exactness 'IMPLICIT-INEXACT) #t))))
  164.         (else
  165.          (k start integer exactness #f))))
  166.     (k start integer exactness #f))))
  167.  
  168. (define (parse-denominator-1 string start end numerator exactness radix sign)
  169.   ;; State: numerator parsed, / seen.
  170.   (let ((finish
  171.      (lambda (denominator exactness sign)
  172.        (finish-rational numerator denominator exactness sign))))
  173.     (parse-digits string start end 0 exactness radix
  174.       (lambda (start* integer exactness sharp?)
  175.     sharp?
  176.     (and (> start* start) ; >0 denominator digits 
  177.          (parse-complex string start* end
  178.                 (finish integer exactness sign)
  179.                 exactness radix sign))))))
  180.  
  181. (define (parse-decimal-1 string start end exactness sign)
  182.   ;; State: radix is 10, leading dot seen.
  183.   (and (fix:< start end)
  184.        (let ((digit (char->digit (string-ref string start) 10))
  185.          (start (fix:+ start 1)))
  186.      (and digit
  187.           (parse-decimal-2 string start end digit -1 exactness sign)))))
  188.  
  189. (define (parse-decimal-2 string start end integer exponent exactness sign)
  190.   ;; State: radix is 10, dot seen.
  191.   (let loop ((start start) (integer integer) (exponent exponent))
  192.     (if (fix:< start end)
  193.     (let ((char (string-ref string start))
  194.           (start+1 (fix:+ start 1)))
  195.       (cond ((char->digit char 10)
  196.          => (lambda (digit)
  197.               (loop start+1
  198.                 (+ (* integer 10) digit)
  199.                 (- exponent 1))))
  200.         ((char=? #\# char)
  201.          (parse-decimal-3 string start+1 end
  202.                   integer exponent exactness sign))
  203.         (else
  204.          (parse-decimal-4 string start end
  205.                   integer exponent exactness sign))))
  206.     (finish-real integer exponent exactness sign))))
  207.  
  208. (define (parse-decimal-3 string start end integer exponent exactness sign)
  209.   ;; State: radix is 10, dot and # seen.
  210.   (let loop ((start start))
  211.     (if (fix:< start end)
  212.     (let ((char (string-ref string start))
  213.           (start+1 (fix:+ start 1)))
  214.       (if (char=? #\# char)
  215.           (loop start+1)
  216.           (parse-decimal-4 string start end
  217.                    integer exponent exactness sign)))
  218.     (finish-real integer exponent exactness sign))))
  219.  
  220. (define (parse-decimal-4 string start end integer exponent exactness sign)
  221.   (if (exponent-marker? (string-ref string start))
  222.       (parse-exponent-1 string (fix:+ start 1) end
  223.             integer exponent exactness sign)
  224.       (parse-decimal-5 string start end integer exponent exactness sign)))
  225.  
  226. (define (parse-exponent-1 string start end integer exponent exactness sign)
  227.   ;; State: radix is 10, exponent seen.
  228.   (define (get-digits start esign)
  229.     (and (fix:< start end)
  230.      (let ((digit (char->digit (string-ref string start) 10)))
  231.        (and digit
  232.         (let loop ((start (fix:+ start 1)) (eint digit))
  233.           (if (fix:< start end)
  234.               (let ((digit
  235.                  (char->digit (string-ref string start) 10)))
  236.             (if digit
  237.                 (loop (fix:+ start 1)
  238.                   (+ (* eint 10) digit))
  239.                 (continue start eint esign)))
  240.               (continue start eint esign)))))))
  241.  
  242.   (define (continue start eint esign)
  243.     (let ((exponent (+ exponent (if (eq? #\- esign) (- eint) eint))))
  244.       (if (fix:= start end)
  245.       (finish-real integer exponent exactness sign)
  246.       (parse-decimal-5 string start end
  247.                integer exponent exactness sign))))
  248.                
  249.   
  250.   (and (fix:< start end)
  251.        (let ((esign (string-ref string start)))
  252.      (if (sign? esign)
  253.          (get-digits (fix:+ start 1) esign)
  254.          (get-digits start #f)))))
  255.  
  256. (define (parse-decimal-5 string start end integer exponent exactness sign)
  257.   (parse-complex string start end
  258.          (finish-real integer exponent exactness sign)
  259.          exactness 10 sign))
  260.  
  261. (define (parse-complex string start end real exactness radix sign)
  262.   (if (fix:< start end)
  263.       (let ((char (string-ref string start))
  264.         (start+1 (fix:+ start 1))
  265.         (exactness (if (eq? 'IMPLICIT-INEXACT exactness) #f exactness)))
  266.     (cond ((sign? char)
  267.            (let ((imaginary
  268.               (parse-top-level string start end exactness radix)))
  269.          (and (complex? imaginary)
  270.               (= 0 (real-part imaginary))
  271.               (+ real imaginary))))
  272.           ((char=? #\@ char)
  273.            (let ((angle
  274.               (parse-top-level string start+1 end exactness radix)))
  275.          (and (real? angle)
  276.               (make-polar real angle))))
  277.           ((i? char)
  278.            (and sign
  279.             (fix:= start+1 end)
  280.             (make-rectangular 0 real)))
  281.           (else #f)))
  282.       real))
  283.  
  284. (define (finish-integer integer exactness sign)
  285.   ;; State: result is integer, apply exactness and sign.
  286.   (finish integer exactness sign))
  287.  
  288. (define (finish-rational numerator denominator exactness sign)
  289.   ;; State: result is rational, apply exactness and sign.
  290.   (finish (/ numerator denominator) exactness sign))
  291.  
  292. ;; (finish-real integer exponent exactness sign)
  293. ;;
  294. ;;    magnitude is (* INTEGER (EXPT 10 EXPONENT))
  295. ;;
  296. ;; In the general case for an inexact result, to obtain a correctly
  297. ;; rounded result, it is necessary to work with exact or high
  298. ;; precision numbers and convert to the rounded result at the last
  299. ;; moment.
  300. ;;
  301. ;; Sometimes flonum arithmetic is sufficient to obtain a correct result.
  302. ;; This is true when all the operations are known, by properties of
  303. ;; the numbers they operate on, to give exact results, except possibly
  304. ;; for the final operation which must then round correctly.
  305. ;;
  306. ;; Certain integers can be represented exactly by floating point numbers,
  307. ;; for example, IEEE 64 bit fp numbers can represent the integers 0
  308. ;; through 9007199254740991 (lets call these floating point integers),
  309. ;; and powers of 10 from 10^0 up to 10^22 (because 5^22 =
  310. ;; 2384185791015625 < 9007199254740991).
  311. ;;
  312. ;; This means that all 15 and fewer digit numbers and 90% of 16 digit
  313. ;; numbers with relatively small exponents can be converted correctly
  314. ;; using flonum arithmetic.
  315. ;;
  316. ;; (INTEGER->FLONUM N #b01) acts as both a conversion and a predicate for
  317. ;; integers that are also floating point integers.  (It might be
  318. ;; useful to have an extra flag that tests for N being a floating
  319. ;; point integer scaled by a power of two, e.g. 10^20.)
  320. ;;
  321. ;; Reciprocals of powers of 10 cannot be represented exactly as floating
  322. ;; point numbers because 1/10 is a continued fraction in binary.
  323. ;; Instead of
  324. ;;    (* INTEGER (EXPT 10 EXPONENT))
  325. ;; we compute
  326. ;;    (/ INTEGER (EXPT 10 (- EXPONENT)))
  327. ;; This method also benfits accuracy when FLONUM-PARSER-FAST? is true and
  328. ;; the reciprocal is exact.
  329.  
  330. (define exact-flonum-powers-of-10)    ; a vector, i -> 10.^i
  331.  
  332. (define (finish-real integer exponent exactness sign)
  333.   ;; State: result is integer, apply exactness and sign.
  334.  
  335.   (define (high-precision-method)
  336.     (apply-exactness exactness
  337.              (* (apply-sign sign integer)
  338.             (expt 10 exponent))))
  339.    
  340.   (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness))
  341.       (let ((abs-exponent (if (< exponent 0) (- exponent) exponent))
  342.         (powers-of-10 exact-flonum-powers-of-10))
  343.     (define-integrable (finish-flonum x power-of-10)
  344.       (if (eq? #\- sign)
  345.           (if (eq? exponent abs-exponent)
  346.           (flo:- 0. (flo:* x power-of-10))
  347.           (flo:- 0. (flo:/ x power-of-10)))
  348.           (if (eq? exponent abs-exponent)
  349.           (flo:* x power-of-10)
  350.           (flo:/ x power-of-10))))
  351.     (cond ((and flonum-parser-fast?
  352.             (<= abs-exponent 308)) ; this aught to be defined somewhere
  353.            (if (< abs-exponent (vector-length powers-of-10))
  354.            (finish-flonum (int:->flonum integer)
  355.                   (vector-ref powers-of-10 abs-exponent))
  356.            (finish-flonum (int:->flonum integer)
  357.                   (flo:expt 10. (int:->flonum abs-exponent)))))
  358.           ((and (< abs-exponent (vector-length powers-of-10))
  359.             ((ucode-primitive integer->flonum 2) integer #b1))
  360.            => (lambda (exact-flonum-integer)
  361.             (finish-flonum exact-flonum-integer
  362.                    (vector-ref powers-of-10 abs-exponent))))
  363.           (else (high-precision-method))))
  364.       (high-precision-method)))
  365.  
  366. (define flonum-parser-fast?
  367.   #f)
  368.  
  369. (define (finish number exactness sign)
  370.   (apply-sign sign (apply-exactness exactness number)))
  371.  
  372. (define (apply-sign sign number)
  373.   (if (eq? #\- sign)
  374.       (- number)
  375.       number))
  376.  
  377. (define (apply-exactness exactness number)
  378.   (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness))
  379.       (exact->inexact number)
  380.       number))
  381.  
  382. (define-integrable (exponent-marker? char)
  383.   (or (char=? #\e char) (char=? #\E char)
  384.       (char=? #\s char) (char=? #\S char)
  385.       (char=? #\f char) (char=? #\F char)
  386.       (char=? #\d char) (char=? #\D char)
  387.       (char=? #\l char) (char=? #\L char)))
  388.  
  389. (define-integrable (sign? char)
  390.   (or (char=? #\+ char) (char=? #\- char)))
  391.  
  392. (define-integrable (i? char)
  393.   (or (char=? #\i char) (char=? #\I char)))
  394.  
  395. (define (initialize-package!)
  396.   (set! exact-flonum-powers-of-10
  397.     (let loop ((i 0) (power 1) (powers '()))
  398.       (if (= (inexact->exact (exact->inexact power)) power)
  399.           (loop (+ i 1) (* power 10) (cons (exact->inexact power) powers))
  400.           (list->vector (reverse! powers)))))
  401.   unspecific)
  402.