real BigDecimal type (bigdec, M literals)
bigdec / 1.5M / 0.0M silently produced doubles. Add a jbigdec value type
{unscaled, scale} over Chez exact integers (host/chez/bigdec.ss): value =
unscaled * 10^-scale. An M-suffix literal reads to a :bigdec form that the back
end lowers to jolt-bigdec-from-string (same IR-leaf path as #inst/#uuid); bigdec
coerces a number/string. Equality is by value (1.0M = 1.00M true, 3M = 3 false),
str drops the M and pr keeps it, class is java.math.BigDecimal, decimal? is true.
Arithmetic contagion isn't modelled (out of scope). The old corpus cases passed
spuriously as doubles; they now exercise a genuine BigDecimal.
This commit is contained in:
parent
7db5fabc8d
commit
ab96650fbb
10 changed files with 288 additions and 191 deletions
83
host/chez/bigdec.ss
Normal file
83
host/chez/bigdec.ss
Normal file
|
|
@ -0,0 +1,83 @@
|
||||||
|
;; BigDecimal (jolt-i2jm). A jbigdec is {unscaled, scale} over Chez arbitrary-
|
||||||
|
;; precision exact integers; its value is unscaled * 10^-scale (1.5M = {15,1},
|
||||||
|
;; 1.00M = {100,2}, 3M = {3,0}). M-suffix literals read to a :bigdec form that the
|
||||||
|
;; back end lowers to jolt-bigdec-from-string; bigdec coerces a number/string.
|
||||||
|
;; Equality is by value (1.0M = 1.00M), str drops the M, pr keeps it, class is
|
||||||
|
;; java.math.BigDecimal. Arithmetic contagion is not modelled (jolt-i2jm scope).
|
||||||
|
|
||||||
|
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
|
||||||
|
|
||||||
|
(define (bd-index-char s ch)
|
||||||
|
(let loop ((i 0))
|
||||||
|
(cond ((>= i (string-length s)) #f)
|
||||||
|
((char=? (string-ref s i) ch) i)
|
||||||
|
(else (loop (+ i 1))))))
|
||||||
|
|
||||||
|
;; "1.50" -> {150,2}; "3" -> {3,0}; "-0.0" -> {0,1}; ".5" -> {5,1}.
|
||||||
|
(define (jolt-bigdec-from-string s)
|
||||||
|
(let* ((neg (and (> (string-length s) 0) (char=? (string-ref s 0) #\-)))
|
||||||
|
(sgn (and (> (string-length s) 0) (or neg (char=? (string-ref s 0) #\+))))
|
||||||
|
(s1 (if sgn (substring s 1 (string-length s)) s))
|
||||||
|
(sign (if neg -1 1))
|
||||||
|
(dot (bd-index-char s1 #\.)))
|
||||||
|
(if dot
|
||||||
|
(let* ((intp (substring s1 0 dot))
|
||||||
|
(fracp (substring s1 (+ dot 1) (string-length s1)))
|
||||||
|
(digs (string-append intp fracp))
|
||||||
|
(unscaled (if (= 0 (string-length digs)) 0 (string->number digs))))
|
||||||
|
(make-jbigdec (* sign unscaled) (string-length fracp)))
|
||||||
|
(make-jbigdec (* sign (string->number s1)) 0))))
|
||||||
|
|
||||||
|
;; bigdec coercion: a bigdec is itself; an exact integer keeps scale 0; a string
|
||||||
|
;; or any other number routes through its decimal text.
|
||||||
|
(define (jolt-bigdec x)
|
||||||
|
(cond
|
||||||
|
((jbigdec? x) x)
|
||||||
|
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
||||||
|
((string? x) (jolt-bigdec-from-string x))
|
||||||
|
((number? x) (jolt-bigdec-from-string (jolt-num->string x)))
|
||||||
|
(else (error #f "bigdec: cannot coerce" x))))
|
||||||
|
|
||||||
|
;; value equality: unscaled_a * 10^scale_b == unscaled_b * 10^scale_a.
|
||||||
|
(define (jbigdec=? a b)
|
||||||
|
(= (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
||||||
|
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
|
||||||
|
|
||||||
|
;; render the decimal text (no M): insert the point `scale` digits from the right.
|
||||||
|
(define (jbigdec->string bd)
|
||||||
|
(let* ((u (jbigdec-unscaled bd)) (sc (jbigdec-scale bd))
|
||||||
|
(neg (< u 0)) (digs (number->string (abs u))))
|
||||||
|
(string-append
|
||||||
|
(if neg "-" "")
|
||||||
|
(if (<= sc 0)
|
||||||
|
digs
|
||||||
|
(let* ((padded (if (<= (string-length digs) sc)
|
||||||
|
(string-append (make-string (- (+ sc 1) (string-length digs)) #\0) digs)
|
||||||
|
digs))
|
||||||
|
(pl (string-length padded)))
|
||||||
|
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
|
||||||
|
|
||||||
|
;; --- wire into the value model ----------------------------------------------
|
||||||
|
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||||
|
|
||||||
|
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
||||||
|
(define %bd-jolt=2 jolt=2)
|
||||||
|
(set! jolt=2 (lambda (a b)
|
||||||
|
(cond ((and (jbigdec? a) (jbigdec? b)) (jbigdec=? a b))
|
||||||
|
((or (jbigdec? a) (jbigdec? b)) #f)
|
||||||
|
(else (%bd-jolt=2 a b)))))
|
||||||
|
|
||||||
|
;; str drops the M; pr/pr-str keep it.
|
||||||
|
(define %bd-str-render jolt-str-render-one)
|
||||||
|
(set! jolt-str-render-one (lambda (x) (if (jbigdec? x) (jbigdec->string x) (%bd-str-render x))))
|
||||||
|
(define %bd-pr-str jolt-pr-str)
|
||||||
|
(set! jolt-pr-str (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-str x))))
|
||||||
|
(define %bd-pr-readable jolt-pr-readable)
|
||||||
|
(set! jolt-pr-readable (lambda (x) (if (jbigdec? x) (string-append (jbigdec->string x) "M") (%bd-pr-readable x))))
|
||||||
|
|
||||||
|
;; class / decimal?
|
||||||
|
(define %bd-class jolt-class)
|
||||||
|
(set! jolt-class (lambda (x) (if (jbigdec? x) "java.math.BigDecimal" (%bd-class x))))
|
||||||
|
(def-var! "clojure.core" "class" jolt-class)
|
||||||
|
(set! jolt-decimal? (lambda (x) (jbigdec? x)))
|
||||||
|
(def-var! "clojure.core" "decimal?" jolt-decimal?)
|
||||||
|
|
@ -35,6 +35,7 @@
|
||||||
(define hc-kw-regex (keyword #f "regex"))
|
(define hc-kw-regex (keyword #f "regex"))
|
||||||
(define hc-kw-inst (keyword #f "#inst"))
|
(define hc-kw-inst (keyword #f "#inst"))
|
||||||
(define hc-kw-uuid (keyword #f "#uuid"))
|
(define hc-kw-uuid (keyword #f "#uuid"))
|
||||||
|
(define hc-kw-bigdec (keyword #f "bigdec"))
|
||||||
|
|
||||||
;; --- form predicates --------------------------------------------------------
|
;; --- form predicates --------------------------------------------------------
|
||||||
(define (hc-sym? x) (symbol-t? x))
|
(define (hc-sym? x) (symbol-t? x))
|
||||||
|
|
@ -62,6 +63,8 @@
|
||||||
(define (hc-regex? x) (hc-tagged-of x hc-kw-regex))
|
(define (hc-regex? x) (hc-tagged-of x hc-kw-regex))
|
||||||
(define (hc-inst? x) (hc-tagged-of x hc-kw-inst))
|
(define (hc-inst? x) (hc-tagged-of x hc-kw-inst))
|
||||||
(define (hc-uuid? x) (hc-tagged-of x hc-kw-uuid))
|
(define (hc-uuid? x) (hc-tagged-of x hc-kw-uuid))
|
||||||
|
(define (hc-bigdec? x) (hc-tagged-of x hc-kw-bigdec))
|
||||||
|
(define (hc-bigdec-source x) (jolt-get x hc-kw-form))
|
||||||
;; A live namespace value spliced into a form (e.g. `(str ~*ns*) in a macro):
|
;; A live namespace value spliced into a form (e.g. `(str ~*ns*) in a macro):
|
||||||
;; the analyzer can't carry an opaque runtime value, so recognize a jns and
|
;; the analyzer can't carry an opaque runtime value, so recognize a jns and
|
||||||
;; reconstruct it by name at the call site (jolt-8sha).
|
;; reconstruct it by name at the call site (jolt-8sha).
|
||||||
|
|
@ -299,6 +302,8 @@
|
||||||
(def-var! "jolt.host" "form-uuid?" hc-uuid?)
|
(def-var! "jolt.host" "form-uuid?" hc-uuid?)
|
||||||
(def-var! "jolt.host" "form-ns-value?" hc-ns-value?)
|
(def-var! "jolt.host" "form-ns-value?" hc-ns-value?)
|
||||||
(def-var! "jolt.host" "form-ns-value-name" hc-ns-value-name)
|
(def-var! "jolt.host" "form-ns-value-name" hc-ns-value-name)
|
||||||
|
(def-var! "jolt.host" "form-bigdec?" hc-bigdec?)
|
||||||
|
(def-var! "jolt.host" "form-bigdec-source" hc-bigdec-source)
|
||||||
(def-var! "jolt.host" "form-elements" hc-elements)
|
(def-var! "jolt.host" "form-elements" hc-elements)
|
||||||
(def-var! "jolt.host" "form-vec-items" hc-vec-items)
|
(def-var! "jolt.host" "form-vec-items" hc-vec-items)
|
||||||
(def-var! "jolt.host" "form-set-items" hc-set-items)
|
(def-var! "jolt.host" "form-set-items" hc-set-items)
|
||||||
|
|
|
||||||
|
|
@ -134,10 +134,12 @@
|
||||||
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
|
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\N))
|
||||||
(let ((n (string->number (substring body 0 (- blen 1)))))
|
(let ((n (string->number (substring body 0 (- blen 1)))))
|
||||||
(and n (integer? n) (* sign n))))
|
(and n (integer? n) (* sign n))))
|
||||||
;; bigdecimal suffix M -> double
|
;; bigdecimal suffix M -> a :bigdec form carrying the numeric text; the back
|
||||||
|
;; end lowers it to a runtime jbigdec (jolt-i2jm).
|
||||||
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\M))
|
((and (> blen 1) (char=? (string-ref body (- blen 1)) #\M))
|
||||||
(let ((n (string->number (substring body 0 (- blen 1)))))
|
(let ((n (string->number (substring body 0 (- blen 1)))))
|
||||||
(and n (exact->inexact (* sign n)))))
|
(and n (real? n)
|
||||||
|
(rdr-make-tagged (keyword #f "bigdec") (substring tok 0 (- len 1))))))
|
||||||
(else
|
(else
|
||||||
(let ((n (string->number tok))) ; tok carries its own sign
|
(let ((n (string->number tok))) ; tok carries its own sign
|
||||||
;; keep exactness: "42" -> exact int, "3.14"/"1e3" -> flonum.
|
;; keep exactness: "42" -> exact int, "3.14"/"1e3" -> flonum.
|
||||||
|
|
|
||||||
|
|
@ -347,3 +347,8 @@
|
||||||
;; thread macros, def-var!'d into clojure.core.async. After concurrency.ss (reuses
|
;; thread macros, def-var!'d into clojure.core.async. After concurrency.ss (reuses
|
||||||
;; ms->duration) and the collection/seq layer.
|
;; ms->duration) and the collection/seq layer.
|
||||||
(load "host/chez/async.ss")
|
(load "host/chez/async.ss")
|
||||||
|
|
||||||
|
;; BigDecimal (jolt-i2jm): the jbigdec value type + bigdec/decimal?/class/equality/
|
||||||
|
;; printing. Loads LAST so its set!-wraps of jolt-class/jolt=2/the printers sit
|
||||||
|
;; outermost over every earlier extension.
|
||||||
|
(load "host/chez/bigdec.ss")
|
||||||
|
|
|
||||||
|
|
@ -90,7 +90,6 @@
|
||||||
"type of record" "chunked-seq? always false"
|
"type of record" "chunked-seq? always false"
|
||||||
"close on throw" "macroexpand-1"
|
"close on throw" "macroexpand-1"
|
||||||
"bean is the map" "proxy resolves nil"
|
"bean is the map" "proxy resolves nil"
|
||||||
"bigdec" "bigdec int M" "bigdec suffix M"
|
|
||||||
"transient vector" "transient map"
|
"transient vector" "transient map"
|
||||||
"atom override fires nested"
|
"atom override fires nested"
|
||||||
"reader conditional" "reader cond :jolt" "reader cond no match"
|
"reader conditional" "reader cond :jolt" "reader cond no match"
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
|
|
@ -798,8 +798,7 @@
|
||||||
|
|
||||||
(defn clojure-version [] "1.11.0-jolt")
|
(defn clojure-version [] "1.11.0-jolt")
|
||||||
|
|
||||||
;; Jolt numbers are doubles; no BigDecimal, no ratios.
|
;; bigdec is a host fn (host/chez/bigdec.ss) — a real BigDecimal value type.
|
||||||
(defn bigdec [x] (* 1.0 x))
|
|
||||||
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
(defn numerator [x] (throw (ex-info "numerator requires a ratio (Jolt has no ratios)" {})))
|
||||||
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
(defn denominator [x] (throw (ex-info "denominator requires a ratio (Jolt has no ratios)" {})))
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -23,6 +23,7 @@
|
||||||
form-map-pairs form-set-items form-special? compile-ns
|
form-map-pairs form-set-items form-special? compile-ns
|
||||||
form-regex? form-regex-source
|
form-regex? form-regex-source
|
||||||
form-inst? form-inst-source form-uuid? form-uuid-source
|
form-inst? form-inst-source form-uuid? form-uuid-source
|
||||||
|
form-bigdec? form-bigdec-source
|
||||||
form-ns-value? form-ns-value-name
|
form-ns-value? form-ns-value-name
|
||||||
form-macro? form-expand-1 resolve-global
|
form-macro? form-expand-1 resolve-global
|
||||||
form-sym-meta host-intern! form-syntax-quote-lower
|
form-sym-meta host-intern! form-syntax-quote-lower
|
||||||
|
|
@ -463,6 +464,9 @@
|
||||||
;; end emits a runtime inst/uuid value (host/chez/inst-time.ss).
|
;; end emits a runtime inst/uuid value (host/chez/inst-time.ss).
|
||||||
(form-inst? form) {:op :inst :source (form-inst-source form)}
|
(form-inst? form) {:op :inst :source (form-inst-source form)}
|
||||||
(form-uuid? form) {:op :uuid :source (form-uuid-source form)}
|
(form-uuid? form) {:op :uuid :source (form-uuid-source form)}
|
||||||
|
;; bigdecimal literal (1.5M) -> a :bigdec leaf; the back end emits a runtime
|
||||||
|
;; jbigdec built from the numeric text.
|
||||||
|
(form-bigdec? form) {:op :bigdec :source (form-bigdec-source form)}
|
||||||
;; a live namespace value spliced into a form (~*ns* in a macro) -> a
|
;; a live namespace value spliced into a form (~*ns* in a macro) -> a
|
||||||
;; :the-ns leaf the back end reconstructs by name at the call site.
|
;; :the-ns leaf the back end reconstructs by name at the call site.
|
||||||
(form-ns-value? form) {:op :the-ns :name (form-ns-value-name form)}
|
(form-ns-value? form) {:op :the-ns :name (form-ns-value-name form)}
|
||||||
|
|
|
||||||
|
|
@ -404,6 +404,8 @@
|
||||||
;; #inst / #uuid literals -> runtime inst / uuid values.
|
;; #inst / #uuid literals -> runtime inst / uuid values.
|
||||||
:inst (str "(jolt-inst-from-string " (chez-str-lit (:source node)) ")")
|
:inst (str "(jolt-inst-from-string " (chez-str-lit (:source node)) ")")
|
||||||
:uuid (str "(jolt-uuid-from-string " (chez-str-lit (:source node)) ")")
|
:uuid (str "(jolt-uuid-from-string " (chez-str-lit (:source node)) ")")
|
||||||
|
;; bigdecimal literal (1.5M) -> a runtime jbigdec from its numeric text.
|
||||||
|
:bigdec (str "(jolt-bigdec-from-string " (chez-str-lit (:source node)) ")")
|
||||||
;; a namespace value spliced into a form (~*ns*) -> reconstruct by name.
|
;; a namespace value spliced into a form (~*ns*) -> reconstruct by name.
|
||||||
:the-ns (str "(intern-ns! " (chez-str-lit (:name node)) ")")
|
:the-ns (str "(intern-ns! " (chez-str-lit (:name node)) ")")
|
||||||
;; (.method target arg*) -> jolt-host-call for an rt-shimmed method, else
|
;; (.method target arg*) -> jolt-host-call for an rt-shimmed method, else
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue