Ignore:
Timestamp:
02/20/08 20:53:10 (12 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/mathh/trunk/flonum-extras.scm

    r8556 r8594  
    55        (usual-integrations)
    66        (generic)
     7  (disable-interrupts)
    78        (no-bound-checks)
    89        (no-procedure-checks-for-usual-bindings)
     10        (bound-to-procedure
     11          ##sys#signal-hook
     12          ##sys#check-integer
     13          ##sys#flonum-fraction
     14          ##sys#floor
     15          ##sys#ceiling
     16          ##sys#exact->inexact )
    917  (export
     18    ; Checked
    1019    real->flonum
    1120    fixnum->flonum
     
    5564    flexpt
    5665    flnumerator
    57     fldenominator ) )
     66    fldenominator
     67    ; Unchecked
     68    %fp=
     69    %fp<
     70    %fp>
     71    %fp>=
     72    %fp<=
     73    %fpmax
     74    %fpmin
     75    %fp+
     76    %fp-
     77    %fp*
     78    %fp/
     79    ) )
    5880
    5981(use mathh)
     
    6183;;;
    6284
    63 (define-inline (%fold1 func init lyst)
     85(define (check-flonum loc obj)
     86  (unless (##core#inline "C_i_flonump" obj)
     87    (##sys#signal-hook #:type-error loc
     88                       "bad argument type - not a flonum" obj) ) )
     89
     90(define (check-non-negative-integer loc obj)
     91  (##sys#check-integer obj loc)
     92  (unless ((##core#primitive "C_lessp") 0 obj)
     93    (##sys#signal-hook #:type-error loc
     94                       "bad argument type - not a non-negative integer" obj) ) )
     95
     96;;;
     97
     98(define-inline (%fold1 loc func init lyst)
     99  (check-flonum loc init)
    64100  (let loop ([acc init] [lyst lyst])
    65101          (if (null? lyst)
    66102              acc
    67               (loop (func acc (car lyst)) (cdr lyst)) ) ) )
    68 
    69 (define-inline (%and-fold1 func init lyst)
     103              (let ([cur (car lyst)])
     104          (check-flonum loc cur)
     105          (loop (func acc cur) (cdr lyst)) ) ) ) )
     106
     107(define-inline (%and-fold1 loc func init lyst)
     108  (check-flonum loc init)
    70109  (let loop ([prv init] [lyst lyst])
    71110          (or (null? lyst)
    72               (and (func prv (car lyst))
    73              (loop (car lyst) (cdr lyst)) ) ) ) )
     111        (let ([cur (car lyst)])
     112          (check-flonum loc cur)
     113                (and (func prv cur)
     114               (loop cur (cdr lyst)) ) ) ) ) )
     115
     116;;;
    74117
    75118(define %fpfrac ##sys#flonum-fraction)
    76119
    77 (define %fptrunc modf)
    78 
    79 (define-inline (%fpfloor fp)
    80   (if (fp= 0.0 fp)
     120(define %fptrunc ##sys#truncate)
     121
     122(define %fpfloor ##sys#floor)
     123
     124(define %fpceil ##sys#ceiling)
     125
     126(define-inline (%fprnd fp)
     127  (if (##core#inline "C_flonum_equalp" 0.0 fp)
    81128      0.0
    82       (let ([nt (%fptrunc fp)])
    83         (if (fp< 0.0 fp)
    84             nt
    85             (fp- nt 1.0) ) ) ) )
    86 
    87 (define-inline (%fpceil fp)
    88   (if (fp= 0.0 fp)
    89       0.0
    90       (let ([nt (%fptrunc fp)])
    91         (if (or (fp< 0.0 fp) (not (fp= fp nt)))
    92             (fp+ nt 1.0)
    93             nt ) ) ) )
    94 
    95 (define-inline (%fprnd fp)
    96   (if (fp= 0.0 fp)
    97       0.0
    98       (%fptrunc (fp+ fp (if (fp< 0.0 fp) 0.5 -0.5))) ) )
     129      (%fptrunc (##core#inline_allocate ("C_a_i_flonum_plus" 4)
     130                 fp
     131                 (if (##core#inline "C_flonum_lessp" 0.0 fp) 0.5 -0.5))) ) )
    99132
    100133(define-inline (%fpquo fpn fpd)
    101   (%fptrunc (fp/ fpn fpd)) )
     134  (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) )
    102135
    103136(define-inline (%fprem fpn fpd)
    104   (fp- fpn (fp* (%fptrunc (fp/ fpn fpd)) fpd)) )
     137  (##core#inline_allocate ("C_a_i_flonum_difference" 4)
     138   fpn
     139   (##core#inline_allocate ("C_a_i_flonum_times" 4)
     140    (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd))
     141    fpd)) )
    105142
    106143(define-inline (%fpquo-and-rem fpn fpd)
    107144  (let ([quo (%fpquo fpn fpd)])
    108     (values quo (fp- fpn (fp* quo fpd))) ) )
    109 
    110 (define-inline (%fp< x y)
    111   (or (and (fp= -0.0 x)
    112            (fp= 0.0 y))
    113       (fp< x y) ) )
    114 
    115 (define-inline (%fp<= x y)
    116   (or (and (fp= -0.0 x)
    117            (fp= 0.0 y))
    118       (fp<= x y) ) )
    119 
    120 (define-inline (%fp> x y)
    121   (or (and (fp= 0.0 x)
    122            (fp= -0.0 y))
    123       (fp> x y) ) )
    124 
    125 (define-inline (%fp>= x y)
    126   (or (and (fp= 0.0 x)
    127            (fp= -0.0 y))
    128       (fp>= x y) ) )
     145    (values quo
     146            (##core#inline_allocate ("C_a_i_flonum_difference" 4)
     147             fpn
     148             (##core#inline_allocate ("C_a_i_flonum_times" 4) quo fpd))) ) )
    129149
    130150(define-inline (%fpinteger? fp)
    131   (fp= 0.0 (%fpfrac fp)) )
    132 
    133 (define (%fpnan? fp)
    134   (not (fp= fp fp)) )
     151  (##core#inline "C_flonum_equalp" 0.0 (%fpfrac fp)) )
     152
     153(define-inline (%fpnan? fp)
     154  (not (##core#inline "C_flonum_equalp" fp fp)) )
     155
     156(define (%fp= x y)
     157  (##core#inline "C_flonum_equalp" x y) )
     158
     159(define (%fp< x y)
     160  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
     161           (##core#inline "C_flonum_equalp" 0.0 y))
     162      (##core#inline "C_flonum_lessp" x y) ) )
     163
     164(define (%fp<= x y)
     165  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
     166           (##core#inline "C_flonum_equalp" 0.0 y))
     167      (##core#inline "C_flonum_less_or_equal_p" x y) ) )
     168
     169(define (%fp> x y)
     170  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
     171           (##core#inline "C_flonum_equalp" -0.0 y))
     172      (##core#inline "C_flonum_greaterp" x y) ) )
     173
     174(define (%fp>= x y)
     175  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
     176           (##core#inline "C_flonum_equalp" -0.0 y))
     177      (##core#inline "C_flonum_greater_or_equal_p" x y) ) )
     178
     179(define (%fpmax x y)
     180  (##core#inline "C_i_flonum_max" x y) )
     181
     182(define (%fpmin x y)
     183  (##core#inline "C_i_flonum_min" x y) )
     184
     185(define (%fp+ x y)
     186  (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
     187
     188(define (%fp- x y)
     189  (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
     190
     191(define (%fp* x y)
     192  (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
     193
     194(define (%fp/ x y)
     195  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
    135196
    136197(define-inline (%fpdiv0-and-mod0 fpn fpd)
    137198  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
    138     (cond [(fp>= fpd 0.0)
    139             (if (fp< rem (fp/ fpd 2.0))
    140                 (if (fp>= rem (fp/ fpd -2.0))
     199    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
     200            (if (##core#inline "C_flonum_lessp"
     201                 rem
     202                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
     203                (if (##core#inline "C_flonum_greater_or_equal_p"
     204                     rem
     205                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    141206                    (values quo rem)
    142                     (values (fp- quo 1.0) (fp+ rem fpd)) )
    143                 (values (fp+ quo 1.0) (fp- rem fpd)) ) ]
    144           [(fp< rem (fp/ fpd -2.0))
    145             (if (fp>= rem (fp/ fpd 2.0))
     207                    (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
     208                            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) )
     209                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
     210                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
     211          [(##core#inline "C_flonum_lessp"
     212            rem
     213            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
     214            (if (##core#inline "C_flonum_greater_or_equal_p"
     215                 rem
     216                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    146217                (values quo rem)
    147                 (values (fp+ quo 1.0) (fp- rem fpd)) ) ]
     218                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
     219                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
    148220          [else
    149             (values (fp- quo 1.0) (fp+ rem fpd)) ] ) ) )
     221            (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
     222                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ] ) ) )
    150223
    151224(define-inline (%fpdiv0 fpn fpd)
    152225  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
    153     (cond [(fp>= fpd 0.0)
    154             (if (fp< rem (fp/ fpd 2.0))
    155                 (if (fp>= rem (fp/ fpd -2.0))
     226    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
     227            (if (##core#inline "C_flonum_lessp"
     228                 rem
     229                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
     230                (if (##core#inline "C_flonum_greater_or_equal_p"
     231                     rem
     232                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    156233                    quo
    157                     (fp- quo 1.0) )
    158                 (fp+ quo 1.0) ) ]
    159           [(fp< rem (fp/ fpd -2.0))
    160             (if (fp>= rem (fp/ fpd 2.0))
     234                    (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) )
     235                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
     236          [(##core#inline "C_flonum_lessp"
     237            rem
     238            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
     239            (if (##core#inline "C_flonum_greater_or_equal_p"
     240                 rem
     241                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    161242                quo
    162                 (fp+ quo 1.0) ) ]
     243                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
    163244          [else
    164             (fp- quo 1.0) ] ) ) )
     245            (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ] ) ) )
    165246
    166247(define-inline (%fpmod0 fpn fpd)
    167248  (let ([rem (%fprem fpn fpd)])
    168     (cond [(fp>= fpd 0.0)
    169             (if (fp< rem (fp/ fpd 2.0))
    170                 (if (fp>= rem (fp/ fpd -2.0))
     249    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
     250            (if (##core#inline "C_flonum_lessp"
     251                 rem
     252                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
     253                (if (##core#inline "C_flonum_greater_or_equal_p"
     254                     rem
     255                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
    171256                    rem
    172                     (fp+ rem fpd) )
    173                 (fp- rem fpd) ) ]
    174           [(fp< rem (fp/ fpd -2.0))
    175             (if (fp>= rem (fp/ fpd 2.0))
     257                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) )
     258                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) ) ]
     259          [(##core#inline "C_flonum_lessp"
     260            rem
     261            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
     262            (if (##core#inline "C_flonum_greater_or_equal_p"
     263                 rem
     264                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
    176265                rem
    177                 (fp- rem fpd) )]
     266                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) )]
    178267          [else
    179             (fp+ rem fpd) ] ) ) )
    180 
    181 ;;;
    182 
    183 (define real->flonum
    184   (let ([exact->inexact exact->inexact])
    185     (lambda (value)
    186       (if (flonum? value)
    187           value
    188           (exact->inexact value) ) ) ) )
    189 
    190 (define fixnum->flonum
    191   (let ([exact->inexact exact->inexact])
    192     (lambda (fx)
    193       (unless (fixnum? fx)
    194         (##sys#signal-hook #:type-error 'fixnum->flonum
    195                            "bad argument type - not a fixnum" fx) )
    196       (exact->inexact fx) ) ) )
     268            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ] ) ) )
     269
     270;;;
     271
     272(define (real->flonum value)
     273  (if (##core#inline "C_i_flonump" value)
     274      value
     275      (##sys#exact->inexact value) ) )
     276
     277(define (fixnum->flonum fx)
     278  (if (##core#inline "C_fixnump" fx)
     279      (##sys#exact->inexact fx)
     280      (##sys#signal-hook #:type-error 'fixnum->flonum
     281                         "bad argument type - not a fixnum" fx) ) )
    197282
    198283;;;
    199284
    200285(define (fl=? fl . rest)
    201         (%and-fold1 fp= fl rest) )
     286        (%and-fold1 'fl=? %fp= fl rest) )
    202287
    203288(define (fl<? fl . rest)
    204         (%and-fold1 %fp< fl rest) )
     289        (%and-fold1 'fl<? %fp< fl rest) )
    205290
    206291(define (fl>? fl . rest)
    207         (%and-fold1 %fp> fl rest) )
     292        (%and-fold1 'fl>? %fp> fl rest) )
    208293
    209294(define (fl<=? fl . rest)
    210         (%and-fold1 %fp<= fl rest) )
     295        (%and-fold1 'fl<=? %fp<= fl rest) )
    211296
    212297(define (fl>=? fl . rest)
    213         (%and-fold1 %fp>= fl rest) )
     298        (%and-fold1 'fl>=? %fp>= fl rest) )
    214299
    215300(define (flcompare fl1 fl2)
    216         (cond [(fp= fl1 fl2)
    217                 (cond [(fp= -0.0 fl1)
    218                   (if (fp= -0.0 fl1) 0 1) ]
    219                       [(fp= -0.0 fl2)
    220                         (if (fp= 0.0 fl1) -1 0) ]
     301  (check-flonum 'flcompare fl1)
     302  (check-flonum 'flcompare fl2)
     303        (cond [(##core#inline "C_flonum_equalp" fl1 fl2)
     304                (cond [(##core#inline "C_flonum_equalp" -0.0 fl1)
     305                  (if (##core#inline "C_flonum_equalp" -0.0 fl1)
     306                      0
     307                      1) ]
     308                      [(##core#inline "C_flonum_equalp" -0.0 fl2)
     309                        (if (##core#inline "C_flonum_equalp" 0.0 fl1)
     310                            -1
     311                            0) ]
    221312                      [else
    222313                        0 ] ) ]
    223               [(fp< fl1 fl2)
     314              [(##core#inline "C_flonum_lessp" fl1 fl2)
    224315                -1 ]
    225316              [else
     
    227318
    228319(define (flmax fl . rest)
    229         (%fold1 fpmax fl rest) )
     320        (%fold1 'flmax %fpmax fl rest) )
    230321
    231322(define (flmin fl . rest)
    232         (%fold1 fpmin fl rest) )
     323        (%fold1 'flmin %fpmin fl rest) )
    233324
    234325(define (flmax-and-min fl . rest)
    235         (let loop ([mx fl] [mn fl] [lyst rest])
     326  (check-flonum 'flmax-and-min fl)
     327        (let loop ([mx fl]
     328                   [mn fl]
     329                   [lyst rest])
    236330          (if (null? lyst)
    237331              (values mx mn)
    238332              (let ([cur (car lyst)])
    239           (loop (fpmax mx cur) (fpmin mn cur) (cdr lyst)) ) ) ) )
     333                (check-flonum 'flmax-and-min cur)
     334          (loop (##core#inline "C_i_flonum_max" mx cur)
     335                (##core#inline "C_i_flonum_min" mn cur)
     336                (cdr lyst)) ) ) ) )
    240337
    241338;;;
    242339
    243340(define (flinteger? fl)
    244         (%fpinteger? fl) )
     341  (check-flonum 'flinteger? fl)
     342  (%fpinteger? fl) )
    245343
    246344(define (flzero? fl)
    247         (fp= 0.0 fl) )
     345  (check-flonum 'flzero? fl)
     346        (##core#inline "C_flonum_equalp" 0.0 fl) )
    248347
    249348(define (flpositive? fl)
    250         (fp< 0.0 fl) )
     349  (check-flonum 'flpositive? fl)
     350        (##core#inline "C_flonum_lessp" 0.0 fl) )
    251351
    252352(define (flnegative? fl)
    253         (or (fp= -0.0 fl)
    254       (fp< fl 0.0) ) )
     353  (check-flonum 'flnegative? fl)
     354        (or (##core#inline "C_flonum_equalp" -0.0 fl)
     355      (##core#inline "C_flonum_lessp" fl 0.0) ) )
    255356
    256357(define (flodd? fl)
    257   (fx= 1 (bitwise-and (%fptrunc fl) #b1)) )
     358  (check-flonum 'flodd? fl)
     359  (eq? 1 (##core#inline_allocate ("C_a_i_bitwise_and" 4) (%fptrunc fl) #b1)) )
    258360
    259361(define (fleven? fl)
    260   (fx= 0 (bitwise-and (%fptrunc fl) #b1)) )
     362  (check-flonum 'fleven? fl)
     363  (eq? 0 (##core#inline_allocate ("C_a_i_bitwise_and" 4) (%fptrunc fl) #b1)) )
    261364
    262365(define (flfinite? fl)
    263   (finite? fl) )
     366  (check-flonum 'flfinite? fl)
     367  (##core#inline "C_i_finitep" fl) )
    264368
    265369(define (flinfinite? fl)
    266   (not (finite? fl)) )
     370  (check-flonum 'flinfinite? fl)
     371  (not (##core#inline "C_i_finitep" fl)) )
    267372
    268373(define (flnan? fl)
     374  (check-flonum 'flnan? fl)
    269375  (%fpnan? fl) )
    270376
     
    272378
    273379(define (fl+ fl . rest)
    274         (%fold1 fp+ fl rest) )
     380        (%fold1 'fl+ %fp+ fl rest) )
    275381
    276382(define (fl* fl . rest)
    277         (%fold1 fp* fl rest) )
     383        (%fold1 'fl* %fp* fl rest) )
    278384
    279385(define (fl- fl . rest)
    280386  (or (and (null? rest)
    281            (fpneg fl) )
    282       (%fold1 fp- fl rest) ) )
     387           (##core#inline_allocate ("C_a_i_flonum_negate" 4) fl) )
     388      (%fold1 'fl- %fp- fl rest) ) )
    283389
    284390(define (fl/ fl . rest)
    285391  (or (and (null? rest)
    286            (fp/ 1.0 fl) )
    287         (%fold1 fp/ fl rest) ) )
     392           (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 1.0 fl) )
     393        (%fold1 'fl/ %fp/ fl rest) ) )
    288394
    289395(define (flabs fl)
    290   (cond [(fp= -0.0 fl)  0.0]
    291         [(fp< fl 0.0)   (fpneg fl)]
    292         [else           fl] ) )
     396  (check-flonum 'flabs fl)
     397  (##core#inline_allocate ("C_a_i_abs" 4) fl) )
    293398
    294399(define (flfraction fl)
     400  (check-flonum 'flfraction fl)
    295401  (%fpfrac fl) )
    296402
    297403(define (fltruncate fl)
     404  (check-flonum 'fltruncate fl)
    298405  (%fptrunc fl) )
    299406
    300407(define (flfloor fl)
     408  (check-flonum 'flfloor fl)
    301409  (%fpfloor fl) )
    302410
    303411(define (flceiling fl)
     412  (check-flonum 'flceiling fl)
    304413  (%fpceil fl) )
    305414
    306415(define (flround fl)
     416  (check-flonum 'flround fl)
    307417  (%fprnd fl) )
    308418
    309419(define (fldiv fln fld)
     420  (check-flonum 'fldiv fln)
     421  (check-flonum 'fldiv fld)
    310422  (%fpquo fln fld) )
    311423
    312424(define (flmod fln fld)
     425  (check-flonum 'flmod fln)
     426  (check-flonum 'flmod fld)
    313427  (%fprem fln fld) )
    314428
    315429(define (fldiv-and-mod fln fld)
     430  (check-flonum 'fldiv-and-mod fln)
     431  (check-flonum 'fldiv-and-mod fld)
    316432  (%fpquo-and-rem fln fld) )
    317433
    318434(define (fldiv0 fln fld)
     435  (check-flonum 'fldiv0 fln)
     436  (check-flonum 'fldiv0 fld)
    319437  (%fpdiv0 fln fld) )
    320438
    321439(define (flmod0 fln fld)
     440  (check-flonum 'flmod0 fln)
     441  (check-flonum 'flmod0 fld)
    322442  (%fpmod0 fln fld) )
    323443
    324444(define (fldiv0-and-mod0 fln fld)
     445  (check-flonum 'fldiv0-and-mod0 fln)
     446  (check-flonum 'fldiv0-and-mod0 fld)
    325447  (%fpdiv0-and-mod0 fln fld) )
    326448
    327 (define flexp
    328   (let ([exp exp])
    329     (lambda (fl)
    330       (exp fl) ) ) )
    331 
    332 (define fllog
    333   (let ([log log])
    334     (lambda (fl #!optional base)
    335       (or (and base
    336                ((make-log/base base) fl) )
    337           #;
    338           (and (VERY-SMALL-FLONUM? fl)
    339                (log1p (fp- fl 1.0)) )
    340           (log fl) ) ) ) )
    341 
    342 (define flsin
    343         (let ([sin sin])
    344                 (lambda (fl)
    345                         (sin fl) ) ) )
    346 
    347 (define flcos
    348         (let ([cos cos])
    349                 (lambda (fl)
    350                         (cos fl) ) ) )
    351 
    352 (define fltan
    353         (let ([tan tan])
    354                 (lambda (fl)
    355                         (tan fl) ) ) )
    356 
    357 (define flasin
    358         (let ([asin asin])
    359                 (lambda (fl)
    360                         (asin fl) ) ) )
    361 
    362 (define flacos
    363         (let ([acos acos])
    364                 (lambda (fl)
    365                         (acos fl) ) ) )
    366 
    367 (define flatan
    368   (let ([atan atan])
    369     (lambda (fl #!optional fld)
    370       (or (and fld
    371                (atan (fp/ fl fld)) )
    372           (atan fl) ) ) ) )
    373 
    374 (define flsqrt
    375   (let ([sqrt sqrt])
    376     (lambda (fl)
    377       (sqrt fl) ) ) )
    378 
    379 (define flexpt
    380   (let ([expt expt])
    381     (lambda (fl exp)
    382       (or (and (= 2.0 fl)
    383                (ldexp 1.0 exp) )
    384           (expt fl exp) ) ) ) )
     449(define (flexp fl)
     450  (check-flonum 'flexp fl)
     451  (##core#inline_allocate ("C_a_i_exp" 4) fl) )
     452
     453(define (fllog fl . rest)
     454  (check-flonum 'fllog fl)
     455  (if (null? rest)
     456      (##core#inline_allocate ("C_a_i_log" 4) fl)
     457      (let ([base (car rest)])
     458        (check-non-negative-integer 'fllog base)
     459        ((make-log/base base) fl) ) ) )
     460
     461(define (flsin fl)
     462  (check-flonum 'flsin fl)
     463  (##core#inline_allocate ("C_a_i_sin" 4) fl) )
     464
     465(define (flcos fl)
     466  (check-flonum 'flcos fl)
     467  (##core#inline_allocate ("C_a_i_cos" 4) fl) )
     468
     469(define (fltan fl)
     470  (check-flonum 'fltan fl)
     471  (##core#inline_allocate ("C_a_i_tan" 4) fl) )
     472
     473(define (flasin fl)
     474  (check-flonum 'flasin fl)
     475  (##core#inline_allocate ("C_a_i_asin" 4) fl) )
     476
     477(define (flacos fl)
     478  (check-flonum 'flacos fl)
     479  (##core#inline_allocate ("C_a_i_acos" 4) fl) )
     480
     481(define (flatan fl . rest)
     482  (check-flonum 'flatan fl)
     483  (if (null? rest)
     484      (##core#inline_allocate ("C_a_i_atan" 4) fl)
     485      (let ([fld (car rest)])
     486        (check-flonum 'flatan fld)
     487        (##core#inline_allocate ("C_a_i_atan2" 4) fl fld) ) ) )
     488
     489(define (flsqrt fl)
     490  (check-flonum 'flsqrt fl)
     491  (##core#inline_allocate ("C_a_i_sqrt" 4) fl) )
     492
     493(define (flexpt fl exp)
     494  (check-flonum 'flexpt fl)
     495  (check-flonum 'flexpt exp)
     496  (or (and (= 2.0 fl)
     497           (ldexp 1.0 exp) )
     498      ((##core#primitive "C_expt") fl exp) ) )
    385499
    386500(define (flnumerator fl)
     501  (check-flonum 'flnumerator fl)
    387502  fl )
    388503
    389504(define (fldenominator fl)
     505  (check-flonum 'fldenominator fl)
    390506  (if (%fpnan? fl)
    391507      fl
Note: See TracChangeset for help on using the changeset viewer.