Numbers-style category dispatch for binary numeric ops
Arithmetic and comparisons lowered to raw Chez ops, so an operand outside Chez's tower (BigDecimal) crashed with a raw condition, and Chez contagion leaked: (* 1.0 0) gave exact 0 where the JVM gives 0.0, (* ##Inf 0) gave 0 instead of ##NaN, (/ 1 0) raised an untyped error. One seam now (host/chez/seq.ss): call position emits jolt-n* macros with the both-Chez-numbers fast path open-coded; value position folds through the same binary ops. Anything outside the tower falls to per-op slow hooks that java/bigdec.ss extends, so bigdec arithmetic works in every position (the old static-only :bigdec typing limitation is gone). JVM rules patched into the fast path: a double operand wins, an exact zero divisor throws ArithmeticException while a double zero divisor yields Inf/NaN, quot/rem/mod cover ratios and doubles, min/max return the original operand with NaN winning, a nil operand is NPE and a non-number CCE, zero-arg -// throw ArityException at runtime instead of failing expansion. Also: with-precision now binds *math-context* and bigdec results round with real RoundingMode semantics (UNNECESSARY throws; division rounds to precision instead of throwing); rationalize goes through the shortest decimal print like BigDecimal.valueOf (the identity stub is gone); ratios coerce to bigdec like Numbers.toBigDecimal; min/max int-literal operands no longer coerce to flonum in the numeric pass. Perf neutral: fib and seq benches unchanged (the fast path is two type checks the optimizer folds); hinted fl/fx paths untouched. 19 JVM-certified corpus rows; cts baseline 5614->5730 pass, 192->88 errors, 84->79 baselined namespaces.
This commit is contained in:
parent
38abc1be84
commit
e66a91750e
13 changed files with 1106 additions and 729 deletions
|
|
@ -7,21 +7,19 @@
|
||||||
;;
|
;;
|
||||||
;; Arithmetic follows java.math.BigDecimal's scale rules: add/sub align to the
|
;; 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
|
;; larger scale; multiply adds scales; divide gives the exact quotient at minimal
|
||||||
;; scale or throws ArithmeticException on a non-terminating expansion. Clojure
|
;; scale or throws ArithmeticException on a non-terminating expansion (a bound
|
||||||
;; contagion: a bigdec mixed with an integer stays a bigdec; a flonum operand wins
|
;; *math-context* rounds instead). Clojure contagion: a bigdec mixed with an
|
||||||
;; (the result is a double). jbd-add/-sub/-mul/-div, jbd-min/-max, the jbd-lt?/…
|
;; integer or ratio stays a bigdec; a flonum operand wins (the result is a
|
||||||
;; /zero? helpers, and jbd-quot/-rem are the shared engine. Two paths reach it, both
|
;; double). jbd-add/-sub/-mul/-div, jbd-min/-max, the jbd-lt?/…/zero? helpers,
|
||||||
;; leaving the inlined native hot path untouched:
|
;; and jbd-quot/-rem are the shared engine. Two paths reach it, both leaving the
|
||||||
;; - value position ((reduce + bigs)/(apply * bigs)): the jolt-add/-sub/-mul/-div
|
;; inlined fast path untouched:
|
||||||
;; and compare shims dispatch here when a bigdec operand is present.
|
;; - the seq.ss binary dispatch: every generic op (any position — (+ (bigdec x)
|
||||||
;; - call position ((+ 1.5M 2.5M), (< a b), (zero? b)): jolt.passes.numeric tags
|
;; 1), (reduce + bigs), (quot 10.0 3M)) whose operand is outside Chez's tower
|
||||||
;; the invoke :num-kind :bigdec when every operand is statically a bigdec (M
|
;; falls to the jolt-*-slow hooks extended below.
|
||||||
;; literal or a let-bound copy, integer literals allowed), and the back end
|
;; - static call position ((+ 1.5M 2.5M), (< a b), (zero? b)): jolt.passes.numeric
|
||||||
;; lowers it to the jbd op. Non-bigdec code is unaffected.
|
;; tags the invoke :num-kind :bigdec when every operand is statically a bigdec
|
||||||
;; Gaps (a runtime bigdec the analyzer can't see statically): a bigdec mixed with a
|
;; (M literal or a let-bound copy, integer literals allowed), and the back end
|
||||||
;; flonum in call position ((+ 1.5M 2.0)) and arithmetic over a bigdec the analyzer
|
;; lowers it directly to the jbd op.
|
||||||
;; 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))
|
(define-record-type jbigdec (fields unscaled scale) (nongenerative chez-jbigdec-v1))
|
||||||
|
|
||||||
|
|
@ -79,11 +77,13 @@
|
||||||
(define (jbigdec->flonum b)
|
(define (jbigdec->flonum b)
|
||||||
(exact->inexact (/ (jbigdec-unscaled b) (expt 10 (jbigdec-scale 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
|
;; coerce an exact operand to a bigdec; pass a bigdec through. Used on the
|
||||||
;; non-flonum mixed path (bigdec + long -> bigdec).
|
;; non-flonum mixed path (bigdec + long -> bigdec). A Ratio converts like
|
||||||
|
;; Numbers.toBigDecimal — exact decimal expansion or throw on non-terminating.
|
||||||
(define (jbd-coerce x)
|
(define (jbd-coerce x)
|
||||||
(cond ((jbigdec? x) x)
|
(cond ((jbigdec? x) x)
|
||||||
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
((and (number? x) (exact? x) (integer? x)) (make-jbigdec x 0))
|
||||||
|
((and (number? x) (exact? x) (rational? x)) (jbd-rational->bigdec x))
|
||||||
(else (error #f "bigdec arithmetic: cannot coerce operand" x))))
|
(else (error #f "bigdec arithmetic: cannot coerce operand" x))))
|
||||||
|
|
||||||
;; --- core arithmetic on the {unscaled, scale} pair --------------------------
|
;; --- core arithmetic on the {unscaled, scale} pair --------------------------
|
||||||
|
|
@ -117,12 +117,39 @@
|
||||||
"java.lang.ArithmeticException"
|
"java.lang.ArithmeticException"
|
||||||
"Non-terminating decimal expansion; no exact representable decimal result.")))))))
|
"Non-terminating decimal expansion; no exact representable decimal result.")))))))
|
||||||
|
|
||||||
|
;; floor(log10 |r|) for a nonzero exact rational.
|
||||||
|
(define (jbd-exp10 r)
|
||||||
|
(let ((n (abs (numerator r))) (d (denominator r)))
|
||||||
|
(if (>= n d)
|
||||||
|
(- (jbd-digits (quotient n d)) 1)
|
||||||
|
(let loop ((x (* n 10)) (e -1))
|
||||||
|
(if (>= x d) e (loop (* x 10) (- e 1)))))))
|
||||||
|
;; round an exact rational to `prec` significant digits (the MathContext divide).
|
||||||
|
(define (jbd-rational-prec r prec mode)
|
||||||
|
(if (= r 0)
|
||||||
|
(make-jbigdec 0 0)
|
||||||
|
(let* ((neg (< r 0)) (ar (abs r))
|
||||||
|
(s (- prec 1 (jbd-exp10 ar)))
|
||||||
|
(scaled (* ar (expt 10 s)))
|
||||||
|
(q (floor scaled)) (frac (- scaled q))
|
||||||
|
(q2 (if (jbd-round-inc? q frac 1 mode neg) (+ q 1) q))
|
||||||
|
(res (make-jbigdec (if neg (- q2) q2) s)))
|
||||||
|
;; a carry can add a digit (9.99 -> 10.0); re-normalizing drops an exact
|
||||||
|
;; trailing zero, never re-rounds.
|
||||||
|
(if (> (jbd-digits q2) prec) (jbd-round-prec res prec mode) res))))
|
||||||
|
|
||||||
(define (jbd2-div a b)
|
(define (jbd2-div a b)
|
||||||
(when (= 0 (jbigdec-unscaled b))
|
(when (= 0 (jbigdec-unscaled b))
|
||||||
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
||||||
;; a/b = (ua * 10^sb) / (ub * 10^sa) as an exact rational.
|
;; a/b = (ua * 10^sb) / (ub * 10^sa) as an exact rational. Unlimited context:
|
||||||
(jbd-rational->bigdec (/ (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
;; exact result at minimal scale or throw on a non-terminating expansion. A
|
||||||
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a))))))
|
;; bound *math-context* instead rounds to its precision.
|
||||||
|
(let ((r (/ (* (jbigdec-unscaled a) (expt 10 (jbigdec-scale b)))
|
||||||
|
(* (jbigdec-unscaled b) (expt 10 (jbigdec-scale a)))))
|
||||||
|
(mc (jbd-math-context)))
|
||||||
|
(if mc
|
||||||
|
(jbd-rational-prec r (jbd-mc-precision mc) (jbd-mc-mode mc))
|
||||||
|
(jbd-rational->bigdec r))))
|
||||||
|
|
||||||
;; integer-division semantics (quot/rem): truncate toward zero, scale 0.
|
;; integer-division semantics (quot/rem): truncate toward zero, scale 0.
|
||||||
(define (jbd-int-quot a b)
|
(define (jbd-int-quot a b)
|
||||||
|
|
@ -139,13 +166,65 @@
|
||||||
(define (jbd-compare2 a b)
|
(define (jbd-compare2 a b)
|
||||||
(let-values (((ua ub s) (jbd-align a b))) (cond ((< ua ub) -1) ((> ua ub) 1) (else 0))))
|
(let-values (((ua ub s) (jbd-align a b))) (cond ((< ua ub) -1) ((> ua ub) 1) (else 0))))
|
||||||
|
|
||||||
|
;; --- *math-context* (with-precision) -----------------------------------------
|
||||||
|
;; with-precision binds clojure.core/*math-context* to {:precision N :rounding
|
||||||
|
;; MODE}; every exact bigdec result rounds through it (java.math.MathContext).
|
||||||
|
(define jbd-kw-precision (keyword #f "precision"))
|
||||||
|
(define jbd-kw-rounding (keyword #f "rounding"))
|
||||||
|
(define (jbd-math-context)
|
||||||
|
(let ((mc (var-deref "clojure.core" "*math-context*")))
|
||||||
|
(if (jolt-nil? mc) #f mc)))
|
||||||
|
(define (jbd-mc-precision mc) (jolt-get mc jbd-kw-precision))
|
||||||
|
(define (jbd-mc-mode mc)
|
||||||
|
(let ((r (jolt-get mc jbd-kw-rounding)))
|
||||||
|
(cond ((symbol-t? r) (symbol-t-name r))
|
||||||
|
((string? r) r)
|
||||||
|
(else "HALF_UP"))))
|
||||||
|
|
||||||
|
;; should |value| = q + r/div (0 <= r < div) round up in magnitude? neg is the
|
||||||
|
;; value's sign; r/div may be exact rationals (the division path).
|
||||||
|
(define (jbd-round-inc? q r div mode neg)
|
||||||
|
(cond ((= r 0) #f)
|
||||||
|
((string=? mode "UP") #t)
|
||||||
|
((string=? mode "DOWN") #f)
|
||||||
|
((string=? mode "CEILING") (not neg))
|
||||||
|
((string=? mode "FLOOR") neg)
|
||||||
|
((string=? mode "HALF_DOWN") (> (* 2 r) div))
|
||||||
|
((string=? mode "HALF_EVEN")
|
||||||
|
(let ((c (- (* 2 r) div)))
|
||||||
|
(cond ((> c 0) #t) ((< c 0) #f) (else (odd? q)))))
|
||||||
|
((string=? mode "UNNECESSARY")
|
||||||
|
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Rounding necessary")))
|
||||||
|
(else (>= (* 2 r) div)))) ; HALF_UP, the MathContext default
|
||||||
|
|
||||||
|
(define (jbd-digits n) (string-length (number->string (abs n))))
|
||||||
|
;; round a bigdec to `prec` significant digits with `mode` (a RoundingMode name).
|
||||||
|
(define (jbd-round-prec bd prec mode)
|
||||||
|
(let ((u (jbigdec-unscaled bd)) (s (jbigdec-scale bd)))
|
||||||
|
(if (= u 0)
|
||||||
|
bd
|
||||||
|
(let ((digs (jbd-digits u)))
|
||||||
|
(if (<= digs prec)
|
||||||
|
bd
|
||||||
|
(let* ((drop (- digs prec)) (div (expt 10 drop))
|
||||||
|
(neg (< u 0)) (au (abs u))
|
||||||
|
(q (quotient au div)) (r (remainder au div))
|
||||||
|
(q2 (if (jbd-round-inc? q r div mode neg) (+ q 1) q))
|
||||||
|
(res (make-jbigdec (if neg (- q2) q2) (- s drop))))
|
||||||
|
;; a carry can add a digit back (99 -> 100 at precision 2)
|
||||||
|
(if (> (jbd-digits q2) prec) (jbd-round-prec res prec mode) res)))))))
|
||||||
|
(define (jbd-mc-round x)
|
||||||
|
(let ((mc (and (jbigdec? x) (jbd-math-context))))
|
||||||
|
(if mc (jbd-round-prec x (jbd-mc-precision mc) (jbd-mc-mode mc)) x)))
|
||||||
|
|
||||||
;; A binary op over operands that may mix bigdec / integer / flonum. flonum-op is
|
;; 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.
|
;; the native fallback for the double-contagion path; bd-op is the exact bigdec op
|
||||||
|
;; (its result rounds through a bound *math-context*).
|
||||||
(define (jbd-binop flonum-op bd-op a b)
|
(define (jbd-binop flonum-op bd-op a b)
|
||||||
(if (or (flonum? a) (flonum? b))
|
(if (or (flonum? a) (flonum? b))
|
||||||
(flonum-op (if (jbigdec? a) (jbigdec->flonum a) a)
|
(flonum-op (if (jbigdec? a) (jbigdec->flonum a) a)
|
||||||
(if (jbigdec? b) (jbigdec->flonum b) b))
|
(if (jbigdec? b) (jbigdec->flonum b) b))
|
||||||
(bd-op (jbd-coerce a) (jbd-coerce b))))
|
(jbd-mc-round (bd-op (jbd-coerce a) (jbd-coerce b)))))
|
||||||
|
|
||||||
;; --- variadic engine ops (Phase-2 emit targets + value-position folds) -------
|
;; --- variadic engine ops (Phase-2 emit targets + value-position folds) -------
|
||||||
(define (jbd-fold flonum-op bd-op init xs)
|
(define (jbd-fold flonum-op bd-op init xs)
|
||||||
|
|
@ -203,23 +282,78 @@
|
||||||
;; --- wire into the value model ----------------------------------------------
|
;; --- wire into the value model ----------------------------------------------
|
||||||
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
(def-var! "clojure.core" "bigdec" jolt-bigdec)
|
||||||
|
|
||||||
;; Value-position arithmetic: (reduce + bigs) / (apply * bigs) pass +/*/- // AS A
|
;; The seq.ss binary numeric dispatch (jolt-add2/… and the jolt-n* macros) routes
|
||||||
;; VALUE, which lowers to these shims (NOT the inlined hot-path native op). Extend
|
;; any op whose operand is outside Chez's tower to the *-slow hooks; extend each
|
||||||
;; them to dispatch to the bigdec engine when a bigdec operand is present; ordinary
|
;; with a bigdec arm. Every arithmetic position (call, value, higher-order)
|
||||||
;; numeric folds hit the captured native path unchanged.
|
;; funnels through these, so contagion and *math-context* rounding apply
|
||||||
(define jbd-prev-add jolt-add)
|
;; uniformly. min/max need no arm: the generic jolt-min2 compares through
|
||||||
(define jbd-prev-sub jolt-sub)
|
;; jolt-num-cmp-slow and returns the original operand.
|
||||||
(define jbd-prev-mul jolt-mul)
|
(set! jolt-num-slow?
|
||||||
(define jbd-prev-div jolt-div)
|
(let ((prev jolt-num-slow?)) (lambda (x) (or (jbigdec? x) (prev x)))))
|
||||||
(define jbd-prev-min jolt-min)
|
(define (jbd-extend-hook prev bd-op)
|
||||||
(define jbd-prev-max jolt-max)
|
(lambda (a b)
|
||||||
(define (jbd-any? xs) (and (pair? xs) (or (jbigdec? (car xs)) (jbd-any? (cdr xs)))))
|
(if (or (jbigdec? a) (jbigdec? b)) (bd-op a b) (prev a b))))
|
||||||
(set! jolt-add (lambda xs (if (jbd-any? xs) (apply jbd-add xs) (apply jbd-prev-add xs))))
|
(set! jolt-add-slow (jbd-extend-hook jolt-add-slow (lambda (a b) (jbd-binop + jbd2+ a b))))
|
||||||
(set! jolt-sub (lambda xs (if (jbd-any? xs) (apply jbd-sub xs) (apply jbd-prev-sub xs))))
|
(set! jolt-sub-slow (jbd-extend-hook jolt-sub-slow (lambda (a b) (jbd-binop - jbd2- a b))))
|
||||||
(set! jolt-mul (lambda xs (if (jbd-any? xs) (apply jbd-mul xs) (apply jbd-prev-mul xs))))
|
(set! jolt-mul-slow (jbd-extend-hook jolt-mul-slow (lambda (a b) (jbd-binop * jbd2* a b))))
|
||||||
(set! jolt-div (lambda xs (if (jbd-any? xs) (apply jbd-div xs) (apply jbd-prev-div xs))))
|
(set! jolt-div-slow (jbd-extend-hook jolt-div-slow (lambda (a b) (jbd-binop / jbd2-div a b))))
|
||||||
(set! jolt-min (lambda xs (if (jbd-any? xs) (apply jbd-min xs) (apply jbd-prev-min xs))))
|
(set! jolt-num-cmp-slow
|
||||||
(set! jolt-max (lambda xs (if (jbd-any? xs) (apply jbd-max xs) (apply jbd-prev-max xs))))
|
(let ((prev jolt-num-cmp-slow))
|
||||||
|
(lambda (a b)
|
||||||
|
(if (and (or (jbigdec? a) (jbigdec? b)) (jbd-numberish? a) (jbd-numberish? b))
|
||||||
|
(jbd-value-compare a b)
|
||||||
|
(prev a b)))))
|
||||||
|
;; quot/rem/mod: a double operand demotes to the double path; exact operands use
|
||||||
|
;; the integer-division bigdec ops (mod = rem, floor-adjusted to the divisor's sign).
|
||||||
|
(define (jbd->num x) (if (jbigdec? x) (jbigdec->flonum x) x))
|
||||||
|
(set! jolt-quot-slow
|
||||||
|
(jbd-extend-hook jolt-quot-slow
|
||||||
|
(lambda (a b) (if (or (flonum? a) (flonum? b))
|
||||||
|
(jolt-quot (jbd->num a) (jbd->num b))
|
||||||
|
(jbd-int-quot (jbd-coerce a) (jbd-coerce b))))))
|
||||||
|
(set! jolt-rem-slow
|
||||||
|
(jbd-extend-hook jolt-rem-slow
|
||||||
|
(lambda (a b) (if (or (flonum? a) (flonum? b))
|
||||||
|
(jolt-rem (jbd->num a) (jbd->num b))
|
||||||
|
(jbd-int-rem (jbd-coerce a) (jbd-coerce b))))))
|
||||||
|
(set! jolt-mod-slow
|
||||||
|
(jbd-extend-hook jolt-mod-slow
|
||||||
|
(lambda (a b)
|
||||||
|
(if (or (flonum? a) (flonum? b))
|
||||||
|
(jolt-mod (jbd->num a) (jbd->num b))
|
||||||
|
(let* ((bb (jbd-coerce b))
|
||||||
|
(m (jbd-int-rem (jbd-coerce a) bb)))
|
||||||
|
(if (or (jbd-zero? m) (eq? (jbd-neg? m) (jbd-neg? bb))) m (jbd2+ m bb)))))))
|
||||||
|
;; unary shims: inc/dec and the sign predicates take a bigdec arm. set! updates
|
||||||
|
;; call-position references; the re-def-var! updates the var cell AND claims the
|
||||||
|
;; wrapped proc's class name before the prelude's inc'/dec' aliases are defined
|
||||||
|
;; ((type inc) stays clojure.core$inc — first def wins in the class registry).
|
||||||
|
(define jbd-one (make-jbigdec 1 0))
|
||||||
|
(set! jolt-inc (let ((prev jolt-inc)) (lambda (x) (if (jbigdec? x) (jbd-mc-round (jbd2+ x jbd-one)) (prev x)))))
|
||||||
|
(set! jolt-dec (let ((prev jolt-dec)) (lambda (x) (if (jbigdec? x) (jbd-mc-round (jbd2- x jbd-one)) (prev x)))))
|
||||||
|
(set! jolt-zero? (let ((prev jolt-zero?)) (lambda (x) (if (jbigdec? x) (jbd-zero? x) (prev x)))))
|
||||||
|
(set! jolt-pos? (let ((prev jolt-pos?)) (lambda (x) (if (jbigdec? x) (jbd-pos? x) (prev x)))))
|
||||||
|
(set! jolt-neg? (let ((prev jolt-neg?)) (lambda (x) (if (jbigdec? x) (jbd-neg? x) (prev x)))))
|
||||||
|
(def-var! "clojure.core" "inc" jolt-inc)
|
||||||
|
(def-var! "clojure.core" "dec" jolt-dec)
|
||||||
|
(def-var! "clojure.core" "zero?" jolt-zero?)
|
||||||
|
(def-var! "clojure.core" "pos?" jolt-pos?)
|
||||||
|
(def-var! "clojure.core" "neg?" jolt-neg?)
|
||||||
|
|
||||||
|
;; rationalize: reference Clojure goes through BigDecimal.valueOf(double) — the
|
||||||
|
;; SHORTEST decimal print of the double, not its exact binary value — so
|
||||||
|
;; (rationalize 1.1) is 11/10. A bigdec is exact already; other exacts pass through.
|
||||||
|
(define (jolt-rationalize x)
|
||||||
|
(cond ((jbigdec? x) (/ (jbigdec-unscaled x) (expt 10 (jbigdec-scale x))))
|
||||||
|
((flonum? x)
|
||||||
|
(if (or (nan? x) (infinite? x))
|
||||||
|
(jolt-throw (jolt-host-throwable "java.lang.NumberFormatException"
|
||||||
|
(string-append "Invalid input: " (number->string x))))
|
||||||
|
(let ((bd (jolt-bigdec-from-string (jolt-num->string x))))
|
||||||
|
(/ (jbigdec-unscaled bd) (expt 10 (jbigdec-scale bd))))))
|
||||||
|
((number? x) x)
|
||||||
|
(else (jolt-num-cast-throw x))))
|
||||||
|
(def-var! "clojure.core" "rationalize" jolt-rationalize)
|
||||||
|
|
||||||
;; compare: add a bigdec arm (enables compare / sort / sorted collections). A
|
;; 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.
|
;; bigdec vs a plain number compares by value; bigdec vs bigdec is scale-independent.
|
||||||
|
|
|
||||||
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
212
host/chez/seq.ss
212
host/chez/seq.ss
|
|
@ -158,17 +158,209 @@
|
||||||
((fx=? i 0) (seq-first s))
|
((fx=? i 0) (seq-first s))
|
||||||
(else (loop (jolt-seq (seq-more s)) (fx- i 1)))))))
|
(else (loop (jolt-seq (seq-more s)) (fx- i 1)))))))
|
||||||
|
|
||||||
|
;; --- checked arithmetic: JVM Numbers.ops-style category dispatch -------------
|
||||||
|
;; Every arithmetic/comparison site (the inlined jolt-n* macros in call position,
|
||||||
|
;; the variadic shims in value position) funnels a binary op through ONE dispatch:
|
||||||
|
;; both operands inside Chez's tower take the native op with JVM contagion rules
|
||||||
|
;; patched in (a double operand wins — Chez's exact-zero shortcut must not leak:
|
||||||
|
;; (* 1.5 0) is 0.0, not 0; an exact zero divisor throws ArithmeticException, a
|
||||||
|
;; double zero divisor yields ##Inf/##NaN); an operand OUTSIDE the tower (e.g.
|
||||||
|
;; BigDecimal) falls to a slow hook the numeric shim extends (java/bigdec.ss).
|
||||||
|
;; A non-numeric operand is a ClassCastException, like the JVM.
|
||||||
|
(define (jolt-num-cast-throw x)
|
||||||
|
(if (jolt-nil? x)
|
||||||
|
(jolt-throw (jolt-host-throwable "java.lang.NullPointerException" ""))
|
||||||
|
(jolt-throw (jolt-host-throwable
|
||||||
|
"java.lang.ClassCastException"
|
||||||
|
(string-append "class " (jolt-class-name x)
|
||||||
|
" cannot be cast to class java.lang.Number")))))
|
||||||
|
(define (jolt-div0-throw)
|
||||||
|
(jolt-throw (jolt-host-throwable "java.lang.ArithmeticException" "Divide by zero")))
|
||||||
|
|
||||||
|
;; slow hooks: one per op, taking over when an operand is outside Chez's tower.
|
||||||
|
;; A numeric shim (java/bigdec.ss) set!-extends them; the base case is the JVM's:
|
||||||
|
;; not a number -> ClassCastException. The hooks are BINARY and never re-enter
|
||||||
|
;; the variadic shims, so extension order can't recurse.
|
||||||
|
(define (jolt-add-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-sub-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-mul-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-div-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
;; comparison of operands outside the Chez tower: numeric shims extend this to a
|
||||||
|
;; 3-way compare; anything left over is not a number.
|
||||||
|
(define (jolt-num-cmp-slow a b)
|
||||||
|
(jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
|
||||||
|
(define (jolt-add2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (+ a b) (jolt-add-slow a b)))
|
||||||
|
(define (jolt-sub2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (- a b) (jolt-sub-slow a b)))
|
||||||
|
(define (jolt-mul2 a b)
|
||||||
|
(if (and (number? a) (number? b))
|
||||||
|
(if (or (flonum? a) (flonum? b))
|
||||||
|
(fl* (real->flonum a) (real->flonum b))
|
||||||
|
(* a b))
|
||||||
|
(jolt-mul-slow a b)))
|
||||||
|
(define (jolt-div2 a b)
|
||||||
|
(if (and (number? a) (number? b))
|
||||||
|
(if (or (flonum? a) (flonum? b))
|
||||||
|
(fl/ (real->flonum a) (real->flonum b))
|
||||||
|
(if (eqv? b 0) (jolt-div0-throw) (/ a b)))
|
||||||
|
(jolt-div-slow a b)))
|
||||||
|
(define (jolt-lt2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (< a b) (< (jolt-num-cmp-slow a b) 0)))
|
||||||
|
(define (jolt-gt2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (> a b) (> (jolt-num-cmp-slow a b) 0)))
|
||||||
|
(define (jolt-le2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (<= a b) (<= (jolt-num-cmp-slow a b) 0)))
|
||||||
|
(define (jolt-ge2 a b)
|
||||||
|
(if (and (number? a) (number? b)) (>= a b) (>= (jolt-num-cmp-slow a b) 0)))
|
||||||
|
;; min/max return the ORIGINAL operand (type and exactness kept, like
|
||||||
|
;; Numbers.min): (min 1 2.0) is 1, not 1.0. A NaN operand wins.
|
||||||
|
(define (jolt-min2 a b)
|
||||||
|
(cond ((and (flonum? a) (nan? a)) a)
|
||||||
|
((and (flonum? b) (nan? b)) b)
|
||||||
|
(else (if (jolt-lt2 a b) a b))))
|
||||||
|
(define (jolt-max2 a b)
|
||||||
|
(cond ((and (flonum? a) (nan? a)) a)
|
||||||
|
((and (flonum? b) (nan? b)) b)
|
||||||
|
(else (if (jolt-gt2 a b) a b))))
|
||||||
|
|
||||||
|
;; quot/rem/mod over the full tower: truncating division; a double operand makes
|
||||||
|
;; the result a double; mod has floor semantics (result takes the divisor's
|
||||||
|
;; sign). A zero divisor throws ArithmeticException in both worlds (JVM double
|
||||||
|
;; quot/rem check the divisor before dividing). Non-tower operands hit the
|
||||||
|
;; set!-extensible slow hooks.
|
||||||
|
(define (jolt-quot-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-rem-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-mod-slow a b) (jolt-num-cast-throw (if (number? a) b a)))
|
||||||
|
(define (jolt-quot a b)
|
||||||
|
(cond ((not (and (number? a) (number? b))) (jolt-quot-slow a b))
|
||||||
|
((or (flonum? a) (flonum? b))
|
||||||
|
(let ((n (real->flonum a)) (d (real->flonum b)))
|
||||||
|
(if (fl= d 0.0) (jolt-div0-throw) (fltruncate (fl/ n d)))))
|
||||||
|
((eqv? b 0) (jolt-div0-throw))
|
||||||
|
((and (integer? a) (integer? b)) (quotient a b))
|
||||||
|
(else (truncate (/ a b)))))
|
||||||
|
(define (jolt-rem a b)
|
||||||
|
(cond ((not (and (number? a) (number? b))) (jolt-rem-slow a b))
|
||||||
|
((or (flonum? a) (flonum? b))
|
||||||
|
(let ((n (real->flonum a)) (d (real->flonum b)))
|
||||||
|
(if (fl= d 0.0) (jolt-div0-throw)
|
||||||
|
(fl- n (fl* d (fltruncate (fl/ n d)))))))
|
||||||
|
((eqv? b 0) (jolt-div0-throw))
|
||||||
|
((and (integer? a) (integer? b)) (remainder a b))
|
||||||
|
(else (- a (* b (truncate (/ a b)))))))
|
||||||
|
(define (jolt-mod a b)
|
||||||
|
(cond ((not (and (number? a) (number? b))) (jolt-mod-slow a b))
|
||||||
|
((and (integer? a) (integer? b) (not (flonum? a)) (not (flonum? b)))
|
||||||
|
(if (eqv? b 0) (jolt-div0-throw) (modulo a b)))
|
||||||
|
(else
|
||||||
|
(let ((m (jolt-rem a b)))
|
||||||
|
(if (or (zero? m) (eq? (negative? m) (negative? b))) m (jolt-add2 m b))))))
|
||||||
|
|
||||||
;; value-position arithmetic (the higher-order forms: (reduce + []), (apply * xs)).
|
;; value-position arithmetic (the higher-order forms: (reduce + []), (apply * xs)).
|
||||||
;; Scheme's +/-/*// already implement the JVM-parity numeric tower: exact+exact ->
|
;; Folded through the binary dispatch so contagion/edge rules hold; identities
|
||||||
;; exact, exact/exact -> Ratio, any flonum -> flonum. Identities (+)=0 / (*)=1 are
|
;; (+)=0 / (*)=1 are exact, matching exact integer arithmetic. The hot path uses
|
||||||
;; exact, matching exact integer arithmetic. The hot path uses the inlined native
|
;; the inlined native ops, not these.
|
||||||
;; ops, not these.
|
;; recognizer for slow-path numeric types; numeric shims extend it.
|
||||||
(define (jolt-add . xs) (apply + xs))
|
(define (jolt-num-slow? x) #f)
|
||||||
(define (jolt-sub . xs) (apply - xs))
|
(define (jolt-num-check1 x) ; (+ x)/(* x) return x but still type-check it
|
||||||
(define (jolt-mul . xs) (apply * xs))
|
(if (or (number? x) (jolt-num-slow? x)) x (jolt-num-cast-throw x)))
|
||||||
(define (jolt-div . xs) (apply / xs))
|
(define (jolt-add . xs)
|
||||||
(define (jolt-min . xs) (apply min xs))
|
(cond ((null? xs) 0)
|
||||||
(define (jolt-max . xs) (apply max xs))
|
((null? (cdr xs)) (jolt-num-check1 (car xs)))
|
||||||
|
(else (fold-left jolt-add2 (car xs) (cdr xs)))))
|
||||||
|
(define (jolt-arity0-throw name)
|
||||||
|
(jolt-throw (jolt-host-throwable
|
||||||
|
"clojure.lang.ArityException"
|
||||||
|
(string-append "Wrong number of args (0) passed to: clojure.core/" name))))
|
||||||
|
(define (jolt-sub . xs)
|
||||||
|
(cond ((null? xs) (jolt-arity0-throw "-"))
|
||||||
|
((null? (cdr xs)) (jolt-sub2 0 (car xs)))
|
||||||
|
(else (fold-left jolt-sub2 (car xs) (cdr xs)))))
|
||||||
|
(define (jolt-mul . xs)
|
||||||
|
(cond ((null? xs) 1)
|
||||||
|
((null? (cdr xs)) (jolt-num-check1 (car xs)))
|
||||||
|
(else (fold-left jolt-mul2 (car xs) (cdr xs)))))
|
||||||
|
(define (jolt-div . xs)
|
||||||
|
(cond ((null? xs) (jolt-arity0-throw "/"))
|
||||||
|
((null? (cdr xs)) (jolt-div2 1 (car xs)))
|
||||||
|
(else (fold-left jolt-div2 (car xs) (cdr xs)))))
|
||||||
|
(define (jolt-min x . xs) (fold-left jolt-min2 x xs))
|
||||||
|
(define (jolt-max x . xs) (fold-left jolt-max2 x xs))
|
||||||
|
;; variadic comparison chains for value position ((apply < xs)).
|
||||||
|
(define (jolt-cmp-chain op2)
|
||||||
|
(lambda (x . xs)
|
||||||
|
(let loop ((a x) (rest xs))
|
||||||
|
(cond ((null? rest) #t)
|
||||||
|
((op2 a (car rest)) (loop (car rest) (cdr rest)))
|
||||||
|
(else #f)))))
|
||||||
|
(define jolt-lt (jolt-cmp-chain jolt-lt2))
|
||||||
|
(define jolt-gt (jolt-cmp-chain jolt-gt2))
|
||||||
|
(define jolt-le (jolt-cmp-chain jolt-le2))
|
||||||
|
(define jolt-ge (jolt-cmp-chain jolt-ge2))
|
||||||
|
|
||||||
|
;; call-position arithmetic: inlined macros with the both-Chez-numbers fast path
|
||||||
|
;; open-coded; anything else falls to the binary dispatch above. Comparisons
|
||||||
|
;; return a genuine Scheme boolean (the backend's truthy elision relies on it).
|
||||||
|
(define-syntax jolt-n+
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) 0)
|
||||||
|
((_ a) (jolt-add a))
|
||||||
|
((_ ea eb) (let ((a ea) (b eb))
|
||||||
|
(if (and (number? a) (number? b)) (+ a b) (jolt-add a b))))
|
||||||
|
((_ a b c ...) (jolt-n+ (jolt-n+ a b) c ...))))
|
||||||
|
(define-syntax jolt-n-
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) (jolt-sub))
|
||||||
|
((_ a) (jolt-sub a))
|
||||||
|
((_ ea eb) (let ((a ea) (b eb))
|
||||||
|
(if (and (number? a) (number? b)) (- a b) (jolt-sub a b))))
|
||||||
|
((_ a b c ...) (jolt-n- (jolt-n- a b) c ...))))
|
||||||
|
(define-syntax jolt-n*
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) 1)
|
||||||
|
((_ a) (jolt-mul a))
|
||||||
|
((_ ea eb) (let ((a ea) (b eb))
|
||||||
|
(if (and (number? a) (number? b))
|
||||||
|
(if (or (flonum? a) (flonum? b))
|
||||||
|
(fl* (real->flonum a) (real->flonum b))
|
||||||
|
(* a b))
|
||||||
|
(jolt-mul a b))))
|
||||||
|
((_ a b c ...) (jolt-n* (jolt-n* a b) c ...))))
|
||||||
|
(define-syntax jolt-n-div
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) (jolt-div))
|
||||||
|
((_ a) (jolt-div a))
|
||||||
|
((_ a b) (jolt-div2 a b))
|
||||||
|
((_ a b c ...) (jolt-n-div (jolt-div2 a b) c ...))))
|
||||||
|
(define-syntax define-n-cmp
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ name op op2)
|
||||||
|
(define-syntax name
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) (op2))
|
||||||
|
((_ a) (begin a #t))
|
||||||
|
((_ ea eb) (let ((a ea) (b eb))
|
||||||
|
(if (and (number? a) (number? b)) (op a b) (op2 a b))))
|
||||||
|
((_ ea eb c (... ...)) (let ((a ea) (b eb))
|
||||||
|
(and (name a b) (name b c (... ...))))))))))
|
||||||
|
(define-n-cmp jolt-n< < jolt-lt2)
|
||||||
|
(define-n-cmp jolt-n> > jolt-gt2)
|
||||||
|
(define-n-cmp jolt-n<= <= jolt-le2)
|
||||||
|
(define-n-cmp jolt-n>= >= jolt-ge2)
|
||||||
|
(define-syntax jolt-n-min
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) (jolt-min))
|
||||||
|
((_ a) (jolt-min a))
|
||||||
|
((_ a b) (jolt-min2 a b))
|
||||||
|
((_ a b c ...) (jolt-n-min (jolt-min2 a b) c ...))))
|
||||||
|
(define-syntax jolt-n-max
|
||||||
|
(syntax-rules ()
|
||||||
|
((_) (jolt-max))
|
||||||
|
((_ a) (jolt-max a))
|
||||||
|
((_ a b) (jolt-max2 a b))
|
||||||
|
((_ a b c ...) (jolt-n-max (jolt-max2 a b) c ...))))
|
||||||
|
|
||||||
;; --- unchecked (Java long) arithmetic: wrap to signed 64 bits ----------------
|
;; --- unchecked (Java long) arithmetic: wrap to signed 64 bits ----------------
|
||||||
;; Clojure's unchecked-* (and +/-/* under *unchecked-math*) are long ops that
|
;; Clojure's unchecked-* (and +/-/* under *unchecked-math*) are long ops that
|
||||||
|
|
|
||||||
|
|
@ -133,8 +133,8 @@
|
||||||
(concat (map first ss)
|
(concat (map first ss)
|
||||||
(apply interleave (map rest ss))))))))
|
(apply interleave (map rest ss))))))))
|
||||||
|
|
||||||
;; No ratio type on Jolt, so rationalize is identity.
|
;; rationalize is host-native (java/bigdec.ss): a double routes through its
|
||||||
(defn rationalize [x] x)
|
;; shortest decimal print like BigDecimal.valueOf, so (rationalize 1.1) is 11/10.
|
||||||
|
|
||||||
;; 0-arg: a stateful transducer (tracks [seen? prev] in a volatile, so no sentinel
|
;; 0-arg: a stateful transducer (tracks [seen? prev] in a volatile, so no sentinel
|
||||||
;; value is needed). 1-arg: eager dedupe of consecutive equal elements.
|
;; value is needed). 1-arg: eager dedupe of consecutive equal elements.
|
||||||
|
|
|
||||||
|
|
@ -109,11 +109,15 @@
|
||||||
(with-open ~(vec (drop 2 bindings)) ~@body)
|
(with-open ~(vec (drop 2 bindings)) ~@body)
|
||||||
(finally (__close ~(first bindings)))))))
|
(finally (__close ~(first bindings)))))))
|
||||||
|
|
||||||
;; jolt numbers are doubles — there is no BigDecimal math context, so the
|
;; Binds *math-context*; BigDecimal arithmetic in the dynamic scope rounds its
|
||||||
;; precision (and optional :rounding mode) is accepted and ignored.
|
;; results to the precision with the rounding mode (default HALF_UP, like
|
||||||
|
;; java.math.MathContext).
|
||||||
(defmacro with-precision [precision & exprs]
|
(defmacro with-precision [precision & exprs]
|
||||||
(let [body (if (= :rounding (first exprs)) (drop 2 exprs) exprs)]
|
(let [[rounding body] (if (= :rounding (first exprs))
|
||||||
`(do ~@body)))
|
[(second exprs) (drop 2 exprs)]
|
||||||
|
['HALF_UP exprs])]
|
||||||
|
`(binding [clojure.core/*math-context* {:precision ~precision :rounding '~rounding}]
|
||||||
|
~@body)))
|
||||||
|
|
||||||
(defmacro with-bindings [binding-map & body]
|
(defmacro with-bindings [binding-map & body]
|
||||||
`(with-bindings* ~binding-map (fn [] ~@body)))
|
`(with-bindings* ~binding-map (fn [] ~@body)))
|
||||||
|
|
|
||||||
|
|
@ -17,13 +17,17 @@
|
||||||
|
|
||||||
;; Hot clojure.core primitives lowered to native Scheme.
|
;; Hot clojure.core primitives lowered to native Scheme.
|
||||||
;; `=` is the exactness-aware jolt= from values.ss; inc/dec/
|
;; `=` is the exactness-aware jolt= from values.ss; inc/dec/
|
||||||
;; not are rt shims; mod/rem/quot map to Scheme's (Scheme has all three).
|
;; not are rt shims. Arithmetic and comparisons lower to the jolt-n* checked
|
||||||
|
;; macros (host/chez/seq.ss): the both-Chez-numbers fast path is open-coded and
|
||||||
|
;; anything else (BigDecimal, a non-number) takes the Numbers.ops-style category
|
||||||
|
;; dispatch, with JVM contagion (a double operand wins; an exact zero divisor is
|
||||||
|
;; ArithmeticException; a double zero divisor is ##Inf/##NaN).
|
||||||
(def ^:private native-ops
|
(def ^:private native-ops
|
||||||
{"+" "+" "-" "-" "*" "*" "/" "/"
|
{"+" "jolt-n+" "-" "jolt-n-" "*" "jolt-n*" "/" "jolt-n-div"
|
||||||
"<" "<" ">" ">" "<=" "<=" ">=" ">="
|
"<" "jolt-n<" ">" "jolt-n>" "<=" "jolt-n<=" ">=" "jolt-n>="
|
||||||
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
|
"=" "jolt=" "inc" "jolt-inc" "dec" "jolt-dec" "not" "jolt-not"
|
||||||
"min" "min" "max" "max"
|
"min" "jolt-n-min" "max" "jolt-n-max"
|
||||||
"mod" "modulo" "rem" "remainder" "quot" "quotient"
|
"mod" "jolt-mod" "rem" "jolt-rem" "quot" "jolt-quot"
|
||||||
"vector" "jolt-vector" "hash-map" "jolt-hash-map-fn" "hash-set" "jolt-hash-set"
|
"vector" "jolt-vector" "hash-map" "jolt-hash-map-fn" "hash-set" "jolt-hash-set"
|
||||||
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
|
"conj" "jolt-conj" "get" "jolt-get" "nth" "jolt-nth" "count" "jolt-count"
|
||||||
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
|
"assoc" "jolt-assoc" "dissoc" "jolt-dissoc" "contains?" "jolt-contains?"
|
||||||
|
|
@ -53,12 +57,12 @@
|
||||||
"protocol-dispatch3" "protocol-dispatch3"})
|
"protocol-dispatch3" "protocol-dispatch3"})
|
||||||
|
|
||||||
;; Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
|
;; Value-position resolution for a clojure.core ref passed AS A VALUE (to map /
|
||||||
;; filter / reduce / apply). Arithmetic is the exception — Scheme's +/-/*// return
|
;; filter / reduce / apply). The jolt-n* call-position forms are macros, so value
|
||||||
;; EXACT results for exact/zero-arg inputs, breaking the all-double model in
|
;; position substitutes the variadic procedures over the same binary dispatch.
|
||||||
;; higher-order use, so value-position arithmetic routes to the flonum wrappers.
|
|
||||||
(def ^:private core-value-procs
|
(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"}))
|
"min" "jolt-min" "max" "jolt-max"
|
||||||
|
"<" "jolt-lt" ">" "jolt-gt" "<=" "jolt-le" ">=" "jolt-ge"}))
|
||||||
|
|
||||||
;; Per-op arity gate: only lower when the Scheme prim and the jolt fn agree at
|
;; 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).
|
;; this arity. Ops absent from the table are variadic (legal at any arity).
|
||||||
|
|
@ -83,7 +87,7 @@
|
||||||
|
|
||||||
;; jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg,
|
;; jolt's comparison ops are vacuously true at arity 1 and DON'T inspect the arg,
|
||||||
;; but Scheme's < demands a number even there — special-case.
|
;; but Scheme's < demands a number even there — special-case.
|
||||||
(def ^:private cmp1-ops #{"<" ">" "<=" ">="})
|
(def ^:private cmp1-ops #{"jolt-n<" "jolt-n>" "jolt-n<=" "jolt-n>="})
|
||||||
|
|
||||||
;; Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method`
|
;; Host interop methods with a Chez RT shim (rt.ss jolt-host-call). A `.method`
|
||||||
;; call on any other method routes to record-method-dispatch (a reify/record
|
;; call on any other method routes to record-method-dispatch (a reify/record
|
||||||
|
|
@ -93,7 +97,7 @@
|
||||||
;; Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an
|
;; Native-op Scheme procedures that return a genuine Scheme boolean (#t/#f), so an
|
||||||
;; :if test built from them needs no jolt-truthy? wrapper.
|
;; :if test built from them needs no jolt-truthy? wrapper.
|
||||||
(def ^:private bool-returning-ops
|
(def ^:private bool-returning-ops
|
||||||
#{"<" "<=" ">" ">=" "jolt=" "jolt-not"
|
#{"jolt-n<" "jolt-n<=" "jolt-n>" "jolt-n>=" "jolt=" "jolt-not"
|
||||||
"jolt-even?" "jolt-odd?" "jolt-pos?" "jolt-neg?"
|
"jolt-even?" "jolt-odd?" "jolt-pos?" "jolt-neg?"
|
||||||
"jolt-zero?" "jolt-empty?" "jolt-contains?" "jolt-nil?" "jolt-some?"})
|
"jolt-zero?" "jolt-empty?" "jolt-contains?" "jolt-nil?" "jolt-some?"})
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -183,7 +183,12 @@
|
||||||
ls (lng-spec nm n)
|
ls (lng-spec nm n)
|
||||||
bs (bd-spec nm n)]
|
bs (bd-spec nm n)]
|
||||||
(cond
|
(cond
|
||||||
(and ds (ok? :double :double))
|
(and ds (ok? :double :double)
|
||||||
|
;; min/max return the ORIGINAL operand (Numbers.min: an integer
|
||||||
|
;; literal stays exact), so an int-literal operand blocks the
|
||||||
|
;; flonum lowering there — flmin would coerce it.
|
||||||
|
(or (not (contains? #{"min" "max"} nm))
|
||||||
|
(every? (fn [c] (= c :double)) cls)))
|
||||||
;; coerce integer-literal operands to flonum so fl-ops never see an exact int.
|
;; coerce integer-literal operands to flonum so fl-ops never see an exact int.
|
||||||
(let [args' (mapv (fn [nd] (if (int-lit? nd) (assoc nd :val (double (get nd :val))) nd))
|
(let [args' (mapv (fn [nd] (if (int-lit? nd) (assoc nd :val (double (get nd :val))) nd))
|
||||||
argnodes)]
|
argnodes)]
|
||||||
|
|
|
||||||
|
|
@ -3515,4 +3515,23 @@
|
||||||
{:suite "exceptions / hierarchy catch" :label "a typed throwable matches its superclasses, not unrelated ones" :expected "[true true true false]" :actual "(let [e (try (Long/parseLong \"z\") (catch Throwable e e))] [(instance? NumberFormatException e) (instance? IllegalArgumentException e) (instance? Exception e) (instance? java.io.IOException e)])"}
|
{:suite "exceptions / hierarchy catch" :label "a typed throwable matches its superclasses, not unrelated ones" :expected "[true true true false]" :actual "(let [e (try (Long/parseLong \"z\") (catch Throwable e e))] [(instance? NumberFormatException e) (instance? IllegalArgumentException e) (instance? Exception e) (instance? java.io.IOException e)])"}
|
||||||
{:suite "equality / identity" :label "= short-circuits on identity without realizing a lazy seq (Util.equiv k1 == k2)" :expected "0" :actual "(let [n (atom 0) s (map (fn [x] (swap! n inc) x) [1 2 3])] (= s s) @n)"}
|
{:suite "equality / identity" :label "= short-circuits on identity without realizing a lazy seq (Util.equiv k1 == k2)" :expected "0" :actual "(let [n (atom 0) s (map (fn [x] (swap! n inc) x) [1 2 3])] (= s s) @n)"}
|
||||||
{:suite "realized? / lazy seq" :label "realized? reads a lazy seq's realization flag" :expected "[false true]" :actual "(let [s (map inc [1 2 3])] [(realized? s) (do (doall s) (realized? s))])"}
|
{:suite "realized? / lazy seq" :label "realized? reads a lazy seq's realization flag" :expected "[false true]" :actual "(let [s (map inc [1 2 3])] [(realized? s) (do (doall s) (realized? s))])"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "double contagion beats exact-zero shortcut" :expected "[0.0 0.0 0.0 0.0]" :actual "[(* 1.0 0) (* 0 1.5) (/ 0 1.5) (- 0.0 0)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "Inf times zero is NaN" :expected "[true true]" :actual "[(NaN? (* ##Inf 0)) (NaN? (* 0 ##-Inf))]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "zero over NaN is NaN" :expected "true" :actual "(NaN? (/ 0 ##NaN))"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "double division by exact zero is signed Inf" :expected "[##Inf ##-Inf]" :actual "[(/ 1.0 0) (/ -1.0 0)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "exact division by zero throws ArithmeticException" :expected "[:ae :ae :ae]" :actual "[(try (/ 1 0) (catch ArithmeticException _ :ae)) (try (/ 0) (catch ArithmeticException _ :ae)) (try (quot 1.0 0) (catch ArithmeticException _ :ae))]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "non-number operand is ClassCastException" :expected "[:cce :cce]" :actual "[(try (+ 1 \"a\") (catch ClassCastException _ :cce)) (try (< \"a\" 1) (catch ClassCastException _ :cce))]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "quot over ratios truncates" :expected "[6 -2 1]" :actual "[(quot 3 1/2) (quot -3 4/3) (quot 37/2 15)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "quot/rem double contagion" :expected "[3.0 1.5 0.0]" :actual "[(quot 10.0 3) (rem 5.5 2) (quot 1 ##Inf)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "mod takes the divisor's sign on doubles" :expected "[0.5 -0.5 1.5]" :actual "[(mod -5.5 2) (mod 5.5 -2) (mod 5.5 2)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "min/max return the original operand" :expected "[1 4.0 1M]" :actual "[(min 1 2.0) (max 3 4.0) (min 1M 2)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "NaN wins min/max" :expected "[true true]" :actual "[(NaN? (min 1.0 ##NaN)) (NaN? (max ##NaN 1.0))]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "bigdec call position mixes with doubles" :expected "[3.5 1.0 true]" :actual "[(+ 1.5M 2.0) (/ 2.0M 2.0) (< 1.5M 2.0)]"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "runtime bigdec reaches call-position ops" :expected "[4M 2M true]" :actual "(let [x (bigdec 3)] [(+ x 1) (- x 1) (< 1 x)])"}
|
||||||
|
{:suite "numbers / ops dispatch" :label "inc/dec on bigdec" :expected "[2.5M 0.5M]" :actual "[(inc 1.5M) (dec 1.5M)]"}
|
||||||
|
{:suite "numbers / with-precision" :label "rounding modes" :expected "[2M -1M 1M -2M 2M 1M]" :actual "[(with-precision 1 :rounding UP (* 1.1M 1M)) (with-precision 1 :rounding CEILING (* -1.1M 1M)) (with-precision 1 :rounding DOWN (* 1.9M 1M)) (with-precision 1 :rounding FLOOR (* -1.9M 1M)) (with-precision 1 :rounding HALF_EVEN (* 2.5M 1M)) (with-precision 1 :rounding HALF_DOWN (* 1.5M 1M))]"}
|
||||||
|
{:suite "numbers / with-precision" :label "UNNECESSARY throws when rounding needed, passes exact" :expected "[:ae 2M]" :actual "[(try (with-precision 1 :rounding UNNECESSARY (* 1.5M 1M)) (catch ArithmeticException _ :ae)) (with-precision 1 :rounding UNNECESSARY (* 2M 1M))]"}
|
||||||
|
{:suite "numbers / with-precision" :label "division rounds to precision (default HALF_UP)" :expected "\"0.3333\"" :actual "(str (with-precision 4 (/ 1M 3M)))"}
|
||||||
|
{:suite "numbers / rationalize" :label "doubles go through shortest decimal print" :expected "[11/10 3/2 1 0 -1]" :actual "[(rationalize 1.1) (rationalize 1.5) (rationalize 1.0) (rationalize 0.0) (rationalize -1.0)]"}
|
||||||
|
{:suite "numbers / rationalize" :label "bigdec and exacts pass through exactly" :expected "[3/2 1/3 7]" :actual "[(rationalize 1.5M) (rationalize 1/3) (rationalize 7)]"}
|
||||||
]
|
]
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
# clojure-test-suite known failures: <namespace> <fail> <error>
|
# clojure-test-suite known failures: <namespace> <fail> <error>
|
||||||
# The gate fails on any per-namespace change, worse OR better; regenerate
|
# The gate fails on any per-namespace change, worse OR better; regenerate
|
||||||
# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
|
# with: JOLT_CTS_WRITE_BASELINE=1 host/chez/cts.sh
|
||||||
clojure.core-test.abs 1 1
|
clojure.core-test.abs 1 0
|
||||||
clojure.core-test.add-watch 0 3
|
clojure.core-test.add-watch 0 3
|
||||||
clojure.core-test.ancestors 9 0
|
clojure.core-test.ancestors 9 0
|
||||||
clojure.core-test.atom 14 0
|
clojure.core-test.atom 14 0
|
||||||
|
|
@ -34,10 +34,8 @@ clojure.core-test.intern 2 0
|
||||||
clojure.core-test.keys 0 4
|
clojure.core-test.keys 0 4
|
||||||
clojure.core-test.lazy-seq 3 0
|
clojure.core-test.lazy-seq 3 0
|
||||||
clojure.core-test.long 2 5
|
clojure.core-test.long 2 5
|
||||||
clojure.core-test.max 3 1
|
|
||||||
clojure.core-test.min 3 1
|
|
||||||
clojure.core-test.minus 2 0
|
clojure.core-test.minus 2 0
|
||||||
clojure.core-test.mod 12 34
|
clojure.core-test.mod 23 0
|
||||||
clojure.core-test.neg-int-qmark 1 0
|
clojure.core-test.neg-int-qmark 1 0
|
||||||
clojure.core-test.not-eq 3 0
|
clojure.core-test.not-eq 3 0
|
||||||
clojure.core-test.nth 0 1
|
clojure.core-test.nth 0 1
|
||||||
|
|
@ -52,32 +50,29 @@ clojure.core-test.plus 11 0
|
||||||
clojure.core-test.plus-squote 11 0
|
clojure.core-test.plus-squote 11 0
|
||||||
clojure.core-test.pop 0 1
|
clojure.core-test.pop 0 1
|
||||||
clojure.core-test.pos-int-qmark 1 0
|
clojure.core-test.pos-int-qmark 1 0
|
||||||
clojure.core-test.quot 12 23
|
clojure.core-test.quot 30 0
|
||||||
clojure.core-test.rand-nth 0 1
|
clojure.core-test.rand-nth 0 1
|
||||||
clojure.core-test.rational-qmark 3 0
|
clojure.core-test.rational-qmark 3 0
|
||||||
clojure.core-test.rationalize 10 0
|
|
||||||
clojure.core-test.realized-qmark 3 0
|
clojure.core-test.realized-qmark 3 0
|
||||||
clojure.core-test.reduce 0 1
|
clojure.core-test.reduce 0 1
|
||||||
clojure.core-test.rem 12 22
|
clojure.core-test.rem 21 0
|
||||||
clojure.core-test.remove-watch 0 1
|
clojure.core-test.remove-watch 0 1
|
||||||
clojure.core-test.run-bang 1 0
|
clojure.core-test.run-bang 1 0
|
||||||
clojure.core-test.select-keys 2 0
|
clojure.core-test.select-keys 2 0
|
||||||
clojure.core-test.seqable-qmark 1 0
|
clojure.core-test.seqable-qmark 1 0
|
||||||
clojure.core-test.short 7 5
|
clojure.core-test.short 7 5
|
||||||
clojure.core-test.shuffle 1 0
|
clojure.core-test.shuffle 1 0
|
||||||
clojure.core-test.slash 2 22
|
|
||||||
clojure.core-test.some-fn 3 0
|
clojure.core-test.some-fn 3 0
|
||||||
clojure.core-test.sort-by 2 0
|
clojure.core-test.sort-by 2 0
|
||||||
clojure.core-test.special-symbol-qmark 4 0
|
clojure.core-test.special-symbol-qmark 4 0
|
||||||
clojure.core-test.star 22 0
|
clojure.core-test.star 13 0
|
||||||
clojure.core-test.star-squote 19 0
|
clojure.core-test.star-squote 13 0
|
||||||
clojure.core-test.transient 23 0
|
clojure.core-test.transient 23 0
|
||||||
clojure.core-test.underive 7 0
|
clojure.core-test.underive 7 0
|
||||||
clojure.core-test.update 1 0
|
clojure.core-test.update 1 0
|
||||||
clojure.core-test.vals 0 3
|
clojure.core-test.vals 0 3
|
||||||
clojure.core-test.vec 1 0
|
clojure.core-test.vec 1 0
|
||||||
clojure.core-test.when-let 1 0
|
clojure.core-test.when-let 1 0
|
||||||
clojure.core-test.with-precision 17 0
|
|
||||||
clojure.edn-test.read-string 46 5
|
clojure.edn-test.read-string 46 5
|
||||||
clojure.string-test.capitalize 0 4
|
clojure.string-test.capitalize 0 4
|
||||||
clojure.string-test.ends-with-qmark 1 4
|
clojure.string-test.ends-with-qmark 1 4
|
||||||
|
|
|
||||||
|
|
@ -36,7 +36,7 @@
|
||||||
(ev "(def add1 (fn* ([x] (+ x 1))))")
|
(ev "(def add1 (fn* ([x] (+ x 1))))")
|
||||||
(let ((e (emitf "u" "(fn* ([y] (add1 y)))")))
|
(let ((e (emitf "u" "(fn* ([y] (add1 y)))")))
|
||||||
(ok "plain fn is inlined (call to add1 gone)" (not (has? e "add1")))
|
(ok "plain fn is inlined (call to add1 gone)" (not (has? e "add1")))
|
||||||
(ok "inlined body present (+ ... 1)" (has? e "(+")))
|
(ok "inlined body present (jolt-n+ ... 1)" (has? e "(jolt-n+")))
|
||||||
(ok "inlined plain fn runtime: (add1 41) = 42" (= 42 (jnum->exact (ev "((fn* ([y] (add1 y))) 41)"))))
|
(ok "inlined plain fn runtime: (add1 41) = 42" (= 42 (jnum->exact (ev "((fn* ([y] (add1 y))) 41)"))))
|
||||||
|
|
||||||
;; a ^double fn: body fl-ops fire after inlining, and the call is gone.
|
;; a ^double fn: body fl-ops fire after inlining, and the call is gone.
|
||||||
|
|
|
||||||
|
|
@ -127,10 +127,36 @@ arithmetic, `=`, and `hash` behave exactly as the JVM — but report `Long`, not
|
||||||
`Byte`/`Short`/`Integer`, so `(class (byte 5))` and `(instance? Byte (byte 5))`
|
`Byte`/`Short`/`Integer`, so `(class (byte 5))` and `(instance? Byte (byte 5))`
|
||||||
diverge. This is substrate-inherent: a Chez fixnum is an immediate `identical?`
|
diverge. This is substrate-inherent: a Chez fixnum is an immediate `identical?`
|
||||||
to the plain integer (nothing to tag, and numbers carry no metadata), so the only
|
to the plain integer (nothing to tag, and numbers carry no metadata), so the only
|
||||||
faithful representation is a boxed type — which would crash raw compiled `(+ …)`
|
faithful representation is a boxed type — which would crash the compiled
|
||||||
(arithmetic emits a bare Chez `+`) or force every `+`/`-`/`*` through an
|
arithmetic fast path (both operands Chez numbers → the raw Chez op) or force
|
||||||
unwrapping dispatcher, de-optimizing all arithmetic. Same shape as the accepted
|
every `+`/`-`/`*` through an unwrapping dispatcher, de-optimizing all
|
||||||
BigInt-vs-Long unification.
|
arithmetic. Same shape as the accepted BigInt-vs-Long unification.
|
||||||
|
|
||||||
|
## Number operations
|
||||||
|
|
||||||
|
Binary arithmetic and comparisons follow the JVM's `Numbers.ops(x, y)` category
|
||||||
|
dispatch. Every position (call, value, higher-order) funnels a binary op through
|
||||||
|
one seam (`host/chez/seq.ss`): operands inside Chez's tower take the native op
|
||||||
|
with the JVM contagion rules patched in; an operand outside it (BigDecimal)
|
||||||
|
falls to a slow hook the numeric shim extends (`host/chez/java/bigdec.ss`); a
|
||||||
|
non-numeric operand throws `ClassCastException`. The rules the corpus pins
|
||||||
|
(`numbers / ops dispatch`, `numbers / with-precision`, `numbers / rationalize`):
|
||||||
|
|
||||||
|
- A double operand wins: `(* 1.0 0)` is `0.0` (Chez's exact-zero shortcut must
|
||||||
|
not leak), `(* ##Inf 0)` is `##NaN`, `(+ 1.5M 2.0)` is `3.5`.
|
||||||
|
- Division: an exact zero divisor throws `ArithmeticException`; a double zero
|
||||||
|
divisor yields `##Inf`/`##-Inf`/`##NaN`. `(/ 1M 3M)` with no bound
|
||||||
|
`*math-context*` throws (non-terminating); under `with-precision` it rounds.
|
||||||
|
- `quot`/`rem`/`mod` cover the full tower (ratios truncate; doubles keep double;
|
||||||
|
`mod` takes the divisor's sign; zero divisor throws in both worlds).
|
||||||
|
- `min`/`max` return the *original* operand (`(min 1 2.0)` is `1`, exact); a
|
||||||
|
`##NaN` operand wins.
|
||||||
|
- `with-precision` binds `*math-context*`; BigDecimal results round to the
|
||||||
|
precision with the `java.math.RoundingMode` semantics (default `HALF_UP`,
|
||||||
|
`UNNECESSARY` throws).
|
||||||
|
- `rationalize` routes a double through its shortest decimal print
|
||||||
|
(`BigDecimal.valueOf`), so `(rationalize 1.1)` is `11/10`, not the exact
|
||||||
|
binary expansion.
|
||||||
|
|
||||||
## Hosting jolt on a new runtime
|
## Hosting jolt on a new runtime
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
"Rows of test/chez/corpus.edn whose :expected differs from reference JVM Clojure. The corpus is JVM-sourced (regen-corpus.clj), so this list is only the rows whose JVM value is an opaque host object that cannot round-trip to readable source — Java arrays, transients, atoms, beans, proxies, and chunks print as #object[..@addr] with a per-run identity — plus the (fn* foo) strictness case. For that the corpus keeps jolt's value. certify.clj gates on NEW (unlisted) divergences and STALE entries. Keyed by [suite label].",
|
"Rows of test/chez/corpus.edn whose :expected differs from reference JVM Clojure. The corpus is JVM-sourced (regen-corpus.clj), so this list is only the rows whose JVM value is an opaque host object that cannot round-trip to readable source — Java arrays, transients, atoms, beans, proxies, and chunks print as #object[..@addr] with a per-run identity — plus the (fn* foo) strictness case. For that the corpus keeps jolt's value. certify.clj gates on NEW (unlisted) divergences and STALE entries. Keyed by [suite label].",
|
||||||
:legend
|
:legend
|
||||||
{:numeric-model
|
{:numeric-model
|
||||||
"jolt has a numeric tower (exact integer / Ratio / double); no BigDecimal",
|
"jolt has the full numeric tower (exact integer / Ratio / double / BigDecimal); binary ops dispatch by operand category with JVM contagion rules",
|
||||||
:host-model
|
:host-model
|
||||||
"no JVM host: classes->name strings, type->symbol, *in* is a map, inline-impl extenders, duck-typed with-open close",
|
"no JVM host: classes->name strings, type->symbol, *in* is a map, inline-impl extenders, duck-typed with-open close",
|
||||||
:reader-model
|
:reader-model
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue