From c3be09a06c4579f9b1c2d89b019d4f8c4e8edcf7 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Mon, 13 Aug 2018 18:04:57 +0200 Subject: decimalization --- modules/language/python/module/decimal.scm | 217 +++++++++++++++-------------- 1 file changed, 113 insertions(+), 104 deletions(-) (limited to 'modules/language/python/module/decimal.scm') diff --git a/modules/language/python/module/decimal.scm b/modules/language/python/module/decimal.scm index 6d0d21a..bd309dd 100644 --- a/modules/language/python/module/decimal.scm +++ b/modules/language/python/module/decimal.scm @@ -18,6 +18,7 @@ #:use-module (language python bool) #:use-module (language python module) #:use-module (oop pf-objects) + #:use-module (oop goops) #:use-module (language python module re) #:use-module (ice-9 control) #:use-module ((ice-9 match) #:select ((match . ice:match))) @@ -373,10 +374,11 @@ This is the copyright information of the file ported over to scheme ;; Map conditions (per the spec) to signals (define _condition_map - `((,ConversionSyntax . ,InvalidOperation) - (,DivisionImpossible . ,InvalidOperation) - (,DivisionUndefined . ,InvalidOperation) - (,InvalidContext . ,InvalidOperation))) + (dict + `((,ConversionSyntax . ,InvalidOperation) + (,DivisionImpossible . ,InvalidOperation) + (,DivisionUndefined . ,InvalidOperation) + (,InvalidContext . ,InvalidOperation)))) ;; Valid rounding modes (define _rounding_modes @@ -418,10 +420,16 @@ This is the copyright information of the file ported over to scheme ((ref m 'group) "int")) (define (get-parsed-frac m) - ((ref m 'group) "frac")) + (let ((r ((ref m 'group) "frac"))) + (if (eq? r None) + "" + r))) (define (get-parsed-exp m) - ((ref m 'group) "exp")) + (let ((r ((ref m 'group) "exp"))) + (if (eq? r None) + 0 + (string->number r)))) (define (get-parsed-diag m) ((ref m 'group) "diag")) @@ -456,8 +464,8 @@ This is the copyright information of the file ported over to scheme ;; REs insist on real strings, so we can too. (cond ((isinstance value str) - (let ((m (_parser (scm-str str)))) - (if (not m) + (let ((m (_parser (scm-str value)))) + (if (not (bool m)) (let ((context (if (eq? context None) (getcontext) context))) @@ -472,7 +480,7 @@ This is the copyright information of the file ported over to scheme (diag (get-parsed-diag m)) (signal (get-parsed-sig m))) - (set self 'sign sign) + (set self '_sign sign) (if (not (eq? intpart None)) (begin @@ -489,12 +497,12 @@ This is the copyright information of the file ported over to scheme "0"))) "0")) (if signal - (set self '_exp "N") - (set self '_exp "n"))) + (set self '_exp 'N) + (set self '_exp 'n))) (begin ;; infinity (set self '_int "0") - (set self '_exp "F"))) + (set self '_exp 'F))) (set self '_is_special #t)))))) ;; From an integer @@ -614,7 +622,7 @@ This is the copyright information of the file ported over to scheme (define-syntax-rule (norm-op self op) (begin - (set! op ((ref self '_convert_other) op)) + (set! op (_convert_other op)) (if (eq? op NotImplemented) op #f))) @@ -626,7 +634,7 @@ This is the copyright information of the file ported over to scheme code)) (define-syntax-rule (un-special self context) - (if ((ref self '_is_special)) + (if (ref self '_is_special) (let ((ans ((ref self '_check_nans) #:context context))) (if (bool ans) ans @@ -636,18 +644,19 @@ This is the copyright information of the file ported over to scheme (define-syntax-rule (bin-special o1 o2 context) (if (or (ref o1 '_is_special) (ref o2 '_is_special)) - (or (un-special o1 context) (un-special o2 context)))) + (or (un-special o1 context) (un-special o2 context)) + #f)) (define-syntax-rule (add-special self other context) (or (bin-special self other context) - (if ((ref self '_isinfinity)) + (if (bool ((ref self '_isinfinity))) ;; If both INF, same sign => ;; same as both, opposite => error. (if (and (not (= (ref self '_sign) (ref other '_sign))) - ((ref other '_isinfinity))) + (bool ((ref other '_isinfinity)))) ((cx-error context) InvalidOperation "-INF + INF") (Decimal self)) - (if ((ref other '_isinfinity)) + (if (bool ((ref other '_isinfinity))) (Decimal other) ; Can't both be infinity here #f)))) @@ -656,13 +665,13 @@ This is the copyright information of the file ported over to scheme (twix ((bin-special self other context) it it) - ((if ((ref self '_isinfinity)) + ((if (bool ((ref self '_isinfinity))) (if (not (bool other)) ((cx-error context) InvalidOperation "(+-)INF * 0") (pylist-ref _SignedInfinity resultsign)) #f) it it) - (if ((ref other '_isinfinity)) + (if (bool ((ref other '_isinfinity))) (if (not (bool self)) ((cx-error context) InvalidOperation "(+-)INF * 0") (pylist-ref _SignedInfinity resultsign)) @@ -674,13 +683,13 @@ This is the copyright information of the file ported over to scheme (twix ((bin-special self other context) it it) - ((and ((ref self '_isinfinity)) ((ref other '_isinfinity))) it + ((and (bool ((ref self '_isinfinity))) (bool ((ref other '_isinfinity)))) it ((cx-error context) InvalidOperation "(+-)INF/(+-)INF")) - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it (pylist-ref _SignedInfinity sign)) - (((ref other '_isinfinity)) it + ((bool ((ref other '_isinfinity))) it ((cx-error context) Clamped "Division by infinity") (_dec_from_triple sign "0" (cx-etiny context)))))) @@ -740,27 +749,26 @@ This is the copyright information of the file ported over to scheme (let lp ((l l) (r2 '())) (ice:match l ((#\E . l) - (let* ((n (length r1)) + (let* ((n (length r2)) (m (list->string (append (reverse r1) (reverse r2)))) - (e (+ (- n 1) (string->number (list->string l))))) + (e (+ (- n) (string->number (list->string l))))) (cons m e))) ((x . l) (lp l (cons x r2)))))) ((x . l) (lp l (cons x r1)))))) - - - (cond + + (cond ((isinstance f int) ; handle integer inputs (cls f)) ((not (isinstance f float)) (raise (TypeError "argument must be int or float."))) ((or (inf? f) (nan? f)) (cls (cond - ((nan? f) "") - ((eq? f (inf)) "") - ((eq? f (- (inf))) "")))) + ((nan? f) "Nan") + ((eq? f (inf)) "Inf") + ((eq? f (- (inf))) "-Inf")))) (else (let* ((sign (if (>= f 0) 0 1)) (me (frexp f)) @@ -1117,7 +1125,6 @@ This is the copyright information of the file ported over to scheme (intpart #f) (fracpart #f) (exppart #f)) - (cond ((ref self '_is_special) (cond @@ -1150,26 +1157,26 @@ This is the copyright information of the file ported over to scheme (cond ((<= dotplace 0) (set! intpart "0") - (set! fracpart (+ "." + (* "0" (- dotplace)) + i))) + (set! fracpart (+ "." (* "0" (- dotplace)) i))) ((>= dotplace (len i)) (set! intpart (+ i (* "0" (- dotplace (len i))))) (set! fracpart "")) (else (set! intpart (pylist-slice i None dotplace None)) - (set! fracpart (+ '.' (pylist-slice i dotplace None None))))) + (set! fracpart (+ "." (pylist-slice i dotplace None None))))) - (cond ((= leftdigits dotplace) - (set! exp "")) + (set! exppart "")) (else (let ((context (if (eq? context None) (getcontext) context))) - (set! exp + (set! exppart (+ (pylist-ref '("e" "E") (cx-capitals context)) (format #f "~@d" (- leftdigits dotplace))))))) - (+ sign intpart fracpart exp)))))) + + (+ sign intpart fracpart exppart)))))) (define to_eng_string (lam (self (= context None)) @@ -1251,19 +1258,22 @@ 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)) - (self_exp (ref self '_sign)) - (other_exp (ref other '_sign)) + (self_exp (ref self '_exp)) + (other_exp (ref other '_exp)) (prec (cx-prec context)) - (exp (min self_exp other_exp)) + (exp ((@ (guile) min) self_exp other_exp)) (sign #f) (ans #f)) @@ -1272,43 +1282,46 @@ 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 (min self_sign other_sign)) + (set! sign ((@ (guile) min) self_sign other_sign)) (if (= negativezero 1) (set! sign 1)) (set! ans (_dec_from_triple sign "0" exp)) (set! ans ((ref ans '_fix) context)) ans) #f) it it) - + (let () (pk 1 6)) ((if (not (bool self)) (begin - (set! exp (max exp (- other_exp prec 1))) + (set! exp ((@ (guile) max) exp (- other_exp prec 1))) (set! ans ((ref other '_rescale) exp (cx-rounding context))) (set! ans ((ref ans '_fix) context)) ans) #f) it it) - + (let () (pk 1 7)) ((if (not (bool other)) (begin - (set! exp (max exp (- self_exp prec 1))) + (set! exp ((@ (guile) max) exp (- self_exp prec 1))) (set! ans ((ref self '_rescale) exp (cx-rounding context))) (set! ans ((ref ans '_fix) context)) 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 (cadr ab)) + (op2_i (cdr ab)) (result (_WorkRep)))) + (let () (pk 1 9)) + ((cond ((not (= (ref op1 'sign) (ref op2 'sign))) ;; Equal and opposite @@ -1339,6 +1352,8 @@ 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))) @@ -1481,14 +1496,14 @@ This is the copyright information of the file ported over to scheme (logxor (ref self '_sign) (ref other '_sign))) (ideal_exp - (if ((ref other '_isinfinity)) + (if (bool ((ref other '_isinfinity))) (ref self '_exp) - (min (ref self 'exp) (ref other '_exp)))) + ((@ (guile) min) (ref self 'exp) (ref other '_exp)))) (expdiff (- ((ref self 'adjusted)) ((ref other 'adjusted))))))) ((or (not (bool self)) - ((ref other '_isinfinity)) + (bool ((ref other '_isinfinity))) (<= expdiff -1)) it (list (_dec_from_triple sign "0" 0) ((ref self '_rescale) ideal_exp (cx-rounding context)))) @@ -1546,8 +1561,8 @@ This is the copyright information of the file ported over to scheme (logxor (ref self '_sign) (ref other '_sign)))))) - (((ref self '_isinfinity)) it - (if ((ref other '_isinfinity)) + ((bool ((ref self '_isinfinity))) it + (if (bool ((ref other '_isinfinity))) (let ((ans ((cx-error context) InvalidOperation "divmod(INF, INF)"))) (list ans ans)) @@ -1586,7 +1601,7 @@ This is the copyright information of the file ported over to scheme ((bin-special self other context) it it) - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it ((cx-error context) InvalidOperation "INF % x")) ((not (bool other)) it @@ -1617,7 +1632,7 @@ This is the copyright information of the file ported over to scheme ((bin-special self other context) it it) ;; self == +/-infinity -> InvalidOperation - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it ((cx-error context) InvalidOperation "remainder_near(infinity, x)")) ;; other == 0 -> either InvalidOperation or DivisionUndefined @@ -1627,12 +1642,12 @@ This is the copyright information of the file ported over to scheme ((cx-error context) DivisionUndefined "remainder_near(0, 0)"))) ;; other = +/-infinity -> remainder = self - (((ref other '_isinfinity)) it + ((bool ((ref other '_isinfinity))) it (let ((ans (Decimal self))) ((ref ans '_fix) context))) ;; self = 0 -> remainder = self, with ideal exponent - (let (let ((ideal_exponent (min (ref self '_exp) (ref other '_exp)))))) + (let (let ((ideal_exponent ((@ (guile) min) (ref self '_exp) (ref other '_exp)))))) ((not (bool self)) it (let ((ans (_dec_from_triple (ref self '_sign) "0" ideal_exponent))) @@ -1691,8 +1706,8 @@ This is the copyright information of the file ported over to scheme ((bin-special self other context) it it) - (((ref self '_isinfinity)) it - (if ((ref other '_isinfinity)) + ((bool ((ref self '_isinfinity))) it + (if (bool ((ref other '_isinfinity))) ((cx-error context) InvalidOperation "INF // INF") (pylist-ref _SignedInfinity (logxor (ref self '_sign) (ref other '_sign))))) @@ -1807,7 +1822,7 @@ This is the copyright information of the file ported over to scheme (let* ((exp_max (if (= (cx-clamp context) 0) (cx-emax context) Etop)) - (new_exp (min (max (ref self '_exp) Etiny) exp_max))) + (new_exp ((@ (guile) min) ((@ (guile) max) (ref self '_exp) Etiny) exp_max))) (if (not (= new_exp (ref self '_exp))) (begin ((cx-error context) Clamped) @@ -2306,7 +2321,7 @@ This is the copyright information of the file ported over to scheme (if (and ((ref other '_isinteger)) (= (ref other '_sign) 0)) (begin (let ((ideal_exponent (* (ref self '_exp) (int other)))) - (set! zeros (min (- exponent ideal_exponent) (- p 1))))) + (set! zeros ((@ (guile) min) (- exponent ideal_exponent) (- p 1))))) (set! zeros 0)) (_dec_from_triple 0 (+ "1" (* "0" zeros)) (- exponent zeros))))) @@ -2504,7 +2519,7 @@ This is the copyright information of the file ported over to scheme (= (ref other '_sign) 0)) (let ((ideal_exponent (* (ref self '_exp) (int other)))) - (min (- xe ideal_exponent) + ((@ (guile) min) (- xe ideal_exponent) (- p (len str_xc)))) 0))) (_dec_from_triple 0 (+ str_xc (* '0' zeros)) (- xe zeros))))))) @@ -2580,7 +2595,7 @@ This is the copyright information of the file ported over to scheme (pylist-ref _SignedInfinity result_sign))) ;; Inf**(+ve or Inf) = Inf; Inf**(-ve or -Inf) = 0 - (((self '_isinfinity)) it + ((bool ((self '_isinfinity))) it (if (= (ref other '_sign) 0) (pylist-ref _SignedInfinity result_sign) (_dec_from_triple result_sign "0" 0))) @@ -2623,7 +2638,7 @@ This is the copyright information of the file ported over to scheme ;; self ** infinity is infinity if self > 1, 0 if self < 1 ;; self ** -infinity is infinity if self < 1, 0 if self > 1 - (((ref other '_isinfinity)) it + ((bool ((ref other '_isinfinity))) it (if (eq? (= (ref other '_sign) 0) (< self_adj 0)) (_dec_from_triple result_sign "0" 0) @@ -2769,7 +2784,7 @@ This is the copyright information of the file ported over to scheme (let (get-context context)) ((un-special self context) it it) (let ((dup ((ref self _fix) context)))) - (((dup '_isinfinity)) it dup) + ((bool ((dup '_isinfinity))) it dup) ((not (bool dup)) it (_dec_from_triple (ref dup '_sign) "0" 0)) @@ -2806,9 +2821,9 @@ This is the copyright information of the file ported over to scheme (cond ((bool ans) ans) - ((or ((ref exp '_isinfinity)) ((ref self '_isinfinity))) - (if (and ((ref exp '_isinfinity)) - ((ref self '_isinfinity))) + ((or (bool ((ref exp '_isinfinity))) (bool ((ref self '_isinfinity)))) + (if (and (bool ((ref exp '_isinfinity))) + (bool ((ref self '_isinfinity)))) (Decimal self)) ; if both are inf, it is OK ((cx-error context) InvalidOperation "quantize with one INF")) (else @@ -3027,7 +3042,7 @@ This is the copyright information of the file ported over to scheme (let ((ans ((ref self '_check_nans) #:context context))) (if (bool ans) ans - (if (and ((self '_isinfinity)) (= (ref self '_sign) 0)) + (if (and (bool ((self '_isinfinity))) (= (ref self '_sign) 0)) (Decimal self) #f))) @@ -3747,7 +3762,7 @@ This is the copyright information of the file ported over to scheme (ans it it) ;; logb(+/-Inf) = +Inf - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it _Infinity) ;; logb(0) = -Inf, DivisionByZero @@ -3960,7 +3975,7 @@ This is the copyright information of the file ported over to scheme ;; decide which flags to raise using value of ans (cond - (((ref ans '_isinfinity)) + ((bool ((ref ans '_isinfinity))) ((cx-error context) Overflow "Infinite result from next_toward" (ref ans '_sign)) ((cx-error context) Inexact) @@ -4046,7 +4061,7 @@ This is the copyright information of the file ported over to scheme ((not (and (<= (- p) o) (<= o p))) it ((cx-error context) InvalidOperation)) - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it (Decimal self)) ;; get values, pad if necessary @@ -4087,7 +4102,7 @@ This is the copyright information of the file ported over to scheme (<= o limsup)))) it ((cx-error context) InvalidOperation)) - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it (Decimal self)) (let* ((d (_dec_from_triple (ref self '_sign) @@ -4115,7 +4130,7 @@ This is the copyright information of the file ported over to scheme ((not (and (<= (- p) o) (<= o p))) it ((cx-error context) InvalidOperation)) - (((ref self '_isinfinity)) it + ((bool ((ref self '_isinfinity))) it (Decimal self)) ;; get values, pad if necessary @@ -4372,7 +4387,7 @@ This is the copyright information of the file ported over to scheme (define _set_integer_check (lambda (self name value vmin vmax) (if (not (isinstance value int)) - (raise (TypeError (format #f "~a must be an integer" name)))) + (raise (TypeError (format #f "~a must be an integer was ~a" name value)))) (cond ((equal? vmin "-inf") @@ -4511,7 +4526,7 @@ This is the copyright information of the file ported over to scheme trap_enabler is set, it reraises the exception. Otherwise, it returns the default value after setting the flag. " - (let ((error ((ref _condition_map 'get) condition condition))) + (let ((error (py-get _condition_map condition condition))) (if (in error (ref self '_ignored_flags)) ;; Don't touch the flag (py-apply (ref (error) 'handle) self (* args)) @@ -6212,7 +6227,7 @@ This is the copyright information of the file ported over to scheme (set tmp 'int (* (ref tmp 'int) (expt 10 (- (ref tmp 'exp) (ref other 'exp))))) (set tmp 'exp (ref other 'exp)) - (values op1 op2)))))) + (cons op1 op2)))))) ;;##### Integer arithmetic functions used by ln, log10, exp and __pow__ ##### @@ -6570,7 +6585,7 @@ This is the copyright information of the file ported over to scheme (lambda (coeff exp) (values (_div_nearest coeff 10) (+ exp 1)))))))) -(pk 3) + (define _corr (dict '(("1" . 100) ("2" . 70) ("3" . 53) ("4" . 40) ("5" . 31) ("6" . 23 ) ("7" . 16) ("8" . 10) ("9" . 5)))) (define _log10_lb @@ -6663,7 +6678,7 @@ This is the copyright information of the file ported over to scheme #:Emin -999999 #:capitals 1 #:clamp 0)) -(pk 3 1) + ;; Pre-made alternate contexts offered by the specification ;; Don't change these; the user should be able to select these ;; contexts and be able to reproduce results from other implementations @@ -6675,7 +6690,7 @@ This is the copyright information of the file ported over to scheme #:rounding ROUND_HALF_UP #:traps (list DivisionByZero Overflow InvalidOperation Clamped Underflow) #:flags '())) -(pk 3 2) + (define ExtendedContext (Context #:prec 9 @@ -6696,7 +6711,7 @@ This is the copyright information of the file ported over to scheme ;;# number between the optional sign and the optional exponent must have ;;# at least one decimal digit, possibly after the decimal point. The ;;# lookahead expression '(?=\d|\.\d)' checks this. -(pk 5) + (define _parser (ref (compile " # A numeric string consists of: @@ -6718,11 +6733,11 @@ This is the copyright information of the file ported over to scheme \\Z " (logior VERBOSE IGNORECASE)) 'match)) -(pk 6) + (define _all_zeros (ref (compile "0*$" ) 'match)) -(pk 7) + (define _exact_half (ref (compile "50*$") 'match)) -(pk 8) + ;;##### PEP3101 support functions ############################################## ;;# The functions in this section have little to do with the Decimal ;;# class, and could potentially be reused or adapted for other pure @@ -6747,12 +6762,12 @@ This is the copyright information of the file ported over to scheme (?P[eEfFgGn%])? \\Z " (logior VERBOSE DOTALL))) -(pk 9) + ;; The locale module is only needed for the 'n' format specifier. The ;; rest of the PEP 3101 code functions quite happily without it, so we ;; don't care too much if locale isn't present. (define _locale (Module "locale")) -(pk 10) + (define _parse_format_specifier (lam (format_spec (= _localeconv None)) "Parse and validate a format specifier. @@ -6947,9 +6962,9 @@ This is the copyright information of the file ported over to scheme (pylist-ref spec "sign")) (else "")))) -(pk 11) + (define typed (dict '(("E" . "E") ("e" . "e") ("G" . "E") ("g" . "e")))) -(pk 12) + (define _format_number (lambda (is_negative intpart fracpart exp spec) "Format a number, given the following data: @@ -6994,31 +7009,25 @@ This is the copyright information of the file ported over to scheme ;;##### Useful Constants (internal use only) ################################ ;; Reusable defaults -(pk 13 1) (define _Infinity (Decimal "Inf")) -(pk 13 2) (define _NegativeInfinity (Decimal "-Inf")) -(pk 13 3) (define _NaN (Decimal "NaN")) -(pk 13 4) (define _Zero (Decimal 0)) -(pk 13 5) (define _One (Decimal 1)) -(pk 13 6) (define _NegativeOne (Decimal -1)) -(pk 13 7) + ;; _SignedInfinity[sign] is infinity w/ that sign (define _SignedInfinity (list _Infinity _NegativeInfinity)) -(pk 13 8) + ;; Constants related to the hash implementation; hash(x) is based ;; on the reduction of x modulo _PyHASH_MODULUS (define _PyHASH_MODULUS (ref hash_info 'modulus)) -(pk 13 9) + ;; hash values to use for positive and negative infinities, and nans (define _PyHASH_INF (ref hash_info 'inf)) -(pk 13 10) (define _PyHASH_NAN (ref hash_info 'nan)) -(pk 13 11) + ;; _PyHASH_10INV is the inverse of 10 modulo the prime _PyHASH_MODULUS (define _PyHASH_10INV (pow 10 (- _PyHASH_MODULUS 2) _PyHASH_MODULUS)) -(pk 13 12) + +(setcontext DefaultContext) -- cgit v1.2.3