decimal.scm 226 KB
Newer Older
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1 2
(define-module (language python module decimal)
  #:use-module ((language python module collections) #:select (namedtuple))
3 4
  #:use-module ((language python module itertools) #:select (chain repeat))
  #:use-module ((language python module sys) #:select (maxsize hash_info))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
5 6
  #:use-module (language python module)
  #:use-module ((language python module python) #:select
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
7 8
		(isinstance str float int tuple classmethod pow property
			    complex range reversed (format . str-format)))
9
  #:use-module (language python list)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
10
  #:use-module (language python number)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
11 12 13 14
  #:use-module (language python string)
  #:use-module (language python for)
  #:use-module (language python try)
  #:use-module (language python hash)
15
  #:use-module (language python dict)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
16 17 18
  #:use-module (language python def)
  #:use-module (language python exceptions)
  #:use-module (language python bool)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
19
  #:use-module (language python module)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
20
  #:use-module (oop pf-objects)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
21
  #:use-module (oop goops)
22
  #:use-module (language python module re)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
23
  #:use-module (ice-9 control)
24
  #:use-module (ice-9 format)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
25
  #:use-module ((ice-9 match) #:select ((match . ice:match)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
  #:export
  (        ;; Two major classes
   Decimal Context

	   ;; Named tuple representation
	   DecimalTuple

	   ;; Contexts
	   DefaultContext BasicContext ExtendedContext
		    
	   ;; Exceptions
	   DecimalException Clamped InvalidOperation DivisionByZero
	   Inexact Rounded Subnormal Overflow Underflow
	   FloatOperation

	   ;; Exceptional conditions that trigger InvalidOperation
	   DivisionImpossible InvalidContext ConversionSyntax DivisionUndefined

	   ;; Constants for use in setting up contexts
	   ROUND_DOWN ROUND_HALF_UP ROUND_HALF_EVEN ROUND_CEILING
	   ROUND_FLOOR ROUND_UP ROUND_HALF_DOWN ROUND_05UP

	   ;; Functions for manipulating contexts
	   setcontext getcontext localcontext

	   ;; Limits for the C version for compatibility
	   MAX_PREC  MAX_EMAX MIN_EMIN MIN_ETINY))

Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
54 55 56 57 58
(define (abool x)
  (if (eq? x None)
      None
      (bool x)))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
59
(define-syntax-rule (aif it p . l) (let ((it p)) (if (bool it) . l)))
Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
60
(define-syntax-rule (aaif it p . l) (let ((it p)) (if (abool it) . l)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
61 62

(define-syntax-rule (D x) (lambda () x))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
63

64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
#|
This is the copyright information of the file ported over to scheme
# Copyright (c) 2004 Python Software Foundation.
# All rights reserved.

# Written by Eric Price <eprice at tjhsst.edu>
#    and Facundo Batista <facundo at taniquetil.com.ar>
#    and Raymond Hettinger <python at rcn.com>
#    and Aahz <aahz at pobox.com>
#    and Tim Peters

# This module should be kept in sync with the latest updates of the
# IBM specification as it evolves.  Those updates will be treated
# as bug fixes (deviation from the spec is a compatibility, usability
# bug) and will be backported.  At this point the spec is stabilizing
# and the updates are becoming fewer, smaller, and less significant.
|#

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
82
(define guile:modulo (@ (guile) modulo))
83

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
84 85 86 87 88 89
(define __name__   "decimal")
(define __xname__  __name__)
(define __version__ "1.70")
;; Highest version of the spec this complies with
;; See http://speleotrove.com/decimal/

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
90
(define DecimalTuple (namedtuple "DecimalTuple" "sign,digits,exponent"))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
91

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
92 93 94 95 96 97 98 99 100
;; Rounding
(define ROUND_DOWN      'ROUND_DOWN)
(define ROUND_HALF_UP   'ROUND_HALF_UP)
(define ROUND_HALF_EVEN 'ROUND_HALF_EVEN)
(define ROUND_CEILING   'ROUND_CEILING)
(define ROUND_FLOOR     'ROUND_FLOOR)
(define ROUND_UP        'ROUND_UP)
(define ROUND_HALF_DOWN 'ROUND_HALF_DOWN)
(define ROUND_05UP      'ROUND_05UP)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
101

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
102 103 104 105
;; Compatibility with the C version
(define MAX_PREC 425000000)
(define MAX_EMAX 425000000)
(define MIN_EMIN -425000000)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
106

107
(if (= maxsize  (- (ash 1 63) 1))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
108 109 110 111
    (begin
      (set! MAX_PREC 999999999999999999)
      (set! MAX_EMAX 999999999999999999)
      (set! MIN_EMIN -999999999999999999)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
112

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
113
(define MIN_ETINY  (- MIN_EMIN (- MAX_PREC 1)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
114

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
115
;; Context
116 117 118 119 120 121 122 123 124 125
(define-inlinable (cx-prec     x) (rawref x 'prec))
(define-inlinable (cx-emax     x) (rawref x 'Emax))
(define-inlinable (cx-emin     x) (rawref x 'Emin))
(define-inlinable (cx-etiny    x) ((ref x 'Etiny)))
(define-inlinable (cx-etop     x) ((ref x 'Etop)))
(define-inlinable (cx-copy     x) ((ref x 'copy)))
(define-inlinable (cx-clear_flags x) ((ref x 'clear_flags)))
(define-inlinable (cx-raise    x) (ref x '_raise_error))
(define-inlinable (cx-error    x) (ref x '_raise_error))
(define-inlinable (cx-capitals x) (rawref x 'capitals))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
126
(define-inlinable (cx-cap      x) (rawref x 'capitals))
127 128 129 130 131
(define-inlinable (cx-rounding x) (rawref x 'rounding))
(define-inlinable (cx-clamp    x) (rawref x 'clamp))
(define-inlinable (cx-traps    x) (rawref x 'traps))
(define-inlinable (cx-flags    x) (rawref x 'flags))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
;; Errors

(define-python-class DecimalException (ArithmeticError)
    "Base exception class.

    Used exceptions derive from this.
    If an exception derives from another exception besides this (such as
    Underflow (Inexact, Rounded, Subnormal) that indicates that it is only
    called if the others are present.  This isn't actually used for
    anything, though.

    handle  -- Called when context._raise_error is called and the
               trap_enabler is not set.  First argument is self, second is the
               context.  More arguments can be given, those being after
               the explanation in _raise_error (For example,
               context._raise_error(NewError, '(-x)!', self._sign) would
               call NewError().handle(context, self._sign).)

    To define a new exception, it should be sufficient to have it derive
    from DecimalException.
    "
    
    (define handle
      (lambda (self context . args)
        (values))))


(define-python-class Clamped (DecimalException)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
160
    "Exponent of a 0 changed to fit bounds.
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
161 162 163 164 165 166 167

    This occurs and signals clamped if the exponent of a result has been
    altered in order to fit the constraints of a specific concrete
    representation.  This may occur when the exponent of a zero result would
    be outside the bounds of a representation, or when a large normal
    number would have an encoded exponent that cannot be represented.  In
    this latter case, the exponent is reduced to fit and the corresponding
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
168 169
    number of zero digits are appended to the coefficient ('fold-down').
    ")
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325

(define-python-class InvalidOperation (DecimalException)
    "An invalid operation was performed.

    Various bad things cause this:

    Something creates a signaling NaN
    -INF + INF
    0 * (+-)INF
    (+-)INF / (+-)INF
    x % 0
    (+-)INF % x
    x._rescale( non-integer )
    sqrt(-x) , x > 0
    0 ** 0
    x ** (non-integer)
    x ** (+-)INF
    An operand is invalid

    The result of the operation after these is a quiet positive NaN,
    except when the cause is a signaling NaN, in which case the result is
    also a quiet NaN, but with the original sign, and an optional
    diagnostic information.
    "
    (define handle
      (lambda (self context . args)
        (if (bool args)
	    (let ((ans  (_dec_from_triple
			 (ref (car args) '_sign)
			 (ref (car args) '_int)
			 "n" #t)))
	      ((ref ans '_fix_nan) context))
	    _NaN))))

(define-python-class ConversionSyntax (InvalidOperation)
    "Trying to convert badly formed string.

    This occurs and signals invalid-operation if a string is being
    converted to a number and it does not conform to the numeric string
    syntax.  The result is [0,qNaN].
    "
    (define handle
      (lambda x _NaN)))

(define-python-class DivisionByZero (DecimalException ZeroDivisionError)
    "Division by 0.

    This occurs and signals division-by-zero if division of a finite number
    by zero was attempted (during a divide-integer or divide operation, or a
    power operation with negative right-hand operand), and the dividend was
    not zero.

    The result of the operation is [sign,inf], where sign is the exclusive
    or of the signs of the operands for divide, or is 1 for an odd power of
    -0, for power.
    "

    (define handle
      (lambda (self context sign . args)
        (pylist-ref _SignedInfinity sign))))

(define-python-class DivisionImpossible (InvalidOperation)
    "Cannot perform the division adequately.

    This occurs and signals invalid-operation if the integer result of a
    divide-integer or remainder operation had too many digits (would be
    longer than precision).  The result is [0,qNaN].
    "

    (define handle
      (lambda x _NaN)))

(define-python-class DivisionUndefined (InvalidOperation ZeroDivisionError)
    "Undefined result of division.

    This occurs and signals invalid-operation if division by zero was
    attempted (during a divide-integer, divide, or remainder operation), and
    the dividend is also zero.  The result is [0,qNaN].
    "

    (define handle
      (lambda x _NaN)))

(define-python-class Inexact (DecimalException)
    "Had to round, losing information.

    This occurs and signals inexact whenever the result of an operation is
    not exact (that is, it needed to be rounded and any discarded digits
    were non-zero), or if an overflow or underflow condition occurs.  The
    result in all cases is unchanged.

    The inexact signal may be tested (or trapped) to determine if a given
    operation (or sequence of operations) was inexact.
    ")

(define-python-class InvalidContext (InvalidOperation)
    "Invalid context.  Unknown rounding, for example.

    This occurs and signals invalid-operation if an invalid context was
    detected during an operation.  This can occur if contexts are not checked
    on creation and either the precision exceeds the capability of the
    underlying concrete representation or an unknown or unsupported rounding
    was specified.  These aspects of the context need only be checked when
    the values are required to be used.  The result is [0,qNaN].
    "

    (define handle
      (lambda x _NaN)))

(define-python-class Rounded (DecimalException)
    "Number got rounded (not  necessarily changed during rounding).

    This occurs and signals rounded whenever the result of an operation is
    rounded (that is, some zero or non-zero digits were discarded from the
    coefficient), or if an overflow or underflow condition occurs.  The
    result in all cases is unchanged.

    The rounded signal may be tested (or trapped) to determine if a given
    operation (or sequence of operations) caused a loss of precision.
    ")

(define-python-class Subnormal (DecimalException)
    "Exponent < Emin before rounding.

    This occurs and signals subnormal whenever the result of a conversion or
    operation is subnormal (that is, its adjusted exponent is less than
    Emin, before any rounding).  The result in all cases is unchanged.

    The subnormal signal may be tested (or trapped) to determine if a given
    or operation (or sequence of operations) yielded a subnormal result.
    ")

(define-python-class Overflow (Inexact Rounded)
    "Numerical overflow.

    This occurs and signals overflow if the adjusted exponent of a result
    (from a conversion or from an operation that is not an attempt to divide
    by zero), after rounding, would be greater than the largest value that
    can be handled by the implementation (the value Emax).

    The result depends on the rounding mode:

    For round-half-up and round-half-even (and for round-half-down and
    round-up, if implemented), the result of the operation is [sign,inf],
    where sign is the sign of the intermediate result.  For round-down, the
    result is the largest finite number that can be represented in the
    current precision, with the sign of the intermediate result.  For
    round-ceiling, the result is the same as for round-down if the sign of
    the intermediate result is 1, or is [0,inf] otherwise.  For round-floor,
    the result is the same as for round-down if the sign of the intermediate
    result is 0, or is [1,inf] otherwise.  In all cases, Inexact and Rounded
    will also be raised.
    "

    (define handle
      (let ((l (list ROUND_HALF_UP ROUND_HALF_EVEN
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
326
		     ROUND_HALF_DOWN ROUND_UP)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364
	(lambda (self context sign . args)
	  (let/ec ret
	    (if (memq (ref context 'rounding) l)
		(ret (pylist-ref _SignedInfinity sign)))
            
	    (if (= sign 0)
		(if (eq? (ref context 'rounding) ROUND_CEILING)
		    (ret (pylist-ref _SignedInfinity sign))
		    (ret (_dec_from_triple
			  sign
			  (* "9" (cx-prec context))
			  (+ (- (cx-emax context) (cx-prec context)) 1)))))

	    (if (= sign 1)
		(if (eq? (ref context 'rounding) ROUND_FLOOR)
		    (ret (pylist-ref _SignedInfinity sign))
		    (ret (_dec_from_triple
			  sign
			  (* "9" (cx-prec context))
			  (+ (- (cx-emax context) (cx-prec context)) 1))))))))))


(define-python-class Underflow (Inexact Rounded Subnormal)
    "Numerical underflow with result rounded to 0.

    This occurs and signals underflow if a result is inexact and the
    adjusted exponent of the result would be smaller (more negative) than
    the smallest value that can be handled by the implementation (the value
    Emin).  That is, the result is both inexact and subnormal.

    The result after an underflow will be a subnormal number rounded, if
    necessary, so that its exponent is not less than Etiny.  This may result
    in 0 with the sign of the intermediate result and an exponent of Etiny.

    In all cases, Inexact, Rounded, and Subnormal will also be raised.
    ")

(define-python-class FloatOperation (DecimalException TypeError)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
365
    "Enable stricter semantics for mixing floats and Decimals.
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
366 367 368 369 370 371 372 373 374 375 376

    If the signal is not trapped (default), mixing floats and Decimals is
    permitted in the Decimal() constructor, context.create_decimal() and
    all comparison operators. Both conversion and comparisons are exact.
    Any occurrence of a mixed operation is silently recorded by setting
    FloatOperation in the context flags.  Explicit conversions with
    Decimal.from_float() or context.create_decimal_from_float() do not
    set the flag.

    Otherwise (the signal is trapped), only equality comparisons and explicit
    conversions are silent. All other mixed operations raise FloatOperation.
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
377
    ")
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
378

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
379 380
;; List of public traps and flags
(define _signals
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
381 382 383
  (list Clamped DivisionByZero Inexact Overflow Rounded
	Underflow InvalidOperation Subnormal FloatOperation))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
384 385
;; Map conditions (per the spec) to signals
(define _condition_map
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
386 387 388 389 390
  (dict
   `((,ConversionSyntax   . ,InvalidOperation)
     (,DivisionImpossible . ,InvalidOperation)
     (,DivisionUndefined  . ,InvalidOperation)
     (,InvalidContext     . ,InvalidOperation))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
391

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
392 393
;; Valid rounding modes
(define _rounding_modes
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
394
  (list ROUND_DOWN ROUND_HALF_UP ROUND_HALF_EVEN ROUND_CEILING
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
395
	ROUND_FLOOR ROUND_UP ROUND_HALF_DOWN ROUND_05UP))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
396

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
397 398 399 400 401 402 403 404 405
;; ##### Context Functions ##################################################

;; The getcontext() and setcontext() function manage access to a thread-local
;; current context.
(define *context* (make-fluid #f))
(define (getcontext)
  (fluid-ref *context*))
(define (setcontext context)
  (fluid-set! *context* context))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
406

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
407 408 409 410 411 412 413 414 415 416 417 418 419 420
;; ##### Decimal class #######################################################

;; Do not subclass Decimal from numbers.Real and do not register it as such
;; (because Decimals are not interoperable with floats).  See the notes in
;; numbers.py for more detail.

(define _dec_from_triple
  (lam (sign coefficient exponent (= special #f))
    "Create a decimal instance directly, without any validation,
    normalization (e.g. removal of leading zeros) or argument
    conversion.

    This function is for *internal use only*.
    "
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
421 422 423 424 425 426 427 428 429 430 431
    (Decimal sign coefficient exponent special)))

(define (get-parsed-sign m)
  (if (equal? ((ref m 'group) "sign") "-")
      1
      0))

(define (get-parsed-int m)
  ((ref m 'group) "int"))

(define (get-parsed-frac m)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
432 433 434 435
  (let ((r ((ref m 'group) "frac")))
    (if (eq? r None)
	""
	r)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
436 437

(define (get-parsed-exp m)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
438 439 440 441
  (let ((r ((ref m 'group) "exp")))
    (if (eq? r None)
	0
	(string->number r))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
442

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
443 444 445 446 447 448 449
(define (get-parsed-diag m)
  ((ref m 'group) "diag"))

(define (get-parsed-sig m)
  ((ref m 'group) "signal"))

(def (_mk self __init__ (= value "0") (= context None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475
       "Create a decimal point instance.

        >>> Decimal('3.14')              # string input
        Decimal('3.14')
        >>> Decimal((0, (3, 1, 4), -2))  # tuple (sign, digit_tuple, exponent)
        Decimal('3.14')
        >>> Decimal(314)                 # int
        Decimal('314')
        >>> Decimal(Decimal(314))        # another decimal instance
        Decimal('314')
        >>> Decimal('  3.14  \\n')        # leading and trailing whitespace okay
        Decimal('3.14')
        "

        ;; Note that the coefficient, self._int, is actually stored as
        ;; a string rather than as a tuple of digits.  This speeds up
        ;; the "digits to integer" and "integer to digits" conversions
        ;; that are used in almost every arithmetic operation on
        ;; Decimals.  This is an internal detail: the as_tuple function
        ;; and the Decimal constructor still deal with tuples of
        ;; digits.

        ;; From a string
        ;; REs insist on real strings, so we can too.
        (cond
	 ((isinstance value str)
476 477
          (let ((m (_parser (scm-str value))))
            (if (not (bool m))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
478 479 480 481 482 483 484 485 486 487 488 489 490 491
                (let ((context (if (eq? context None)
				   (getcontext)
				   context)))
		  ((cx-raise context)
		   ConversionSyntax
		   (+ "Invalid literal for Decimal: " value))))

	      (let ((sign     (get-parsed-sign m))
		    (intpart  (get-parsed-int  m))
		    (fracpart (get-parsed-frac m))
		    (exp      (get-parsed-exp  m))
		    (diag     (get-parsed-diag m))
		    (signal   (get-parsed-sig  m)))
		
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
492
		(set self '_sign sign)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
493 494 495 496 497
		
		(if (not (eq? intpart None))
		    (begin
		      (set self '_int (str (int (+ intpart fracpart))))
		      (set self '_exp (- exp (len fracpart)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
498
		      (set self '_is_special #f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
499 500 501 502 503 504 505 506 507 508
		    (begin
		      (if (not (eq? diag None))
			  (begin
			    ;; NaN
			    (set self '_int
				 (py-lstrip (str (int (if (bool diag)
							  diag
							  "0")))
					    "0"))
			    (if signal
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
509 510
				(set self '_exp 'N)
				(set self '_exp 'n)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
511 512 513
			  (begin
			    ;; infinity
			    (set self '_int "0")
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
514
			    (set self '_exp 'F)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534
		      (set self '_is_special #t))))))
	 
	;; From an integer	   
        ((isinstance value int)
	 (if (>= value 0)
	     (set self '_sign 0)
	     (set self '_sign 1))
	 (set self '_exp 0)
         (set self '_int (str (abs value)))
	 (set self '_is_special #f))
	
        ;; From another decimal
        ((isinstance value Decimal)
            (set self '_exp        (ref value '_exp       ))
            (set self '_sign       (ref value '_sign      ))
            (set self '_int        (ref value '_int       ))
            (set self '_is_special (ref value '_is_special)))

        ;; From an internal working value
        ((isinstance value _WorkRep)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
535 536
	 (set self '_exp        (int (ref value 'exp)))
	 (set self '_sign       (ref value 'sign))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570
	 (set self '_int        (str (ref value 'int)))
	 (set self '_is_special #f))

        ;; tuple/list conversion (possibly from as_tuple())
        ((isinstance value (list list tuple))
            (if (not (= (len value) 3))
                (raise (ValueError
			(+ "Invalid tuple size in creation of Decimal "
			   "from list or tuple.  The list or tuple "
			   "should have exactly three elements."))))
	    ;; # process sign.  The isinstance test rejects floats
	    (let ((v0 (pylist-ref value 0))
		  (v1 (pylist-ref value 1))
		  (v2 (pylist-ref value 2)))
	      (if (not (and (isinstance v0 int)
			    (or (= v0 0) (= v0 1))))
		  (raise (ValueError
			  (+ "Invalid sign.  The first value in the tuple "
			     "should be an integer; either 0 for a "
			     "positive number or 1 for a negative number."))))
	      (set self '_sign v0)
            (if (eq? v2 'F)
		(begin
		  (set self '_int "0")
		  (set self '_exp v2)
		  (set self 'is_special #t))
		(let ((digits (py-list)))
		  ;; process and validate the digits in value[1]
		  (for ((digit : v1)) ()
		       (if (and (isinstance digit int)
				(<= 0 digit)
				(<= digit 9))
			   ;; skip leading zeros
			   (if (or (bool digits) (> digit 0))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
571
			       (pylist-append! digits digit))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599
			   (raise (ValueError
				   (+ "The second value in the tuple must "
				      "be composed of integers in the range "
				      "0 through 9.")))))
		  
		  (cond
		   ((or (eq? v2 'n) (eq? v2 'N))
		    (begin
		      ;; NaN: digits form the diagnostic
		      (set self '_int  (py-join "" (map str digits)))
		      (set self '_exp  v2)
			(set self '_is_special #t)))
		   ((isinstance v2  int)
		    ;; finite number: digits give the coefficient
		    (set self '_int (py-join "" (map str digits)))
		    (set self '_exp v2)
		    (set self '_is_special #f))
		   (else
		    (raise (ValueError
			    (+ "The third value in the tuple must "
			       "be an integer, or one of the "
			       "strings 'F', 'n', 'N'.")))))))))

	((isinstance value float)
	 (let ((context (if (eq? context None)
			    (getcontext)
			    context)))
	   ((cx-error context)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
600
	    FloatOperation
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
601 602 603 604 605 606 607
	    (+ "strict semantics for mixing floats and Decimals are "
	       "enabled"))
	   
	   (__init__ self ((ref Decimal 'from_float) value))))

	(else
	 (raise (TypeError
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
608
		 (format #f "Cannot convert ~a to Decimal" value))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
609

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
610
(define-inlinable (divmod x y)
611
  (values (floor-quotient x y) (floor-remainder x y)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
612 613

(define-syntax twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
614
  (syntax-rules (when let let* if)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
615
    ((_ a) a)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
616 617 618
    ((_ (let () a ...) . l)
     (begin a ... (twix . l)))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
619 620
    ((_ (let ((a aa) ...) b ...) . l)
     (let ((a aa) ...) b ... (twix . l)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
621
    ((_ (let (a ...)) . l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
622 623 624 625 626
     (a ... (twix . l)))
    ((_ (let* (a ...) b ...) . l)
     (let* (a ...) b ... (twix . l)))
    ((_ (if . u) . l)
     (begin (if . u) (twix . l)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
627 628
    ((_ (when . u) . l)
     (begin (when . u) (twix . l)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
629
    ((_ (a it code ...) . l)
Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
630
     (aaif it a (begin code ...) (twix . l)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
631

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
632
(define-syntax-rule (norm-op self op)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
633
  (begin
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
634
    (set! op (_convert_other op))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
635
    (if (eq? op NotImplemented)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
636
	op
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
637 638 639 640 641 642 643 644 645
	#f)))

(define-syntax-rule (get-context context code)
  (let ((context (if (eq? context None)
		     (getcontext)
		     context)))
    code))

(define-syntax-rule (un-special self context)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
646
  (if (ref self '_is_special)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
647 648
      (let ((ans ((ref self '_check_nans) #:context context)))
	(if (bool ans)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
649
	    ans
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
650 651 652 653 654 655
	    #f))
      #f))

(define-syntax-rule (bin-special o1 o2 context)
  (if (or (ref o1  '_is_special)
	  (ref o2  '_is_special))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
656 657
      (or (un-special o1 context) (un-special o2 context))
      #f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
658 659 660

(define-syntax-rule (add-special self other context)
  (or (bin-special self other context)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
661
      (if (bool ((ref self '_isinfinity)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
662 663 664
	  ;; If both INF, same sign =>
	  ;; same as both, opposite => error.
	  (if (and (not (= (ref self '_sign) (ref other '_sign)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
665
		   (bool ((ref other '_isinfinity))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
666 667
	      ((cx-error context) InvalidOperation "-INF + INF")
	      (Decimal self))	      
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
668
	  (if (bool ((ref other '_isinfinity)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
669
	      (Decimal other) ; Can't both be infinity here
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
670 671
	      #f))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
672
(define-syntax-rule (mul-special self other context resultsign)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
673 674 675 676
  (if (or (ref self '_is_special) (ref other '_is_special))
      (twix
       ((bin-special self other context) it it)
	       
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
677
       ((if (bool ((ref self '_isinfinity)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
678 679 680 681 682
	    (if (not (bool other))
		((cx-error context) InvalidOperation "(+-)INF * 0")
		(pylist-ref _SignedInfinity resultsign))
	    #f) it it)

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
683
       (if (bool ((ref other '_isinfinity)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
684 685 686 687 688 689
	   (if (not (bool self))
	       ((cx-error context) InvalidOperation "(+-)INF * 0")
	       (pylist-ref _SignedInfinity resultsign))
	   #f))
      #f))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
690 691 692 693 694
(define-syntax-rule (div-special self other context sign)
  (if (or (ref self '_is_special) (ref other '_is_special))
      (twix
       ((bin-special self other context) it it)
       
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
695
       ((and (bool ((ref self '_isinfinity))) (bool ((ref other '_isinfinity)))) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
696
	((cx-error context) InvalidOperation "(+-)INF/(+-)INF"))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
697

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
698
       ((bool ((ref self '_isinfinity))) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
699
	(pylist-ref _SignedInfinity sign))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
700

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
701
       ((bool ((ref other '_isinfinity))) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
702
	((cx-error context) Clamped "Division by infinity")
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
703 704
	(_dec_from_triple sign  "0" (cx-etiny context))))
      #f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
705
        
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
706

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723
(define-python-class Decimal (object)
    "Floating point class for decimal arithmetic."
    
    
    ;; Generally, the value of the Decimal instance is given by
    ;;  (-1)**_sign * _int * 10**_exp
    ;; Special values are signified by _is_special == True

    (define __init__
      (case-lambda
       ((self sign coefficient exponent special)
	(set self '_sign       sign)
	(set self '_int        coefficient)
	(set self '_exp        exponent)
	(set self '_is_special special))
       
       ((self)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
724
	(_mk self __init__))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
725
       ((self a)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
726
	(_mk self __init__ a))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
727
       ((self a b)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
728
	(_mk self __init__ a b))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
729

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
730
    (define from_float
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752
      (classmethod
       (lambda (cls f)
        "Converts a float to a decimal number, exactly.

        Note that Decimal.from_float(0.1) is not the same as Decimal('0.1').
        Since 0.1 is not exactly representable in binary floating point, the
        value is stored as the nearest representable value which is
        0x1.999999999999ap-4.  The exact equivalent of the value in decimal
        is 0.1000000000000000055511151231257827021181583404541015625.

        >>> Decimal.from_float(0.1)
        Decimal('0.1000000000000000055511151231257827021181583404541015625')
        >>> Decimal.from_float(float('nan'))
        Decimal('NaN')
        >>> Decimal.from_float(float('inf'))
        Decimal('Infinity')
        >>> Decimal.from_float(-float('inf'))
        Decimal('-Infinity')
        >>> Decimal.from_float(-0.0)
        Decimal('-0')

        "
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
753 754 755 756
	(define (frexp x)
	  (if (< x 0) (set! x (- x)))
	  
	  (let lp ((l (string->list (format #f "~e" x))) (r1 '()))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
757
	    (ice:match l
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
758 759
	       ((#\. . l)
		(let lp ((l l) (r2 '()))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
760
		  (ice:match l
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
761
		    ((#\E . l)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
762
		     (let* ((n (length r2))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
763
			    (m (list->string (append (reverse r1) (reverse r2))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
764
			    (e (+ (- n) (string->number (list->string l)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
765 766 767 768 769 770
		       (cons m e)))
		    ((x . l)
		     (lp l (cons x r2))))))
	       
	       ((x . l)
		(lp l (cons x r1))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
771 772

	(cond
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
773 774 775 776 777 778
	 ((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
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
779 780 781
		((nan? f)          "Nan")
		((eq? f (inf))     "Inf")
		((eq? f (- (inf))) "-Inf"))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
782 783 784
	 (else
	  (let* ((sign (if (>= f 0) 0 1))
		 (me   (frexp f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
785 786 787
		 (m    (car me))
		 (e    (cdr me))
		 (res  (_dec_from_triple sign m e)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
788 789
	    (if (eq? cls Decimal)
		res
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
790
		(cls res))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807
    
    (define _isnan
      (lambda (self)
        "Returns whether the number is not actually one.

        0 if a number
        1 if NaN
        2 if sNaN
        "
        (if (ref self '_is_special)
            (let ((exp (ref self '_exp)))
	      (cond
	       ((eq? exp 'n) 1)
	       ((eq? exp 'N) 2)
	       (else         0)))
	    0)))
    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
808
    (define _isinfinity 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
809 810 811 812 813 814 815 816 817 818 819
      (lambda (self)
        "Returns whether the number is infinite

        0 if finite or not a number
        1 if +INF
        -1 if -INF
        "
        (if (eq? (ref self '_exp) 'F)
            (if (eq? (ref self '_sign) 1)
                -1
		1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
820
	    0)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838
    
    (define _check_nans
      (lam (self (= other None) (= context None))
        "Returns whether the number is not actually one.

        if self, other are sNaN, signal
        if self, other are NaN return nan
        return 0

        Done before operations.
        "

        (let ((self_is_nan ((ref self '_isnan)))
	      (other_is_nan
	       (if (eq? other None)
		   #f
		   ((ref other '_isnan)))))
	  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
839
	  (if (or (bool self_is_nan) (bool other_is_nan))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
840 841 842 843 844 845 846 847
	      (let ((context (if (eq? context None)
				 (getcontext)
				 context)))
		(cond
		 ((eq? self_is_nan 2)
		  ((cx-error context) InvalidOperation "sNaN" self))
		 ((eq? other_is_nan 2)
		  ((cx-error context) InvalidOperation "sNaN" other))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
848
		 ((bool self_is_nan)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896
		  ((ref self '_fix_nan) context))
		 (else
		  ((ref other '_fix_nan) context))))
	      0))))
		 

    (define _compare_check_nans
      (lambda (self other context)
        "Version of _check_nans used for the signaling comparisons
        compare_signal, __le__, __lt__, __ge__, __gt__.

        Signal InvalidOperation if either self or other is a (quiet
        or signaling) NaN.  Signaling NaNs take precedence over quiet
        NaNs.

        Return 0 if neither operand is a NaN.

        "
        (let ((context (if (eq? context None)
			   (getcontext)
			   context)))

	  (if (or (ref self  '_is_special)
		  (ref other '_is_special))
	      (cond
	       (((ref self 'is_snan))
		((cx-error context)
		 InvalidOperation
		 "comparison involving sNaN" self))

 	       (((ref other 'is_snan))
		((cx-error context)
		 InvalidOperation
		 "comparison involving sNaN" other))
		
	       (((ref self 'is_qnan))
		((cx-error context)
		 InvalidOperation
		 "comparison involving NaN" self))

 	       (((ref other 'is_qnan))
		((cx-error context)
		 InvalidOperation
		 "comparison involving NaN" other))
	       
	       (else 0))
	      0))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
897
    (define __bool__
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
898 899 900 901 902
      (lambda (self)
        "Return True if self is nonzero; otherwise return False.

        NaNs and infinities are considered nonzero.
        "
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
903
        (or (ref self '_is_special) (not (equal? (ref self '_int) "0")))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920

    (define _cmp
      (lambda (self other)
        "Compare the two non-NaN decimal instances self and other.

        Returns -1 if self < other, 0 if self == other and 1
        if self > other.  This routine is for internal use only."

	(let ((self_sign  (ref self  '_sign))
	      (other_sign (ref other '_sign)))
	  (cond
	   ((or (ref self '_is_special) (ref other '_is_special))
	    (let ((self_inf  ((ref self  '_isinfinity)))
		  (other_inf ((ref other '_isinfinity))))
	      (cond
	       ((eq? self_inf other_inf) 0)
	       ((< self_inf other_inf)  -1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
921
	       (else                     1))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
922
	    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
923 924 925 926 927 928 929 930 931 932 933 934 935
	   ;; check for zeros;  Decimal('0') == Decimal('-0')
	   ((not (bool self))
	    (if (not (bool other))
		0
		(let ((s (ref other '_sign)))
		  (if (= s 0)
		      -1
		      1))))
	   ((not (bool other))
	    (let ((s (ref self '_sign)))
	      (if (= s 0)
		  1
		  -1)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
936
	  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971
	   ((< other_sign self_sign)
	    -1)
	   ((< self_sign other_sign)
	    1)

	   (else
	    (let ((self_adjusted  ((ref self  'adjusted)))
		  (other_adjusted ((ref other 'adjusted)))
		  (self_exp       (ref self  '_exp))
		  (other_exp      (ref other '_exp)))
	      (cond
	       ((= self_adjusted other_adjusted)
		(let ((self_padded  (+ (ref self '_int)
				       (* "0" (- self_exp  other_exp))))
		      (other_padded (+ (ref other '_int)
				       (* "0" (- other_exp  self_exp)))))
		  (cond
		   ((equal? self_padded other_padded)
		    0)
		   ((< self_padded other_padded)
		    (if (= self_sign 0)
			-1
			1))
		   (else
		    (if (= self_sign 0)
			1
			-1)))))
	       ((> self_adjusted other_adjusted)
		(if (= self_sign 0)
		    1
		    -1))
	       (else
		(if (= self_sign 0)
		    -1
		    1)))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
972 973 974 975 976 977 978 979 980 981 982 983 984 985
    
    ;; Note: The Decimal standard doesn't cover rich comparisons for
    ;; Decimals.  In particular, the specification is silent on the
    ;; subject of what should happen for a comparison involving a NaN.
    ;; We take the following approach:
    ;;
    ;;   == comparisons involving a quiet NaN always return False
    ;;   != comparisons involving a quiet NaN always return True
    ;;   == or != comparisons involving a signaling NaN signal
    ;;      InvalidOperation, and return False or True as above if the
    ;;      InvalidOperation is not trapped.
    ;;   <, >, <= and >= comparisons involving a (quiet or signaling)
    ;;      NaN signal InvalidOperation, and return False if the
    ;;      InvalidOperation is not trapped.
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
986
    ;;    ;; This behavior is designed to conform as closely as possible to
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
987 988 989 990
    ;; that specified by IEEE 754.
    
    (define __eq__
      (lam (self other (= context None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
991
	   (let* ((so    (_convert_for_comparison self other #:equality_op #t))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
992 993
		  (self  (car so))
		  (other (cdr so)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
994 995 996 997 998 999 1000 1001
	     
	     (cond
	      ((eq? other NotImplemented)
	       other)
	      ((bool ((ref self '_check_nans) other context))
	       #f)
	      (else (= ((ref self '_cmp) other) 0))))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1002
    (define _xlt 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1003 1004
      (lambda (<)
	(lam (self other (= context None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1005
	     (let* ((so (_convert_for_comparison self other #:equality_op #t))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1006 1007
		    (self  (car so))
		    (other (cdr so)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1008 1009 1010 1011 1012 1013
	     
	       (cond
		((eq? other NotImplemented)
		 other)
		((bool ((ref self '_compare_check_nans) other context))
		 #f)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1014
		(else (< ((ref self '_cmp) other) 0)))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1015
      
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1016 1017 1018 1019
    (define __lt__ (lambda x (apply (_xlt <  ) x)))
    (define __le__ (lambda x (apply (_xlt <= ) x)))
    (define __gt__ (lambda x (apply (_xlt >  ) x)))
    (define __ge__ (lambda x (apply (_xlt >= ) x)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1020

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1021
    (define compare 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034
      (lam (self other (= context None))
        "Compare self to other.  Return a decimal value:

        a or b is a NaN ==> Decimal('NaN')
        a < b           ==> Decimal('-1')
        a == b          ==> Decimal('0')
        a > b           ==> Decimal('1')
        "
        (let ((other (_convert_other other #:raiseit #t)))
	  ;; Compare(NaN, NaN) = NaN
	  (if (or (ref self '_is_special)
		  (and (bool other)
		       (ref other '_is_special)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1035 1036 1037 1038
	      (let ((it ((ref self '_check_nans) other context)))
		(if (bool it)
		    it
		    (Decimal ((ref self '_cmp) other))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053

    (define __hash__
      (lambda (self)
	"x.__hash__() <==> hash(x)"

        ;; In order to make sure that the hash of a Decimal instance
        ;; agrees with the hash of a numerically equal integer, float
        ;; or Fraction, we follow the rules for numeric hashes outlined
        ;; in the documentation.  (See library docs, 'Built-in Types').
        (cond
	 ((ref self '_is_special)
	  (cond
	   (((ref self 'is_snan))
	    (raise (TypeError "Cannot hash a signaling NaN value.")))
	   (((ref self 'is_snan))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1054
	    (hash (nan) pyhash-N))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1055
	   ((= 1 (ref self '_sign))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1056
	    (hash (- (inf)) pyhash-N))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1057
	   (else
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1058
	    (hash (inf) pyhash-N))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1059 1060 1061 1062 1063
	    
	 (else
	  (let* ((exp (ref self '_exp))
		 (exp_hash
		  (if (>= exp 0)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1064 1065
		      (pow 10            exp     pyhash-N)
		      (pow _PyHASH_10INV (- exp) pyhash-N)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1066 1067
		 
		 (hash_
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1068
		  (modulo (* (int (ref self '_int)) exp_hash)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080
			   pyhash-N))

		 (ans
		  (if (>= self 0) hash_ (- hash_))))
	    (if (= ans -1) -2 ans))))))
    
    (define as_tuple
      (lambda (self)
        "Represents the number as a triple tuple.

        To show the internals exactly as they are.
        "
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1081
	(DecimalTuple (ref self '_sign)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107
		      (tuple (map int (ref self '_int)))
		      (ref self '_exp))))

    (define as_integer_ratio
      (lambda (self)
        "Express a finite Decimal instance in the form n / d.

        Returns a pair (n, d) of integers.  When called on an infinity
        or NaN, raises OverflowError or ValueError respectively.

        >>> Decimal('3.14').as_integer_ratio()
        (157, 50)
        >>> Decimal('-123e5').as_integer_ratio()
        (-12300000, 1)
        >>> Decimal('0.00').as_integer_ratio()
        (0, 1)
        "
        (if (ref self '_is_special)
            (if ((ref self 'is_nan))
                (raise (ValueError
			"cannot convert NaN to integer ratio"))
                (raise (OverflowError
			"cannot convert Infinity to integer ratio"))))

        (if (not (bool self))
            (values 0 1)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1108 1109 1110 1111 1112 1113 1114
	    (let* ((s (ref self '_sign))
		   (n (int (ref self '_int)))
		   (e (ref self '_exp))
		   (x
		    (* n (if (> exp 0)
			     (expt 10 exp)
			     (/ 1 (expt 10 (- expt)))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1115
	      (values (numerator x)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1116
		      (denominator x))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1117
    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1118
    (define __repr__
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1119 1120 1121
      (lambda (self)
        "Represents the number as an instance of Decimal."
        ;# Invariant:  eval(repr(d)) == d
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1122
        (format #f "Decimal('~a')" (str self))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1123 1124 1125 1126 1127 1128 1129

    (define __str__
      (lam (self  (= eng #f) (= context None))
        "Return string representation of the number in scientific notation.

        Captures all of the information in the underlying representation.
        "
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1130
	(let* ((sign         (if (= (ref self '_sign) 0) "" "-"))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169
	       (exp          (ref self '_exp))
	       (i            (ref self '_int))
	       (leftdigits   (+ exp (len i)))
	       (dotplace     #f)
	       (intpart      #f)
	       (fracpart     #f)
	       (exppart      #f))
	  (cond
	   ((ref self '_is_special)
            (cond
	     ((eq? (ref self '_exp) 'F)
	      (+ sign "Infinity"))
	     ((eq? (ref self '_exp) 'n)
	      (+ sign  "NaN" (ref self '_int)))
	     (else ; self._exp == 'N'
	      (+ sign  "sNaN" (ref self '_int)))))
	   (else
	    ;; dotplace is number of digits of self._int to the left of the
	    ;; decimal point in the mantissa of the output string (that is,
	    ;; after adjusting the exponent)
	    (cond
	     ((and (<= exp 0) (> leftdigits  -6))
	      ;; no exponent required
	      (set! dotplace leftdigits))
	     
	     ((not eng)
	      ;; usual scientific notation: 1 digit on left of the point
	      (set! dotplace 1))
	     
	     ((equal? i "0")
	      ;; engineering notation, zero
	      (set! dotplace (- (modulo (+ leftdigits 1) 3) 1)))
	     (else
	      ;; engineering notation, nonzero
	      (set! dotplace (- (modulo (+ leftdigits 1) 3) 1))))

	    (cond
	     ((<= dotplace 0)
	      (set! intpart "0")
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1170
	      (set! fracpart (+ "." (* "0" (- dotplace)) i)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1171 1172 1173 1174 1175
	     ((>= dotplace (len i))
	      (set! intpart (+ i (* "0" (- dotplace (len i)))))
	      (set! fracpart ""))
	     (else
	      (set! intpart (pylist-slice i None dotplace None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1176
	      (set! fracpart (+ "." (pylist-slice i dotplace None None)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1177 1178 1179

	    (cond
	     ((= leftdigits dotplace)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1180
	      (set! exppart ""))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1181 1182 1183 1184
	     (else
	      (let ((context (if (eq? context None)
				 (getcontext)
				 context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1185
		(set! exppart
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1186
		      (+ (pylist-ref '("e" "E") (cx-capitals context))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1187
			 (format #f "[email protected]" (- leftdigits dotplace)))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1188 1189
	    
	    (+ sign intpart fracpart exppart))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200
    
    (define to_eng_string
      (lam (self (= context None))
        "Convert to a string, using engineering notation if an exponent is needed.
        Engineering notation has an exponent which is a multiple of 3.  This
        can leave up to 3 digits to the left of the decimal place and may
        require the addition of either one or two trailing zeros.
        "
        ((ref self '__str__) #:eng #t #:contect context)))

    (define __neg__
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1201
      (lam (self (= context None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1202 1203 1204 1205 1206
        "Returns a copy with the sign switched.

        Rounds, if it has reason.
        "
	(twix 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1207 1208 1209 1210
	 ((un-special self context) it it)
	 (let* ((context (if (eq? context None)
			     (getcontext)
			     context))
Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
1211
		(ans     (if (and (not (bool self))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1212
				  (not (eq? (cx-rounding context)
Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
1213
					    ROUND_FLOOR)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1214 1215 1216
			     ;; -Decimal('0') is Decimal('0'),
			     ;; not Decimal('-0'), except
			     ;; in ROUND_FLOOR rounding mode.
Stefan Israelsson Tampe's avatar
glob  
Stefan Israelsson Tampe committed
1217 1218
			     ((ref self 'copy_abs))
			     ((ref self 'copy_negate)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1219
	   ((ref ans '_fix) context)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1220

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1221
    (define __pos__
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241
      (lam (self (= context None))
        "Returns a copy, unless it is a sNaN.

        Rounds the number (if more than precision digits)
        "
	(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))
			     (Decimal self))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1242
	   ((ref ans '_fix) context)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1243 1244 1245 1246 1247 1248 1249 1250 1251 1252

    (define __abs__
      (lam (self  (= round #t) (= context None))
	"Returns the absolute value of self.

        If the keyword argument 'round' is false, do not round.  The
        expression self.__abs__(round=False) is equivalent to
        self.copy_abs().
        "
	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1253
	 ((not (bool round)) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1254 1255 1256 1257 1258 1259 1260 1261
	  ((ref self 'copy_abs)))

	 ((un-special self context) it it)

	 (if (= (ref self '_sign) 1)
	     ((ref self '__neg__) #:context context)
	     ((ref self '__pos__) #:context context)))))
    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1262

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1263 1264 1265 1266 1267 1268 1269
    (define __add__
      (lam (self other (= context None))
        "Returns self + other.

        -INF + INF (or the reverse) cause InvalidOperation errors.
        "
	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1270
	 ((norm-op self other) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1271
	 (let (get-context context))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1272

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1273
	 ((add-special self other context) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1274

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1275 1276 1277
	 (let* ((negativezero 0)
		(self_sign    (ref self  '_sign))
		(other_sign   (ref other '_sign))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1278 1279
		(self_exp     (ref self  '_exp))
		(other_exp    (ref other '_exp))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1280
		(prec         (cx-prec context))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1281
		(exp          ((@ (guile) min) self_exp other_exp))		    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1282 1283
		(sign         #f)
		(ans          #f))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1284
	  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1285 1286 1287 1288 1289
	   (if (and (eq? (cx-rounding context) ROUND_FLOOR)
		    (not (= self_sign other_sign)))
	       ;; If the answer is 0, the sign should be negative,
	       ;; in this case.
	       (set! negativezero 1)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1290

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1291 1292
	 ((if (and (not (bool self)) (not (bool other)))
	      (begin
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1293
		(set! sign ((@ (guile) min) self_sign other_sign))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1294 1295 1296 1297 1298 1299
		(if (= negativezero 1)
		    (set! sign 1))
		(set! ans (_dec_from_triple sign "0" exp))
		(set! ans ((ref ans '_fix) context))
		ans)
	      #f) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1300

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1301 1302
	 ((if (not (bool self))
	      (begin
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1303
		(set! exp ((@ (guile) max) exp (- other_exp prec 1)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1304
		(set! ans ((ref other '_rescale) exp
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1305
			   (cx-rounding context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1306 1307 1308
		(set! ans ((ref ans '_fix) context))
		ans)
	      #f) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1309

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1310 1311
	 ((if (not (bool other))
	      (begin
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1312
		(set! exp ((@ (guile) max) exp (- self_exp prec 1)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1313
		(set! ans ((ref self '_rescale) exp
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1314
			   (cx-rounding context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1315 1316 1317 1318
		(set! ans ((ref ans '_fix) context))
		ans)
	      #f) it it)
		
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1319 1320 1321
	 (let* ((op1    (_WorkRep self))
		(op2    (_WorkRep other))
		(ab     (_normalize op1 op2 prec))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1322 1323
		(op1    (car  ab))
		(op2    (cdr  ab))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1324
		(result (_WorkRep))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1325 1326 1327 1328 1329

	 ((cond
	   ((not (= (ref op1 'sign) (ref op2 'sign)))
	    ;; Equal and opposite
	    (twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1330
	     ((equal? self other) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1331 1332 1333 1334 1335
	      (set! ans (_dec_from_triple negativezero "0" exp))
	      (set! ans ((ref ans '_fix) context))
	      ans)
		    
	     (begin
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1336
	       (if (< self other)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350
		   (let ((t op1))
		     (set! op1 op2)
		     (set! op2 t)))
		    
	       (if (= (ref op1 'sign) 1)			
		   (let ((t (ref op1 'sign)))
		     (set result 'sign 1)
		     (set op1 'sign (ref op2 'sign))
		     (set op2 'sign t))
		   (set result 'sign 0))
	       #f)))
	   ((= (ref op1 'sign) 1)
	    (set result 'sign 1)
	    #f)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1351 1352 1353 1354

	   (else
	    (set result 'sign 0)
	    #f)) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1355 1356 1357 1358 1359 1360 1361 1362 1363 1364

	 (begin
	   (if (= (ref op2 'sign) 0)
	       (set result 'int (+ (ref op1 'int) (ref op2 'int)))
	       (set result 'int (- (ref op1 'int) (ref op2 'int))))

	   (set result 'exp (ref op1 'exp))
	   (set! ans (Decimal result))
	   ((ref ans '_fix) context)))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1365
    (define __radd__ (lambda x (apply __add__ x)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1366 1367 1368 1369 1370

    (define __sub__
      (lam (self other (= context None))
	"Return self - other"
	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1371 1372
	 ((norm-op self other)            it it)
	 ((bin-special self other context) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1373 1374 1375 1376 1377
	 ((ref self '__add__)
	  ((ref other 'copy_negate)) #:context context))))

    (define  __rsub__
      (lam (self other (= context None))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1378
	"Return other - self"
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1379
    	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1380
	 ((norm-op self other) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1381
	 ((ref other '__sub__) self  #:context context))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1382 1383 1384 1385 1386 1387 1388 1389

    (define __mul__
      (lam (self other (= context None))
        "Return self * other.

        (+-) INF * 0 (or its reverse) raise InvalidOperation.
        "
	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1390
	 ((norm-op self other) it it)	 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1391 1392
	 (let (get-context context))
	 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1393 1394
	 (let ((resultsign (logxor (ref self  '_sign)
				   (ref other '_sign)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1395

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1396
	 ((mul-special self other context resultsign) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1397

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1398
	 (let ((resultexp (+ (ref self '_exp) (ref other '_exp)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1399 1400

	 ;; Special case for multiplying by zero
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1401
	 ((or (not (bool self)) (not (bool other))) it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1402
	  (let ((ans (_dec_from_triple resultsign "0" resultexp)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1403
	    ((ref ans '_fix) context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1404 1405
	 
	 ;; Special case for multiplying by power of 10
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1406
	 ((equal? (ref self '_int) "1") it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1407
	  (let ((ans (_dec_from_triple resultsign (ref other '_int) resultexp)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1408
	    ((ref ans '_fix) context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1409

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1410
	 ((equal? (ref other '_int) "1") it
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1411
	  (let ((ans (_dec_from_triple resultsign (ref self '_int) resultexp)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1412
	    ((ref ans '_fix) context)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1413 1414 1415 1416

	 (let* ((op1 (_WorkRep self))
		(op2 (_WorkRep other))
		(ans (_dec_from_triple resultsign
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1417
				       (str (* (ref op1 'int) (ref op2 'int)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1418
				       resultexp)))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1419 1420
	   ((ref ans '_fix) context)))))
  
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1421 1422 1423 1424 1425 1426
    (define __rmul__ __mul__)

    (define __truediv__
      (lam (self other (= context None))
	"Return self / other."
	(twix
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1427
	 ((norm-op self other) it it)	 
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1428 1429
	 (let (get-context context))
   
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1430 1431
	 (let ((sign (logxor (ref self  '_sign)
			     (ref other '_sign)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1432

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1433
	 ((div-special self other context sign) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1434 1435

	 ;; Special cases for zeroes
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1436 1437 1438 1439 1440
	 ((if (not (bool other))
	      (if (not (bool self))
		  ((cx-error context) DivisionUndefined "0 / 0")
		  ((cx-error context) DivisionByZero    "x / 0" sign))
	      #f) it it)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1441

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479
	 (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-))))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1480
			      
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1481 1482
	   (let ((ans (_dec_from_triple sign (str coeff) exp)))
	     ((ref ans '_fix) context))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1483

1484 1485 1486
    (define _divide
      (lambda (self other context)	
        "Return (self // other, self % other), to context.prec precision.
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1487 1488 1489

        Assumes that neither self nor other is a NaN, that self is not
        infinite and that other is nonzero.
1490 1491 1492 1493 1494 1495 1496
        "
	(apply values
	(twix
	 (let (let ((sign
		     (logxor (ref self  '_sign)
			     (ref other '_sign)))
		    (ideal_exp
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1497
		     (if (bool ((ref other '_isinfinity)))
1498
			 (ref self '_exp)
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1499
			 ((@ (guile) min) (ref self 'exp) (ref other '_exp))))
1500 1501 1502 1503
		    (expdiff
		     (- ((ref self 'adjusted)) ((ref other 'adjusted)))))))
	 
	 ((or (not (bool self))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1504
	      (bool ((ref other '_isinfinity)))