diff options
Diffstat (limited to 'modules/language/python/module')
-rw-r--r-- | modules/language/python/module/decimal.scm | 270 |
1 files changed, 141 insertions, 129 deletions
diff --git a/modules/language/python/module/decimal.scm b/modules/language/python/module/decimal.scm index bd309dd..ee7db1a 100644 --- a/modules/language/python/module/decimal.scm +++ b/modules/language/python/module/decimal.scm @@ -50,7 +50,9 @@ ;; Limits for the C version for compatibility MAX_PREC MAX_EMAX MIN_EMIN MIN_ETINY)) -(define-syntax-rule (aif it p . l) (let ((it p)) (if it . l))) +(define-syntax-rule (aif it p . l) (let ((it p)) (if (bool it) . l))) + +(define-syntax-rule (D x) (lambda () x)) #| This is the copyright information of the file ported over to scheme @@ -523,8 +525,8 @@ This is the copyright information of the file ported over to scheme ;; From an internal working value ((isinstance value _WorkRep) - (set self '_exp (int (ref value '_exp))) - (set self '_sign (ref value '_sign)) + (set self '_exp (int (ref value 'exp))) + (set self '_sign (ref value 'sign)) (set self '_int (str (ref value 'int))) (set self '_is_special #f)) @@ -691,7 +693,8 @@ This is the copyright information of the file ported over to scheme ((bool ((ref other '_isinfinity))) it ((cx-error context) Clamped "Division by infinity") - (_dec_from_triple sign "0" (cx-etiny context)))))) + (_dec_from_triple sign "0" (cx-etiny context)))) + #f)) (define-python-class Decimal (object) @@ -826,7 +829,7 @@ This is the copyright information of the file ported over to scheme #f ((ref other '_isnan))))) - (if (or self_is_nan other_is_nan) + (if (or (bool self_is_nan) (bool other_is_nan)) (let ((context (if (eq? context None) (getcontext) context))) @@ -835,7 +838,7 @@ This is the copyright information of the file ported over to scheme ((cx-error context) InvalidOperation "sNaN" self)) ((eq? other_is_nan 2) ((cx-error context) InvalidOperation "sNaN" other)) - (self_is_nan + ((bool self_is_nan) ((ref self '_fix_nan) context)) (else ((ref other '_fix_nan) context)))) @@ -973,15 +976,14 @@ This is the copyright information of the file ported over to scheme ;; <, >, <= and >= comparisons involving a (quiet or signaling) ;; NaN signal InvalidOperation, and return False if the ;; InvalidOperation is not trapped. - ;; - ;; This behavior is designed to conform as closely as possible to + ;; ;; This behavior is designed to conform as closely as possible to ;; that specified by IEEE 754. (define __eq__ (lam (self other (= context None)) (let* ((so (_convert_for_comparison self other #:equality_op #t)) - (self (car so)) - (other (cadr so))) + (self (car so)) + (other (cdr so))) (cond ((eq? other NotImplemented) @@ -994,8 +996,8 @@ This is the copyright information of the file ported over to scheme (lambda (<) (lam (self other (= context None)) (let* ((so (_convert_for_comparison self other #:equality_op #t)) - (self (car so)) - (other (cadr so))) + (self (car so)) + (other (cdr so))) (cond ((eq? other NotImplemented) @@ -1023,9 +1025,10 @@ This is the copyright information of the file ported over to scheme (if (or (ref self '_is_special) (and (bool other) (ref other '_is_special))) - (aif it ((ref self '_check_nans) other context) - it - (Decimal ((ref self '_cmp) other))))))) + (let ((it ((ref self '_check_nans) other context))) + (if (bool it) + it + (Decimal ((ref self '_cmp) other)))))))) (define __hash__ (lambda (self) @@ -1193,21 +1196,22 @@ This is the copyright information of the file ported over to scheme Rounds, if it has reason. " + (pk '__neg__) (twix - ((un-special self context) it it) - (let* ((context (if (eq? context None) - (getcontext) - context)) - (ans (if (and (not (bool self)) - (not (eq? (cx-rounding context) - ROUND_FLOOR))) - ;; -Decimal('0') is Decimal('0'), - ;; not Decimal('-0'), except - ;; in ROUND_FLOOR rounding mode. - ((ref self 'copy_abs)) - ((ref self 'copy_negate))))) - - ((ref ans '_fix) context))))) + ((un-special self context) it it) + (let () (pk 1)) + (let* ((context (if (eq? context None) + (getcontext) + context)) + (ans (if (pk (and (not (bool self)) + (not (eq? (cx-rounding context) + ROUND_FLOOR)))) + ;; -Decimal('0') is Decimal('0'), + ;; not Decimal('-0'), except + ;; in ROUND_FLOOR rounding mode. + ((pk (ref self 'copy_abs))) + ((pk (ref self 'copy_negate)))))) + ((ref ans '_fix) context))))) (define __pos__ (lam (self (= context None)) @@ -1258,15 +1262,11 @@ This is the copyright information of the file ported over to scheme -INF + INF (or the reverse) cause InvalidOperation errors. " (twix - (let () (pk 1 1 other)) ((norm-op self other) it it) - (let () (pk 1 2)) (let (get-context context)) - (let () (pk 1 3)) + ((add-special self other context) it it) - (let () (pk 1 4)) - (let* ((negativezero 0) (self_sign (ref self '_sign)) (other_sign (ref other '_sign)) @@ -1282,7 +1282,7 @@ This is the copyright information of the file ported over to scheme ;; If the answer is 0, the sign should be negative, ;; in this case. (set! negativezero 1))) - (let () (pk 1 5)) + ((if (and (not (bool self)) (not (bool other))) (begin (set! sign ((@ (guile) min) self_sign other_sign)) @@ -1292,7 +1292,7 @@ This is the copyright information of the file ported over to scheme (set! ans ((ref ans '_fix) context)) ans) #f) it it) - (let () (pk 1 6)) + ((if (not (bool self)) (begin (set! exp ((@ (guile) max) exp (- other_exp prec 1))) @@ -1301,7 +1301,7 @@ This is the copyright information of the file ported over to scheme (set! ans ((ref ans '_fix) context)) ans) #f) it it) - (let () (pk 1 7)) + ((if (not (bool other)) (begin (set! exp ((@ (guile) max) exp (- self_exp prec 1))) @@ -1311,28 +1311,24 @@ This is the copyright information of the file ported over to scheme ans) #f) it it) - (let () (pk 1 8)) - (let* ((op1 (_WorkRep self)) (op2 (_WorkRep other)) (ab (_normalize op1 op2 prec)) - (op1_i (car ab)) - (op2_i (cdr ab)) + (op1 (car ab)) + (op2 (cdr ab)) (result (_WorkRep)))) - (let () (pk 1 9)) - ((cond ((not (= (ref op1 'sign) (ref op2 'sign))) ;; Equal and opposite (twix - ((= op1_i op2_i) it + ((equal? self other) it (set! ans (_dec_from_triple negativezero "0" exp)) (set! ans ((ref ans '_fix) context)) ans) (begin - (if (< op1_i op2_i) + (if (< self other) (let ((t op1)) (set! op1 op2) (set! op2 t))) @@ -1352,8 +1348,6 @@ This is the copyright information of the file ported over to scheme (set result 'sign 0) #f)) it it) - (let () (pk 1 10)) - (begin (if (= (ref op2 'sign) 0) (set result 'int (+ (ref op1 'int) (ref op2 'int))) @@ -1376,10 +1370,10 @@ This is the copyright information of the file ported over to scheme (define __rsub__ (lam (self other (= context None)) - "Return other - self" + "Return other - self" (twix ((norm-op self other) it it) - ((ref 'other '__sub__) self #:context context)))) + ((ref other '__sub__) self #:context context)))) (define __mul__ (lam (self other (= context None)) @@ -1431,57 +1425,57 @@ This is the copyright information of the file ported over to scheme (let ((sign (logxor (ref self '_sign) (ref other '_sign))))) - ((div-special self other context sign) it it) + ((div-special self other context sign) it it) ;; Special cases for zeroes - ((if (not (bool other)) - (if (not (bool self)) - ((cx-error context) DivisionUndefined "0 / 0") - ((cx-error context) DivisionByZero "x / 0" sign)) - #f) it it) + ((if (not (bool other)) + (if (not (bool self)) + ((cx-error context) DivisionUndefined "0 / 0") + ((cx-error context) DivisionByZero "x / 0" sign)) + #f) it it) - (let ((exp #f) - (coeff #f) - (prec (cx-prec context)) - (nself (len (ref self '_int))) - (nother (len (ref other '_int)))) - (if (not (bool self)) - (begin - (set! exp (- (ref self '_exp) (ref other '_exp))) - (set! coeff 0)) - ;; OK, so neither = 0, INF or NaN - (let ((shift (+ nother (- nself) prec 1)) - (op1 (_WorkRep self)) - (op2 (_WorkRep other))) - (set! exp (- (ref self '_exp) (ref other '_exp) shift)) - (call-with-values - (lambda () - (if (>= shift 0) - (divmod (* (ref op1 'int) (expt 10 shift)) - (ref op2 'int)) - (divmod (ref op1 'int) - (* (ref op2 'int) (expt 10 shift))))) - (lambda (coeff- remainder) - (set! coeff - (if (not (= remainder 0)) - ;; result is not exact adjust to ensure - ;; correct rounding - (if (= (modulo coeff- 5) 0) - (+ coeff- 1) - coeff) - (let ((ideal_exp (- (ref self '_exp) - (ref other '_exp)))) - (let lp ((coeff- coeff-) (exp- exp)) - (if (and (< exp- ideal_exp) - (= (modulo coeff 10) 0)) - (lp (/ coeff 10) (+ exp- 1)) - (begin - (set exp exp-) - coeff)))))))))) + (let ((exp #f) + (coeff #f) + (prec (cx-prec context)) + (nself (len (ref self '_int))) + (nother (len (ref other '_int)))) + (if (not (bool self)) + (begin + (set! exp (- (ref self '_exp) (ref other '_exp))) + (set! coeff 0)) + ;; OK, so neither = 0, INF or NaN + (let ((shift (+ nother (- nself) prec 1)) + (op1 (_WorkRep self)) + (op2 (_WorkRep other))) + (set! exp (- (ref self '_exp) (ref other '_exp) shift)) + (call-with-values + (lambda () + (if (>= shift 0) + (divmod (* (ref op1 'int) (expt 10 shift)) + (ref op2 'int)) + (divmod (ref op1 'int) + (* (ref op2 'int) (expt 10 shift))))) + (lambda (coeff- remainder) + (set! coeff + (if (not (= remainder 0)) + ;; result is not exact adjust to ensure + ;; correct rounding + (if (= (modulo coeff- 5) 0) + (+ coeff- 1) + coeff) + (let ((ideal_exp (- (ref self '_exp) + (ref other '_exp)))) + (let lp ((coeff- coeff-) (exp- exp)) + (if (and (< exp- ideal_exp) + (= (modulo coeff- 10) 0)) + (lp (/ coeff- 10) (+ exp- 1)) + (begin + (set! exp exp-) + coeff-)))))))))) - - (let ((ans (_dec_from_triple sign (str coeff) exp))) - ((ref ans '_fix) context)))))) + + (let ((ans (_dec_from_triple sign (str coeff) exp))) + ((ref ans '_fix) context)))))) (define _divide (lambda (self other context) @@ -1805,19 +1799,20 @@ This is the copyright information of the file ported over to scheme " (twix - (((ref self '_is_special)) it + (let () (pk 3 1)) + ((ref self '_is_special) it (if ((ref self '_isnan)) ;; decapitate payload if necessary ((ref self '_fix_nan) context) ;; self is +/-Infinity; return unaltered (Decimal self))) - + (let () (pk 3 2)) ;; if self is zero then exponent should be between Etiny and ;; Emax if clamp==0, and between Etiny and Etop if clamp==1. (let ((Etiny (cx-etiny context)) (Etop (cx-etop context)))) - + (let () (pk 3 3)) ((not (bool self)) it (let* ((exp_max (if (= (cx-clamp context) 0) (cx-emax context) @@ -1828,7 +1823,7 @@ This is the copyright information of the file ported over to scheme ((cx-error context) Clamped) (_dec_from_triple (ref self '_sign) "0" new_exp)) (Decimal self)))) - + (let () (pk 3 4)) ;; exp_min is the smallest allowable exponent of the result, ;; equal to max(self.adjusted()-context.prec+1, Etiny) (let ((exp_min (+ (len (ref self '_int)) @@ -1841,27 +1836,33 @@ This is the copyright information of the file ported over to scheme ((cx-error context) Inexact) ((cx-error context) Rounded) ans)) - + (let () (pk 3 5)) (let* ((self_is_subnormal (< exp_min Etiny)) (exp_min (if self_is_subnormal Etiny exp_min)))) - + (let () (pk 3 6)) ;; round if self has too many digits ((< (ref self '_exp) exp_min) it (let ((digits (+ (len (ref self '_int)) (ref self '_exp) (- exp_min)))) + (pk 3 7) (if (< digits 0) (set! self (_dec_from_triple (ref self '_sign) "1" (- exp_min 1))) (set! digits 0)) + (for ((k v : (ref self '_pick_rounding_function))) () + (pk k (v))) + + (pk 3 8) (let* ((ans #f) - (rounding_method (pylist-ref + (rounding_method (pk 'me (pylist-ref (ref self '_pick_rounding_function) - (cx-rounding context))) + (pk 'r (cx-rounding context))))) (changed (rounding_method self digits)) (coeff (or (bool (pylist-slice (ref self '_int) None digits None)) "0"))) + (pk 3 9) (if (> changed 0) (begin (set! coeff (str (+ (int coeff) 1))) @@ -1869,42 +1870,50 @@ This is the copyright information of the file ported over to scheme (begin (set! coeff (pylist-slice coeff None -1 None)) (set! exp_min (+ exp_min 1)))))) - + (pk 3 10) ;; check whether the rounding pushed the exponent out of range (if (> exp_min Etop) (set! ans ((cx-error context) Overflow "above Emax" (ref self '_sign))) (set! ans (_dec_from_triple (ref self '_sign) coeff exp_min))) - + (pk 3 11) ;; raise the appropriate signals, taking care to respect ;; the precedence described in the specification (if (and changed self_is_subnormal) ((cx-error context) Underflow)) + (pk 3 12) (if self_is_subnormal ((cx-error context) Subnormal)) + (pk 3 13) (if changed ((cx-error context) Inexact)) - + (pk 3 14) ((cx-error context) Rounded) + (pk 3 15) (if (not (bool ans)) ;; raise Clamped on underflow to 0 ((cx-error context) Clamped)) ans))) + + (let () (pk 3 7)) + (begin (if self_is_subnormal ((cx-error context) Subnormal)) - + (let () (pk 4)) ;; fold down if clamp == 1 and self has too few digits (if (and (= (cx-clamp context) 1) (> (ref self '_exp) Etop)) (begin ((cx-error context) Clamped) + (let () (pk 5)) (let ((self_padded (+ (ref self '_int) (* "0" (- (ref self '_exp) Etop))))) + (let () (pk 6)) (_dec_from_triple (ref self '_sign) self_padded Etop))) ;; here self was representable to begin with; return unchanged @@ -1981,15 +1990,6 @@ This is the copyright information of the file ported over to scheme (_round_down self prec) (- (_round_down self prec))))) - (define _pick_rounding_function - (dict `((,ROUND_DOWN . ,_round_down ) - (,ROUND_UP . ,_round_up ) - (,ROUND_HALF_UP . ,_round_half_up) - (,ROUND_HALF_DOWN . ,_round_half_down) - (,ROUND_HALF_EVEN . ,_round_half_even) - (,ROUND_CEILING . ,_round_ceiling) - (,ROUND_FLOOR . ,_round_floor) - (,ROUND_05UP . ,_round_05up)))) (define __round__ (lam (self (= n None)) @@ -2524,6 +2524,16 @@ This is the copyright information of the file ported over to scheme 0))) (_dec_from_triple 0 (+ str_xc (* '0' zeros)) (- xe zeros))))))) + (define _pick_rounding_function + (dict `((,ROUND_DOWN . ,(D _round_down)) + (,ROUND_UP . ,(D _round_up )) + (,ROUND_HALF_UP . ,(D _round_half_up)) + (,ROUND_HALF_DOWN . ,(D _round_half_down)) + (,ROUND_HALF_EVEN . ,(D _round_half_even)) + (,ROUND_CEILING . ,(D _round_ceiling)) + (,ROUND_FLOOR . ,(D _round_floor)) + (,ROUND_05UP . ,(D _round_05up))))) + (define __pow__ (lam (self other (= modulo None) (= context None)) "Return self ** other [ % modulo]. @@ -2933,7 +2943,7 @@ This is the copyright information of the file ported over to scheme (let* ((this_function (pylist-ref (ref self '_pick_rounding_function) rounding)) - (changed (this_function self digits)) + (changed ((this_function) self digits)) (coeff (or (bool (pylist-slice _int None digits None)) "0"))) @@ -3593,34 +3603,36 @@ This is the copyright information of the file ported over to scheme (twix (let (get-context context)) - + (let () (pk 4 1)) ;; ln(NaN) = NaN (let ((ans ((ref self '_check_nans) #:context context)))) + (let () (pk 4 1.2 ans)) (ans it it) + (let () (pk 4 2)) ;; ln(0.0) == -Infinity ((not (bool self)) it _NegativeInfinity) - + (let () (pk 4)) ;; ln(Infinity) = Infinity ((= ((ref self '_isinfinity)) 1) it _Infinity) - + (let () (pk 4 3)) ;; ln(1.0) == 0.0 ((equal? self _One) it _Zero) - + (let () (pk 4 4)) ;; ln(negative) raises InvalidOperation (if (= (ref self '_sign) 1) ((cx-error context) InvalidOperation "ln of a negative value")) - + (let () (pk 4 5)) ;; result is irrational, so necessarily inexact (let* ((op (_WorkRep self)) (c (ref op 'int)) (e (ref op 'exp)) (p (cx-prec context)))) - + (let () (pk 4 6)) ;; correctly rounded result: repeatedly increase precision by 3 ;; until we get an unambiguously roundable result @@ -6629,7 +6641,7 @@ This is the copyright information of the file ported over to scheme " (cond ((isinstance other Decimal) - (values self other)) + (cons self other)) ;; Comparison with a Rational instance (also includes integers): ;; self op n/d <=> self*d op n (for n and d integers, d positive). @@ -6637,12 +6649,12 @@ This is the copyright information of the file ported over to scheme ;; comparison result. ((isinstance other int) (if (not (bool (ref self '_is_special))) - (values + (cons (_dec_from_triple (ref self '_sign) (* (str int (ref self '_int)) (ref other 'denominator)) (ref self '_exp)) (Decimal (ref other 'numerator))) - (values NotImplemented NotImplemented))) + (cons NotImplemented NotImplemented))) ;; Comparisons with float and complex types. == and != comparisons ;; with complex numbers should succeed, returning either True or False @@ -6659,8 +6671,8 @@ This is the copyright information of the file ported over to scheme (pylist-set! (ref context 'flags) FloatOperation 1) ((cx-error context) FloatOperation "strict semantics for mixing floats and Decimals are enabled")) - (values self ((ref Decimal 'from_float) other))) - (values NotImplemented NotImplemented))))))) + (cons self ((ref Decimal 'from_float) other))) + (cons NotImplemented NotImplemented))))))) ;;##### Setup Specific Contexts ############################################ |