1#lang racket/base 2(require racket/private/check 3 racket/fixnum 4 racket/extflonum 5 "parse-case.rkt" 6 "parameter.rkt" 7 ;; Used only to coerce strings to extflonums 8 ;; when extflonums are not fully supported: 9 (prefix-in host: "../host/string-to-number.rkt")) 10 11(provide string->number 12 unchecked-string->number) 13 14;; The `string->number` parser is responsible for handling Racket's 15;; elaborate number syntax (mostly inherited from Scheme). It relies 16;; on a host-system `string->number` only for generating 17;; pseudo-extflonums when flonums aren't really supported. Otherwise, 18;; the parser here performs all checking and arithmetic that the 19;; reader needs. 20 21(define/who (string->number s 22 [radix 10] 23 [convert-mode 'number-or-false] 24 [decimal-mode (if (read-decimal-as-inexact) 25 'decimal-as-inexact 26 'decimal-as-exact)] 27 [single-mode (if (read-single-flonum) 28 'single 29 'double)]) 30 (check who string? s) 31 (check who (lambda (p) (and (exact-integer? radix) 32 (<= 2 radix 16))) 33 #:contract "(integer-in 2 16)" 34 radix) 35 (check who (lambda (p) (or (eq? p 'number-or-false) 36 (eq? p 'read))) 37 #:contract "(or/c 'number-or-false 'read)" 38 convert-mode) 39 (check who (lambda (p) (or (eq? p 'decimal-as-inexact) 40 (eq? p 'decimal-as-exact))) 41 #:contract "(or/c 'decimal-as-inexact 'decimal-as-exact)" 42 decimal-mode) 43 (check who (lambda (p) (or (eq? p 'single) 44 (eq? p 'double))) 45 #:contract "(or/c 'single 'double)" 46 single-mode) 47 (unchecked-string->number s radix convert-mode decimal-mode single-mode)) 48 49(define (unchecked-string->number s radix convert-mode decimal-mode single-mode) 50 (do-string->number s 0 (string-length s) 51 radix #:radix-set? #f 52 decimal-mode 53 convert-mode 54 single-mode)) 55 56;; ---------------------------------------- 57 58(struct parse-state (exactness ; see below 59 convert-mode ; 'number-or-false, 'read, or 'must-read 60 can-single? ; whether 3.4f0 reads as single-flonum or not 61 fst ; rect-prefix, polar-prefix, '+/- if started with sign, or #f 62 other-exactness) ; exactness to use for the imag part or saved real part 63 #:authentic) 64 65;; `sgn/z` records a sign in case `n` is zero 66(struct rect-prefix (sgn/z n start) #:authentic) 67(struct polar-prefix (sgn/z n start) #:authentic) 68 69;; Exactness state is one of 70;; - 'exact ; found "#e" 71;; - 'inexact ; found "#i" 72;; - 'decimal-as-exact 73;; - 'decimal-as-inexact 74;; - 'approx ; => was 'decimal-as-inexact and found "." or "#" 75;; - 'single ; => was 'decimal-as-inexact and found "f"/"s" 76;; - 'double ; => was 'decimal-as-inexact and found "e"/"d"/"x" 77;; - 'extflonum ; => was 'decimal-as-inexact and found "t" 78;; - 'extflonum->inexact ; => was 'inexact and found "t" 79;; - 'extflonum->exact ; => was 'exact and found "t" 80 81(define (init-state exactness convert-mode single-mode fst) 82 (parse-state exactness convert-mode (eq? single-mode 'single) fst exactness)) 83 84(define (state-has-first-half? state) 85 (define fst (parse-state-fst state)) 86 (and fst (not (eq? fst '+/-)))) 87 88(define (state-set-first-half state fst) 89 (struct-copy parse-state state 90 [fst fst] 91 [exactness (parse-state-other-exactness state)] 92 [other-exactness (parse-state-exactness state)])) 93 94(define (state-first-half state) 95 (init-state (parse-state-other-exactness state) 96 (parse-state-convert-mode state) 97 (if (parse-state-can-single? state) 'single 'double) 98 #f)) 99 100(define (state-second-half state) 101 (init-state (parse-state-exactness state) 102 (parse-state-convert-mode state) 103 (if (parse-state-can-single? state) 'single 'double) 104 #f)) 105 106;; ---------------------------------------- 107 108;; When parsing fails, either return an error string or #f. An error 109;; string is reported only in 'read mode and when if we're somehow 110;; onligated to parse as a number, such as after `#i`. As a 111;; convenience, `state` can be just a convert-mode symbol. 112(define-syntax-rule (fail state msg arg ...) 113 (cond 114 [(eq? (state->convert-mode state) 'must-read) 115 (format msg arg ...)] 116 [else #f])) 117 118(define (state->convert-mode state) 119 (if (parse-state? state) (parse-state-convert-mode state) state)) 120 121(define (state->dbz-convert-mode state) 122 (define convert-mode (parse-state-convert-mode state)) 123 (if (eq? convert-mode 'read) 124 'must-read 125 convert-mode)) 126 127(define (bad-digit c s state) 128 (cond 129 [(char=? c #\nul) 130 (fail state "nul character in `~.a`" s)] 131 [else 132 (fail state "bad digit `~a`" c)])) 133 134(define (bad-mixed-decimal-fraction s state) 135 (fail state "decimal points and fractions cannot be mixed in `~.a`" s)) 136 137(define (bad-misplaced what s state) 138 (fail state "misplaced `~a` in `~.a`" what s)) 139 140(define (bad-no-digits after s state) 141 (fail state "missing digits after `~a` in `~.a`" after s)) 142 143(define (bad-extflonum-for-complex i s state) 144 (fail state "cannot combine extflonum `~a` into a complex number" i)) 145 146;; For chaining a potentially failing parse/conversion with more: 147(define-syntax-rule (maybe e k) 148 (let ([v e]) 149 (if (or (not v) (string? v)) 150 v 151 (k v)))) 152 153;; ---------------------------------------- 154 155;; Lazy exponentiation and devision lets us avoid 156;; extremely large bignums when we're trying to 157;; compute an inexact number that will just be 158;; infinity 159(struct lazy-expt (n radix exp) 160 #:authentic) 161(struct lazy-rational (n d) 162 #:authentic) 163 164(define (lazy-number n radix exp) 165 (cond 166 [(eq? n 'dbz) n] 167 [(eq? n 'dbz!) n] 168 [else 169 (if (and (exp . < . 30) 170 (exp . > . -30)) 171 (* n (expt radix exp)) 172 (lazy-expt n radix exp))])) 173 174(define (lazy-divide n d d-exactness) 175 (cond 176 [(eqv? d 0) (if (eq? d-exactness 'exact) 177 'dbz! 178 'dbz)] 179 [(or (lazy-expt? n) 180 (lazy-expt? d)) 181 (lazy-rational n d)] 182 [else (/ n d)])) 183 184(define (simplify-lazy-divide n0) 185 (cond 186 [(lazy-rational? n0) 187 (define n (lazy-rational-n n0)) 188 (define d (lazy-rational-d n0)) 189 (define n-n (if (lazy-expt? n) (lazy-expt-n n) n)) 190 (define n-exp (if (lazy-expt? n) (lazy-expt-exp n) 0)) 191 (define d-n (if (lazy-expt? d) (lazy-expt-n d) d)) 192 (define d-exp (if (lazy-expt? d) (lazy-expt-exp d) 0)) 193 (define radix (if (lazy-expt? n) (lazy-expt-radix n) (lazy-expt-radix d))) 194 (lazy-number (/ n-n d-n) radix (- n-exp d-exp))] 195 [else n0])) 196 197(define (force-lazy-exact n0 state s) 198 (define n (simplify-lazy-divide n0)) 199 (cond 200 [(or (eq? n 'dbz) (eq? n 'dbz!)) 201 (fail (state->dbz-convert-mode state) "division by zero in `~.a`" s)] 202 [(lazy-expt? n) 203 (* (lazy-expt-n n) (expt (lazy-expt-radix n) (lazy-expt-exp n)))] 204 [else n])) 205 206(define (force-lazy-inexact sgn/z n0 state s [precision 2048]) 207 (define n1 (simplify-lazy-divide n0)) 208 (cond 209 [(eq? n0 'dbz) (if (fx= sgn/z -1) -inf.0 +inf.0)] 210 [(eq? n0 'dbz!) 211 (fail (state->dbz-convert-mode state) "division by zero in `~.a`" s)] 212 [(lazy-expt? n1) 213 (define n (lazy-expt-n n1)) 214 (define exp (lazy-expt-exp n1)) 215 (define radix (lazy-expt-radix n1)) 216 (define approx-expt (+ (/ (if (integer? n) 217 (integer-length n) 218 (- (integer-length (numerator n)) 219 (integer-length (denominator n)))) 220 (log radix 2)) 221 exp)) 222 (cond 223 [(eqv? n 0) (if (fx= sgn/z -1) (- 0.0) 0.0)] 224 [(approx-expt . > . precision) (if (fx= sgn/z -1) -inf.0 +inf.0)] 225 [(approx-expt . < . (- precision)) (if (fx= sgn/z -1) (- 0.0) 0.0)] 226 [else 227 (* n (expt radix exp))])] 228 [(eqv? n1 0) (if (fx= sgn/z -1) (- 0.0) 0.0)] 229 [else n1])) 230 231(define (fast-inexact state sgn n radix exp sgn2 exp2) 232 (case (parse-state-exactness state) 233 [(double approx) 234 (cond 235 [(state-has-first-half? state) #f] 236 [(eqv? n 0) (if (fx= sgn 1) 0.0 (- 0.0))] 237 [(and (fixnum? n) 238 (n . < . (expt 2 50)) 239 (n . > . (- (expt 2 50)))) 240 ;; No loss of precision in mantissa from early flonum conversion 241 (let ([exp (+ exp (* sgn2 exp2))]) 242 (cond 243 [(and (fixnum? exp) 244 (cond 245 [(radix . fx<= . 10) (fx<= -15 exp 15)] 246 [else (fx<= -12 exp 12)])) 247 ;; No loss of precision in radix^exponent as a flonum 248 (let ([m (fx->fl (if (fx= sgn -1) 249 (fx- 0 n) 250 n))]) 251 (cond 252 [(eqv? exp 0) m] 253 [(not (fixnum? exp)) #f] 254 [else 255 (define fradix (if (fx= radix 10) 256 10.0 257 (fx->fl radix))) 258 (cond 259 [(exp . fx< . 0) (/ m (expt fradix (fx- 0 exp)))] 260 [else (* m (expt fradix exp))])]))] 261 [else #f]))] 262 [else #f])] 263 [else #f])) 264 265;; The `sgn/z` argument lets us produce -0.0 instead of 0.0 as needed 266;; when converting an exact zero to inexact. That is, the sign is `-1` 267;; when the input has a literal "-", but it's only used when `n` is 0. 268(define (finish sgn/z n s state 269 ;; Used only when we have to resort to host:string->number: 270 #:range [range #f]) 271 (define fst (parse-state-fst state)) 272 (cond 273 [(or (not fst) (eq? fst '+/-)) 274 (case (parse-state-exactness state) 275 [(single) 276 (maybe (force-lazy-inexact sgn/z n state s) 277 (lambda (r) 278 (if (parse-state-can-single? state) 279 (if (single-flonum-available?) 280 (real->single-flonum r) 281 (raise (exn:fail:unsupported 282 (string-append 283 "read: single-flonums are not supported on this platform\n" 284 " conversion from: " (number->string r)) 285 (current-continuation-marks)))) 286 (exact->inexact r))))] 287 [(exact) 288 (case n 289 [(+inf.0 -inf.0 +nan.0) 290 (fail state "no exact representation for ~a" n)] 291 [else 292 (maybe (force-lazy-exact n state s) 293 (lambda (r) (inexact->exact r)))])] 294 [(extended) 295 (cond 296 [(eq? (parse-state-convert-mode state) 'number-or-false) 297 #f] 298 [(extflonum-available?) 299 (maybe (force-lazy-inexact sgn/z n state s 32768) 300 (lambda (r) 301 (real->extfl r)))] 302 [else 303 (define trim-s (trim-number s 304 (if range (car range) 0) 305 (if range (cdr range) (string-length s)))) 306 (host:string->number trim-s 10 'read)])] 307 [(double inexact approx) 308 (maybe (force-lazy-inexact sgn/z n state s) 309 (lambda (r0) 310 (exact->inexact r0)))] 311 [(extflonum->inexact) 312 (fail state "cannot convert extflonum to inexact in `~a`" s)] 313 [(extflonum->exact) 314 (fail state "cannot convert extflonum to exact in `~a`" s)] 315 [else (force-lazy-exact n state s)])] 316 [(polar-prefix? fst) 317 (define pos (polar-prefix-start fst)) 318 (define m (finish (polar-prefix-sgn/z fst) (polar-prefix-n fst) s (state-first-half state) 319 #:range (cons 0 pos))) 320 (define a (finish sgn/z n s (state-second-half state) 321 #:range (cons pos (string-length s)))) 322 ;; extflonum errors take precedence over errors like divide-by-zero 323 (cond 324 [(extflonum? m) 325 (bad-extflonum-for-complex m s state)] 326 [(extflonum? a) 327 (bad-extflonum-for-complex a s state)] 328 [else 329 (maybe m 330 (lambda (m) 331 (maybe a 332 (lambda (a) 333 (define cn (make-polar m a)) 334 (case (parse-state-exactness state) 335 [(exact) (inexact->exact cn)] 336 [else cn])))))])] 337 [fst (fail state "missing `i` for complex number in `~.a`" s)])) 338 339;; Called when we find an "i" that might be at the end of the input 340(define (finish-imaginary sgn/z n s start end state) 341 (define fst (parse-state-fst state)) 342 (cond 343 [(and (eq? fst '+/-) 344 (fx= start end)) 345 ;; Just an imaginary part, ok since the input started "+" or "-" 346 (maybe (finish sgn/z n s state) 347 (lambda (i) 348 (cond 349 [(extflonum? i) 350 (bad-extflonum-for-complex i s state)] 351 [else 352 (define zero 353 (case (parse-state-other-exactness state) 354 [(inexact) 0.0] 355 [else 0])) 356 (make-rectangular zero i)])))] 357 [(and (rect-prefix? fst) 358 (fx= start end)) 359 (define pos (rect-prefix-start fst)) 360 (define r (finish (rect-prefix-sgn/z fst) (rect-prefix-n fst) s (state-first-half state) 361 #:range (cons 0 pos))) 362 (define i (finish sgn/z n s (state-second-half state) 363 #:range (cons pos (string-length s)))) 364 ;; extflonum errors take precedence over other errors (such as divide-by-zero) 365 (cond 366 [(extflonum? r) 367 (bad-extflonum-for-complex r s state)] 368 [(extflonum? i) 369 (bad-extflonum-for-complex r i state)] 370 [else 371 (maybe r 372 (lambda (r) 373 (maybe i 374 (lambda (i) 375 (make-rectangular r i)))))])] 376 [else 377 (bad-misplaced "i" s state)])) 378 379;; Given a current exactness and an inferred exactness, combine the 380;; two specifications 381(define (set-exactness state new-exactness #:override? [override? #f]) 382 (define exactness (parse-state-exactness state)) 383 (define result-exactness 384 (case new-exactness 385 [(single double) 386 (case exactness 387 [(exact) 'exact] 388 [(decimal-as-exact) (if override? 389 new-exactness 390 'decimal-as-exact)] 391 [else new-exactness])] 392 [(approx) 393 (case exactness 394 [(exact inexact decimal-as-exact) exactness] 395 [else new-exactness])] 396 [(extended) 397 ;; extended mode always overrides 398 (case exactness 399 [(inexact) 'extflonum->inexact] 400 [(exact) 'extflonum->exact] 401 [else 'extended])] 402 [else new-exactness])) 403 (if (eq? exactness result-exactness) 404 state 405 (struct-copy parse-state state 406 [exactness result-exactness]))) 407 408(define (set-exactness-by-char state c #:override? [override? #f]) 409 (set-exactness 410 state 411 (case c 412 [(#\e #\E #\d #\D #\l #\L #\0) 'double] 413 [(#\f #\F #\s #\S) 'single] 414 [(#\t #\T) 'extended]) 415 #:override? override?)) 416 417;; When we have to use `host:string->number` to deal with extflonums, 418;; we need to extract the right part of the string. Remove any '#' 419;; from the front and any 'i' at the end. 420(define (trim-number s start end) 421 (cond 422 [(eqv? (string-ref s start) #\#) 423 (trim-number s (fx+ 2 start) end)] 424 [(let ([c (string-ref s (fx- end 1))]) 425 (or (eqv? c #\i) (eqv? c #\I))) 426 (trim-number s start (fx- end 1))] 427 [else (substring s start end)])) 428 429;; ---------------------------------------- 430;; The simple strategy of accumuling digits --- adding a digit to 431;; the accumulator muliplties by the radix --- is O(n^2). A 432;; "digits" starts with that simple strategy, but it then falls 433;; back to a list representation if the accumulator gets large, 434;; and accumulated values are combined in a divide-and-conquer 435;; style. 436;;;; 437;; A digits is either 438;; - val-integer 439;; - (cons (cons val-integer shift-integer) digits) 440;; where `shift-integer` is an amount to shift `digits` by radix 441;; before adding `val-integer` 442 443(define (add-digit d c radix) 444 (cond 445 [(pair? d) 446 (define p (car d)) 447 (define digits (add-digit (car p) c radix)) 448 (if (pair? digits) 449 (list* (car digits) 450 (cons (cdr digits) (cdr p)) 451 (cdr d)) 452 (cons (cons digits (fx+ 1 (cdr p))) 453 (cdr d)))] 454 [(eqv? d 0) c] 455 [(< d (expt 2 100)) (+ (* d radix) c)] 456 [else 457 (cons (cons c 1) d)])) 458 459(define (digits->integer d radix) 460 (cond 461 [(pair? d) 462 (define len (let loop ([d d]) 463 (if (pair? d) 464 (fx+ 1 (loop (cdr d))) 465 1))) 466 (let loop ([d d] [len len]) 467 (cond 468 [(fx= len 1) (if (pair? d) 469 (caar d) 470 d)] 471 [else 472 (define hi-len (fxrshift len 1)) 473 (define lo-len (fx- len hi-len)) 474 (define hi (loop d hi-len)) 475 (let split-loop ([shift 0] [hi-len hi-len] [d d]) 476 (if (fx= hi-len 0) 477 (+ hi 478 (* (expt radix shift) 479 (loop d lo-len))) 480 (split-loop (fx+ shift (cdar d)) 481 (fx- hi-len 1) 482 (cdr d))))]))] 483 [else d])) 484 485;; ---------------------------------------- 486 487;; The parser is implemented as a kind of state machine that is driven 488;; by the next input character. The current function mostly represents 489;; the state. Some state is in other arguments -- especially the 490;; `state` argument, obviously --- to avoid duplicating all functions 491;; for similar states, such as parsing a number in the real or 492;; imaginary position of a complex number. 493 494;; The `convert-mode` argument here can be 'number-or-false, 'read, or 495;; 'must-read, where 'must-read reports an error on parsing failure 496;; instead of returning #f. At this level, we mostly detect the 497;; special numbers `+inf.0` in combinations, and otherwise dispatch 498;; to parsing a complex number, fraction, or exponential. 499(define (do-string->number s start end 500 radix #:radix-set? radix-set? 501 exactness ; 'inexact, 'exact, 'decimal-as-inexact, or 'decimal-as-exact 502 convert-mode 503 single-mode) 504 (parse-case 505 s start end radix => c 506 [(eof) 507 (fail convert-mode "no digits")] 508 [(digit) 509 (read-integer 1 c s (fx+ 1 start) end radix (init-state exactness convert-mode single-mode #f))] 510 [(#\#) 511 (define next (fx+ 1 start)) 512 (parse-case 513 ;; use `10` instead of `radix`, because we don't want a hex conversion 514 s next end 10 => i 515 [(eof) 516 (fail convert-mode "no character after `#` indicator in `~.a`" s)] 517 [(#\e #\E #\i #\I) 518 (cond 519 [(or (eq? exactness 'exact) (eq? exactness 'inexact)) 520 (fail convert-mode "misplaced exactness specification at `~.a`" (substring s start end))] 521 [else 522 (do-string->number s (fx+ 1 next) end 523 radix #:radix-set? radix-set? 524 (if (or (char=? i #\e) (char=? i #\E)) 'exact 'inexact) 525 (if (eq? convert-mode 'read) 'must-read convert-mode) 526 single-mode)])] 527 [(#\b #\B #\o #\O #\d #\D #\x #\X) 528 (cond 529 [radix-set? 530 (fail convert-mode "misplaced radix specification at `~.a`" (substring s start end))] 531 [else 532 (define radix 533 (case i 534 [(#\b #\B) 2] 535 [(#\o #\O) 8] 536 [(#\d #\D) 10] 537 [else 16])) 538 (do-string->number s (fx+ 1 next) end 539 radix #:radix-set? #t 540 exactness 541 (if (eq? convert-mode 'read) 'must-read convert-mode) 542 single-mode)])] 543 [else 544 ;; The reader always complains about a bad leading `#` 545 (fail (if (eq? convert-mode 'read) 'must-read convert-mode) 546 "bad `#` indicator `~a` at `~.a`" i (substring s start end))])] 547 [(#\+) 548 (read-signed 1 s (fx+ 1 start) end radix (init-state exactness convert-mode single-mode '+/-))] 549 [(#\-) 550 (read-signed -1 s (fx+ 1 start) end radix (init-state exactness convert-mode single-mode '+/-))] 551 [(#\.) 552 (read-decimal 1 #f 0 s (fx+ 1 start) end radix (set-exactness 553 (init-state exactness convert-mode single-mode #f) 554 'approx))] 555 [else 556 (bad-digit c s convert-mode)])) 557 558;; consumed a "+" or "-" 559(define (read-signed sgn s start end radix state) 560 (parse-case 561 s start end radix => c 562 [(eof) (fail state "no digits in `~.a`" s)] 563 [(digit) 564 (read-integer sgn c s (fx+ 1 start) end radix state)] 565 [(#\.) 566 (read-decimal sgn #f 0 s (fx+ 1 start) end radix (set-exactness state 'approx))] 567 [(#\i #\I) 568 ;; maybe "[+-]inf.0" 569 (parse-case 570 s (fx+ 1 start) end radix => c2 571 [(eof) 572 (finish-imaginary sgn sgn s (fx+ 1 start) end state)] 573 [(#\n #\N) 574 (read-infinity sgn c s (fx+ 2 start) end radix state)] 575 [else (bad-digit c s state)])] 576 [(#\n #\N) 577 ;; maybe "[+-]nan.0" 578 (read-nan c s (fx+ 1 start) end radix state)] 579 [else 580 (bad-digit c s state)])) 581 582;; consumed some digits 583(define (read-integer sgn n s start end radix state) 584 (define (get-n) (* sgn (digits->integer n radix))) 585 (parse-case 586 s start end radix => c 587 [(eof) (finish sgn (get-n) s state)] 588 [(digit) 589 (read-integer sgn (add-digit n c radix) s (fx+ 1 start) end radix state)] 590 [(#\.) 591 (read-decimal sgn (digits->integer n radix) 0 s (fx+ 1 start) end radix (set-exactness state 'approx))] 592 [(#\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 593 (read-exponent sgn (get-n) 0 s (fx+ 1 start) end radix (set-exactness-by-char state c))] 594 [(#\/) 595 (read-rational sgn (get-n) #f s (fx+ 1 start) end radix state)] 596 [(#\#) 597 (read-approx sgn (digits->integer n radix) 1 #f s (fx+ 1 start) end radix (set-exactness state 'approx))] 598 [(#\+ #\-) 599 (read-imag c sgn (get-n) (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state)] 600 [(#\@) 601 (read-polar sgn (get-n) s (fx+ 1 start) end radix state)] 602 [(#\i #\I) 603 (finish-imaginary sgn (get-n) s (fx+ 1 start) end state)] 604 [else 605 (bad-digit c s state)])) 606 607;; consumed digits and "." 608(define (read-decimal sgn n exp s start end radix state) 609 (define (get-n) (if n 610 (lazy-number (* sgn (digits->integer n radix)) radix (- exp)) 611 (bad-no-digits "." s state))) 612 (parse-case 613 s start end radix => c 614 [(eof) (or (and n (fast-inexact state sgn (digits->integer n radix) radix 0 -1 exp)) 615 (maybe (get-n) 616 (lambda (n) 617 (finish sgn n s state))))] 618 [(digit) 619 (define next (fx+ 1 start)) 620 (cond 621 [(and (eqv? c #\0) 622 (fx= next end)) 623 ;; avoid extra work when ".0" is used to get an inexact zero 624 (read-decimal sgn (or n 0) exp s next end radix state)] 625 [else 626 (read-decimal sgn (add-digit (or n 0) c radix) (fx+ 1 exp) s (fx+ 1 start) end radix state)])] 627 [(#\.) 628 (bad-misplaced "." s state)] 629 [(#\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 630 (if n 631 (read-exponent sgn (* sgn (digits->integer n radix)) (- exp) s (fx+ 1 start) end radix (set-exactness-by-char state c)) 632 (bad-no-digits "." s state))] 633 [(#\/) 634 (bad-mixed-decimal-fraction s state)] 635 [(#\#) 636 (if n 637 (read-approx sgn (digits->integer n radix) (fx- 0 exp) #t s (fx+ 1 start) end radix state) 638 (bad-misplaced "#" s state))] 639 [(#\+ #\-) 640 (if n 641 (read-imag c sgn (get-n) (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state) 642 (bad-no-digits "." s state))] 643 [(#\@) 644 (maybe (get-n) 645 (lambda (n) 646 (read-polar sgn n s (fx+ 1 start) end radix state)))] 647 [(#\i #\I) 648 (maybe (get-n) 649 (lambda (n) 650 (finish-imaginary sgn n s (fx+ 1 start) end state)))] 651 [else 652 (bad-digit c s state)])) 653 654;; consumed digits and maybe "." and some "#"s 655(define (read-approx sgn n exp saw-.? s start end radix state) 656 (define (get-n) (lazy-number (* sgn n) radix exp)) 657 (parse-case 658 s start end radix => c 659 [(eof) (finish sgn (get-n) s state)] 660 [(digit) 661 (bad-misplaced "#" s state)] 662 [(#\.) 663 (if saw-.? 664 (bad-misplaced "." s state) 665 (read-approx sgn n exp #t s (fx+ 1 start) end radix state))] 666 [(#\#) 667 (read-approx sgn n (if saw-.? exp (fx+ 1 exp)) saw-.? s (fx+ 1 start) end radix state)] 668 [(#\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 669 (read-exponent sgn (* sgn n) exp s (fx+ 1 start) end radix (set-exactness-by-char state c))] 670 [(#\/) 671 (if saw-.? 672 (bad-mixed-decimal-fraction s state) 673 (read-rational sgn (get-n) #f s (fx+ 1 start) end radix state))] 674 [(#\+ #\-) 675 (read-imag c sgn (get-n) (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state)] 676 [(#\@) 677 (read-polar sgn (get-n) s (fx+ 1 start) end radix state)] 678 [(#\i #\I) 679 (finish-imaginary sgn (get-n) s (fx+ 1 start) end state)] 680 [else 681 (bad-digit c s state)])) 682 683;; consumed digits and "e" (or similar) 684(define (read-exponent sgn sgn-n exp s start end radix state) 685 (parse-case 686 s start end radix => c 687 [(eof #\@) (fail state "empty exponent `~.a`" s)] 688 [(digit) 689 (read-signed-exponent sgn sgn-n exp 1 c s (fx+ 1 start) end radix state)] 690 [(#\+ #\-) 691 (define sgn2 (if (eqv? c #\+) +1 -1)) 692 (read-signed-exponent sgn sgn-n exp sgn2 #f s (fx+ 1 start) end radix state)] 693 [(#\. #\# #\/ #\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 694 (bad-misplaced c s state)] 695 [(#\i #\I) 696 (if (state-has-first-half? state) 697 (fail state "empty exponent `~.a`" s) 698 (bad-misplaced "i" s state))] 699 [else 700 (bad-digit c s state)])) 701 702;; consumed digits and "e" (or similar) and "+" or "-" (if any) and maybe digits 703(define (read-signed-exponent sgn sgn-n exp sgn2 exp2 s start end radix state) 704 (define (get-n) (if exp2 705 (lazy-number sgn-n radix (+ exp (* sgn2 (digits->integer exp2 radix)))) 706 (fail state "empty exponent `~.a`" s))) 707 (parse-case 708 s start end radix => c 709 [(eof) (or (and exp2 710 (number? sgn-n) 711 (fast-inexact state (if (eqv? sgn-n 0) sgn 1) sgn-n radix exp sgn2 (digits->integer exp2 radix))) 712 (maybe (get-n) 713 (lambda (n) 714 (finish sgn n s state))))] 715 [(digit) 716 (define new-exp2 (add-digit (or exp2 0) c radix)) 717 (read-signed-exponent sgn sgn-n exp sgn2 new-exp2 s (fx+ 1 start) end radix state)] 718 [(#\+ #\-) 719 (maybe (get-n) 720 (lambda (n) 721 (read-imag c sgn n (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state)))] 722 [(#\. #\# #\/ #\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 723 (bad-misplaced c s state)] 724 [(#\@) 725 (maybe (get-n) 726 (lambda (n) 727 (read-polar sgn n s (fx+ 1 start) end radix state)))] 728 [(#\i #\I) 729 (maybe (get-n) 730 (lambda (n) 731 (finish-imaginary sgn n s (fx+ 1 start) end state)))] 732 [else 733 (bad-digit c s state)])) 734 735;; consumed "+in" or "-in" 736(define (read-infinity sgn c s start end radix state) 737 (parse-case* 738 s start end 739 [[(#\f #\F) 740 (#\.) 741 (#\0 #\f #\t #\F #\T)] 742 (define n (if (negative? sgn) -inf.0 +inf.0)) 743 (define new-state (set-exactness-by-char state (string-ref s (fx+ start 2)) 744 #:override? #t)) 745 (parse-case 746 s (fx+ 3 start) end radix => c2 747 [(eof) (finish sgn n s new-state)] 748 [(#\+ #\-) 749 (read-imag c2 sgn n (if (eqv? c2 #\+) +1 -1) s (fx+ 4 start) end radix new-state)] 750 [(#\@) 751 (read-polar sgn n s (fx+ 4 start) end radix new-state)] 752 [(#\i #\I) 753 (finish-imaginary sgn n s (fx+ 4 start) end new-state)] 754 [else 755 (bad-digit c s state)])] 756 [else 757 (bad-digit c s state)])) 758 759;; consumed "+n" 760(define (read-nan c s start end radix state) 761 (parse-case* 762 s start end 763 [[(#\a #\A) 764 (#\n #\N) 765 (#\.) 766 (#\0 #\f #\t #\F #\T)] 767 (define n +nan.0) 768 (define new-state (set-exactness-by-char state (string-ref s (fx+ start 3)) 769 #:override? #t)) 770 (parse-case 771 s (fx+ 4 start) end radix => c2 772 [(eof) (finish +1 n s new-state)] 773 [(#\+ #\-) 774 (read-imag c2 1 n (if (eqv? c2 #\+) +1 -1) s (fx+ 5 start) end radix new-state)] 775 [(#\@) 776 (read-polar 1 n s (fx+ 5 start) end radix new-state)] 777 [(#\i #\I) 778 (finish-imaginary +1 n s (fx+ 5 start) end new-state)] 779 [else 780 (bad-digit c s state)])] 781 [else 782 (bad-digit c s state)])) 783 784;; consumed digits and "/" 785(define (read-rational sgn sgn-n d s start end radix state) 786 (define (get-n) (if d 787 (lazy-divide sgn-n (digits->integer d radix) 'exact) 788 (bad-no-digits "/" s state))) 789 (parse-case 790 s start end radix => c 791 [(eof) 792 (maybe (get-n) 793 (lambda (n) 794 (finish sgn n s state)))] 795 [(digit) 796 (read-rational sgn sgn-n (add-digit (or d 0) c radix) s (fx+ 1 start) end radix state)] 797 [(#\.) 798 (bad-mixed-decimal-fraction s state)] 799 [(#\#) 800 (if d 801 (read-denom-approx sgn sgn-n (digits->integer d radix) 1 s (fx+ 1 start) end radix (set-exactness state 'approx)) 802 (bad-misplaced "#" s state))] 803 [(#\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 804 (maybe (get-n) 805 (lambda (sgn-n) 806 (read-exponent sgn sgn-n 0 s (fx+ 1 start) end radix (set-exactness-by-char state c))))] 807 [(#\/) 808 (bad-misplaced "/" s state)] 809 [(#\+ #\-) 810 (maybe (get-n) 811 (lambda (n) 812 (read-imag c sgn n (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state)))] 813 [(#\@) 814 (maybe (get-n) 815 (lambda (n) 816 (read-polar sgn n s (fx+ 1 start) end radix state)))] 817 [(#\i #\I) 818 (maybe (get-n) 819 (lambda (n) 820 (finish-imaginary sgn n s (fx+ 1 start) end state)))] 821 [else 822 (bad-digit c s state)])) 823 824;; consumed digits and "/" and digits and "#" 825(define (read-denom-approx sgn sgn-n d exp s start end radix state) 826 (define (get-n) (lazy-divide sgn-n (lazy-number d radix exp) 'approx)) 827 (parse-case 828 s start end radix => c 829 [(eof) (finish sgn (get-n) s state)] 830 [(#\#) 831 (read-denom-approx sgn sgn-n d (fx+ 1 exp) s (fx+ 1 start) end radix state)] 832 [(digit) 833 (bad-misplaced "#" s state)] 834 [(#\. #\/) 835 (bad-misplaced c s state)] 836 [(#\e #\E #\d #\D #\l #\L #\f #\F #\s #\S #\t #\T) 837 (read-exponent sgn (get-n) 0 s (fx+ 1 start) end radix (set-exactness-by-char state c))] 838 [(#\+ #\-) 839 (read-imag c sgn (get-n) (if (eqv? c #\+) +1 -1) s (fx+ 1 start) end radix state)] 840 [(#\@) 841 (read-polar sgn (get-n) s (fx+ 1 start) end radix state)] 842 [(#\i #\I) 843 (finish-imaginary sgn (get-n) s (fx+ 1 start) end state)] 844 [else 845 (bad-digit c s state)])) 846 847;; consumed "+" or "-" after the number in `real` 848(define (read-imag c real-sgn real sgn s start end radix state) 849 (cond 850 [(or (state-has-first-half? state) 851 (eq? 'extended (parse-state-exactness state))) 852 ;; already parsing a complex number 853 (bad-misplaced c s state)] 854 [else 855 ;; take it from almost the top, pushing the number so far into `state`; 856 ;; we don't have to start at the very top, because we saw a "+" or "-" 857 (read-signed sgn s start end radix (state-set-first-half state (rect-prefix real-sgn real (fx- start 1))))])) 858 859;; consumed "@" after the number in `real` 860(define (read-polar real-sgn real s start end radix state) 861 (cond 862 [(or (state-has-first-half? state) 863 (eq? 'extended (parse-state-exactness state))) 864 ;; already parsing a complex number 865 (bad-misplaced "@" s state)] 866 [else 867 ;; take it from the top, pushing the number so far into `state` 868 (parse-case 869 s start end radix => c 870 [(eof) 871 (bad-misplaced "@" s state)] 872 [(#\+ #\-) 873 (define new-state (state-set-first-half state (polar-prefix real-sgn real start))) 874 (read-signed (if (eq? c '#\+) 1 -1) s (fx+ 1 start) end radix new-state)] 875 [(digit) 876 (define new-state (state-set-first-half state (polar-prefix real-sgn real start))) 877 (read-integer 1 c s (fx+ 1 start) end radix new-state)] 878 [else 879 (bad-digit c s state)])])) 880 881;; ---------------------------------------- 882 883(module+ test 884 (require (only-in racket/base 885 [string->number racket:string->number])) 886 887 (let ([s (make-string 1000000 #\9)]) 888 (unless (equal? (time (string->number s)) 889 (sub1 (expt 10 1000000))) 890 (error 'fail "large number"))) 891 892 (define (try s) 893 (define expect (racket:string->number s 10 'read 'decimal-as-inexact)) 894 (define got (string->number s 10 'read 'decimal-as-inexact)) 895 (unless (equal? expect got) 896 (error 'fail "~e\n expect: ~e\n got: ~e" s expect got))) 897 898 (try "#i+inf.0") 899 (try "-inf.0") 900 (try "#i+inf.f") 901 (try "-inf.f") 902 (try "#e+inf.0") 903 (when (extflonum-available?) (try "-inf.t")) 904 (try "10") 905 (try "10.1") 906 (try "1+2i") 907 (try "#e10.1") 908 (try "1#.#") 909 (try "#e1#.#") 910 (try "1/2") 911 (try "#x+e#s+e") 912 (try "#e#x+e#s+e") 913 (try "-e#l-e") 914 (try "#e#x+e#s+e@-e#l-e") 915 (when (extflonum-available?) (try "3.1415926535897932385t0")) 916 (try "+nan.0+1i") 917 (when (extflonum-available?) (try "3.0t0")) 918 (try "+i") 919 (try "-i") 920 (try "#i3") 921 (try "#i3+i") 922 (try "1/2+i") 923 (try "1.2+i") 924 (try "1/2+3") 925 (try "1.2+3") 926 (when (extflonum-available?) (try "#i1.2t0+3i")) 927 (try "#i-0") 928 (try "#i0") 929 (try "-0#") 930 (try "#i1-0i") 931 (try "1#e500") 932 (try "1#e10000000000000000000000000000000") 933 (try "1#e-10000000000000000000000000000000") 934 (try "-0#e10") 935 (try "-0#e10000000000000000000000000000000") 936 (try "1/2@0") 937 (try "#i+8#i") 938 (try "1#/3") 939 (try "+inf.0@1") 940 (try "+inf.0@1/1") 941 (try "1/0#") 942 (try "1#/0") 943 (try "-1/0#") 944 (try "#e1/2#e10") 945 (try "1/0") 946 (try "1@+inf.0") 947 (try "1/1@+inf.0") 948 ;(try "#d1/0+3.0i") 949 (when (extflonum-available?) 950 (try "3.0t0+1/0i") 951 (try "1/0+3.0t0i") 952 (try "+inf.t0+1/0i") 953 (try "1/0+inf.t0i") 954 (try "3.#t0")) 955 (try "-1-2i") 956 (try "-4.242154731064108e-5-6.865001427422244e-5i") 957 (try "1e300+1e300i") 958 (try "#x8f0767e50d4d0c07563bd81f530d36") 959 (try "t") 960 (try "s2") 961 (try "2e") 962 (try ".e1") 963 (try "+.e1") 964 (try "#e1") 965 (try "1e#") 966 (try "1e+") 967 (try "1e+-") 968 (try ".#e1") 969 (try "1/") 970 (try "/2") 971 (try "1//2") 972 (try "2..") 973 (try "2+1")) 974