Changeset 13775 in project


Ignore:
Timestamp:
03/15/09 23:53:13 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/err5rs-arithmetic
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/tags/1.0.0/chicken-primitive-object-inlines.scm

    r13761 r13775  
    979979(define-inline (%even? n) (##core#inline "C_i_evenp" n))
    980980
     981(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
    981982(define-inline (%- x y) ((##core#primitive "C_minus") x y))
    982983(define-inline (%* x y) ((##core#primitive "C_times") x y))
    983984(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
    984 (define-inline (%+ x y) ((##core#primitive "C_plus") x y))
     985
     986(define-inline (%add1 x) (%+ x 1))
     987(define-inline (%sub1 x) (%- x 1))
    985988
    986989(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
  • release/4/err5rs-arithmetic/trunk/chicken-primitive-object-inlines.scm

    r13757 r13775  
    979979(define-inline (%even? n) (##core#inline "C_i_evenp" n))
    980980
     981(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
    981982(define-inline (%- x y) ((##core#primitive "C_minus") x y))
    982983(define-inline (%* x y) ((##core#primitive "C_times") x y))
    983984(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
    984 (define-inline (%+ x y) ((##core#primitive "C_plus") x y))
     985
     986(define-inline (%add1 x) (%+ x 1))
     987(define-inline (%sub1 x) (%- x 1))
    985988
    986989(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r13757 r13775  
    77        (usual-integrations)
    88  (disable-interrupts)
    9         (generic)
    109        (inline)
    1110        (local)
     
    254253;;
    255254
    256 (define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    257 
    258 (define-inline (%check-list loc obj) (unless (%list? obj) (error-type-list loc obj)))
    259 
    260 (define-inline (%check-integer loc obj) (unless (%integer? obj) (error-type-integer loc obj)))
     255(define-inline (%check-fixnum loc obj)
     256  (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     257
     258(define-inline (%check-list loc obj)
     259  (unless (%list? obj) (error-type-list loc obj)) )
     260
     261(define-inline (%check-integer loc obj)
     262  (unless (%integer? obj) (error-type-integer loc obj)) )
    261263
    262264;;
    263265
    264266(define-inline (%check-fixnum-bounds-order loc fx1 fx2)
    265   (unless (%fx<= fx1 fx2)
    266     (error-bounds-order loc start end) ) )
     267  (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
    267268
    268269(define-inline (%check-fixnum-range loc lfx fx hfx)
    269   (unless (%fxclosed? lfx fx hfx)
    270     (error-outside-range loc fx lfx hfx) ) )
     270  (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    271271
    272272;;
     
    284284
    285285(define-inline (%check-fixnum-bits-count loc count start end)
    286   (unless (%fx< (%fxabs count) (%fx- end start))
    287     (error-bits-count loc count start end) ) )
     286  (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) )
    288287
    289288;;
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13766 r13775  
    11;;;; err5rs-arithmetic-fixnums.scm
    22;;;; Kon Lovett, Mar '09
     3
     4;; Issues
     5;;
     6;; - No support for the full-numeric-tower. All operations upon core numerics.
    37
    48;;; Prelude
     
    711  (usual-integrations)
    812  (disable-interrupts)
    9   (fixnum)
    1013  (inline)
    1114  (local)
     
    1922(include "chicken-primitive-object-inlines")
    2023
    21 ;;
    22 
    23 (define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    24 
    25 (define-inline (%check-fixnum-cardinal loc obj)
    26   (unless (and (%fixnum? obj) (%fxcardinal? obj))
    27     (error-type-cardinal-fixnum loc obj) ) )
    28 
    29 ;;
     24;; Argument checking
     25
     26(define-inline (%check-fixnum loc obj)
     27  (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     28
     29(define-inline (%check-fixnum-shift-amount loc obj)
     30  (unless (and (%fixnum? obj)
     31               (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj)))
     32                 (%fxclosed? 0 amt fixnum-precision)))
     33    (error-type-shift-amount loc obj) ) )
    3034
    3135(define-inline (%check-fixnum-bounds-order loc start end)
    32   (unless (%fx<= start end)
    33     (error-bounds-order loc start end) ) )
     36  (unless (%fx<= start end) (error-bounds-order loc start end)) )
    3437
    3538(define-inline (%check-fixnum-range loc lfx fx hfx)
    36   (unless (%fxclosed? lfx fx hfx)
    37     (error-outside-range loc fx lfx hfx) ) )
    38 
    39 ;;
     39  (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    4040
    4141(define-inline (%check-word-bits-range loc obj)
     
    5252  (%check-fixnum-range loc 0 end fixnum-width) )
    5353
    54 (define-inline (%check-fixnum-bits-count loc count start end)
    55   (unless (%fx< count (%fx- end start))
    56     (error-bits-count loc count start end) ) )
    57 
    58 ;;
     54(define-inline (%check-fixnum-bits-count loc obj start end)
     55  (unless (and (%fixnum? obj) (%fxcardinal? obj)) (error-negative-count loc obj))
     56  (unless (%fx< obj (%fx- end start)) (error-bits-count loc obj start end)) )
    5957
    6058(define-inline (%check-zero-division loc fx1 fx2)
    61   (when (%fxzero? fx2)
    62     (error-zero-division loc fx1 fx2) ) )
    63 
    64 ;;
     59  (when (%fxzero? fx2) (error-zero-division loc fx1 fx2)) )
     60
     61;; Fold operations
    6562
    6663;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
     
    8380               (loop (%cdr ls) cur) ) ) ) ) )
    8481
    85 ;;
     82;; Arithmetic
     83
     84(define-inline (%fxdiv0 fxn fxd)
     85  (let* ((quo (%quotient fxn fxd))
     86         (rem (%- fxn (%* quo fxd))))
     87    (cond ((%<= 0 fxd)
     88           (if (%< (%* rem 2) fxd)
     89               (if (%<= (%* rem -2) fxd) quo
     90                   (%- quo 1) )
     91               (%+ quo 1) ) )
     92          ((%< fxd (%* rem -2))
     93           (if (%<= fxd (%* rem 2)) quo
     94               (%+ quo 1) ) )
     95          (else
     96           (%- quo 1) ) ) ) )
     97
     98(define-inline (%fxmod0 fxn fxd)
     99  (let* ((quo (%quotient fxn fxd))
     100         (rem (%- fxn (%* quo fxd))))
     101    (cond ((%<= 0 fxd)
     102           (if (%< (%* rem 2) fxd)
     103               (if (%<= (%* rem -2) fxd) rem
     104                   (%+ rem fxd) )
     105               (%- rem fxd) ) )
     106          ((%< fxd (%* rem -2))
     107           (if (%<= fxd (%* rem 2)) rem
     108               (%- rem fxd) ) )
     109          (else
     110           (%+ rem fxd) ) ) ) )
    86111
    87112(define-inline (%fxdiv0-and-mod0 fxn fxd)
     
    99124           (values (%- quo 1) (%+ rem fxd)) ) ) ) )
    100125
    101 (define-inline (%fxdiv0 fxn fxd)
    102   (let* ((quo (%quotient fxn fxd))
    103          (rem (%- fxn (%* quo fxd))))
    104     (cond ((%<= 0 fxd)
    105            (if (%< (%* rem 2) fxd)
    106                (if (%<= (%* rem -2) fxd) quo
    107                    (%- quo 1) )
    108                (%+ quo 1) ) )
    109           ((%< fxd (%* rem -2))
    110            (if (%<= fxd (%* rem 2)) quo
    111                (%+ quo 1) ) )
    112           (else
    113            (%- quo 1) ) ) ) )
    114 
    115 (define-inline (%fxmod0 fxn fxd)
    116   (let* ((quo (%quotient fxn fxd))
    117          (rem (%- fxn (%* quo fxd))))
    118     (cond ((%<= 0 fxd)
    119            (if (%< (%* rem 2) fxd)
    120                (if (%<= (%* rem -2) fxd) rem
    121                    (%+ rem fxd) )
    122                (%- rem fxd) ) )
    123           ((%< fxd (%* rem -2))
    124            (if (%<= fxd (%* rem 2)) rem
    125                (%- rem fxd) ) )
    126           (else
    127            (%+ rem fxd) ) ) ) )
    128 
    129126(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
     127
     128(define-inline (%fxsamesign fx1 fx2)
     129  (or (and (%fxpositive? fx1) (%fxpositive? fx2)) (and (%fxnegative? fx1) (%fxnegative? fx2))) )
     130
     131(define-inline (%underflowed? resfx argfx)
     132  (if (%fxsamesign resfx argfx) (%fx> resfx argfx)
     133      (%fx< resfx argfx) ) )
     134
     135(define-inline (%overflowed? resfx argfx)
     136  (if (%fxsamesign resfx argfx) (%fx< resfx argfx)
     137      (%fx> resfx argfx) ) )
    130138
    131139;;;
     
    144152  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
    145153  fx+ fx- fx*
    146   fxand fxior fxxor ;fxnot - from chicken
     154  fxnot fxand fxior fxxor
    147155  fxif
    148156  fxbit-count
     
    156164  fxreverse-bit-field
    157165  ;; Extras
     166  fx<>?
    158167  fxcompare
    159168  fxabs
     
    164173  fxpow2log2
    165174  fixnum->string
    166   fx#- fx#+ fx#* fx#/
    167175  ; Macros
    168   *fx=? *fx<? *fx>? *fx<=? *fx>=?
     176  *fx=? *fx<? *fx>? *fx<=? *fx>=? *fx<>?
    169177  *fxmax *fxmin
    170178  *fx- *fx+ *fx* *fx/
    171179  *fxand *fxior *fxxor
    172180  ; Macro helpers
    173   $fx= $fx< $fx> $fx>= $fx<=
     181  $fx= $fx< $fx> $fx>= $fx<= $fx<>
    174182  $fxmax $fxmin
    175183  $fxand $fxior $fxxor
     
    180188          (fxmax chicken:fxmax)
    181189          (fxmin chicken:fxmin)
     190          (fxnot chicken:fxnot)
    182191          (fxand chicken:fxand)
    183192          (fxior chicken:fxior)
     
    199208(define (make-arithmetic-condition loc msg args)
    200209  (make-composite-condition
    201     (make-exn-condition loc msg args)
    202     (make-property-condition 'arithmetic)) )
     210   (make-exn-condition loc msg args)
     211   (make-property-condition 'arithmetic)) )
     212
     213(define (make-shift-amount-condition loc amt)
     214  (make-arithmetic-condition loc "invalid shift amount" amt) )
    203215
    204216(define (make-zero-division-condition loc fx1 fx2)
     
    206218
    207219; &implementation-restriction
    208 (define (make-fixnum-representation-condition loc fx1 fx2)
    209   (make-arithmetic-condition loc "result not representable as fixnum" (list fx1 fx2)) )
     220(define (make-fixnum-representation-condition loc args)
     221  (make-arithmetic-condition loc "result not representable as fixnum" args) )
    210222
    211223;;; Errors
     
    214226  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    215227
    216 (define (error-type-cardinal-fixnum loc obj)
    217   (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal fixnum" obj) )
    218 
    219228(define (error-type-radix loc radix)
    220229  (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
     
    226235  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
    227236
     237(define (error-negative-count loc count)
     238  (##sys#signal-hook #:bounds-error loc "cannot be negative" count) )
     239
    228240(define (error-bits-count loc count start end)
    229241  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    230242
     243(define (error-type-shift-amount loc obj)
     244  (abort (make-shift-amount-condition loc args)) )
     245
    231246(define (error-zero-division loc fx1 fx2)
    232247  (abort (make-zero-division-condition loc fx1 fx2)) )
    233248
    234 (define (error-fixnum-representation loc fx1 fx2)
    235   (abort (make-fixnum-representation-condition loc fx1 fx2)) )
     249(define (error-fixnum-representation loc . args)
     250  (abort (make-fixnum-representation-condition loc args)) )
    236251
    237252;;; Constants
     
    246261(define ($fx>= x y) (%fx>= x y))
    247262(define ($fx<= x y) (%fx<= x y))
     263(define ($fx<> x y) (not (%fx= x y)))
    248264(define ($fx+ x y) (%fx+ x y))
    249265(define ($fx- x y) (%fx- x y))
     
    286302;;
    287303
     304(define (fxnot fx)
     305  (%check-fixnum 'fxnot fx)
     306  (%fxnot fx) )
     307
    288308(define (fxand fx . fxs) (%fxfold 'fxand $fxand fx fxs))
    289309(define (fxior fx . fxs) (%fxfold 'fxior $fxior fx fxs))
     
    317337  (%check-fixnum 'fx+ fx1)
    318338  (%check-fixnum 'fx+ fx2)
    319   (%fx+ fx1 fx2) )
     339  (let ((sum (%fx+ fx1 fx2)))
     340    (if (not (or (%underflowed? sum fx1) (%underflowed? sum fx2))) sum
     341        (error-fixnum-representation 'fx+ fx1 fx2) ) ) )
    320342
    321343(define (fx- fx1 #!optional fx2)
    322344  (%check-fixnum 'fx- fx1)
    323   (if (not fx2) (%fxneg fx1)
    324       (begin
    325         (%check-fixnum 'fx- fx2)
    326         (%fx- fx1 fx2) ) ) )
     345  (cond (fx2
     346         (%check-fixnum 'fx- fx2)
     347         (let ((dif (%fx- fx1 fx2)))
     348           (if (not (or (%overflowed? dif fx1) (%overflowed? dif fx2))) dif
     349               (error-fixnum-representation 'fx- fx1 fx2) ) ) )
     350        ((%fx= fx1 most-negative-fixnum)
     351         (error-fixnum-representation 'fx- fx1) ) ;R6RS says raise &assertion but unsymmetrical
     352        (else
     353         (%fxneg fx1) ) ) )
    327354
    328355(define (fx* fx1  fx2)
    329356  (%check-fixnum 'fx* fx1)
    330357  (%check-fixnum 'fx* fx2)
    331   (%fx* fx1 fx2) )
     358  (let ((prd (%fx* fx1 fx2)))
     359    (if (not (or (%underflowed? prd fx1) (%underflowed? prd fx2))) prd
     360        (error-fixnum-representation 'fx* fx1 fx2) ) ) )
    332361
    333362(define (fxdiv fxn fxd)
     
    335364  (%check-fixnum 'fxdiv fxd)
    336365  (%check-zero-division 'fxdiv fxn fxd)
    337   (%fx/ fxn fxd) )
     366  (let ((quo (%fx/ fxn fxd)))
     367    (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
     368        (error-fixnum-representation 'fxdiv fxn fxd) ) ) )
    338369
    339370(define (fxmod fxn fxd)
     
    347378  (%check-fixnum 'fxdiv-and-mod fxd)
    348379  (%check-zero-division 'fxdiv fxn fxd)
    349   (values (%fx/ fxn fxd) (%fxmod fxn fxd)) )
     380  (let ((quo (%fx/ fxn fxd)))
     381    (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) (values quo (%fxmod fxn fxd))
     382        (error-fixnum-representation 'fx/ fxn fxd) ) ) )
     383
     384;;
    350385
    351386(define (fxdiv0 fxn fxd)
     
    373408        (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
    374409
     410;;
     411
    375412(define (fx*/carry fx1 fx2 fx3)
    376413  (%check-fixnum 'fx*/carry fx1)
     
    394431    (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
    395432
     433;;
     434
     435;invariant - (fixnum? (floorÊ(*ÊfxÊ(exptÊ2Êamount))))
     436
    396437(define (fxarithmetic-shift fx amount)
    397438  (%check-fixnum 'fxarithmetic-shift fx)
    398   (%check-fixnum 'fxarithmetic-shift amount)
    399   (if (%fxpositive? amount) (%fxshr fx (%fxneg amount))
     439  (%check-fixnum-shift-amount 'fxarithmetic-shift amount)
     440  (if (%fxnegative? amount) (%fxshr fx (%fxneg amount))
    400441      (%fxshl fx amount) ) )
    401442
    402443(define (fxarithmetic-shift-left fx amount)
    403444  (%check-fixnum 'fxarithmetic-shift-left fx)
    404   (%check-fixnum-cardinal 'fxarithmetic-shift-left amount)
     445  (%check-fixnum-shift-amount 'fxarithmetic-shift-left amount)
    405446  (%fxshl fx amount) )
    406447
    407448(define (fxarithmetic-shift-right fx amount)
    408449  (%check-fixnum 'fxarithmetic-shift-right fx)
    409   (%check-fixnum-cardinal 'fxarithmetic-shift-right amount)
     450  (%check-fixnum-shift-amount 'fxarithmetic-shift-right amount)
    410451  (%fxshr fx amount) )
    411452
     
    459500  (%check-fixnum 'fxrotate-bit-field fx)
    460501  (%check-bits-range 'fxrotate-bit-field start end)
    461   (%check-fixnum-cardinal 'fxrotate-bit-field count)
    462502  (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
    463503  (*bitwise-rotate-bit-field fx start end count) )
     
    471511
    472512;;
     513
     514(define (fx<>? fx . fxs) (%fxand-fold 'fx<>? $fx<> fx fxs))
    473515
    474516(define (fxcompare fx1 fx2)
     
    491533(define (fxadd1 fx)
    492534  (%check-fixnum 'fxadd1 fx)
    493   (%fxadd1 fx) )
     535  (let ((sum (%fxadd1 fx)))
     536    (if (not (or (%underflowed? sum fx) (%underflowed? sum 1))) sum
     537        (error-fixnum-representation 'fxadd1 fx) ) ) )
    494538
    495539(define (fxsub1 fx)
    496540  (%check-fixnum 'fxsub1 fx)
    497   (%fxsub1 fx) )
    498 
    499 (define (fx/ fx1  fx2)
     541  (let ((dif (%fxsub1 fx)))
     542    (if (not (or (%overflowed? dif fx) (%overflowed? dif 1))) dif
     543        (error-fixnum-representation 'fxsub1 fx) ) ) )
     544
     545(define (fx/ fxn fxd)
    500546  (%check-fixnum 'fx/ fxn)
    501547  (%check-fixnum 'fx/ fxd)
    502548  (%check-zero-division 'fx/ fxn fxd)
    503   (%fx/ fxn fxd) )
     549  (let ((quo (%fx/ fxn fxd)))
     550    (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
     551        (error-fixnum-representation 'fx/ fxn fxd) ) ) )
    504552
    505553(define (fxquotient fxn fxd)
     
    507555  (%check-fixnum 'fxquotient fxd)
    508556  (%check-zero-division 'fxquotient fxn fxd)
    509   (%fx/ fxn fxd) )
     557  (let ((quo (%fx/ fxn fxd)))
     558    (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
     559        (error-fixnum-representation 'fxquotient fxn fxd) ) ) )
    510560
    511561(define (fxremainder fxn fxd)
     
    513563  (%check-fixnum 'fxremainder fxd)
    514564  (%check-zero-division 'fxremainder fxn fxd)
    515   (%fx- fxn (%fx* (%fx/ fxn fxd) fxd)) )
     565  (let ((quo (%fx/ fxn fxd)))
     566    (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) (%fx- fxn (%fx* quo fxd))
     567        (error-fixnum-representation 'fxquotient fxn fxd) ) ) )
    516568
    517569;;
     
    565617;;
    566618
    567 (define (fx#- fx . fxs)
    568   (%check-fixnum 'fx#- fx)
    569   (cond ((%null? fxs)         (%fxneg fx))
    570         ((%null? (%cdr fxs))  (%fx- fx (%car fxs)))
    571         (else                 (%fxfold 'fx#- $fx- fx fxs) ) ) )
    572 
    573 (define (fx#+ fx . fxs)
    574   (%check-fixnum 'fx#+ fx)
    575   (cond ((%null? fxs)         fx)
    576         ((%null? (%cdr fxs))  (%fx+ fx (%car fxs)))
    577         (else                 (%fxfold 'fx#+ $fx+ fx fxs) ) ) )
    578 
    579 (define (fx#* fx . fxs)
    580   (%check-fixnum 'fx#* fx)
    581   (cond ((%null? fxs)         fx)
    582         ((%null? (%cdr fxs))  (%fx* fx (%car fxs)))
    583         (else                 (%fxfold 'fx#* $fx* fx fxs) ) ) )
    584 
    585 (define (fx#/ fx . fxs)
    586   (%check-fixnum 'fx#/ fx)
    587   (cond ((%null? fxs)         fx)
    588         ((%null? (%cdr fxs))  (%fx/ fx (%car fxs)))
    589         (else                 (%fxfold 'fx#/ $fx/ fx fxs) ) ) )
    590 
    591 ;;
    592 
    593619(define-syntax *fx=?
    594620  (syntax-rules ()
     
    636662      (and ($fx>= ?x ?y) (*fx>=? ?y ?rest ...)) ) ) )
    637663
     664(define-syntax *fx<>?
     665  (syntax-rules ()
     666    ((_ ?x)
     667      #t )
     668    ((_ ?x ?y)
     669      ($fx<> ?x ?y) )
     670    ((_ ?x ?y ?rest ...)
     671      (and ($fx<> ?x ?y) (*fx<>? ?y ?rest ...)) ) ) )
     672
    638673;;
    639674
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13716 r13775  
    11;;;; err5rs-arithmetic-flonums.scm
    22;;;; Kon Lovett, Mar '09
     3
     4;; Issues
     5;;
     6;; - No support for the full-numeric-tower. All operations upon core numerics.
     7;;
     8;; - `flnumerator' & `fldenominator` are implemented.
    39
    410;;; Prelude
     
    713        (usual-integrations)
    814  (disable-interrupts)
    9         (generic)
    1015        (inline)
    1116        (local)
     
    2328;;
    2429
    25 (define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    26 
    27 (define-inline (%check-flonum loc obj) (unless (%flonum? obj) (error-type-flonum loc obj)))
    28 
    29 (define-inline (%check-cardinal loc obj) (unless (%<= 0 obj) (error-type-cardinal loc obj)))
    30 
    31 (define-inline (%check-real loc obj) (unless (real? obj) (error-type-real loc obj)))
     30(define-inline (%check-fixnum loc obj)
     31  (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     32
     33(define-inline (%check-flonum loc obj)
     34  (unless (%flonum? obj) (error-type-flonum loc obj)) )
     35
     36(define-inline (%check-cardinal loc obj)
     37  (unless (%cardinal? obj) (error-type-cardinal loc obj)) )
     38
     39(define-inline (%check-real loc obj)
     40  (unless (real? obj) (error-type-real loc obj)) )
    3241
    3342;;
     
    118127  ; ERR5RS
    119128  real->flonum fixnum->flonum
    120   fl=? fl<? fl>? fl<=? fl>=? flcompare
     129  fl=? fl<? fl>? fl<=? fl>=?
    121130  flinteger?
    122131  flzero? flpositive? flnegative? flodd? fleven?
     
    125134  flmax flmin flmax-and-min
    126135  flabs
    127   flfraction
    128136  flfloor flceiling flround fltruncate
    129137  fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0
     
    131139  flnumerator fldenominator
    132140  ; Extras
    133   flnegate)
     141  fl<>?
     142  flcompare
     143  flfraction
     144  flnegate
     145  ; Macros
     146  ~fl=? ~fl<? ~fl>? ~fl<=? ~fl>=? ~fl<>?
     147  ~flmax ~flmin
     148  ~fl- ~fl+ ~fl* ~fl/
     149  ; Macro helpers
     150  $fp= $fp< $fp> $fp>= $fp<= $fp<>?
     151  $fpmax $fpmin
     152  $fp+ $fp- $fp* $fp/)
    134153
    135154(import scheme chicken foreign srfi-1 mathh)
     
    151170;;; Procedures wrapping primitive-inlines for fold operations
    152171
    153 (define (*fp=? x y) (%fp=? x y))
    154 (define (*fp<? x y) (%fp<? x y))
    155 (define (*fp>? x y) (%fp>? x y))
    156 (define (*fp<=? x y) (%fp<=? x y))
    157 (define (*fp>=? x y) (%fp>=? x y))
    158 (define (*fpmax x y) (%fpmax x y))
    159 (define (*fpmin x y) (%fpmin x y))
    160 (define (*fp- x y) (%fp- x y))
    161 (define (*fp+ x y) (%fp+ x y))
    162 (define (*fp* x y) (%fp* x y))
    163 (define (*fp/ x y) (%fp/ x y))
    164 
    165 ;;;
    166 
    167 ;Doesn't support full-numeric-tower
     172(define ($fp=? x y) (%fp=? x y))
     173(define ($fp<? x y) (%fp<? x y))
     174(define ($fp>? x y) (%fp>? x y))
     175(define ($fp<=? x y) (%fp<=? x y))
     176(define ($fp>=? x y) (%fp>=? x y))
     177(define ($fp<>? x y) (not (%fp=? x y)))
     178(define ($fpmax x y) (%fpmax x y))
     179(define ($fpmin x y) (%fpmin x y))
     180(define ($fp- x y) (%fp- x y))
     181(define ($fp+ x y) (%fp+ x y))
     182(define ($fp* x y) (%fp* x y))
     183(define ($fp/ x y) (%fp/ x y))
     184
     185;;; ERR5RS
     186
     187;;
     188
    168189(define (real->flonum value)
    169190  (if (%flonum? value) value
     
    176197  (%exact->inexact fx) )
    177198
    178 ;;;
    179 
    180 (define (fl=? fp . fps)
    181         (%fpand-fold 'fl=? *fp=? fp fps) )
    182 
    183 (define (fl<? fp . fps)
    184         (%fpand-fold 'fl<? *fp<? fp fps) )
    185 
    186 (define (fl>? fp . fps)
    187         (%fpand-fold 'fl>? *fp>? fp fps) )
    188 
    189 (define (fl<=? fp . fps)
    190         (%fpand-fold 'fl<=? *fp<=? fp fps) )
    191 
    192 (define (fl>=? fp . fps)
    193         (%fpand-fold 'fl>=? *fp>=? fp fps) )
    194 
    195 (define (flcompare fl1 fl2)
    196   (%check-flonum 'flcompare fl1)
    197   (%check-flonum 'flcompare fl2)
    198         (cond ((%fp=? fl1 fl2)
    199                (cond ((%fp=? -0.0 fl1)  (if (%fp=? -0.0 fl1) 0 1))
    200                ((%fp=? -0.0 fl2)  (if (%fp=? 0.0 fl1) -1 0))
    201                      (else              0)))
    202               ((%fp<? fl1 fl2)
    203                -1)
    204               (else
    205                1 ) ) )
    206 
    207 (define (flmax fp . fps)
    208         (%fpfold 'flmax *fpmax fp fps) )
    209 
    210 (define (flmin fp . fps)
    211         (%fpfold 'flmin *fpmin fp fps) )
     199;;
     200
     201(define (fl=? fp . fps) (%fpand-fold 'fl=? $fp=? fp fps))
     202(define (fl<? fp . fps) (%fpand-fold 'fl<? $fp<? fp fps))
     203(define (fl>? fp . fps) (%fpand-fold 'fl>? $fp>? fp fps))
     204(define (fl<=? fp . fps) (%fpand-fold 'fl<=? $fp<=? fp fps))
     205(define (fl>=? fp . fps) (%fpand-fold 'fl>=? $fp>=? fp fps))
     206
     207;;
     208
     209(define (flmax fp . fps) (%fpfold 'flmax $fpmax fp fps))
     210(define (flmin fp . fps) (%fpfold 'flmin $fpmin fp fps))
    212211
    213212(define (flmax-and-min fp . fps)
     
    219218          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
    220219
    221 ;;;
     220;;
    222221
    223222(define (flinteger? fp)
     
    227226(define (flzero? fp)
    228227  (%check-flonum 'flzero? fp)
    229         (%fp=? 0.0 fp) )
     228        (or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp)) )
    230229
    231230(define (flpositive? fp)
     
    239238(define (flodd? fp)
    240239  (%check-flonum 'flodd? fp)
    241   (not (%fp=? 0.0 (fpmod fp 2.0))) )
     240  (not (%fp=? 0.0 (%fpmod fp 2.0))) )
    242241
    243242(define (fleven? fp)
    244243  (%check-flonum 'fleven? fp)
    245   (%fp=? 0.0 (fpmod fp 2.0)) )
     244  (%fp=? 0.0 (%fpmod fp 2.0)) )
    246245
    247246(define (flfinite? fp)
    248247  (%check-flonum 'flfinite? fp)
    249   (%finite? fp) )
     248  (and (not (%fpnan? fp)) (%finite? fp)) )
    250249
    251250(define (flinfinite? fp)
     
    257256  (%fpnan? fp) )
    258257
    259 ;;;
    260 
    261 (define (fl+ fp . fps)
    262         (%fpfold 'fl+ *fp+ fp fps) )
     258;;
     259
     260(define (fl+ fp . fps) (%fpfold 'fl+ $fp+ fp fps))
    263261
    264262(define (fl- fp . fps)
    265263  (if (%null? fps) (%fpnegate fp)
    266       (%fpfold 'fl- *fp- fp fps) ) )
    267 
    268 (define (fl* fp . fps)
    269         (%fpfold 'fl* *fp* fp fps) )
     264      (%fpfold 'fl- $fp- fp fps) ) )
     265
     266(define (fl* fp . fps) (%fpfold 'fl* $fp* fp fps))
    270267
    271268(define (fl/ fp . fps)
    272269  (if (%null? fps) (%fp/ 1.0 fp)
    273         (%fpfold 'fl/ *fp/ fp fps) ) )
     270        (%fpfold 'fl/ $fp/ fp fps) ) )
    274271
    275272(define (flabs fp)
    276273  (%check-flonum 'flabs fp)
    277274  (%fpabs fp) )
    278 
    279 (define (flfraction fp)
    280   (%check-flonum 'flfraction fp)
    281   (%fpfraction fp) )
    282275
    283276(define (fltruncate fp)
     
    383376      (%expt fp exp) ) )
    384377
     378;; n / d = fp
     379;;
     380;; n = fp * d
     381;; d = 1 / (fp / n)
     382
    385383(define (flnumerator fp)
    386384  (%check-flonum 'flnumerator fp)
    387   fp )
     385  (cond ((%fpnan? fp)
     386         +nan )
     387        ((or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
     388         fp )
     389        (else
     390          ) ) )
    388391
    389392(define (fldenominator fp)
    390393  (%check-flonum 'fldenominator fp)
    391   (if (%fpnan? fp) fp
    392       1.0 ) )
    393 
     394  (cond ((%fpnan? fp)
     395         +nan )
     396        ((or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
     397         1.0 )
     398        (else
     399          ) ) )
    394400
    395401;;; Extras
     402
     403(define (fl<>? fp . fps) (%fpand-fold 'fl<>? $fp<>? fp fps))
     404
     405(define (flcompare fl1 fl2)
     406  (%check-flonum 'flcompare fl1)
     407  (%check-flonum 'flcompare fl2)
     408        (cond ((%fp=? fl1 fl2)
     409               (cond ((%fp=? -0.0 fl1)
     410                      (if (%fp=? -0.0 fl1) 0 1) )
     411               ((%fp=? -0.0 fl2)
     412                (if (%fp=? 0.0 fl1) -1 0) )
     413                     (else
     414                      0 ) ) )
     415              ((%fp<? fl1 fl2)
     416               -1 )
     417              (else
     418               1 ) ) )
     419
     420(define (flfraction fp)
     421  (%check-flonum 'flfraction fp)
     422  (%fpfraction fp) )
    396423
    397424(define (flnegate fp)
     
    399426  (%fpnegate fp) )
    400427
     428;;
     429
     430(define-syntax ~fl=?
     431  (syntax-rules ()
     432    ((_ ?x)
     433      #t )
     434    ((_ ?x ?y)
     435      ($fp= ?x ?y) )
     436    ((_ ?x ?y ?rest ...)
     437      (and ($fp= ?x ?y) (~fl=? ?y ?rest ...)) ) ) )
     438
     439(define-syntax ~fl<?
     440  (syntax-rules ()
     441    ((_ ?x)
     442      #t )
     443    ((_ ?x ?y)
     444      ($fp< ?x ?y) )
     445    ((_ ?x ?y ?rest ...)
     446      (and ($fp< ?x ?y) (~fl<? ?y ?rest ...)) ) ) )
     447
     448(define-syntax ~fl>?
     449  (syntax-rules ()
     450    ((_ ?x)
     451      #t )
     452    ((_ ?x ?y)
     453      ($fp> ?x ?y) )
     454    ((_ ?x ?y ?rest ...)
     455      (and ($fp> ?x ?y) (~fl>? ?y ?rest ...)) ) ) )
     456
     457(define-syntax ~fl<=?
     458  (syntax-rules ()
     459    ((_ ?x)
     460      #t )
     461    ((_ ?x ?y)
     462      ($fp<= ?x ?y) )
     463    ((_ ?x ?y ?rest ...)
     464      (and ($fp<= ?x ?y) (~fl<=? ?y ?rest ...)) ) ) )
     465
     466(define-syntax ~fl>=?
     467  (syntax-rules ()
     468    ((_ ?x)
     469      #t )
     470    ((_ ?x ?y)
     471      ($fp>= ?x ?y) )
     472    ((_ ?x ?y ?rest ...)
     473      (and ($fp>= ?x ?y) (~fl>=? ?y ?rest ...)) ) ) )
     474
     475(define-syntax ~fl<>?
     476  (syntax-rules ()
     477    ((_ ?x)
     478      #t )
     479    ((_ ?x ?y)
     480      ($fp<> ?x ?y) )
     481    ((_ ?x ?y ?rest ...)
     482      (and ($fp<> ?x ?y) (~fl<>? ?y ?rest ...)) ) ) )
     483
     484;;
     485
     486(define-syntax ~flmax
     487  (syntax-rules ()
     488    ((_ ?x)
     489      ?x )
     490    ((_ ?x ?y)
     491      ($fpmax ?x ?y) )
     492    ((_ ?x ?y ?rest ...)
     493      ($fpmax ?x (~flmax ?y ?rest ...)) ) ) )
     494
     495(define-syntax ~flmin
     496  (syntax-rules ()
     497    ((_ ?x)
     498      ?x )
     499    ((_ ?x ?y)
     500      ($fpmin ?x ?y) )
     501    ((_ ?x ?y ?rest ...)
     502      ($fpmin ?x (~flmin ?y ?rest ...)) ) ) )
     503
     504;;
     505
     506(define-syntax ~fl-
     507  (syntax-rules ()
     508    ((_ ?x)
     509      ($fpneg ?x) )
     510    ((_ ?x ?y)
     511      ($fp- ?x ?y) )
     512    ((_ ?x ?y ?rest ...)
     513      ($fp- ?x (~fl- ?y ?rest ...) ) ) ) )
     514
     515(define-syntax ~fl+
     516  (syntax-rules ()
     517    ((_ ?x)
     518      ?x )
     519    ((_ ?x ?y)
     520      ($fp+ ?x ?y) )
     521    ((_ ?x ?y ?rest ...)
     522      ($fp+ ?x (~fl+ ?y ?rest ...) ) ) ) )
     523
     524(define-syntax ~fl*
     525  (syntax-rules ()
     526    ((_ ?x)
     527      ?x )
     528    ((_ ?x ?y)
     529      ($fp* ?x ?y) )
     530    ((_ ?x ?y ?rest ...)
     531      ($fp* ?x (~fl* ?y ?rest ...) ) ) ) )
     532
     533(define-syntax ~fl/
     534  (syntax-rules ()
     535    ((_ ?x)
     536      ?x )
     537    ((_ ?x ?y)
     538      ($fp/ ?x ?y) )
     539    ((_ ?x ?y ?rest ...)
     540      ($fp/ ?x (~fl/ ?y ?rest ...) ) ) ) )
     541
    401542) ;module err5rs-arithmetic-flonums
Note: See TracChangeset for help on using the changeset viewer.