Changeset 8594 in project


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

Save.

Location:
release/3/mathh/trunk
Files:
6 edited

Legend:

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

    r8543 r8594  
    55        (usual-integrations)
    66        (generic)
     7  (disable-interrupts)
    78        (no-bound-checks)
    89        (no-procedure-checks-for-usual-bindings)
     
    1011    boolean->bit
    1112    ; Checked
     13    pow2log2
    1214    bitwise-if
    1315    bitwise-if-not
     
    3032    bitwise-arithmetic-shift-right
    3133    ; Unchecked
     34    %pow2log2
    3235    %bitwise-if
    3336    %bitwise-if-not
     
    239242;;;
    240243
    241 #;
    242 (define %pow2log2
    243   (foreign-lambda* unsigned-int ((integer value))
    244    "return (2 << C_uword_log2( (C_uword) value ));"))
    245 
    246 ;;;
    247 
    248244(define-inline (check-list loc obj)
    249245  (##sys#check-list obj loc) )
     
    256252  (when (negative? obj)
    257253    (##sys#signal-hook #:type-error loc
    258      "bad argument type - not an non-negative integer" obj) ) )
     254     "bad argument type - not a non-negative integer" obj) ) )
    259255
    260256(define-inline (check-<= loc num1 num2)
    261257  (when (< num2 num1)
    262258    (##sys#signal-hook #:type-error loc
    263      "bad argument type - not a valid open interval" num1 num2) ) )
     259     "bad argument type - not a valid interval" num1 num2) ) )
    264260
    265261;;;
     
    269265
    270266;;;
     267
     268(define %pow2log2
     269  (foreign-lambda* unsigned-int ((integer value))
     270   "return (2 << C_uword_log2( (C_uword) value ));"))
    271271
    272272(define %bitwise-if
     
    386386;;;
    387387
    388 (define (bitwise-if mask t f)
     388(define (pow2log2 value)
     389  (check-integer 'pow2log2 value)
     390  (%pow2log2 value) )
     391
     392(define (bitwise-if mask true false)
    389393  (check-integer 'bitwise-if mask)
    390   (check-integer 'bitwise-if t)
    391   (check-integer 'bitwise-if f)
    392   (%bitwise-if mask t f))
    393 
    394 (define (bitwise-if-not mask t f)
     394  (check-integer 'bitwise-if true)
     395  (check-integer 'bitwise-if false)
     396  (%bitwise-if mask true false))
     397
     398(define (bitwise-if-not mask true false)
    395399  (check-integer 'bitwise-if-not mask)
    396   (check-integer 'bitwise-if-not t)
    397   (check-integer 'bitwise-if-not f)
    398   (%bitwise-if-not mask t f))
     400  (check-integer 'bitwise-if-not true)
     401  (check-integer 'bitwise-if-not false)
     402  (%bitwise-if-not mask true false))
    399403
    400404(define (bitwise-test? a b)
  • release/3/mathh/trunk/doc.scm

    r8556 r8594  
    1010    (name "mathh")
    1111    (description
    12       (p "Provides access to ISO C math functions in " (code "<math.h>") " "
    13       "that are not defined by Chicken.")
    14       (p "Also supplies " (code "<float.h>") " constants, common derived constants, and "
    15       "limits for Chicken numeric types.") )
     12      (p "Provides:")
     13      (ul
     14        (li "* access to ISO C math functions in " (code "<math.h>") " "
     15          "that are not defined by Chicken.")
     16        (li "* " (code "<float.h>") " constants, common derived constants, and "
     17          "limits for Chicken numeric types.")
     18        (li "* R6RS arithmetic functions.") ) )
    1619
    1720    (author "John Cowan and Kon Lovett")
     
    122125          (describe short-size "Sizeof the C type")
    123126          (describe int-size "Sizeof the C type")
     127          (describe long-size "Sizeof the C type")
    124128          (describe long-long-size "Sizeof the C type, 0 when unsupported") )
    125129      )
     
    224228        (usage "(require-extension fixnum-extras)")
    225229
     230        (p "R6RS fixnum functions. The \"*\" prefixed functions are variable arity "
     231        "versions of the built-in Chicken Scheme functions. This naming convention "
     232        "violates R6RS.")
     233
    226234        (procedure "(fixnum->string FX [RADIX])"
    227235          (p "") )
     
    281289          (p "") )
    282290
     291        (procedure "(fxpow2log2 FX)"
     292          (p "") )
     293
    283294        (procedure "(fxdiv FX-N FX-D)"
    284295          (p "") )
     
    376387        (usage "(require-extension flonum-extras)")
    377388
     389        (p "R6RS flonum functions.")
     390
    378391        (procedure "(real->flonum VALUE)"
    379392          (p "") )
     
    524537
    525538        (usage "(require-extension bitwise-extras)")
     539
     540        (p "R6RS bitwise functions.")
    526541
    527542        (p "Unchecked variants of the following procedures are supplied, named "
    528543        "as the checked version but with a \"%\" prefix.")
     544
     545        (procedure "(pow2log2 VALUE)"
     546                                        (p "Returns " (code "2 ** log2 (" (tt "VALUE") ")") ".") )
    529547
    530548                                (procedure "(boolean->bit OBJECT)"
     
    592610
    593611    (history
     612      (version "1.11" "Added argument checking to fix & flonum functions. [Kon Lovett]")
    594613      (version "1.10" "Cygwin compile fix. Added \"fixnum/flonum/bitwise-extras\". Removed \"count-set-bits\" & \"count-unset-bits\". [Kon Lovett]")
    595614      (version "1.903" "Added C int & float types. [Kon Lovett]")
  • release/3/mathh/trunk/fixnum-extras.scm

    r8556 r8594  
    55        (usual-integrations)
    66        (generic)
     7  (disable-interrupts)
    78        (no-bound-checks)
    89        (no-procedure-checks-for-usual-bindings)
    910        (bound-to-procedure
    10           ##sys#signal-hook )
     11          ##sys#signal-hook
     12          ##sys#make-string
     13          ##sys#string-append )
    1114  (export
    1215    fixnum->string
     
    2831    *fxmin
    2932    fxmax-and-min
     33    fxpow2log2
    3034    fxdiv
    3135    fxdiv-and-mod
     
    6670
    6771(define-inline (fixnum-type-error loc obj)
    68   (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     72  (##sys#signal-hook #:type-error loc
     73                     "bad argument type - not a fixnum" obj) )
    6974
    7075(define-inline (fixnum-zero-division-error loc fx1 fx2)
    71   (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
     76  (##sys#signal-hook #:arithmetic-error loc
     77                     "division by zero" fx1 fx2) )
    7278
    7379(define-inline (fixnum-representation-error loc fx1 fx2)
    74   (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
    75 
    76 (define-inline (%fold1 func init lyst)
     80  (##sys#signal-hook #:arithmetic-error loc
     81                     "results not representable as fixnums" fx1 fx2) )
     82
     83(define-inline (check-fixnum loc obj)
     84  (unless (##core#inline "C_fixnump" obj)
     85    (fixnum-type-error loc obj) ) )
     86
     87(define-inline (check-non-negative-fixnum loc obj)
     88  (unless (and (##core#inline "C_fixnump" obj)
     89               (##core#inline "C_fixnum_less_or_equal_p" 0 obj))
     90    (##sys#signal-hook #:type-error loc
     91                       "bad argument type - not a non-negative fixnum" obj) ) )
     92
     93(define-inline (check-fixnums-<= loc fx1 fx2)
     94  (unless (##core#inline "C_fixnum_less_or_equal_p" fx1 fx2)
     95    (##sys#signal-hook #:type-error loc
     96                       "bad argument type - not an interval" fx1 fx2) ) )
     97
     98(define-inline (check-zero-division loc fx1 fx2)
     99  (when (##core#inline "C_eqp" 0 fx2)
     100    (fixnum-zero-division-error loc fx1 fx2) ) )
     101
     102;;;
     103
     104(define-inline (%fold1 loc func init lyst)
     105  (check-fixnum loc init)
    77106  (let loop ([acc init] [lyst lyst])
    78107          (if (null? lyst)
    79108              acc
    80               (loop (func acc (car lyst)) (cdr lyst)) ) ) )
    81 
    82 (define-inline (%and-fold1 func init lyst)
     109              (let ([cur (car lyst)])
     110          (check-fixnum loc cur)
     111                (loop (func acc cur) (cdr lyst)) ) ) ) )
     112
     113(define-inline (%and-fold1 loc func init lyst)
     114  (check-fixnum loc init)
    83115  (let loop ([prv init] [lyst lyst])
    84116          (or (null? lyst)
    85               (and (func prv (car lyst))
    86              (loop (car lyst) (cdr lyst)) ) ) ) )
     117        (let ([cur (car lyst)])
     118          (check-fixnum loc cur)
     119          (and (func prv (car lyst))
     120               (loop (car lyst) (cdr lyst)) ) ) ) ) )
     121
     122;;;
     123
     124(define (%fx= x y)
     125  (##core#inline "C_eqp" x y) )
     126
     127(define (%fx< x y)
     128  (##core#inline "C_fixnum_lessp" x y) )
     129
     130(define (%fx> x y)
     131  (##core#inline "C_fixnum_greaterp" x y) )
     132
     133(define (%fx>= x y)
     134  (##core#inline "C_fixnum_greater_or_equal_p" x y) )
     135
     136(define (%fx<= x y)
     137  (##core#inline "C_fixnum_less_or_equal_p" x y) )
     138
     139(define (%fxmax x y )
     140  (##core#inline "C_i_fixnum_max" x y) )
     141
     142(define (%fxmin x y )
     143  (##core#inline "C_i_fixnum_min" x y) )
     144
     145(define %fxnegprec (##core#inline "C_fixnum_negate" fixnum-precision))
    87146
    88147(define-inline (%fxdiv0-and-mod0 fxn fxd)
    89   (let* ([quo (quotient fxn fxd)]
    90          [rem (- fxn (* quo fxd))])
    91     (cond [(>= fxd 0)
    92             (if (< (* rem 2) fxd)
    93                 (if (<= (* rem -2) fxd)
     148  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
     149         [rem ((##core#primitive "C_minus")
     150               fxn
     151               ((##core#primitive "C_times") quo fxd))])
     152    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
     153            (if ((##core#primitive "C_lessp")
     154                 ((##core#primitive "C_times") rem 2)
     155                 fxd)
     156                (if ((##core#primitive "C_less_or_equal_p")
     157                     ((##core#primitive "C_times") rem -2)
     158                     fxd)
    94159                    (values quo rem)
    95                     (values (- quo 1) (+ rem fxd)) )
    96                 (values (+ quo 1) (- rem fxd)) ) ]
    97           [(> (* rem -2) fxd)
    98             (if (>= (* rem 2) fxd)
     160                    (values ((##core#primitive "C_minus") quo 1)
     161                            ((##core#primitive "C_plus") rem fxd)) )
     162                (values ((##core#primitive "C_plus") quo 1)
     163                        ((##core#primitive "C_minus") rem fxd)) ) ]
     164          [((##core#primitive "C_greaterp")
     165            ((##core#primitive "C_times") rem -2)
     166            fxd)
     167            (if ((##core#primitive "C_greater_or_equal_p")
     168                 ((##core#primitive "C_times") rem 2)
     169                 fxd)
    99170                (values quo rem)
    100                 (values (+ quo 1) (- rem fxd)) ) ]
     171                (values ((##core#primitive "C_plus") quo 1)
     172                        ((##core#primitive "C_minus") rem fxd)) ) ]
    101173          [else
    102             (values (- quo 1) (+ rem fxd)) ] ) ) )
     174            (values ((##core#primitive "C_minus") quo 1)
     175                    ((##core#primitive "C_plus") rem fxd)) ] ) ) )
    103176
    104177(define-inline (%fxdiv0 fxn fxd)
    105   (let* ([quo (quotient fxn fxd)]
    106          [rem (- fxn (* quo fxd))])
    107     (if (>= fxd 0)
    108         (if (< (* rem 2) fxd)
    109             (if (<= (* rem -2) fxd)
     178  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
     179         [rem ((##core#primitive "C_minus")
     180               fxn
     181               ((##core#primitive "C_times") quo fxd))])
     182    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
     183            (if ((##core#primitive "C_lessp")
     184                 ((##core#primitive "C_times") rem 2)
     185                 fxd)
     186                (if ((##core#primitive "C_less_or_equal_p")
     187                     ((##core#primitive "C_times") rem -2)
     188                     fxd)
     189                    quo
     190                    ((##core#primitive "C_minus") quo 1) )
     191                ((##core#primitive "C_plus") quo 1) ) ]
     192          [((##core#primitive "C_greaterp")
     193            ((##core#primitive "C_times") rem -2)
     194            fxd)
     195            (if ((##core#primitive "C_greater_or_equal_p")
     196                 ((##core#primitive "C_times") rem 2)
     197                 fxd)
    110198                quo
    111                 (- quo 1) )
    112             (+ quo 1) )
    113         (if (> (* rem -2) fxd)
    114             (if (>= (* rem 2) fxd)
    115                 quo
    116                 (+ quo 1) )
    117             (- quo 1) ) ) ) )
     199                ((##core#primitive "C_plus") quo 1) ) ]
     200          [else
     201            ((##core#primitive "C_minus") quo 1) ] ) ) )
    118202
    119203(define-inline (%fxmod0 fxn fxd)
    120   (let* ([quo (quotient fxn fxd)]
    121          [rem (- fxn (* quo fxd))])
    122     (cond [(>= fxd 0)
    123             (if (< (* rem 2) fxd)
    124                 (if (<= (* rem -2) fxd)
     204  (let* ([quo ((##core#primitive "C_quotient") fxn fxd)]
     205         [rem ((##core#primitive "C_minus")
     206               fxn
     207               ((##core#primitive "C_times") quo fxd))])
     208    (cond [((##core#primitive "C_greater_or_equal_p") fxd 0)
     209            (if ((##core#primitive "C_lessp")
     210                 ((##core#primitive "C_times") rem 2)
     211                 fxd)
     212                (if ((##core#primitive "C_less_or_equal_p")
     213                     ((##core#primitive "C_times") rem -2) fxd)
    125214                    rem
    126                     (+ rem fxd) )
    127                 (- rem fxd) ) ]
    128           [(> (* rem -2) fxd)
    129             (if (>= (* rem 2) fxd)
     215                    ((##core#primitive "C_plus") rem fxd) )
     216                ((##core#primitive "C_minus") rem fxd) ) ]
     217          [((##core#primitive "C_greaterp")
     218            ((##core#primitive "C_times") rem -2)
     219            fxd)
     220            (if ((##core#primitive "C_greater_or_equal_p")
     221                 ((##core#primitive "C_times") rem 2)
     222                 fxd)
    130223                rem
    131                 (- rem fxd) ) ]
     224                ((##core#primitive "C_minus") rem fxd) ) ]
    132225          [else
    133             (+ rem fxd) ] ) ) )
     226            ((##core#primitive "C_plus") rem fxd) ] ) ) )
     227
     228(define (%fxand x y)
     229  (##core#inline "C_fixnum_and" x y) )
     230
     231(define (%fxior x y)
     232  (##core#inline "C_fixnum_or" x y) )
     233
     234(define (%fxxor x y)
     235  (##core#inline "C_fixnum_xor" x y) )
    134236
    135237;;;
     
    147249
    148250(define (fx=? fx . rest)
    149         (%and-fold1 fx= fx rest) )
     251        (%and-fold1 'fx=? %fx= fx rest) )
    150252
    151253(define (fx<? fx . rest)
    152         (%and-fold1 fx< fx rest) )
     254        (%and-fold1 'fx<? %fx< fx rest) )
    153255
    154256(define (fx>? fx . rest)
    155         (%and-fold1 fx> fx rest) )
     257        (%and-fold1 'fx>? %fx> fx rest) )
    156258
    157259(define (fx<=? fx . rest)
    158         (%and-fold1 fx<= fx rest) )
     260        (%and-fold1 'fx<=? %fx<= fx rest) )
    159261
    160262(define (fx>=? fx . rest)
    161         (%and-fold1 fx>= fx rest) )
     263        (%and-fold1 'fx>=? %fx>= fx rest) )
    162264
    163265(define (fxcompare fx1 fx2)
    164         (cond [(fx= fx1 fx2)  0]
    165               [(fx< fx1 fx2)  -1]
    166               [else           1] ) )
     266  (check-fixnum 'fxcompare fx1)
     267  (check-fixnum 'fxcompare fx2)
     268        (cond [(##core#inline "C_eqp" fx1 fx2)
     269                0]
     270              [(fx< fx1 fx2)
     271                -1]
     272              [else
     273                1] ) )
    167274
    168275(define (*fxmax fx . rest)
    169         (%fold1 max fx rest) )
     276        (%fold1 'fxmax %fxmax fx rest) )
    170277
    171278(define (*fxmin fx . rest)
    172         (%fold1 min fx rest) )
     279        (%fold1 'fxmin %fxmin fx rest) )
    173280
    174281(define (fxmax-and-min fx . rest)
    175         (let loop ([mx fx] [mn fx] [lyst rest])
     282  (check-fixnum 'fxmax-and-min fx)
     283        (let loop ([mx fx]
     284                   [mn fx]
     285                   [lyst rest])
    176286          (if (null? lyst)
    177287              (values mx mn)
    178288              (let ([cur (car lyst)])
    179           (loop (fxmax mx cur) (fxmin mn cur) (cdr lyst)) ) ) ) )
     289          (check-fixnum 'fxmax-and-min cur)
     290          (loop (##core#inline "C_i_fixnum_max" mx cur)
     291                (##core#inline "C_i_fixnum_min" mn cur)
     292                (cdr lyst)) ) ) ) )
    180293
    181294;;;
    182295
    183296(define (fxzero? fx)
    184         (fx= 0 fx) )
     297  (check-fixnum 'fxzero? fx)
     298        (##core#inline "C_eqp" 0 fx) )
    185299
    186300(define (fxpositive? fx)
    187         (fx< 0 fx) )
     301  (check-fixnum 'fxpositive? fx)
     302        (##core#inline "C_fixnum_lessp" 0 fx) )
    188303
    189304(define (fxnegative? fx)
    190         (fx< fx 0) )
     305  (check-fixnum 'fxnegative? fx)
     306        (##core#inline "C_fixnum_lessp" fx 0) )
    191307
    192308(define (fxodd? fx)
    193         (fx= 1 (fxand fx 1)) )
     309  (check-fixnum 'fxodd? fx)
     310        (##core#inline "C_eqp" 1 (##core#inline "C_fixnum_and" fx 1)) )
    194311
    195312(define (fxeven? fx)
    196         (fx= 0 (fxand fx 1)) )
    197 
    198 ;;;
    199 
    200 (define fxdiv fx/)
     313  (check-fixnum 'fxeven? fx)
     314        (##core#inline "C_eqp" 0 (##core#inline "C_fixnum_and" fx 1)) )
     315
     316;;;
     317
     318(define (fxpow2log2 fx)
     319  (check-fixnum 'fxpow2log2 fx)
     320  (%pow2log2 fx) )
     321
     322(define (fxdiv fxn fxd)
     323  (check-fixnum 'fxdiv fxn)
     324  (check-fixnum 'fxdiv fxd)
     325  (check-zero-division 'fxdiv fxn fxd)
     326  (##core#inline "C_fixnum_divide" fxn fxd) )
    201327
    202328(define (fxdiv-and-mod fxn fxd)
    203         (values (fx/ fxn fxd) (fxmod fxn fxd)) )
     329  (check-fixnum 'fxdiv-and-mod fxn)
     330  (check-fixnum 'fxdiv-and-mod fxd)
     331  (check-zero-division 'fxdiv fxn fxd)
     332        (values (##core#inline "C_fixnum_divide" fxn fxd)
     333                (##core#inline "C_fixnum_modulo" fxn fxd)) )
     334
     335(define (fxdiv0 fxn fxd)
     336  (if (##core#inline "C_fixnump" fxn)
     337      (if (##core#inline "C_fixnump" fxd)
     338          (if (##core#inline "C_eqp" 0 fxd)
     339              (fixnum-zero-division-error 'fxdiv0 fxn fxd)
     340              (let ([d (%fxdiv0 fxn fxd)])
     341                (if (##core#inline "C_fixnump" d)
     342                    d
     343                    (fixnum-representation-error 'fxdiv0 fxn fxd) ) ) )
     344          (fixnum-type-error 'fxdiv0 fxd) )
     345      (fixnum-type-error 'fxdiv0 fxn) ) )
     346
     347(define (fxmod0 fxn fxd)
     348  (if (##core#inline "C_fixnump" fxn)
     349      (if (##core#inline "C_fixnump" fxd)
     350          (if (##core#inline "C_eqp" 0 fxd)
     351              (fixnum-zero-division-error 'fxmod0 fxn fxd)
     352              (let ([m (%fxmod0 fxn fxd)])
     353                (if (##core#inline "C_fixnump" m)
     354                    m
     355                    (fixnum-representation-error 'fxmod0 fxn fxd) ) ) )
     356          (fixnum-type-error 'fxmod0 fxd) )
     357      (fixnum-type-error 'fxmod0 fxn) ) )
    204358
    205359(define (fxdiv0-and-mod0 fxn fxd)
    206   (if (fixnum? fxn)
    207       (if (fixnum? fxd)
    208           (if (fx= fxd 0)
     360  (if (##core#inline "C_fixnump" fxn)
     361      (if (##core#inline "C_fixnump" fxd)
     362          (if (##core#inline "C_eqp" 0 fxd)
    209363              (fixnum-zero-division-error 'fxdiv0-and-mod0 fxn fxd)
    210               (let-values ([(d1 m1) (%fxdiv0-and-mod0 fxn fxd)])
    211                 (if (and (fixnum? d1) (fixnum? m1))
    212                     (values d1 m1)
     364              (let-values ([(d m) (%fxdiv0-and-mod0 fxn fxd)])
     365                (if (and (##core#inline "C_fixnump" d)
     366                         (##core#inline "C_fixnump" m))
     367                    (values d m)
    213368                    (fixnum-representation-error 'fxdiv0-and-mod0 fxn fxd) ) ) )
    214369          (fixnum-type-error 'fxdiv0-and-mod0 fxd) )
    215370      (fixnum-type-error 'fxdiv0-and-mod0 fxn) ) )
    216371
    217 (define (fxdiv0 fxn fxd)
    218   (if (fixnum? fxn)
    219       (if (fixnum? fxd)
    220           (if (fx= fxd 0)
    221               (fixnum-zero-division-error 'fxdiv0 fxn fxd)
    222               (let ([r (%fxdiv0 fxn fxd)])
    223                 (if (fixnum? r)
    224                     r
    225                     (fixnum-representation-error 'fxdiv0 fxn fxd) ) ) )
    226           (fixnum-type-error 'fxdiv0 fxd) )
    227       (fixnum-type-error 'fxdiv0 fxn) ) )
    228 
    229 (define (fxmod0 fxn fxd)
    230   (if (fixnum? fxn)
    231       (if (fixnum? fxd)
    232           (if (fx= fxd 0)
    233               (fixnum-zero-division-error 'fxmod0 fxn fxd)
    234               (let ([r (%fxmod0 fxn fxd)])
    235                 (if (fixnum? r)
    236                     r
    237                     (fixnum-representation-error 'fxmod0 fxn fxd) ) ) )
    238           (fixnum-type-error 'fxmod0 fxd) )
    239       (fixnum-type-error 'fxmod0 fxn) ) )
    240 
    241372(define (fx*/carry fx1 fx2 fx3)
    242   (let ([s0 (fx+ (fx* fx1 fx2) fx3)])
    243     (values s0
    244             (arithmetic-shift (+ (* fx1 fx2) (- fx3 s0)) (- fixnum-precision)) ) ) )
     373  (check-fixnum 'fx*/carry fx1)
     374  (check-fixnum 'fx*/carry fx2)
     375  (check-fixnum 'fx*/carry fx3)
     376  (let ([res (##core#inline "C_fixnum_plus"
     377              (##core#inline "C_fixnum_times" fx1 fx2)
     378              fx3)])
     379    (values res
     380            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
     381             ((##core#primitive "C_plus")
     382              ((##core#primitive "C_times") fx1 fx2)
     383              ((##core#primitive "C_minus") fx3 res))
     384             %fxnegprec) ) ) )
    245385
    246386(define (fx+/carry fx1 fx2 fx3)
    247   (let ([s0 (fx+ (fx+ fx1 fx2) fx3)])
    248     (values s0
    249             (arithmetic-shift (+ (+ fx1 fx2) (- fx3 s0)) (- fixnum-precision)) ) ) )
     387  (check-fixnum 'fx+/carry fx1)
     388  (check-fixnum 'fx+/carry fx2)
     389  (check-fixnum 'fx+/carry fx3)
     390  (let ([res (##core#inline "C_fixnum_plus"
     391              (##core#inline "C_fixnum_plus" fx1 fx2)
     392              fx3)])
     393    (values res
     394            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
     395             ((##core#primitive "C_plus")
     396              ((##core#primitive "C_plus") fx1 fx2)
     397              ((##core#primitive "C_minus") fx3 res))
     398             %fxnegprec) ) ) )
    250399
    251400(define (fx-/carry fx1 fx2 fx3)
    252   (let ([s0 (fx- (fx- fx1 fx2) fx3)])
    253     (values s0
    254             (arithmetic-shift (- (- fx1 fx2) (+ s0 fx3)) (- fixnum-precision)) ) ) )
     401  (check-fixnum 'fx-/carry fx1)
     402  (check-fixnum 'fx-/carry fx2)
     403  (check-fixnum 'fx-/carry fx3)
     404  (let ([res (##core#inline "C_fixnum_difference"
     405              (##core#inline "C_fixnum_difference" fx1 fx2)
     406              fx3)])
     407    (values res
     408            (##core#inline_allocate ("C_a_i_arithmetic_shift" 4)
     409             ((##core#primitive "C_minus")
     410              ((##core#primitive "C_minus") fx1 fx2)
     411              ((##core#primitive "C_plus") res fx3))
     412             %fxnegprec) ) ) )
    255413
    256414(define (fxadd1 fx)
    257   (fx+ fx 1) )
     415  (check-fixnum 'fxadd1 fx)
     416  (##core#inline "C_fixnum_plus" fx 1) )
    258417
    259418(define (fxsub1 fx)
    260   (fx- fx 1) )
    261 
    262 (define fxquotient fx/)
     419  (check-fixnum 'fxsub1 fx)
     420  (##core#inline "C_fixnum_difference" fx 1) )
     421
     422(define (fxquotient fxn fxd)
     423  (check-fixnum 'fxquotient fxn)
     424  (check-fixnum 'fxquotient fxd)
     425  (check-zero-division 'fxquotient fxn fxd)
     426  (##core#inline "C_fixnum_divide" fxn fxd) )
    263427
    264428(define (fxremainder fxn fxd)
    265   (fx- fxn (fx* (fx/ fxn fxd) fxd)) )
    266 
    267 (define fxmodulo fxmod)
     429  (check-fixnum 'fxremainder fxn)
     430  (check-fixnum 'fxremainder fxd)
     431  (check-zero-division 'fxremainder fxn fxd)
     432  (##core#inline "C_fixnum_difference"
     433   fxn
     434   (##core#inline "C_fixnum_times"
     435    (##core#inline "C_fixnum_divide" fxn fxd)
     436    fxd)) )
     437
     438(define (fxmodulo fxn fxd)
     439  (check-fixnum 'fxmodulo fxn)
     440  (check-fixnum 'fxmodulo fxd)
     441  (check-zero-division 'fxmodulo fxn fxd)
     442  (##core#inline "C_fixnum_modulo" fxn fxd) )
    268443
    269444(define (fxarithmetic-shift fx amount)
    270   ((if (fx< 0 amount) fxshl fxshr) fx amount) )
    271 
    272 (define fxarithmetic-shift-left fxshl)
    273 
    274 (define fxarithmetic-shift-right fxshr)
    275 
    276 (define (*fx- fx1 #!optional fx2)
    277   (or (and fx2
    278            (fx- fx1 fx2))
    279       (fxneg fx1) ) )
     445  (check-fixnum 'fxarithmetic-shift fx)
     446  (check-fixnum 'fxarithmetic-shift amount)
     447  (if (##core#inline "C_fixnum_lessp" 0 amount)
     448      (##core#inline "C_fixnum_shift_right"
     449       fx
     450       (##core#inline "C_fixnum_negate" amount))
     451      (##core#inline "C_fixnum_shift_left" fx amount) ) )
     452
     453(define (fxarithmetic-shift-left fx amount)
     454  (check-fixnum 'fxarithmetic-shift-left fx)
     455  (check-non-negative-fixnum 'fxarithmetic-shift-left amount)
     456  (##core#inline "C_fixnum_shift_left" fx amount) )
     457
     458(define (fxarithmetic-shift-right fx amount)
     459  (check-fixnum 'fxarithmetic-shift-right fx)
     460  (check-non-negative-fixnum 'fxarithmetic-shift-right amount)
     461  (##core#inline "C_fixnum_shift_right" fx amount) )
     462
     463(define (*fx- fx1 . rest)
     464  (check-fixnum 'fx- fx1)
     465  (if (null? rest)
     466      (##core#inline "C_fixnum_negate" fx1)
     467      (let ([fx2 (car rest)])
     468        (check-fixnum 'fx- fx2)
     469        (##core#inline "C_fixnum_difference" fx1 fx2) ) ) )
    280470
    281471;;;
    282472
    283473(define (*fxand fx . rest)
    284         (let loop ([fx fx] [rest rest])
    285           (if (null? rest)
    286               fx
    287               (loop (fxand fx (car rest)) (cdr rest)) ) ) )
     474  (%fold1 'fxand %fxand fx rest) )
    288475
    289476(define (*fxior fx . rest)
    290         (let loop ([fx fx] [rest rest])
    291           (if (null? rest)
    292               fx
    293               (loop (fxior fx (car rest)) (cdr rest)) ) ) )
     477        (%fold1 'fxior %fxior fx rest) )
    294478
    295479(define (*fxxor fx . rest)
    296         (let loop ([fx fx] [rest rest])
    297           (if (null? rest)
    298               fx
    299               (loop (fxxor fx (car rest)) (cdr rest)) ) ) )
     480        (%fold1 'fxxor %fxxor fx rest) )
    300481
    301482;;;
     
    306487      (letrec ([fx-digits
    307488                 (lambda (fx from to)
    308                    (if (fx= 0 fx)
    309                        (values (make-string from) to)
    310                        (let* ([quo (fx/ fx radix)]
    311                               [digit (string-ref digits (fx- fx (fx* quo radix)))])
    312                            (let-values ([(str to) (fx-digits quo (fx+ from 1) to)])
    313                              (string-set! str to digit)
    314                              (values str (fx+ to 1)) ) ) ) ) ]
     489                   (if (##core#inline "C_eqp" 0 fx)
     490                       (values (##sys#make-string from) to)
     491                       (let* ([quo
     492                                (##core#inline "C_fixnum_divide" fx radix)]
     493                              [digit
     494                                (##core#inline "C_i_string_ref"
     495                                 digits
     496                                 (##core#inline "C_fixnum_difference"
     497                                  fx
     498                                  (##core#inline "C_fixnum_times" quo radix)))])
     499                           (let-values ([(str to)
     500                                         (fx-digits
     501                                          quo
     502                                          (##core#inline "C_fixnum_plus" from 1) to)])
     503                             (##core#inline "C_i_string_set" str to digit)
     504                             (values str
     505                                     (##core#inline "C_fixnum_plus" to 1)) ) ) ) ) ]
    315506               [fx->str
    316507                 (lambda (fx)
    317                    (cond [(fx= 0 fx)
    318                            (string #\0)]
    319                          [(fx> fx 0)
    320                            (fx-digits fx 0 0)]
    321                          [(fx= fx most-negative-fixnum)
    322                            (string-append (fx->str (fx/ fx radix))
    323                                           (fx->str (fx- radix (fxmod fx radix))))]
     508                   (cond [(##core#inline "C_eqp" 0 fx)
     509                           (##sys#make-string 1 #\0)]
     510                         [(##core#inline "C_fixnum_lessp" 0 fx)
     511                           (let ([str (fx-digits fx 0 0)])
     512                             str ) ]
     513                         [(##core#inline "C_eqp" fx most-negative-fixnum)
     514                           (##sys#string-append
     515                            (fx->str (##core#inline "C_fixnum_divide" fx radix))
     516                            (fx->str (##core#inline "C_fixnum_difference"
     517                                      radix
     518                                      (##core#inline "C_fixnum_modulo" fx radix))))]
    324519                         [else
    325                            (let ([str (fx-digits (fxneg fx) 1 1)])
    326                              (string-set! str 0 #\-)
     520                           (let ([str (fx-digits (##core#inline "C_fixnum_negate" fx) 1 1)])
     521                             (##core#inline "C_i_string_set" str 0 #\-)
    327522                             str ) ] ) ) ] )
    328         (unless (fixnum? fx)
    329           (fixnum-type-error 'fixnum->string fx) )
     523        ;
     524        (check-fixnum 'fixnum->string fx)
    330525        (case radix
    331526          [(2 8 10 16)
     
    338533
    339534(define (fxif mask true false)
     535  (check-fixnum 'fxif mask)
     536  (check-fixnum 'fxif true)
     537  (check-fixnum 'fxif false)
    340538        (%bitwise-if mask true false) )
    341539
    342540(define (fxbit-count fx)
     541  (check-fixnum 'fxbit-count fx)
    343542        (%bitwise-bit-count fx) )
    344543
    345544(define (fxlength fx)
     545  (check-fixnum 'fxlength fx)
    346546        (%bitwise-length fx) )
    347547
    348548(define (fxfirst-bit-set fx)
     549  (check-fixnum 'fxfirst-bit-set fx)
    349550        (%bitwise-first-bit-set fx) )
    350551
    351552(define (fxlast-bit-set fx)
     553  (check-fixnum 'fxlast-bit-set fx)
    352554        (%bitwise-last-bit-set fx) )
    353555
    354556(define (fxbit-set? fx index)
     557  (check-fixnum 'fxbit-set? fx)
     558  (check-non-negative-fixnum 'fxbit-set? index)
    355559        (%bitwise-bit-set? fx index) )
    356560
    357561(define (fxcopy-bit fx index bit)
     562  (check-fixnum 'fxcopy-bit fx)
     563  (check-non-negative-fixnum 'fxcopy-bit index)
     564  (check-fixnum 'fxcopy-bit bit)
    358565        (%bitwise-copy-bit fx index bit) )
    359566
    360567(define (fxbit-field fx start end)
     568  (check-fixnum 'fxbit-field fx)
     569  (check-non-negative-fixnum 'fxbit-field start)
     570  (check-non-negative-fixnum 'fxbit-field end)
     571  (check-fixnums-<= 'fxbit-field start end)
    361572        (%bitwise-bit-field fx start end) )
    362573
    363574(define (fxcopy-bit-field fxto start end fxfrom)
     575  (check-fixnum 'fxcopy-bit-field fxto)
     576  (check-non-negative-fixnum 'fxcopy-bit-field start)
     577  (check-non-negative-fixnum 'fxcopy-bit-field end)
     578  (check-fixnums-<= 'fxcopy-bit-field start end)
     579  (check-fixnum 'fxcopy-bit-field fxfrom)
    364580        (%bitwise-copy-bit-field fxto start end fxfrom) )
    365581
    366582(define (fxrotate-bit-field fx start end count)
     583  (check-fixnum 'fxrotate-bit-field fx)
     584  (check-non-negative-fixnum 'fxrotate-bit-field start)
     585  (check-non-negative-fixnum 'fxrotate-bit-field end)
     586  (check-fixnums-<= 'fxrotate-bit-field start end)
     587  (check-non-negative-fixnum 'fxrotate-bit-field count)
    367588        (%bitwise-rotate-bit-field fx start end count) )
    368589
    369590(define (fxreverse-bit-field fx start end)
     591  (check-fixnum 'fxreverse-bit-field fx)
     592  (check-non-negative-fixnum 'fxreverse-bit-field start)
     593  (check-non-negative-fixnum 'fxreverse-bit-field end)
     594  (check-fixnums-<= 'fxreverse-bit-field start end)
    370595        (%bitwise-reverse-bit-field fx start end) )
    371 
  • 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
  • release/3/mathh/trunk/mathh.html

    r8556 r8594  
    152152<div class="section">
    153153<h3>Description</h3>
    154 <p>Provides access to ISO C math functions in <code>&lt;math.h&gt;</code> that are not defined by Chicken.</p>
    155 <p>Also supplies <code>&lt;float.h&gt;</code> constants, common derived constants, and limits for Chicken numeric types.</p></div>
     154<p>Provides:</p>
     155<ul>
     156<li>* access to ISO C math functions in <code>&lt;math.h&gt;</code> that are not defined by Chicken.</li>
     157<li>* <code>&lt;float.h&gt;</code> constants, common derived constants, and limits for Chicken numeric types.</li>
     158<li>* R6RS arithmetic functions.</li></ul></div>
    156159<div class="section">
    157160<h3>Author</h3>John Cowan and Kon Lovett</div>
     
    330333<td>Sizeof the C type</td></tr>
    331334<tr>
     335<td class="symbol">long-size</td>
     336<td>Sizeof the C type</td></tr>
     337<tr>
    332338<td class="symbol">long-long-size</td>
    333339<td>Sizeof the C type, 0 when unsupported</td></tr></table></div>
     
    579585<div class="section">
    580586<h3>Usage</h3>(require-extension fixnum-extras)</div>
     587<p>R6RS fixnum functions. The &quot;*&quot; prefixed functions are variable arity versions of the built-in Chicken Scheme functions. This naming convention violates R6RS.</p>
    581588<dt class="definition"><strong>procedure:</strong> (fixnum-&gt;string FX [RADIX])</dt>
    582589<dd>
     
    634641<p></p></dd>
    635642<dt class="definition"><strong>procedure:</strong> (fxmodulo FX-N FX-D)</dt>
     643<dd>
     644<p></p></dd>
     645<dt class="definition"><strong>procedure:</strong> (fxpow2log2 FX)</dt>
    636646<dd>
    637647<p></p></dd>
     
    730740<div class="section">
    731741<h3>Usage</h3>(require-extension flonum-extras)</div>
     742<p>R6RS flonum functions.</p>
    732743<dt class="definition"><strong>procedure:</strong> (real-&gt;flonum VALUE)</dt>
    733744<dd>
     
    878889<div class="section">
    879890<h3>Usage</h3>(require-extension bitwise-extras)</div>
     891<p>R6RS bitwise functions.</p>
    880892<p>Unchecked variants of the following procedures are supplied, named as the checked version but with a &quot;%&quot; prefix.</p>
     893<dt class="definition"><strong>procedure:</strong> (pow2log2 VALUE)</dt>
     894<dd>
     895<p>Returns <code>2 ** log2 (<tt>VALUE</tt>)</code>.</p></dd>
    881896<dt class="definition"><strong>procedure:</strong> (boolean-&gt;bit OBJECT)</dt>
    882897<dd>
     
    942957<h3>Version</h3>
    943958<ul>
     959<li>1.11 Added argument checking to fix &amp; flonum functions. [Kon Lovett]</li>
    944960<li>1.10 Cygwin compile fix. Added &quot;fixnum/flonum/bitwise-extras&quot;. Removed &quot;count-set-bits&quot; &amp; &quot;count-unset-bits&quot;. [Kon Lovett]</li>
    945961<li>1.903 Added C int &amp; float types. [Kon Lovett]</li>
  • release/3/mathh/trunk/mathh.setup

    r8543 r8594  
    11(include "setup-header.scm")
    22
     3#|
    34(copy-file "mathh-constants.scm" (chicken-home))
    45
     
    2627        (install-dynld mathh-fpclass *version* (documentation "mathh.html")))
    2728
     29(install-dynld bitwise-extras *version* (documentation "mathh.html"))
     30|#
     31
    2832(install-dynld fixnum-extras *version* (documentation "mathh.html"))
    2933
    3034(install-dynld flonum-extras *version* (documentation "mathh.html"))
    3135
    32 (install-dynld bitwise-extras *version* (documentation "mathh.html"))
    33 
    3436(install-test "mathh-test.scm")
Note: See TracChangeset for help on using the changeset viewer.