Changeset 13570 in project


Ignore:
Timestamp:
03/07/09 19:36:51 (11 years ago)
Author:
Kon Lovett
Message:

Release.

Location:
release/4/mathh
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/mathh/tags/2.0.0/mathh-constants.scm

    r13567 r13570  
    11;;;; mathh-constants.scm
    2 ;;;; Common flonum constants in <math.h> & others
    3 ;;;; Public domain
     2;;;; Common flonum constants in <math.h> + more
     3
     4
     5;;; Flonum Constants
     6
     7;; The precision is greater than those found in <math.h>
    48
    59(define-constant E                                      2.7182818284590452353602874713526624977572)   ; e
  • release/4/mathh/tags/2.0.0/mathh.scm

    r13567 r13570  
    33;;;; Kon Lovett, Mar '09
    44
    5 ;;;; Provides access to ISO C math functions in <math.h>
    6 ;;;; that are not defined by Chicken
     5;;; Provides access to ISO C math functions in <math.h>
     6;;; that are not defined by the Chicken core.
    77
    88;; Issues
     
    1111;; & renames _hypot, _j0, etc.
    1212;;
    13 ;; - Windows does not provide log2, log1p, lgamma, tgamma. scalbn
     13;; - Windows does not provide log2, log1p, lgamma, tgamma. scalbn.
    1414;;
    1515;; - 'gamma' is deprecated in favor of 'tgamma' but not available
    1616;; yet on some platforms, so we use 'gamma' for now.
    1717;;
    18 ;; - Solaris log2 in sunmath.h
     18;; - Solaris log2 in <sunmath.h>.
    1919
    2020
     
    2525  (inline)
    2626  (local)
     27  (number-type generic)
    2728  (no-procedure-checks)
    2829  (no-bound-checks)
     
    3940
    4041(define-inline (%unimplemented-error name)
    41   (error name (##core#immutable '"this function is not available on this platform")) )
     42  (error name (##core#immutable '"this function is unavailable on this platform")) )
    4243
    4344
     
    5960;;; Unimplemented Support
    6061
     62#; ;UNUSED
    6163(define-syntax define-unimplemented
    6264  (syntax-rules ()
     
    7375;; Bessel functions of the 1st kind
    7476
    75 (define bessel-j0 (foreign-lambda double j0 double))
    76 (define bessel-j1 (foreign-lambda double j1 double))
    77 (define bessel-jn (foreign-lambda double jn int double))
     77(define bessel-j0 (foreign-lambda double "j0" double))
     78(define bessel-j1 (foreign-lambda double "j1" double))
     79(define bessel-jn (foreign-lambda double "jn" int double))
    7880
    7981;; Bessel functions of the 2nd kind
    8082
    81 (define bessel-y0 (foreign-lambda double y0 double))
    82 (define bessel-y1 (foreign-lambda double y1 double))
    83 (define bessel-yn (foreign-lambda double yn int double))
     83(define bessel-y0 (foreign-lambda double "y0" double))
     84(define bessel-y1 (foreign-lambda double "y1" double))
     85(define bessel-yn (foreign-lambda double "yn" int double))
    8486
    8587;; Hyperbolic functions
    8688
    87 (define cosh (foreign-lambda double cosh double))
    88 (define sinh (foreign-lambda double sinh double))
    89 (define tanh (foreign-lambda double tanh double))
     89(define cosh (foreign-lambda double "cosh" double))
     90(define sinh (foreign-lambda double "sinh" double))
     91(define tanh (foreign-lambda double "tanh" double))
    9092
    9193;; Euclidean distance function
    9294
    93 (define hypot (foreign-lambda double hypot double double))
     95(define hypot (foreign-lambda double "hypot" double double))
    9496
    9597;; Gamma function
     
    109111  (cond-expand
    110112    [windows  (lambda-unimplemented 'lgamma) ]
    111     [else     (foreign-lambda double lgamma double) ] ) )
     113    [else     (foreign-lambda double "lgamma" double) ] ) )
    112114
    113115;; Base-10 logarithm
    114116
    115 (define log10 (foreign-lambda double log10 double))
     117(define log10 (foreign-lambda double "log10" double))
    116118
    117119;; Base-2 logarithm
     
    124126      (foreign-lambda* double ((double x)) "
    125127        #ifndef M_LN2
    126         # define #define M_LN2 0.693147180559945309417232121458176568
     128        #define #define M_LN2 0.693147180559945309417232121458176568
    127129        #endif
    128         return (log(x) / M_LN2);
    129         " ) ] ) )
     130        C_return( log( x ) / M_LN2 );
     131       ")
     132      #;
     133      (foreign-lambda* double ((double x)) "
     134        #ifndef M_PI
     135        # define M_PI 3.14159265358979323846264338327950288
     136        #endif
     137        #ifndef M_E
     138        # define M_E 2.71828182845904523536028747135266250
     139        #endif
     140        C_return( (log( 2.0 * M_PI * x) / 2.0) + (x * log( x / M_E )) );
     141        ") ] ) )
     142
     143;; Natural logarithm of 1+x accurate for very small x
     144
     145(define log1p
     146  (cond-expand
     147    [windows ; potentially inaccurate but ...
     148      (foreign-lambda* double ((double x)) "C_return( log( 1.0 + x ) );") ]
     149    [else
     150                  (foreign-lambda double "log1p" double) ] ) )
     151
     152;; Compute x * 2**n
     153
     154(define ldexp (foreign-lambda double "ldexp" double integer))
     155
     156;; Efficiently compute x * 2**n
     157
     158(define scalbn
     159  (cond-expand
     160    [windows ; not efficient but ...
     161      (foreign-lambda* double ((double x) (integer n)) "C_return( ldexp( x, n ) );")]
     162    [else
     163      (foreign-lambda double "scalbn" double integer)]) )
    130164
    131165;; Log function for base n
     
    139173         (let ([lnb (log b)])
    140174           (lambda (n)
    141              ((foreign-lambda* double ((double x) (double lnb)) "return (log(x) / lnb);") n lnb)) ) ] ) )
    142 
    143 ;; Natural logarithm of 1+x accurate for very small x
    144 
    145 (define log1p
    146   (cond-expand
    147     [windows ; potentially inaccurate but ...
    148       (foreign-lambda* double ((double x)) "return (log(1.0 + x));") ]
    149     [else
    150                   (foreign-lambda double log1p double) ] ) )
     175             ((foreign-lambda* double ((double x) (double lnb)) "C_return( log( x ) / lnb );") n lnb)) ) ] ) )
    151176
    152177;; Flonum remainder
    153178
    154 (define fpmod (foreign-lambda double fmod double double))
    155 
    156 ;; Return integer, fraction (as multiple values) of a flonum
     179(define fpmod (foreign-lambda double "fmod" double double))
     180
     181;; Return integer & fraction (as multiple values) of a flonum
    157182
    158183(define modf (foreign-primitive ((double x)) "
    159184  double ipart;
    160   double result  = modf(x, &ipart);
    161   C_word* values = C_alloc(2 * C_SIZEOF_FLONUM);
    162   C_word value1  = C_flonum(&values, ipart);
    163   C_word value2  = C_flonum(&values, result);
    164   C_values(4, C_SCHEME_UNDEFINED, C_k, value1, value2);
    165   " ) )
    166 
    167 ;; Compute x * 2**n
    168 
    169 (define ldexp (foreign-lambda double ldexp double integer))
    170 
    171 ;; Efficiently compute x * 2**n
    172 
    173 (define scalbn
    174   (cond-expand
    175     [windows ; not efficient but ...
    176       (foreign-lambda* double ((double x) (integer n)) "return (ldexp(x, n));")]
    177     [else
    178       (foreign-lambda double scalbn double integer)]) )
    179 
    180 ;; Return mantissa, exponent (as multiple values) of a flonum
     185  double result  = modf( x, &ipart );
     186  C_word* values = C_alloc( 2 * C_SIZEOF_FLONUM );
     187  C_word value1  = C_flonum( &values, ipart );
     188  C_word value2  = C_flonum( &values, result );
     189  C_values( 4, C_SCHEME_UNDEFINED, C_k, value1, value2 );
     190  ") )
     191
     192;; Return mantissa & exponent (as multiple values) of a flonum
    181193
    182194(define frexp (foreign-primitive ((double x)) "
    183195  int exp;
    184   double result = frexp(x, &exp);
    185   C_word* values = C_alloc(C_SIZEOF_FLONUM);
    186   C_word value1 = C_flonum(&values, result);
    187   C_word value2 = C_fix(exp);
    188   C_values(4, C_SCHEME_UNDEFINED, C_k, value1, value2);
    189   " ) )
     196  double result = frexp( x, &exp );
     197  C_word* values = C_alloc( C_SIZEOF_FLONUM );
     198  C_word value1 = C_flonum( &values, result );
     199  C_word value2 = C_fix( exp );
     200  C_values( 4, C_SCHEME_UNDEFINED, C_k, value1, value2 );
     201  ") )
    190202
    191203;; Returns a symbol denoting the kind of floating-point number.
     
    196208      (foreign-lambda* symbol ((double x)) "
    197209        char *name;
    198         switch (_fpclass(x)) {
     210        switch (_fpclass( x )) {
    199211        case _FPCLASS_SNAN:
    200212          name = \"signaling-nan\";
     
    231243          break;
    232244        }
    233         C_return (name);
     245        C_return( name );
    234246                          ") ]
    235247    [else
    236248      (foreign-lambda* symbol ((double x)) "
    237249        char *name;
    238         switch (fpclassify(x)) {
     250        switch (fpclassify( x )) {
    239251        case FP_INFINITE:
    240252          name = x < 0 ? \"negative-infinite\" : \"positive-infinite\";
     
    257269          break;
    258270        }
    259         C_return (name);
     271        C_return( name );
    260272                          ") ] ) )
    261273
     
    267279      (foreign-lambda* symbol ((double x)) "
    268280        char *name;
    269         switch (_fpclass(x)) {
     281        switch (_fpclass( x )) {
    270282        case _FPCLASS_SNAN:
    271283        case _FPCLASS_QNAN:
     
    292304          break;
    293305        }
    294         C_return (name);
     306        C_return( name );
    295307                          ") ]
    296308    [else
    297309      (foreign-lambda* symbol ((double x)) "
    298310        char *name;
    299         switch (fpclassify(x)) {
     311        switch (fpclassify( x )) {
    300312        case FP_INFINITE:
    301313          name = \"infinite\";
     
    317329          break;
    318330        }
    319         C_return (name);
     331        C_return( name );
    320332                          ") ] ) )
    321333
  • release/4/mathh/tags/2.0.0/tests/run.scm

    r13567 r13570  
    1 ;;;; mathh-test.scm
     1;;;; mathh-test
    22
    33(require-extension test)
  • release/4/mathh/trunk/mathh-constants.scm

    r13567 r13570  
    11;;;; mathh-constants.scm
    2 ;;;; Common flonum constants in <math.h> & others
    3 ;;;; Public domain
     2;;;; Common flonum constants in <math.h> + more
     3
     4
     5;;; Flonum Constants
     6
     7;; The precision is greater than those found in <math.h>
    48
    59(define-constant E                                      2.7182818284590452353602874713526624977572)   ; e
  • release/4/mathh/trunk/mathh.scm

    r13567 r13570  
    33;;;; Kon Lovett, Mar '09
    44
    5 ;;;; Provides access to ISO C math functions in <math.h>
    6 ;;;; that are not defined by Chicken
     5;;; Provides access to ISO C math functions in <math.h>
     6;;; that are not defined by the Chicken core.
    77
    88;; Issues
     
    1111;; & renames _hypot, _j0, etc.
    1212;;
    13 ;; - Windows does not provide log2, log1p, lgamma, tgamma. scalbn
     13;; - Windows does not provide log2, log1p, lgamma, tgamma. scalbn.
    1414;;
    1515;; - 'gamma' is deprecated in favor of 'tgamma' but not available
    1616;; yet on some platforms, so we use 'gamma' for now.
    1717;;
    18 ;; - Solaris log2 in sunmath.h
     18;; - Solaris log2 in <sunmath.h>.
    1919
    2020
     
    2525  (inline)
    2626  (local)
     27  (number-type generic)
    2728  (no-procedure-checks)
    2829  (no-bound-checks)
     
    3940
    4041(define-inline (%unimplemented-error name)
    41   (error name (##core#immutable '"this function is not available on this platform")) )
     42  (error name (##core#immutable '"this function is unavailable on this platform")) )
    4243
    4344
     
    5960;;; Unimplemented Support
    6061
     62#; ;UNUSED
    6163(define-syntax define-unimplemented
    6264  (syntax-rules ()
     
    7375;; Bessel functions of the 1st kind
    7476
    75 (define bessel-j0 (foreign-lambda double j0 double))
    76 (define bessel-j1 (foreign-lambda double j1 double))
    77 (define bessel-jn (foreign-lambda double jn int double))
     77(define bessel-j0 (foreign-lambda double "j0" double))
     78(define bessel-j1 (foreign-lambda double "j1" double))
     79(define bessel-jn (foreign-lambda double "jn" int double))
    7880
    7981;; Bessel functions of the 2nd kind
    8082
    81 (define bessel-y0 (foreign-lambda double y0 double))
    82 (define bessel-y1 (foreign-lambda double y1 double))
    83 (define bessel-yn (foreign-lambda double yn int double))
     83(define bessel-y0 (foreign-lambda double "y0" double))
     84(define bessel-y1 (foreign-lambda double "y1" double))
     85(define bessel-yn (foreign-lambda double "yn" int double))
    8486
    8587;; Hyperbolic functions
    8688
    87 (define cosh (foreign-lambda double cosh double))
    88 (define sinh (foreign-lambda double sinh double))
    89 (define tanh (foreign-lambda double tanh double))
     89(define cosh (foreign-lambda double "cosh" double))
     90(define sinh (foreign-lambda double "sinh" double))
     91(define tanh (foreign-lambda double "tanh" double))
    9092
    9193;; Euclidean distance function
    9294
    93 (define hypot (foreign-lambda double hypot double double))
     95(define hypot (foreign-lambda double "hypot" double double))
    9496
    9597;; Gamma function
     
    109111  (cond-expand
    110112    [windows  (lambda-unimplemented 'lgamma) ]
    111     [else     (foreign-lambda double lgamma double) ] ) )
     113    [else     (foreign-lambda double "lgamma" double) ] ) )
    112114
    113115;; Base-10 logarithm
    114116
    115 (define log10 (foreign-lambda double log10 double))
     117(define log10 (foreign-lambda double "log10" double))
    116118
    117119;; Base-2 logarithm
     
    124126      (foreign-lambda* double ((double x)) "
    125127        #ifndef M_LN2
    126         # define #define M_LN2 0.693147180559945309417232121458176568
     128        #define #define M_LN2 0.693147180559945309417232121458176568
    127129        #endif
    128         return (log(x) / M_LN2);
    129         " ) ] ) )
     130        C_return( log( x ) / M_LN2 );
     131       ")
     132      #;
     133      (foreign-lambda* double ((double x)) "
     134        #ifndef M_PI
     135        # define M_PI 3.14159265358979323846264338327950288
     136        #endif
     137        #ifndef M_E
     138        # define M_E 2.71828182845904523536028747135266250
     139        #endif
     140        C_return( (log( 2.0 * M_PI * x) / 2.0) + (x * log( x / M_E )) );
     141        ") ] ) )
     142
     143;; Natural logarithm of 1+x accurate for very small x
     144
     145(define log1p
     146  (cond-expand
     147    [windows ; potentially inaccurate but ...
     148      (foreign-lambda* double ((double x)) "C_return( log( 1.0 + x ) );") ]
     149    [else
     150                  (foreign-lambda double "log1p" double) ] ) )
     151
     152;; Compute x * 2**n
     153
     154(define ldexp (foreign-lambda double "ldexp" double integer))
     155
     156;; Efficiently compute x * 2**n
     157
     158(define scalbn
     159  (cond-expand
     160    [windows ; not efficient but ...
     161      (foreign-lambda* double ((double x) (integer n)) "C_return( ldexp( x, n ) );")]
     162    [else
     163      (foreign-lambda double "scalbn" double integer)]) )
    130164
    131165;; Log function for base n
     
    139173         (let ([lnb (log b)])
    140174           (lambda (n)
    141              ((foreign-lambda* double ((double x) (double lnb)) "return (log(x) / lnb);") n lnb)) ) ] ) )
    142 
    143 ;; Natural logarithm of 1+x accurate for very small x
    144 
    145 (define log1p
    146   (cond-expand
    147     [windows ; potentially inaccurate but ...
    148       (foreign-lambda* double ((double x)) "return (log(1.0 + x));") ]
    149     [else
    150                   (foreign-lambda double log1p double) ] ) )
     175             ((foreign-lambda* double ((double x) (double lnb)) "C_return( log( x ) / lnb );") n lnb)) ) ] ) )
    151176
    152177;; Flonum remainder
    153178
    154 (define fpmod (foreign-lambda double fmod double double))
    155 
    156 ;; Return integer, fraction (as multiple values) of a flonum
     179(define fpmod (foreign-lambda double "fmod" double double))
     180
     181;; Return integer & fraction (as multiple values) of a flonum
    157182
    158183(define modf (foreign-primitive ((double x)) "
    159184  double ipart;
    160   double result  = modf(x, &ipart);
    161   C_word* values = C_alloc(2 * C_SIZEOF_FLONUM);
    162   C_word value1  = C_flonum(&values, ipart);
    163   C_word value2  = C_flonum(&values, result);
    164   C_values(4, C_SCHEME_UNDEFINED, C_k, value1, value2);
    165   " ) )
    166 
    167 ;; Compute x * 2**n
    168 
    169 (define ldexp (foreign-lambda double ldexp double integer))
    170 
    171 ;; Efficiently compute x * 2**n
    172 
    173 (define scalbn
    174   (cond-expand
    175     [windows ; not efficient but ...
    176       (foreign-lambda* double ((double x) (integer n)) "return (ldexp(x, n));")]
    177     [else
    178       (foreign-lambda double scalbn double integer)]) )
    179 
    180 ;; Return mantissa, exponent (as multiple values) of a flonum
     185  double result  = modf( x, &ipart );
     186  C_word* values = C_alloc( 2 * C_SIZEOF_FLONUM );
     187  C_word value1  = C_flonum( &values, ipart );
     188  C_word value2  = C_flonum( &values, result );
     189  C_values( 4, C_SCHEME_UNDEFINED, C_k, value1, value2 );
     190  ") )
     191
     192;; Return mantissa & exponent (as multiple values) of a flonum
    181193
    182194(define frexp (foreign-primitive ((double x)) "
    183195  int exp;
    184   double result = frexp(x, &exp);
    185   C_word* values = C_alloc(C_SIZEOF_FLONUM);
    186   C_word value1 = C_flonum(&values, result);
    187   C_word value2 = C_fix(exp);
    188   C_values(4, C_SCHEME_UNDEFINED, C_k, value1, value2);
    189   " ) )
     196  double result = frexp( x, &exp );
     197  C_word* values = C_alloc( C_SIZEOF_FLONUM );
     198  C_word value1 = C_flonum( &values, result );
     199  C_word value2 = C_fix( exp );
     200  C_values( 4, C_SCHEME_UNDEFINED, C_k, value1, value2 );
     201  ") )
    190202
    191203;; Returns a symbol denoting the kind of floating-point number.
     
    196208      (foreign-lambda* symbol ((double x)) "
    197209        char *name;
    198         switch (_fpclass(x)) {
     210        switch (_fpclass( x )) {
    199211        case _FPCLASS_SNAN:
    200212          name = \"signaling-nan\";
     
    231243          break;
    232244        }
    233         C_return (name);
     245        C_return( name );
    234246                          ") ]
    235247    [else
    236248      (foreign-lambda* symbol ((double x)) "
    237249        char *name;
    238         switch (fpclassify(x)) {
     250        switch (fpclassify( x )) {
    239251        case FP_INFINITE:
    240252          name = x < 0 ? \"negative-infinite\" : \"positive-infinite\";
     
    257269          break;
    258270        }
    259         C_return (name);
     271        C_return( name );
    260272                          ") ] ) )
    261273
     
    267279      (foreign-lambda* symbol ((double x)) "
    268280        char *name;
    269         switch (_fpclass(x)) {
     281        switch (_fpclass( x )) {
    270282        case _FPCLASS_SNAN:
    271283        case _FPCLASS_QNAN:
     
    292304          break;
    293305        }
    294         C_return (name);
     306        C_return( name );
    295307                          ") ]
    296308    [else
    297309      (foreign-lambda* symbol ((double x)) "
    298310        char *name;
    299         switch (fpclassify(x)) {
     311        switch (fpclassify( x )) {
    300312        case FP_INFINITE:
    301313          name = \"infinite\";
     
    317329          break;
    318330        }
    319         C_return (name);
     331        C_return( name );
    320332                          ") ] ) )
    321333
  • release/4/mathh/trunk/tests/run.scm

    r13567 r13570  
    1 ;;;; mathh-test.scm
     1;;;; mathh-test
    22
    33(require-extension test)
Note: See TracChangeset for help on using the changeset viewer.