Merge pull request #217 from jolt-lang/feat/bigdec-arithmetic
BigDecimal arithmetic (value-position + type-directed call-position)
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
bdf436e242
7 changed files with 429 additions and 177 deletions
|
|
@ -3,7 +3,25 @@
|
|||
;; 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.
|
||||
;; java.math.BigDecimal.
|
||||
;;
|
||||
;; Arithmetic follows java.math.BigDecimal's scale rules: add/sub align to the
|
||||
;; larger scale; multiply adds scales; divide gives the exact quotient at minimal
|
||||
;; scale or throws ArithmeticException on a non-terminating expansion. Clojure
|
||||
;; contagion: a bigdec mixed with an integer stays a bigdec; a flonum operand wins
|
||||
;; (the result is a double). jbd-add/-sub/-mul/-div, jbd-min/-max, the jbd-lt?/…
|
||||
;; /zero? helpers, and jbd-quot/-rem are the shared engine. Two paths reach it, both
|
||||
;; leaving the inlined native hot path untouched:
|
||||
;; - value position ((reduce + bigs)/(apply * bigs)): the jolt-add/-sub/-mul/-div
|
||||
;; and compare shims dispatch here when a bigdec operand is present.
|
||||
;; - call position ((+ 1.5M 2.5M), (< a b), (zero? b)): jolt.passes.numeric tags
|
||||
;; the invoke :num-kind :bigdec when every operand is statically a bigdec (M
|
||||
;; literal or a let-bound copy, integer literals allowed), and the back end
|
||||
;; lowers it to the jbd op. Non-bigdec code is unaffected.
|
||||
;; Gaps (a runtime bigdec the analyzer can't see statically): a bigdec mixed with a
|
||||
;; flonum in call position ((+ 1.5M 2.0)) and arithmetic over a bigdec the analyzer
|
||||
;; types as :any ((+ (bigdec x) 1)) fall through to the raw op and throw; use value
|
||||
;; position or a literal-typed let.
|
||||
|
||||
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
|
||||
|
||||
|
|
@ -57,9 +75,167 @@
|
|||
(pl (string-length padded)))
|
||||
(string-append (substring padded 0 (- pl sc)) "." (substring padded (- pl sc) pl)))))))
|
||||
|
||||
;; value as a Chez flonum (for double contagion: a flonum operand wins).
|
||||
(define (jbigdec->flonum b)
|
||||
(exact->inexact (/ (jbigdec-unscaled b) (expt 10 (jbigdec-scale b)))))
|
||||
|
||||
;; coerce an exact integer to a scale-0 bigdec; pass a bigdec through. Used on the
|
||||
;; non-flonum mixed path (bigdec + long -> bigdec).
|
||||
(define (jbd-coerce x)
|
||||
(cond ((jbigdec? x) x)
|
||||
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
||||
(else (error #f "bigdec arithmetic: cannot coerce operand" x))))
|
||||
|
||||
;; --- core arithmetic on the {unscaled, scale} pair --------------------------
|
||||
;; align two bigdecs to a common scale, returning (unscaled-a unscaled-b scale).
|
||||
(define (jbd-align a b)
|
||||
(let ((sa (jbigdec-scale a)) (sb (jbigdec-scale b)))
|
||||
(cond
|
||||
((= sa sb) (values (jbigdec-unscaled a) (jbigdec-unscaled b) sa))
|
||||
((> sa sb) (values (jbigdec-unscaled a)
|
||||
(* (jbigdec-unscaled b) (expt 10 (- sa sb))) sa))
|
||||
(else (values (* (jbigdec-unscaled a) (expt 10 (- sb sa)))
|
||||
(jbigdec-unscaled b) sb)))))
|
||||
|
||||
(define (jbd2+ a b) (let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (+ ua ub) s)))
|
||||
(define (jbd2- a b) (let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (- ua ub) s)))
|
||||
(define (jbd2* a b) (make-jbigdec (* (jbigdec-unscaled a) (jbigdec-unscaled b))
|
||||
(+ (jbigdec-scale a) (jbigdec-scale b))))
|
||||
(define (jbd-negate a) (make-jbigdec (- (jbigdec-unscaled a)) (jbigdec-scale a)))
|
||||
|
||||
;; exact rational -> bigdec at minimal scale, or throw if non-terminating. den must
|
||||
;; factor into 2s and 5s; scale = max(count2, count5).
|
||||
(define (jbd-rational->bigdec r)
|
||||
(let ((p (numerator r)) (q (denominator r)))
|
||||
(let loop ((d q) (c2 0) (c5 0))
|
||||
(cond
|
||||
((= d 1) (let ((sc (max c2 c5)))
|
||||
(make-jbigdec (* p (quotient (expt 10 sc) q)) sc)))
|
||||
((= 0 (modulo d 2)) (loop (quotient d 2) (+ c2 1) c5))
|
||||
((= 0 (modulo d 5)) (loop (quotient d 5) c2 (+ c5 1)))
|
||||
(else (jolt-throw (jolt-host-throwable
|
||||
"java.lang.ArithmeticException"
|
||||
"Non-terminating decimal expansion; no exact representable decimal result.")))))))
|
||||
|
||||
(define (jbd2-div a b)
|
||||
(when (= 0 (jbigdec-unscaled b))
|
||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
||||
;; a/b = (ua * 10^sb) / (ub * 10^sa) as an exact rational.
|
||||
(jbd-rational->bigdec (/ (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
||||
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a))))))
|
||||
|
||||
;; integer-division semantics (quot/rem): truncate toward zero, scale 0.
|
||||
(define (jbd-int-quot a b)
|
||||
(when (= 0 (jbigdec-unscaled b))
|
||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
||||
(let-values (((ua ub s) (jbd-align a b))) (make-jbigdec (quotient ua ub) 0)))
|
||||
(define (jbd-int-rem a b)
|
||||
(when (= 0 (jbigdec-unscaled b))
|
||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
||||
(let-values (((ua ub s) (jbd-align a b)))
|
||||
(make-jbigdec (remainder ua ub) (max (jbigdec-scale a) (jbigdec-scale b)))))
|
||||
|
||||
;; scale-independent ordering: compare unscaled values aligned to a common scale.
|
||||
(define (jbd-compare2 a b)
|
||||
(let-values (((ua ub s) (jbd-align a b))) (cond ((< ua ub) -1) ((> ua ub) 1) (else 0))))
|
||||
|
||||
;; A binary op over operands that may mix bigdec / integer / flonum. flonum-op is
|
||||
;; the native fallback for the double-contagion path; bd-op is the exact bigdec op.
|
||||
(define (jbd-binop flonum-op bd-op a b)
|
||||
(if (or (flonum? a) (flonum? b))
|
||||
(flonum-op (if (jbigdec? a) (jbigdec->flonum a) a)
|
||||
(if (jbigdec? b) (jbigdec->flonum b) b))
|
||||
(bd-op (jbd-coerce a) (jbd-coerce b))))
|
||||
|
||||
;; --- variadic engine ops (Phase-2 emit targets + value-position folds) -------
|
||||
(define (jbd-fold flonum-op bd-op init xs)
|
||||
(let loop ((acc init) (rest xs))
|
||||
(if (null? rest) acc (loop (jbd-binop flonum-op bd-op acc (car rest)) (cdr rest)))))
|
||||
|
||||
(define (jbd-add . xs)
|
||||
(cond ((null? xs) (make-jbigdec 0 0))
|
||||
((null? (cdr xs)) (car xs))
|
||||
(else (jbd-fold + jbd2+ (car xs) (cdr xs)))))
|
||||
(define (jbd-sub . xs)
|
||||
(cond ((null? xs) (error #f "- needs at least 1 arg"))
|
||||
((null? (cdr xs)) (if (jbigdec? (car xs)) (jbd-negate (car xs)) (- (car xs))))
|
||||
(else (jbd-fold - jbd2- (car xs) (cdr xs)))))
|
||||
(define (jbd-mul . xs)
|
||||
(cond ((null? xs) (make-jbigdec 1 0))
|
||||
((null? (cdr xs)) (car xs))
|
||||
(else (jbd-fold * jbd2* (car xs) (cdr xs)))))
|
||||
(define (jbd-div . xs)
|
||||
(cond ((null? xs) (error #f "/ needs at least 1 arg"))
|
||||
((null? (cdr xs)) (jbd-binop / jbd2-div (make-jbigdec 1 0) (car xs)))
|
||||
(else (jbd-fold / jbd2-div (car xs) (cdr xs)))))
|
||||
|
||||
;; comparison / predicate helpers (Phase-2 emit targets). A flonum operand demotes
|
||||
;; to the native comparison on the flonum values.
|
||||
(define (jbd-cmp-num op flop a b)
|
||||
(if (or (flonum? a) (flonum? b))
|
||||
(flop (if (jbigdec? a) (jbigdec->flonum a) a) (if (jbigdec? b) (jbigdec->flonum b) b))
|
||||
(op (jbd-compare2 (jbd-coerce a) (jbd-coerce b)) 0)))
|
||||
(define (jbd-lt? a b) (jbd-cmp-num < < a b))
|
||||
(define (jbd-gt? a b) (jbd-cmp-num > > a b))
|
||||
(define (jbd-le? a b) (jbd-cmp-num <= <= a b))
|
||||
(define (jbd-ge? a b) (jbd-cmp-num >= >= a b))
|
||||
(define (jbd-zero? a) (= 0 (jbigdec-unscaled a)))
|
||||
(define (jbd-pos? a) (> (jbigdec-unscaled a) 0))
|
||||
(define (jbd-neg? a) (< (jbigdec-unscaled a) 0))
|
||||
(define (jbd-quot a b) (jbd-int-quot (jbd-coerce a) (jbd-coerce b)))
|
||||
(define (jbd-rem a b) (jbd-int-rem (jbd-coerce a) (jbd-coerce b)))
|
||||
|
||||
;; min/max compare by value but return the ORIGINAL operand (its type and scale
|
||||
;; unchanged), matching java/Clojure: (min 1M 2.0) -> 1M, (max 1M 2.0) -> 2.0,
|
||||
;; (min 1.50M 2M) -> 1.50M. Comparison handles a bigdec mixed with an int / flonum.
|
||||
(define (jbd-value-compare a b)
|
||||
(if (or (flonum? a) (flonum? b))
|
||||
(let ((fa (if (jbigdec? a) (jbigdec->flonum a) a)) (fb (if (jbigdec? b) (jbigdec->flonum b) b)))
|
||||
(cond ((< fa fb) -1) ((> fa fb) 1) (else 0)))
|
||||
(jbd-compare2 (jbd-coerce a) (jbd-coerce b))))
|
||||
;; strict comparison so a tie keeps the second operand, like Clojure's
|
||||
;; (if (< x y) x y) / (if (> x y) x y): (max 1.5M 1.50M) -> 1.50M.
|
||||
(define (jbd-min2 a b) (if (< (jbd-value-compare a b) 0) a b))
|
||||
(define (jbd-max2 a b) (if (> (jbd-value-compare a b) 0) a b))
|
||||
(define (jbd-min x . xs) (fold-left jbd-min2 x xs))
|
||||
(define (jbd-max x . xs) (fold-left jbd-max2 x xs))
|
||||
|
||||
;; --- wire into the value model ----------------------------------------------
|
||||
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||
|
||||
;; Value-position arithmetic: (reduce + bigs) / (apply * bigs) pass +/*/- // AS A
|
||||
;; VALUE, which lowers to these shims (NOT the inlined hot-path native op). Extend
|
||||
;; them to dispatch to the bigdec engine when a bigdec operand is present; ordinary
|
||||
;; numeric folds hit the captured native path unchanged.
|
||||
(define jbd-prev-add jolt-add)
|
||||
(define jbd-prev-sub jolt-sub)
|
||||
(define jbd-prev-mul jolt-mul)
|
||||
(define jbd-prev-div jolt-div)
|
||||
(define jbd-prev-min jolt-min)
|
||||
(define jbd-prev-max jolt-max)
|
||||
(define (jbd-any? xs) (and (pair? xs) (or (jbigdec? (car xs)) (jbd-any? (cdr xs)))))
|
||||
(set! jolt-add (lambda xs (if (jbd-any? xs) (apply jbd-add xs) (apply jbd-prev-add xs))))
|
||||
(set! jolt-sub (lambda xs (if (jbd-any? xs) (apply jbd-sub xs) (apply jbd-prev-sub xs))))
|
||||
(set! jolt-mul (lambda xs (if (jbd-any? xs) (apply jbd-mul xs) (apply jbd-prev-mul xs))))
|
||||
(set! jolt-div (lambda xs (if (jbd-any? xs) (apply jbd-div xs) (apply jbd-prev-div xs))))
|
||||
(set! jolt-min (lambda xs (if (jbd-any? xs) (apply jbd-min xs) (apply jbd-prev-min xs))))
|
||||
(set! jolt-max (lambda xs (if (jbd-any? xs) (apply jbd-max xs) (apply jbd-prev-max xs))))
|
||||
|
||||
;; compare: add a bigdec arm (enables compare / sort / sorted collections). A
|
||||
;; bigdec vs a plain number compares by value; bigdec vs bigdec is scale-independent.
|
||||
(define jbd-prev-compare jolt-compare)
|
||||
(define (jbd-numberish? x) (or (jbigdec? x) (number? x)))
|
||||
(set! jolt-compare
|
||||
(lambda (a b)
|
||||
(if (and (or (jbigdec? a) (jbigdec? b)) (jbd-numberish? a) (jbd-numberish? b))
|
||||
(if (or (flonum? a) (flonum? b))
|
||||
(let ((fa (if (jbigdec? a) (jbigdec->flonum a) a))
|
||||
(fb (if (jbigdec? b) (jbigdec->flonum b) b)))
|
||||
(cond ((< fa fb) -1) ((> fa fb) 1) (else 0)))
|
||||
(jbd-compare2 (jbd-coerce a) (jbd-coerce b)))
|
||||
(jbd-prev-compare a b))))
|
||||
(def-var! "clojure.core" "compare" jolt-compare)
|
||||
|
||||
;; equality: a bigdec equals only another bigdec, by value (matching (= 3M 3) = false).
|
||||
(register-eq-arm! (lambda (a b) (or (jbigdec? a) (jbigdec? b)))
|
||||
(lambda (a b) (and (jbigdec? a) (jbigdec? b) (jbigdec=? a b))))
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -1517,6 +1517,6 @@
|
|||
(guard (e (#t #f))
|
||||
(def-var! "clojure.pprint" "add-padding" (letrec ((add-padding (lambda (width s) (let fnrec2063 ((width width) (s s)) (let* ((padding (max 0 (- width (jolt-count s))))) (jolt-apply (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.string" "join") (jolt-invoke (var-deref "clojure.core" "repeat") padding (integer->char 32))) s)))))) add-padding)))
|
||||
(guard (e (#t #f))
|
||||
(def-var-with-meta! "clojure.pprint" "print-table" (letrec ((print-table (case-lambda ((ks rows) (let fnrec2064 ((ks ks) (rows rows)) (if (jolt-truthy? (jolt-seq rows)) (let* ((widths (jolt-map (lambda (k) (let fnrec2065 ((k k)) (let* ((_a$2067 max) (_a$2068 (jolt-count (jolt-invoke (var-deref "clojure.core" "str") k))) (_a$2069 (jolt-map (lambda (p__39_) (let fnrec2066 ((p__39_ p__39_)) (jolt-count (jolt-invoke (var-deref "clojure.core" "str") (jolt-get p__39_ k))))) rows))) (jolt-apply _a$2067 _a$2068 _a$2069)))) ks)) (spacers (jolt-map (lambda (p__40_) (let fnrec2070 ((p__40_ p__40_)) (jolt-apply (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "repeat") p__40_ "-")))) widths)) (fmt-row (lambda (leader divider trailer row) (let fnrec2071 ((leader leader) (divider divider) (trailer trailer) (row row)) (jolt-invoke (var-deref "clojure.core" "str") leader (jolt-apply (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "interpose") divider (let* ((_a$2074 (lambda (G__96) (let fnrec2072 ((G__96 G__96)) (let* ((G__97 G__96) (col (jolt-nth G__97 0 jolt-nil)) (width (jolt-nth G__97 1 jolt-nil))) (jolt-invoke (var-deref "clojure.pprint" "add-padding") width (jolt-invoke (var-deref "clojure.core" "str") col)))))) (_a$2075 (jolt-map jolt-vector (jolt-map (lambda (p__41_) (let fnrec2073 ((p__41_ p__41_)) (jolt-get row p__41_))) ks) widths))) (jolt-map _a$2074 _a$2075)))) trailer))))) (begin (jolt-invoke (var-deref "clojure.core" "println")) (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "| " " | " " |" (jolt-invoke (var-deref "clojure.core" "zipmap") ks ks))) (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "|-" "-+-" "-|" (jolt-invoke (var-deref "clojure.core" "zipmap") ks spacers))) (begin (jolt-count (jolt-map (lambda (row) (let fnrec2076 ((row row)) (begin (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "| " " | " " |" row)) jolt-nil))) rows)) jolt-nil))) jolt-nil))) ((rows) (let fnrec2077 ((rows rows)) (jolt-invoke print-table (jolt-keys (jolt-first rows)) rows)))))) print-table) (let* ((_o$2078 (keyword #f "doc")) (_o$2079 "Prints a collection of maps in a textual table.")) (jolt-hash-map _o$2078 _o$2079))))
|
||||
(def-var-with-meta! "clojure.pprint" "print-table" (letrec ((print-table (case-lambda ((ks rows) (let fnrec2064 ((ks ks) (rows rows)) (if (jolt-truthy? (jolt-seq rows)) (let* ((widths (jolt-map (lambda (k) (let fnrec2065 ((k k)) (let* ((_a$2067 jolt-max) (_a$2068 (jolt-count (jolt-invoke (var-deref "clojure.core" "str") k))) (_a$2069 (jolt-map (lambda (p__39_) (let fnrec2066 ((p__39_ p__39_)) (jolt-count (jolt-invoke (var-deref "clojure.core" "str") (jolt-get p__39_ k))))) rows))) (jolt-apply _a$2067 _a$2068 _a$2069)))) ks)) (spacers (jolt-map (lambda (p__40_) (let fnrec2070 ((p__40_ p__40_)) (jolt-apply (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "repeat") p__40_ "-")))) widths)) (fmt-row (lambda (leader divider trailer row) (let fnrec2071 ((leader leader) (divider divider) (trailer trailer) (row row)) (jolt-invoke (var-deref "clojure.core" "str") leader (jolt-apply (var-deref "clojure.core" "str") (jolt-invoke (var-deref "clojure.core" "interpose") divider (let* ((_a$2074 (lambda (G__96) (let fnrec2072 ((G__96 G__96)) (let* ((G__97 G__96) (col (jolt-nth G__97 0 jolt-nil)) (width (jolt-nth G__97 1 jolt-nil))) (jolt-invoke (var-deref "clojure.pprint" "add-padding") width (jolt-invoke (var-deref "clojure.core" "str") col)))))) (_a$2075 (jolt-map jolt-vector (jolt-map (lambda (p__41_) (let fnrec2073 ((p__41_ p__41_)) (jolt-get row p__41_))) ks) widths))) (jolt-map _a$2074 _a$2075)))) trailer))))) (begin (jolt-invoke (var-deref "clojure.core" "println")) (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "| " " | " " |" (jolt-invoke (var-deref "clojure.core" "zipmap") ks ks))) (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "|-" "-+-" "-|" (jolt-invoke (var-deref "clojure.core" "zipmap") ks spacers))) (begin (jolt-count (jolt-map (lambda (row) (let fnrec2076 ((row row)) (begin (jolt-invoke (var-deref "clojure.core" "println") (jolt-invoke fmt-row "| " " | " " |" row)) jolt-nil))) rows)) jolt-nil))) jolt-nil))) ((rows) (let fnrec2077 ((rows rows)) (jolt-invoke print-table (jolt-keys (jolt-first rows)) rows)))))) print-table) (let* ((_o$2078 (keyword #f "doc")) (_o$2079 "Prints a collection of maps in a textual table.")) (jolt-hash-map _o$2078 _o$2079))))
|
||||
(guard (e (#t #f))
|
||||
(jolt-invoke (var-deref "clojure.core" "__set-pprint-write-hook!") (lambda (s) (let fnrec2080 ((s s)) (let* ((o (var-deref "clojure.core" "*out*"))) (if (jolt-truthy? (jolt-invoke (var-deref "clojure.core" "instance-check") (jolt-symbol #f "PrettyWriter") o)) (begin (jolt-invoke (var-deref "clojure.pprint" "-write") o s) #t) jolt-nil))))))
|
||||
|
|
@ -134,6 +134,8 @@
|
|||
(define (jolt-sub . xs) (apply - xs))
|
||||
(define (jolt-mul . xs) (apply * xs))
|
||||
(define (jolt-div . xs) (apply / xs))
|
||||
(define (jolt-min . xs) (apply min xs))
|
||||
(define (jolt-max . xs) (apply max xs))
|
||||
|
||||
;; ============================================================================
|
||||
;; IFn dispatch — the dynamic "value as fn" fallback. A callee that the emitter
|
||||
|
|
|
|||
|
|
@ -42,7 +42,8 @@
|
|||
;; EXACT results for exact/zero-arg inputs, breaking the all-double model in
|
||||
;; higher-order use, so value-position arithmetic routes to the flonum wrappers.
|
||||
(def ^:private core-value-procs
|
||||
(merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"}))
|
||||
(merge native-ops {"+" "jolt-add" "-" "jolt-sub" "*" "jolt-mul" "/" "jolt-div"
|
||||
"min" "jolt-min" "max" "jolt-max"}))
|
||||
|
||||
;; Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
|
||||
;; this arity. Ops absent from the table are variadic (legal at any arity).
|
||||
|
|
@ -94,6 +95,18 @@
|
|||
"quot" "fxquotient" "rem" "fxremainder" "mod" "fxmodulo"
|
||||
"<" "fx<?" ">" "fx>?" "<=" "fx<=?" ">=" "fx>=?" "=" "fx=?" "==" "fx=?"})
|
||||
|
||||
;; BigDecimal ops. jolt.passes.numeric tags an arithmetic/comparison invoke
|
||||
;; :num-kind :bigdec when every operand is a bigdec (or an integer literal); these
|
||||
;; are the bigdec.ss engine procedures it lowers to. Variadic where the source op
|
||||
;; is; an integer-literal operand is coerced to a bigdec at runtime, so unlike the
|
||||
;; flonum path no literal rewrite is needed.
|
||||
(def ^:private bd-ops
|
||||
{"+" "jbd-add" "-" "jbd-sub" "*" "jbd-mul" "/" "jbd-div"
|
||||
"min" "jbd-min" "max" "jbd-max"
|
||||
"quot" "jbd-quot" "rem" "jbd-rem"
|
||||
"<" "jbd-lt?" ">" "jbd-gt?" "<=" "jbd-le?" ">=" "jbd-ge?"
|
||||
"zero?" "jbd-zero?" "pos?" "jbd-pos?" "neg?" "jbd-neg?"})
|
||||
|
||||
;; PRELUDE MODE. The default (subset) mode rejects any clojure.core ref
|
||||
;; that isn't a native-op — a clean "out of subset" signal for user-facing `-e`.
|
||||
;; When emitting clojure.core ITSELF as a prelude, core fns reference each other
|
||||
|
|
@ -461,7 +474,7 @@
|
|||
(and (= kind :long) (or (= nm "inc") (= nm "unchecked-inc"))) (str "(fx1+ " (first args) ")")
|
||||
(and (= kind :long) (or (= nm "dec") (= nm "unchecked-dec"))) (str "(fx1- " (first args) ")")
|
||||
:else
|
||||
(let [op (if (= kind :double) (dbl-ops nm) (lng-ops nm))]
|
||||
(let [op (case kind :double (dbl-ops nm) :long (lng-ops nm) :bigdec (bd-ops nm))]
|
||||
(order-args (fn [as] (str "(" op " " (str/join " " as) ")"))))))
|
||||
|
||||
(defn- emit-invoke [node]
|
||||
|
|
|
|||
|
|
@ -49,6 +49,18 @@
|
|||
(and (>= n 2) (contains? #{"<" ">" "<=" ">=" "=" "=="} nm)) :bool
|
||||
:else nil))
|
||||
|
||||
;; result kind of a bigdec-specialized op, or nil. Arithmetic / quot / rem yield a
|
||||
;; bigdec; the comparisons and zero?/pos?/neg? yield a bool. `=` is left to the
|
||||
;; generic jolt= (already bigdec-aware), and `/` can throw (non-terminating) but is
|
||||
;; still a bigdec op. Each non-nil name must have an entry in backend bd-ops.
|
||||
(defn- bd-spec [nm n]
|
||||
(cond
|
||||
(and (>= n 1) (contains? #{"+" "-" "*" "/" "min" "max"} nm)) :bigdec
|
||||
(and (= n 2) (contains? #{"quot" "rem"} nm)) :bigdec
|
||||
(and (= n 1) (contains? #{"zero?" "pos?" "neg?"} nm)) :bool
|
||||
(and (>= n 2) (contains? #{"<" ">" "<=" ">="} nm)) :bool
|
||||
:else nil))
|
||||
|
||||
;; A non-numeric result (a comparison) doesn't propagate a numeric kind.
|
||||
(defn- propagate [spec] (if (= spec :bool) nil spec))
|
||||
|
||||
|
|
@ -150,11 +162,12 @@
|
|||
(get fnode :num-ret) [(get fnode :num-ret) node1]
|
||||
(nil? nm) [nil node1]
|
||||
:else
|
||||
(let [;; per-operand class: :double / :long (typed), :wild (integer literal,
|
||||
;; usable in either), or :no (anything else — blocks specialization).
|
||||
(let [;; per-operand class: :double / :long / :bigdec (typed), :wild (integer
|
||||
;; literal, usable in any), or :no (anything else — blocks specialization).
|
||||
cls (mapv (fn [r] (let [k (nth r 0) nd (nth r 1)]
|
||||
(cond (= k :double) :double
|
||||
(= k :long) :long
|
||||
(= k :bigdec) :bigdec
|
||||
(int-lit? nd) :wild
|
||||
:else :no)))
|
||||
ars)
|
||||
|
|
@ -163,7 +176,8 @@
|
|||
(every? (fn [c] (or (= c :wild) (= c allowed))) cls)
|
||||
(some (fn [c] (= c need)) cls)))
|
||||
ds (dbl-spec nm n)
|
||||
ls (lng-spec nm n)]
|
||||
ls (lng-spec nm n)
|
||||
bs (bd-spec nm n)]
|
||||
(cond
|
||||
(and ds (ok? :double :double))
|
||||
;; coerce integer-literal operands to flonum so fl-ops never see an exact int.
|
||||
|
|
@ -172,6 +186,11 @@
|
|||
[(propagate ds) (assoc node1 :args args' :num-kind :double)])
|
||||
(and ls (ok? :long :long))
|
||||
[(propagate ls) (assoc node1 :num-kind :long)]
|
||||
;; bigdec: every operand a bigdec (integer literals allowed, coerced at
|
||||
;; runtime). A flonum operand blocks this (double contagion) and falls
|
||||
;; through to the generic op.
|
||||
(and bs (ok? :bigdec :bigdec))
|
||||
[(propagate bs) (assoc node1 :num-kind :bigdec)]
|
||||
:else [nil node1])))))
|
||||
|
||||
;; Returns [kind node'] — kind is :double, :long, or nil.
|
||||
|
|
@ -179,6 +198,9 @@
|
|||
(let [op (get node :op)]
|
||||
(cond
|
||||
(= op :const) [(if (float-lit? node) :double nil) node]
|
||||
;; a bigdec (M) literal seeds the :bigdec kind so call-position arithmetic
|
||||
;; over it (and let-bound copies of it) dispatches to the bigdec engine.
|
||||
(= op :bigdec) [:bigdec node]
|
||||
(= op :local) [(get tenv (get node :name)) node]
|
||||
(= op :coerce) [(get node :kind) (assoc node :expr (nth (an (get node :expr) tenv) 1))]
|
||||
(= op :invoke) (an-invoke node tenv)
|
||||
|
|
|
|||
|
|
@ -1312,6 +1312,41 @@
|
|||
{:suite "numbers / literal syntax" :label "bigint zero" :expected "0N" :actual "0N"}
|
||||
{:suite "numbers / literal syntax" :label "bigdec suffix M" :expected "1.5M" :actual "1.5M"}
|
||||
{:suite "numbers / literal syntax" :label "bigdec int M" :expected "0.0M" :actual "0.0M"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "add (value position)" :expected "4.0M" :actual "(reduce + [1.5M 2.5M])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "add preserves max scale" :expected "\"4.00\"" :actual "(str (reduce + [1.50M 2.5M]))"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "add three" :expected "7.0M" :actual "(reduce + [1.5M 2.5M 3.0M])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "subtract (apply)" :expected "3.5M" :actual "(apply - [5M 1.5M])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "multiply adds scales" :expected "\"3.0000\"" :actual "(str (reduce * [1.50M 2.00M]))"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "long contagion stays bigdec" :expected "3.5M" :actual "(reduce + [1.5M 2])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "double contagion -> double" :expected "3.5" :actual "(reduce + [1.5M 2.0])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "exact divide minimal scale" :expected "\"0.25\"" :actual "(str (reduce / [1M 4M]))"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "exact divide whole" :expected "5M" :actual "(reduce / [10M 2M])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "non-terminating divide throws" :expected ":nonterm" :actual "(try (reduce / [1M 3M]) (catch ArithmeticException _ :nonterm))"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "compare is scale-independent" :expected "0" :actual "(compare 1.0M 1.00M)"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "compare orders by value" :expected "-1" :actual "(compare 1.5M 2.5M)"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "sort uses bigdec compare" :expected "[1M 2M 3M]" :actual "(vec (sort [3M 1M 2M]))"}
|
||||
{:suite "numbers / bigdec call position" :label "add" :expected "4.0M" :actual "(+ 1.5M 2.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "multiply adds scales" :expected "\"3.0000\"" :actual "(str (* 1.50M 2.00M))"}
|
||||
{:suite "numbers / bigdec call position" :label "subtract" :expected "3.5M" :actual "(- 5M 1.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "negate" :expected "-1.5M" :actual "(- 1.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "long contagion" :expected "3.5M" :actual "(+ 1.5M 2)"}
|
||||
{:suite "numbers / bigdec call position" :label "exact divide" :expected "0.25M" :actual "(/ 1M 4M)"}
|
||||
{:suite "numbers / bigdec call position" :label "less-than" :expected "true" :actual "(< 1.5M 2.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "greater-than false" :expected "false" :actual "(> 1.5M 2.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "zero?" :expected "true" :actual "(zero? 0M)"}
|
||||
{:suite "numbers / bigdec call position" :label "pos?" :expected "true" :actual "(pos? 1.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "neg? false" :expected "false" :actual "(neg? 1.5M)"}
|
||||
{:suite "numbers / bigdec call position" :label "quot truncates to scale 0" :expected "3M" :actual "(quot 7M 2M)"}
|
||||
{:suite "numbers / bigdec call position" :label "rem" :expected "1M" :actual "(rem 7M 2M)"}
|
||||
{:suite "numbers / bigdec call position" :label "let-bound operands" :expected "4.0M" :actual "(let [a 1.5M b 2.5M] (+ a b))"}
|
||||
{:suite "numbers / bigdec call position" :label "nested arithmetic propagates" :expected "6.0M" :actual "(+ (* 1.5M 2M) 3M)"}
|
||||
{:suite "numbers / bigdec call position" :label "non-terminating divide throws" :expected ":nonterm" :actual "(try (/ 1M 3M) (catch ArithmeticException _ :nonterm))"}
|
||||
{:suite "numbers / bigdec call position" :label "min" :expected "1M" :actual "(min 1M 2M)"}
|
||||
{:suite "numbers / bigdec call position" :label "max of three" :expected "3M" :actual "(max 1M 2M 3M)"}
|
||||
{:suite "numbers / bigdec call position" :label "min returns the operand, scale intact" :expected "\"1.50\"" :actual "(str (min 1.50M 2M))"}
|
||||
{:suite "numbers / bigdec call position" :label "max tie keeps second operand" :expected "\"1.50\"" :actual "(str (max 1.5M 1.50M))"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "max (value position)" :expected "3M" :actual "(reduce max [1M 3M 2M])"}
|
||||
{:suite "numbers / bigdec arithmetic" :label "min (apply)" :expected "1M" :actual "(apply min [3M 1M 2M])"}
|
||||
{:suite "numbers / literal syntax" :label "ratio -> double" :expected "1/2" :actual "1/2"}
|
||||
{:suite "numbers / literal syntax" :label "ratio 3/4" :expected "3/4" :actual "3/4"}
|
||||
{:suite "numbers / literal syntax" :label "neg ratio" :expected "-1/2" :actual "-1/2"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue