Changeset 13606 in project


Ignore:
Timestamp:
03/09/09 04:25:02 (11 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r13604 r13606  
    2020    ##sys#string-append ) )
    2121
     22;;
     23
    2224(require-library srfi-1 int-limits)
    2325
    2426(include "chicken-primitive-object-inlines")
     27
     28;TODO - add to chicken-primitive-object-inline
     29
     30(define-inline (%number? x) (##core#inline "C_i_numberp" x))
     31
     32(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
     33
     34(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     35
     36(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
     37(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
     38(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
     39
     40(define-inline (%negative? x) (##core#inline "C_i_negativep" x))
     41
     42;;
    2543
    2644#>
     
    271289;;
    272290
    273 (define-inline (%boolean->bit b) (if b 1 0))
    274 
    275 (define-inline (%boolean->bit* bit) (if (zero? bit) 0 (%boolean->bit bit)))
    276 
    277 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
    278 
    279 (define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
    280 
    281 (define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
    282 
    283 (define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
    284 
    285 (define-inline (%negative? x) (##core#inline "C_i_negativep" x))
     291(define-inline (%boolean->bit obj) (if obj 1 0))
     292
     293(define-inline (%boolean->bit* obj)
     294  (if (and (%number obj) (%zero? obj)) 0
     295      (%boolean->bit obj) ) )
    286296
    287297
     
    403413  (let ((zeros (make-list machine-word-bits #f)))
    404414    (lambda (n #!optional bitlen)
    405       (if (zero? n)
     415      (if (%zero? n)
    406416          (if bitlen (take zeros bitlen) zeros)
    407417          (let ((bitlen (or bitlen (*bitwise-length n))))
     
    527537    (%check-non-negative-fixnum 'bitwise-integer->list bitlen)
    528538    (%check-word-bits 'bitwise-integer->list bitlen) )
    529   (bitwise-integer->list value bitlen) )
     539  (*bitwise-integer->list value bitlen) )
    530540
    531541(define (bitwise-arithmetic-shift value signed-count)
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13604 r13606  
    1818    ##sys#string-append ) )
    1919
     20;;
     21
    2022(require-library err5rs-arithmetic-bitwise)
    2123
    2224(include "chicken-primitive-object-inlines")
    2325
    24 
    25 ;;;
     26;TODO - add to chicken-primitive-object-inline
     27
     28(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
     29(define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y))
     30(define-inline (%> x y) ((##core#primitive "C_greaterp") x y))
     31(define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y))
     32
     33(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
     34(define-inline (%- x y) ((##core#primitive "C_minus") x y))
     35(define-inline (%* x y) ((##core#primitive "C_times") x y))
     36(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
     37
     38(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
     39
     40(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     41
     42;;
    2643
    2744(define-inline (%fixnum-zero-division-error loc fx1 fx2)
     
    5673
    5774;;
     75
     76;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
    5877
    5978(define-inline (%fxfold-1 loc func init lyst)
     
    7190        (let ((cur (%car ls)))
    7291          (%check-fixnum loc cur)
    73           (and (func acc (%car ls))
    74                (loop (%cdr ls) (%car ls)) ) ) ) ) )
    75 
    76 ;;
    77 
    78 (define-inline (%< x y) ((##core#primitive "C_lessp") x y))
    79 
    80 (define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y))
    81 
    82 (define-inline (%> x y) ((##core#primitive "C_greaterp") x y))
    83 
    84 (define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y))
    85 
    86 (define-inline (%+ x y) ((##core#primitive "C_plus") x y))
    87 
    88 (define-inline (%- x y) ((##core#primitive "C_minus") x y))
    89 
    90 (define-inline (%* x y) ((##core#primitive "C_times") x y))
    91 
    92 (define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
    93 
    94 (define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
     92          (and (func acc cur)
     93               (loop (%cdr ls) cur) ) ) ) ) )
    9594
    9695;;
     
    191190
    192191(define (*fx= x y) (%fx= x y))
    193 
    194192(define (*fx< x y) (%fx< x y))
    195 
    196193(define (*fx> x y) (%fx> x y))
    197 
    198194(define (*fx>= x y) (%fx>= x y))
    199 
    200195(define (*fx<= x y) (%fx<= x y))
    201 
    202196(define (*fxmax x y) (%fxmax x y))
    203 
    204197(define (*fxmin x y) (%fxmin x y))
    205 
    206198(define (*fxand x y) (%fxand x y))
    207 
    208199(define (*fxior x y) (%fxor x y))
    209 
    210200(define (*fxxor x y) (%fxxor x y))
    211 
    212201(define (*fx+ x y) (%fx+ x y))
    213 
    214202(define (*fx- x y) (%fx- x y))
    215 
    216203(define (*fx* x y) (%fx* x y))
    217 
    218204(define (*fx/ x y) (%fx/ x y))
    219205
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13604 r13606  
    1 ;;;; flonum-extras.scm
     1;;;; err5rs-arithmetic-flonums.scm
    22;;;; Kon Lovett, Mar '09
    33
     
    77(declare
    88        (usual-integrations)
    9         (generic)
    109  (disable-interrupts)
     10        (arithmetic-type generic)
     11        (inline)
     12        #;(local)
    1113        (no-bound-checks)
    12         (no-procedure-checks-for-usual-bindings)
     14        (no-procedure-checks)
    1315        (bound-to-procedure
    14           ##sys#signal-hook
     16          ##sys#check-exact
     17          ##sys#check-inexact
    1518          ##sys#check-integer
    16           ##sys#flonum-fraction
    17           ##sys#floor
    18           ##sys#ceiling
    19           ##sys#exact->inexact )
    20   (export
    21     ; Checked
    22     real->flonum
    23     fixnum->flonum
    24     fl=?
    25     fl<?
    26     fl>?
    27     fl<=?
    28     fl>=?
    29     flcompare
    30     flinteger?
    31     flzero?
    32     flpositive?
    33     flnegative?
    34     flodd?
    35     fleven?
    36     flfinite?
    37     flinfinite?
    38     flnan?
    39     fl+
    40     fl*
    41     fl-
    42     fl/
    43     flmax
    44     flmin
    45     flmax-and-min
    46     flabs
    47     flfraction
    48     flfloor
    49     flceiling
    50     flround
    51     fltruncate
    52     fldiv
    53     flmod
    54     fldiv-and-mod
    55     fldiv0
    56     flmod0
    57     fldiv0-and-mod0
    58     flexp
    59     fllog
    60     flsin
    61     flcos
    62     fltan
    63     flasin
    64     flacos
    65     flatan
    66     flsqrt
    67     flexpt
    68     flnumerator
    69     fldenominator
    70     ; Unchecked
    71     %fp=
    72     %fp<
    73     %fp>
    74     %fp>=
    75     %fp<=
    76     %fpmax
    77     %fpmin
    78     %fp+
    79     %fp-
    80     %fp*
    81     %fp/
    82     ) )
    83 
    84 (require-library mathh)
     19          ##sys#check-number
     20          ##sys#signal-hook ) )
     21
     22;;
     23
     24(require-library srfi-1 mathh)
    8525
    8626(include "chicken-primitive-object-inlines")
    8727
     28;TODO - add to chicken-primitive-object-inline
     29
     30(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
     31
     32(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
     33
     34(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
     35(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
     36(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
     37(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
     38(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
     39
     40(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
     41(define-inline (%fpmax x y) (##core#inline "C_i_flonum_min" x y))
     42
     43(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
     44(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
     45(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
     46(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
     47
     48(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
     49
     50(define-inline (%fpneg x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     51
     52(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
     53(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
     54(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
     55(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
     56
     57(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
     58(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
     59(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
     60(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
     61(define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     62(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
     63(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     64(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
     65(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
     66(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
     67(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
     68
     69(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
     70
     71(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
     72
     73(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
     74
     75;;
     76
     77(define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc))
     78
     79(define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc))
     80
     81(define-inline (%check-non-negative-integer loc obj)
     82  (##sys#check-integer obj loc)
     83  (unless (%< 0 obj)
     84    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
     85
     86(define-inline (%check-number loc obj) (##sys#check-number obj loc))
     87
     88;;
     89
     90;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
     91
     92(define-inline (%fpfold-1 loc func init lyst)
     93  (%check-flonum loc init)
     94  (let loop ([ls lyst] [acc init])
     95          (if (%null? ls) acc
     96              (let ([cur (%car ls)])
     97          (%check-flonum loc cur)
     98          (loop (%cdr ls) (func acc cur)) ) ) ) )
     99
     100(define-inline (%fpand-fold-1 loc func init lyst)
     101  (%check-flonum loc init)
     102  (let loop ([ls lyst] [acc init])
     103          (or (%null? ls)
     104        (let ([cur (%car ls)])
     105          (%check-flonum loc cur)
     106                (and (func acc cur)
     107               (loop (%cdr ls) cur) ) ) ) ) )
     108
     109;;
     110
     111(define-inline (%fpquotient fpn fpd) (%fptruncate (%fp/ fpn fpd)))
     112
     113(define-inline (%fpremainder fpn fpd) (%fp- fpn (%fp* (%fpquotient fpn fpd) fpd)))
     114
     115(define-inline (%fpquotient-and-remainder  fpn fpd)
     116  (let ([quo (%fpquotient fpn fpd)])
     117    (values quo (%fp- fpn (%fp* quo fpd))) ) )
     118
     119(define-inline (%fpinteger? fp) (%integer? x))
     120
     121(define-inline (%fpnan? fp) (not (%fp= fp fp)))
     122
     123(define-inline (%fp=? x y) (%fp= x y))
     124
     125(define-inline (%fp<? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp< x y)))
     126
     127(define-inline (%fp<=? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp<= x y)))
     128
     129(define-inline (%fp>? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp> x y)))
     130
     131(define-inline (%fp>=? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp>= x y)))
     132
     133(define-inline (%fpdiv0-and-mod0 fpn fpd)
     134  (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
     135    (cond [(%fp>=? fpd 0.0)
     136            (if (%fp<?
     137                 rem
     138                 (%fp/ fpd 2.0))
     139                (if (%fp>=?
     140                     rem
     141                     (%fp/ fpd -2.0))
     142                    (values quo rem)
     143                    (values (%fp- quo 1.0)
     144                            (%fp+ rem fpd)) )
     145                (values (%fp+ quo 1.0)
     146                        (%fp- rem fpd)) ) ]
     147          [(%fp<?
     148            rem
     149            (%fp/ fpd -2.0))
     150            (if (%fp>=?
     151                 rem
     152                 (%fp/ fpd 2.0))
     153                (values quo rem)
     154                (values (%fp+ quo 1.0)
     155                        (%fp- rem fpd)) ) ]
     156          [else
     157            (values (%fp- quo 1.0)
     158                    (%fp+ rem fpd)) ] ) ) )
     159
     160(define-inline (%fpdiv0 fpn fpd)
     161  (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
     162    (cond [(%fp>=? fpd 0.0)
     163            (if (%fp<?
     164                 rem
     165                 (%fp/ fpd 2.0))
     166                (if (%fp>=?
     167                     rem
     168                     (%fp/ fpd -2.0))
     169                    quo
     170                    (%fp- quo 1.0) )
     171                (%fp+ quo 1.0) ) ]
     172          [(%fp<?
     173            rem
     174            (%fp/ fpd -2.0))
     175            (if (%fp>=?
     176                 rem
     177                 (%fp/ fpd 2.0))
     178                quo
     179                (%fp+ quo 1.0) ) ]
     180          [else
     181            (%fp- quo 1.0) ] ) ) )
     182
     183(define-inline (%fpmod0 fpn fpd)
     184  (let ([rem (%fpremainder fpn fpd)])
     185    (cond [(%fp>=? fpd 0.0)
     186            (if (%fp<?
     187                 rem
     188                 (%fp/ fpd 2.0))
     189                (if (%fp>=?
     190                     rem
     191                     (%fp/ fpd -2.0))
     192                    rem
     193                    (%fp+ rem fpd) )
     194                (%fp- rem fpd) ) ]
     195          [(%fp<?
     196            rem
     197            (%fp/ fpd -2.0))
     198            (if (%fp>=?
     199                 rem
     200                 (%fp/ fpd 2.0))
     201                rem
     202                (%fp- rem fpd) )]
     203          [else
     204            (%fp+ rem fpd) ] ) ) )
     205
     206
    88207;;;
    89208
    90 (define (check-flonum loc obj)
    91   (unless (##core#inline "C_i_flonump" obj)
    92     (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) ) )
    93 
    94 (define (check-non-negative-integer loc obj)
    95   (##sys#check-integer obj loc)
    96   (unless ((##core#primitive "C_lessp") 0 obj)
    97     (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
     209(module err5rs-arithmetic-bitwise (;export
     210  ; ERR5RS
     211  real->flonum fixnum->flonum
     212  fl=? fl<? fl>? fl<=? fl>=? flcompare
     213  flinteger?
     214  flzero? flpositive? flnegative? flodd? fleven?
     215  flfinite? flinfinite? flnan?
     216  fl+ fl* fl- fl/
     217  flmax flmin flmax-and-min
     218  flabs
     219  flfraction
     220  flfloor flceiling flround fltruncate
     221  fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0
     222  flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt
     223  flnumerator fldenominator)
     224
     225(import scheme chicken foreign srfi-1 mathh)
     226
     227
     228;;; Procedures wrapping primitive-inlines for fold operations
     229
     230(define (*fp=? x y) (%fp=? x y))
     231(define (*fp<? x y) (%fp<? x y))
     232(define (*fp>? x y) (%fp>? x y))
     233(define (*fp<=? x y) (%fp<=? x y))
     234(define (*fp>=? x y) (%fp>=? x y))
     235(define (*fpmax x y) (%fpmax x y))
     236(define (*fpmin x y) (%fpmin x y))
     237(define (*fp- x y) (%fp- x y))
     238(define (*fp+ x y) (%fp+ x y))
     239(define (*fp* x y) (%fp* x y))
     240(define (*fp/ x y) (%fp/ x y))
     241
    98242
    99243;;;
    100244
    101 (define-inline (%fold1 loc func init lyst)
    102   (check-flonum loc init)
    103   (let loop ([acc init] [lyst lyst])
    104           (if (null? lyst)
    105               acc
    106               (let ([cur (car lyst)])
    107           (check-flonum loc cur)
    108           (loop (func acc cur) (cdr lyst)) ) ) ) )
    109 
    110 (define-inline (%and-fold1 loc func init lyst)
    111   (check-flonum loc init)
    112   (let loop ([prv init] [lyst lyst])
    113           (or (null? lyst)
    114         (let ([cur (car lyst)])
    115           (check-flonum loc cur)
    116                 (and (func prv cur)
    117                (loop cur (cdr lyst)) ) ) ) ) )
     245(define (real->flonum value)
     246  (if (%flonum? value) value
     247      (begin
     248        (%check-number 'real->flonum value)
     249        (%exact->inexact value) ) ) )
     250
     251(define (fixnum->flonum fx)
     252  (%check-fixnum 'fixnum->flonum fx)
     253  (%exact->inexact fx) )
     254
    118255
    119256;;;
    120257
    121 (define %fpfrac ##sys#flonum-fraction)
    122 
    123 (define %fptrunc ##sys#truncate)
    124 
    125 (define %fpfloor ##sys#floor)
    126 
    127 (define %fpceil ##sys#ceiling)
    128 
    129 (define-inline (%fprnd fp)
    130   (if (##core#inline "C_flonum_equalp" 0.0 fp)
    131       0.0
    132       (%fptrunc (##core#inline_allocate ("C_a_i_flonum_plus" 4)
    133                  fp
    134                  (if (##core#inline "C_flonum_lessp" 0.0 fp) 0.5 -0.5))) ) )
    135 
    136 (define-inline (%fpquo fpn fpd)
    137   (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) )
    138 
    139 (define-inline (%fprem fpn fpd)
    140   (##core#inline_allocate ("C_a_i_flonum_difference" 4)
    141    fpn
    142    (##core#inline_allocate ("C_a_i_flonum_times" 4)
    143     (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd))
    144     fpd)) )
    145 
    146 (define-inline (%fpquo-and-rem fpn fpd)
    147   (let ([quo (%fpquo fpn fpd)])
    148     (values quo
    149             (##core#inline_allocate ("C_a_i_flonum_difference" 4)
    150              fpn
    151              (##core#inline_allocate ("C_a_i_flonum_times" 4) quo fpd))) ) )
    152 
    153 (define-inline (%fpinteger? fp)
    154   (##core#inline "C_flonum_equalp" 0.0 (%fpfrac fp)) )
    155 
    156 (define-inline (%fpnan? fp)
    157   (not (##core#inline "C_flonum_equalp" fp fp)) )
    158 
    159 (define (%fp= x y)
    160   (##core#inline "C_flonum_equalp" x y) )
    161 
    162 (define (%fp< x y)
    163   (or (and (##core#inline "C_flonum_equalp" -0.0 x)
    164            (##core#inline "C_flonum_equalp" 0.0 y))
    165       (##core#inline "C_flonum_lessp" x y) ) )
    166 
    167 (define (%fp<= x y)
    168   (or (and (##core#inline "C_flonum_equalp" -0.0 x)
    169            (##core#inline "C_flonum_equalp" 0.0 y))
    170       (##core#inline "C_flonum_less_or_equal_p" x y) ) )
    171 
    172 (define (%fp> x y)
    173   (or (and (##core#inline "C_flonum_equalp" 0.0 x)
    174            (##core#inline "C_flonum_equalp" -0.0 y))
    175       (##core#inline "C_flonum_greaterp" x y) ) )
    176 
    177 (define (%fp>= x y)
    178   (or (and (##core#inline "C_flonum_equalp" 0.0 x)
    179            (##core#inline "C_flonum_equalp" -0.0 y))
    180       (##core#inline "C_flonum_greater_or_equal_p" x y) ) )
    181 
    182 (define (%fpmax x y)
    183   (##core#inline "C_i_flonum_max" x y) )
    184 
    185 (define (%fpmin x y)
    186   (##core#inline "C_i_flonum_min" x y) )
    187 
    188 (define (%fp+ x y)
    189   (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
    190 
    191 (define (%fp- x y)
    192   (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
    193 
    194 (define (%fp* x y)
    195   (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
    196 
    197 (define (%fp/ x y)
    198   (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
    199 
    200 (define-inline (%fpdiv0-and-mod0 fpn fpd)
    201   (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
    202     (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
    203             (if (##core#inline "C_flonum_lessp"
    204                  rem
    205                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    206                 (if (##core#inline "C_flonum_greater_or_equal_p"
    207                      rem
    208                      (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    209                     (values quo rem)
    210                     (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
    211                             (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) )
    212                 (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
    213                         (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
    214           [(##core#inline "C_flonum_lessp"
    215             rem
    216             (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    217             (if (##core#inline "C_flonum_greater_or_equal_p"
    218                  rem
    219                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    220                 (values quo rem)
    221                 (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
    222                         (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
    223           [else
    224             (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
    225                     (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ] ) ) )
    226 
    227 (define-inline (%fpdiv0 fpn fpd)
    228   (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
    229     (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
    230             (if (##core#inline "C_flonum_lessp"
    231                  rem
    232                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    233                 (if (##core#inline "C_flonum_greater_or_equal_p"
    234                      rem
    235                      (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    236                     quo
    237                     (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) )
    238                 (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
    239           [(##core#inline "C_flonum_lessp"
    240             rem
    241             (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    242             (if (##core#inline "C_flonum_greater_or_equal_p"
    243                  rem
    244                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    245                 quo
    246                 (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
    247           [else
    248             (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ] ) ) )
    249 
    250 (define-inline (%fpmod0 fpn fpd)
    251   (let ([rem (%fprem fpn fpd)])
    252     (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
    253             (if (##core#inline "C_flonum_lessp"
    254                  rem
    255                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    256                 (if (##core#inline "C_flonum_greater_or_equal_p"
    257                      rem
    258                      (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    259                     rem
    260                     (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) )
    261                 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) ) ]
    262           [(##core#inline "C_flonum_lessp"
    263             rem
    264             (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    265             (if (##core#inline "C_flonum_greater_or_equal_p"
    266                  rem
    267                  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    268                 rem
    269                 (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) )]
    270           [else
    271             (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ] ) ) )
     258(define (fl=? fl . fls)
     259        (%fpand-fold-1 'fl=? *fp=? fl fls) )
     260
     261(define (fl<? fl . fls)
     262        (%fpand-fold-1 'fl<? *fp<? fl fls) )
     263
     264(define (fl>? fl . fls)
     265        (%fpand-fold-1 'fl>? *fp>? fl fls) )
     266
     267(define (fl<=? fl . fls)
     268        (%fpand-fold-1 'fl<=? *fp<=? fl fls) )
     269
     270(define (fl>=? fl . fls)
     271        (%fpand-fold-1 'fl>=? *fp>=? fl fls) )
     272
     273(define (flcompare fl1 fl2)
     274  (%check-flonum 'flcompare fl1)
     275  (%check-flonum 'flcompare fl2)
     276        (cond [(%fp=? fl1 fl2)
     277               (cond [(%fp=? -0.0 fl1)  (if (%fp=? -0.0 fl1) 0 1)]
     278               [(%fp=? -0.0 fl2)  (if (%fp=? 0.0 fl1) -1 0)]
     279                     [else              0])]
     280              [(%fp<? fl1 fl2)
     281               -1]
     282              [else
     283               1 ] ) )
     284
     285(define (flmax fl . fls)
     286        (%fpfold-1 'flmax *fpmax fl fls) )
     287
     288(define (flmin fl . fls)
     289        (%fpfold-1 'flmin *fpmin fl fls) )
     290
     291(define (flmax-and-min fl . fls)
     292  (%check-flonum 'flmax-and-min fl)
     293        (let loop ([ls fls] [mx fl] [mn fl])
     294          (if (%null? ls) (values mx mn)
     295              (let ([cur (%car ls)])
     296                (%check-flonum 'flmax-and-min cur)
     297          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
     298
    272299
    273300;;;
    274301
    275 (define (real->flonum value)
    276   (if (##core#inline "C_i_flonump" value)
    277       value
    278       (##sys#exact->inexact value) ) )
    279 
    280 (define (fixnum->flonum fx)
    281   (if (##core#inline "C_fixnump" fx)
    282       (##sys#exact->inexact fx)
    283       (##sys#signal-hook #:type-error 'fixnum->flonum
    284                          "bad argument type - not a fixnum" fx) ) )
     302(define (flinteger? fl)
     303  (%check-flonum 'flinteger? fl)
     304  (%fpinteger? fl) )
     305
     306(define (flzero? fl)
     307  (%check-flonum 'flzero? fl)
     308        (%fp=? 0.0 fl) )
     309
     310(define (flpositive? fl)
     311  (%check-flonum 'flpositive? fl)
     312        (%fp<? 0.0 fl) )
     313
     314(define (flnegative? fl)
     315  (%check-flonum 'flnegative? fl)
     316        (or (%fp=? -0.0 fl)
     317      (%fp<? fl 0.0) ) )
     318
     319(define (flodd? fl)
     320  (%check-flonum 'flodd? fl)
     321  (not (%fp=? 0.0 (fpmod fl 2.0))) )
     322
     323(define (fleven? fl)
     324  (%check-flonum 'fleven? fl)
     325  (%fp=? 0.0 (fpmod fl 2.0)) )
     326
     327(define (flfinite? fl)
     328  (%check-flonum 'flfinite? fl)
     329  (%finite? fl) )
     330
     331(define (flinfinite? fl)
     332  (%check-flonum 'flinfinite? fl)
     333  (not (%finite? fl)) )
     334
     335(define (flnan? fl)
     336  (%check-flonum 'flnan? fl)
     337  (%fpnan? fl) )
     338
    285339
    286340;;;
    287341
    288 (define (fl=? fl . rest)
    289         (%and-fold1 'fl=? %fp= fl rest) )
    290 
    291 (define (fl<? fl . rest)
    292         (%and-fold1 'fl<? %fp< fl rest) )
    293 
    294 (define (fl>? fl . rest)
    295         (%and-fold1 'fl>? %fp> fl rest) )
    296 
    297 (define (fl<=? fl . rest)
    298         (%and-fold1 'fl<=? %fp<= fl rest) )
    299 
    300 (define (fl>=? fl . rest)
    301         (%and-fold1 'fl>=? %fp>= fl rest) )
    302 
    303 (define (flcompare fl1 fl2)
    304   (check-flonum 'flcompare fl1)
    305   (check-flonum 'flcompare fl2)
    306         (cond [(##core#inline "C_flonum_equalp" fl1 fl2)
    307                 (cond [(##core#inline "C_flonum_equalp" -0.0 fl1)
    308                   (if (##core#inline "C_flonum_equalp" -0.0 fl1)
    309                       0
    310                       1) ]
    311                       [(##core#inline "C_flonum_equalp" -0.0 fl2)
    312                         (if (##core#inline "C_flonum_equalp" 0.0 fl1)
    313                             -1
    314                             0) ]
    315                       [else
    316                         0 ] ) ]
    317               [(##core#inline "C_flonum_lessp" fl1 fl2)
    318                 -1 ]
    319               [else
    320                 1 ] ) )
    321 
    322 (define (flmax fl . rest)
    323         (%fold1 'flmax %fpmax fl rest) )
    324 
    325 (define (flmin fl . rest)
    326         (%fold1 'flmin %fpmin fl rest) )
    327 
    328 (define (flmax-and-min fl . rest)
    329   (check-flonum 'flmax-and-min fl)
    330         (let loop ([mx fl]
    331                    [mn fl]
    332                    [lyst rest])
    333           (if (null? lyst)
    334               (values mx mn)
    335               (let ([cur (car lyst)])
    336                 (check-flonum 'flmax-and-min cur)
    337           (loop (##core#inline "C_i_flonum_max" mx cur)
    338                 (##core#inline "C_i_flonum_min" mn cur)
    339                 (cdr lyst)) ) ) ) )
    340 
    341 ;;;
    342 
    343 (define (flinteger? fl)
    344   (check-flonum 'flinteger? fl)
    345   (%fpinteger? fl) )
    346 
    347 (define (flzero? fl)
    348   (check-flonum 'flzero? fl)
    349         (##core#inline "C_flonum_equalp" 0.0 fl) )
    350 
    351 (define (flpositive? fl)
    352   (check-flonum 'flpositive? fl)
    353         (##core#inline "C_flonum_lessp" 0.0 fl) )
    354 
    355 (define (flnegative? fl)
    356   (check-flonum 'flnegative? fl)
    357         (or (##core#inline "C_flonum_equalp" -0.0 fl)
    358       (##core#inline "C_flonum_lessp" fl 0.0) ) )
    359 
    360 (define (flodd? fl)
    361   (check-flonum 'flodd? fl)
    362   (not (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0))) )
    363 
    364 (define (fleven? fl)
    365   (check-flonum 'fleven? fl)
    366   (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0)) )
    367 
    368 (define (flfinite? fl)
    369   (check-flonum 'flfinite? fl)
    370   (##core#inline "C_i_finitep" fl) )
    371 
    372 (define (flinfinite? fl)
    373   (check-flonum 'flinfinite? fl)
    374   (not (##core#inline "C_i_finitep" fl)) )
    375 
    376 (define (flnan? fl)
    377   (check-flonum 'flnan? fl)
    378   (%fpnan? fl) )
    379 
    380 ;;;
    381 
    382 (define (fl+ fl . rest)
    383         (%fold1 'fl+ %fp+ fl rest) )
    384 
    385 (define (fl* fl . rest)
    386         (%fold1 'fl* %fp* fl rest) )
    387 
    388 (define (fl- fl . rest)
    389   (or (and (null? rest)
    390            (##core#inline_allocate ("C_a_i_flonum_negate" 4) fl) )
    391       (%fold1 'fl- %fp- fl rest) ) )
    392 
    393 (define (fl/ fl . rest)
    394   (or (and (null? rest)
    395            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 1.0 fl) )
    396         (%fold1 'fl/ %fp/ fl rest) ) )
     342(define (fl+ fl . fls)
     343        (%fpfold-1 'fl+ %fp+ fl fls) )
     344
     345(define (fl* fl . fls)
     346        (%fpfold-1 'fl* %fp* fl fls) )
     347
     348(define (fl- fl . fls)
     349  (if (%null? fls) (%fpneg fl)
     350      (%fpfold-1 'fl- %fp- fl fls) ) )
     351
     352(define (fl/ fl . fls)
     353  (if (%null? fls) (%fp/ 1.0 fl)
     354        (%fpfold-1 'fl/ %fp/ fl fls) ) )
    397355
    398356(define (flabs fl)
    399   (check-flonum 'flabs fl)
    400   (##core#inline_allocate ("C_a_i_abs" 4) fl) )
     357  (%check-flonum 'flabs fl)
     358  (%fpabs fl) )
    401359
    402360(define (flfraction fl)
    403   (check-flonum 'flfraction fl)
    404   (%fpfrac fl) )
     361  (%check-flonum 'flfraction fl)
     362  (%fpfraction fl) )
    405363
    406364(define (fltruncate fl)
    407   (check-flonum 'fltruncate fl)
    408   (%fptrunc fl) )
     365  (%check-flonum 'fltruncate fl)
     366  (%fptruncate fl) )
    409367
    410368(define (flfloor fl)
    411   (check-flonum 'flfloor fl)
     369  (%check-flonum 'flfloor fl)
    412370  (%fpfloor fl) )
    413371
    414372(define (flceiling fl)
    415   (check-flonum 'flceiling fl)
     373  (%check-flonum 'flceiling fl)
    416374  (%fpceil fl) )
    417375
    418376(define (flround fl)
    419   (check-flonum 'flround fl)
    420   (%fprnd fl) )
     377  (%check-flonum 'flround fl)
     378  (%fpround fl) )
    421379
    422380(define (fldiv fln fld)
    423   (check-flonum 'fldiv fln)
    424   (check-flonum 'fldiv fld)
    425   (%fpquo fln fld) )
     381  (%check-flonum 'fldiv fln)
     382  (%check-flonum 'fldiv fld)
     383  (%fpquotient fln fld) )
    426384
    427385(define (flmod fln fld)
    428   (check-flonum 'flmod fln)
    429   (check-flonum 'flmod fld)
    430   (%fprem fln fld) )
     386  (%check-flonum 'flmod fln)
     387  (%check-flonum 'flmod fld)
     388  (%fpremainder fln fld) )
    431389
    432390(define (fldiv-and-mod fln fld)
    433   (check-flonum 'fldiv-and-mod fln)
    434   (check-flonum 'fldiv-and-mod fld)
    435   (%fpquo-and-rem fln fld) )
     391  (%check-flonum 'fldiv-and-mod fln)
     392  (%check-flonum 'fldiv-and-mod fld)
     393  (%fpquotient-and-remainder fln fld) )
    436394
    437395(define (fldiv0 fln fld)
    438   (check-flonum 'fldiv0 fln)
    439   (check-flonum 'fldiv0 fld)
     396  (%check-flonum 'fldiv0 fln)
     397  (%check-flonum 'fldiv0 fld)
    440398  (%fpdiv0 fln fld) )
    441399
    442400(define (flmod0 fln fld)
    443   (check-flonum 'flmod0 fln)
    444   (check-flonum 'flmod0 fld)
     401  (%check-flonum 'flmod0 fln)
     402  (%check-flonum 'flmod0 fld)
    445403  (%fpmod0 fln fld) )
    446404
    447405(define (fldiv0-and-mod0 fln fld)
    448   (check-flonum 'fldiv0-and-mod0 fln)
    449   (check-flonum 'fldiv0-and-mod0 fld)
     406  (%check-flonum 'fldiv0-and-mod0 fln)
     407  (%check-flonum 'fldiv0-and-mod0 fld)
    450408  (%fpdiv0-and-mod0 fln fld) )
    451409
    452410(define (flexp fl)
    453   (check-flonum 'flexp fl)
    454   (##core#inline_allocate ("C_a_i_exp" 4) fl) )
    455 
    456 (define (fllog fl . rest)
    457   (check-flonum 'fllog fl)
    458   (if (null? rest)
    459       (##core#inline_allocate ("C_a_i_log" 4) fl)
    460       (let ([base (car rest)])
    461         (check-non-negative-integer 'fllog base)
    462         ((make-log/base base) fl) ) ) )
     411  (%check-flonum 'flexp fl)
     412  (%fpexp fl) )
     413
     414(define (fllog fl #!optional base)
     415  (define log/base  ;memoize log/base functions
     416    (let ([bases '()])
     417      (lambda (base)
     418        (let ([cell (assv base bases)])
     419               (if cell (cdr cell)
     420                   (let ([func (make-log/base base)])
     421                     (set! bases (alist-cons base func bases))
     422                     func ) ) ) ) ) )
     423  (%check-flonum 'fllog fl)
     424  (if (not base) (%fplog fl)
     425      (begin
     426        (%check-non-negative-integer 'fllog base)
     427        ((log/base base) fl) ) ) )
    463428
    464429(define (flsin fl)
    465   (check-flonum 'flsin fl)
    466   (##core#inline_allocate ("C_a_i_sin" 4) fl) )
     430  (%check-flonum 'flsin fl)
     431  (%fpsin fl) )
    467432
    468433(define (flcos fl)
    469   (check-flonum 'flcos fl)
    470   (##core#inline_allocate ("C_a_i_cos" 4) fl) )
     434  (%check-flonum 'flcos fl)
     435  (%fpcos fl) )
    471436
    472437(define (fltan fl)
    473   (check-flonum 'fltan fl)
    474   (##core#inline_allocate ("C_a_i_tan" 4) fl) )
     438  (%check-flonum 'fltan fl)
     439  (%fptan fl) )
    475440
    476441(define (flasin fl)
    477   (check-flonum 'flasin fl)
    478   (##core#inline_allocate ("C_a_i_asin" 4) fl) )
     442  (%check-flonum 'flasin fl)
     443  (%fpasin fl) )
    479444
    480445(define (flacos fl)
    481   (check-flonum 'flacos fl)
    482   (##core#inline_allocate ("C_a_i_acos" 4) fl) )
     446  (%check-flonum 'flacos fl)
     447  (%fpacos fl) )
    483448
    484449(define (flatan fl . rest)
    485   (check-flonum 'flatan fl)
    486   (if (null? rest)
    487       (##core#inline_allocate ("C_a_i_atan" 4) fl)
    488       (let ([fld (car rest)])
    489         (check-flonum 'flatan fld)
    490         (##core#inline_allocate ("C_a_i_atan2" 4) fl fld) ) ) )
     450  (%check-flonum 'flatan fl)
     451  (if (%null? rest) (%fpatan fl)
     452      (let ([fld (%car rest)])
     453        (%check-flonum 'flatan fld)
     454        (%fpatan2 fl fld) ) ) )
    491455
    492456(define (flsqrt fl)
    493   (check-flonum 'flsqrt fl)
    494   (##core#inline_allocate ("C_a_i_sqrt" 4) fl) )
     457  (%check-flonum 'flsqrt fl)
     458  (%fpsqrt fl) )
    495459
    496460(define (flexpt fl exp)
    497   (check-flonum 'flexpt fl)
    498   (check-flonum 'flexpt exp)
    499   (or (and (= 2.0 fl)
    500            (ldexp 1.0 exp) )
    501       ((##core#primitive "C_expt") fl exp) ) )
     461  (%check-flonum 'flexpt fl)
     462  (%check-flonum 'flexpt exp)
     463  (if (= 2.0 fl) (ldexp 1.0 exp)
     464      (%expt fl exp) ) )
    502465
    503466(define (flnumerator fl)
    504   (check-flonum 'flnumerator fl)
     467  (%check-flonum 'flnumerator fl)
    505468  fl )
    506469
    507470(define (fldenominator fl)
    508   (check-flonum 'fldenominator fl)
    509   (if (%fpnan? fl)
    510       fl
     471  (%check-flonum 'fldenominator fl)
     472  (if (%fpnan? fl) fl
    511473      1.0 ) )
     474
     475) ;module err5rs-arithmetic-bitwise
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.meta

    r13604 r13606  
    77 (doc-from-wiki)
    88 (synopsis "ERR5RS Arithmetic")
    9  (needs setup-helper srfi-1 int-limits float-limits mathh)
     9 (needs setup-helper srfi-1 int-limits mathh)
    1010 (files
    1111  "tests"
Note: See TracChangeset for help on using the changeset viewer.