102 lines
3.2 KiB
Racket
102 lines
3.2 KiB
Racket
#lang racket/base
|
|
|
|
;; ========================================
|
|
|
|
(provide parse-decimal ;; used by pg, mysql
|
|
parse-exact-fraction) ;; used by pg
|
|
|
|
(define (parse-decimal s)
|
|
(cond [(equal? s "NaN") +nan.0]
|
|
[(regexp-match #rx"^-?([0-9]*)$" s)
|
|
;; big integer
|
|
=> (lambda (m)
|
|
(string->number s))]
|
|
[(regexp-match #rx"^-?([0-9]*)\\.([0-9]*)$" s)
|
|
=> (lambda (m)
|
|
(+ (string->number (cadr m))
|
|
(parse-exact-fraction (caddr m))))]
|
|
[else
|
|
(error 'parse-decimal "internal error: cannot parse ~s as decimal" s)]))
|
|
|
|
(define (parse-exact-fraction s)
|
|
;; eg: (parse-exact-fraction "12") = 12/100
|
|
(/ (string->number s)
|
|
(expt 10 (string-length s))))
|
|
|
|
;; ========================================
|
|
|
|
(provide marshal-decimal ;; pg, odbc (?!)
|
|
exact->decimal-string ;; tests (?)
|
|
exact->scaled-integer) ;; odbc
|
|
|
|
(define (marshal-decimal f i n)
|
|
(cond [(not (real? n))
|
|
(marshal-error f i "numeric" n)]
|
|
[(eqv? n +nan.0)
|
|
"NaN"]
|
|
[(or (eqv? n +inf.0) (eqv? n -inf.0))
|
|
(marshal-error f i "numeric" n)]
|
|
[(or (integer? n) (inexact? n))
|
|
(number->string n)]
|
|
[(exact? n)
|
|
;; Bleah.
|
|
(or (exact->decimal-string n)
|
|
(number->string (exact->inexact n)))]))
|
|
|
|
;; exact->decimal-string : exact -> string or #f
|
|
;; always includes decimal point
|
|
(define (exact->decimal-string n)
|
|
(let* ([whole-part (truncate n)]
|
|
[fractional-part (- (abs n) (abs whole-part))]
|
|
[scaled (exact->scaled-integer fractional-part)])
|
|
(and scaled
|
|
(let* ([ma (car scaled)]
|
|
[ex (cdr scaled)]
|
|
[ma-str (number->string ma)])
|
|
(if (zero? ex)
|
|
(number->string whole-part)
|
|
(string-append (number->string whole-part)
|
|
"."
|
|
(make-string (- ex (string-length ma-str)) #\0)
|
|
ma-str))))))
|
|
|
|
;; exact->scaled-integer : rational -> (cons int nat) or #f
|
|
;; Given x, returns (cons M E) s.t. x = (M * 10^-E)
|
|
(define (exact->scaled-integer n)
|
|
(let* ([whole-part (truncate n)]
|
|
[fractional-part (- (abs n) (abs whole-part))]
|
|
[den (denominator fractional-part)])
|
|
(let*-values ([(den* fives) (factor-out den 5)]
|
|
[(den** twos) (factor-out den* 2)])
|
|
(and (= 1 den**)
|
|
(let ([tens (max fives twos)])
|
|
(cons (* n (expt 10 tens)) tens))))))
|
|
|
|
(define (factor-out-v1 n factor)
|
|
(define (loop n acc)
|
|
(let-values ([(q r) (quotient/remainder n factor)])
|
|
(if (zero? r)
|
|
(loop q (add1 acc))
|
|
(values n acc))))
|
|
(loop n 0))
|
|
|
|
(define (factor-out n factor)
|
|
(define (loop n factor)
|
|
(if (<= factor n)
|
|
(let*-values ([(q n) (loop n (* factor factor))]
|
|
[(q* r) (quotient/remainder q factor)])
|
|
(if (zero? r)
|
|
(values q* (+ n n 1))
|
|
(values q (+ n n))))
|
|
(values n 0)))
|
|
(loop n factor))
|
|
|
|
;; ========================================
|
|
|
|
(provide marshal-error)
|
|
|
|
;; marshal-error : string datum -> (raises error)
|
|
(define (marshal-error f i type datum)
|
|
(error f "cannot marshal as SQL type ~s: ~e"
|
|
type datum))
|