"Fossies" - the Fresh Open Source Software Archive

Member "snd-20.9/libm.scm" (27 Jun 2020, 5548 Bytes) of package /linux/misc/snd-20.9.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ;;; libm.scm
    2 ;;;
    3 ;;; tie the math library into the *libm* environment
    4 
    5 (require cload.scm)
    6 (provide 'libm.scm)
    7 
    8 ;; if loading from a different directory, pass that info to C
    9 (let ((directory (let ((current-file (port-filename)))
   10            (and (memv (current-file 0) '(#\/ #\~))
   11             (substring current-file 0 (- (length current-file) 9))))))
   12   (when (and directory (not (member directory *load-path*)))
   13     (set! *load-path* (cons directory *load-path*)))
   14   (with-let (rootlet)
   15     (require cload.scm))
   16   (when (and directory (not (string-position directory *cload-cflags*)))
   17     (set! *cload-cflags* (string-append "-I" directory " " *cload-cflags*))))
   18 
   19 
   20 (if (not (defined? '*libm*))
   21     (define *libm*
   22       (with-let (unlet)
   23     
   24     (set! *libraries* (cons (cons "libm.scm" (curlet)) *libraries*))
   25 
   26     (c-define
   27      '((double j0 (double) "Bessel j0") 
   28        (double j1 (double)) 
   29        (double jn (int double)) 
   30        (double erf (double)) 
   31        (double erfc (double))
   32        (double lgamma (double))
   33        
   34        (double fabs (double))
   35        (double ceil (double))
   36        (reader-cond ((not (provided? 'netbsd))
   37              (double nearbyint (double))
   38              (double scalbln (double int))
   39              (double fma (double double double))))
   40        (double rint (double))
   41        (int llrint (double))
   42        (int llround (double))
   43        (double trunc (double))
   44        (double fmod (double double))
   45        (double ldexp (double int))
   46        (double scalbn (double int))
   47        (double exp2 (double))
   48        (double expm1 (double))
   49        (double log10 (double))
   50        (double log1p (double))
   51        (double log2 (double))
   52        (int ilogb (double))
   53        (double cbrt (double))
   54        (double hypot (double double))
   55        (double pow (double double))
   56        (double fdim (double double))
   57        (double tgamma (double))
   58        (double copysign (double double))
   59        (double nan (char*))
   60        (double nextafter (double double))
   61        (double nexttoward (double double))
   62        
   63        (reader-cond ((not (provided? 'solaris)) 
   64              (int fpclassify (double))
   65              (int isfinite (double))
   66              (int isinf (double))
   67              (int isnan (double))
   68              (int isnormal (double))
   69              (int signbit (double))))
   70        
   71        ;; exporting these will overwrite the built-in versions
   72        (double floor (double))
   73        (double round (double))
   74        (double remainder (double double))
   75        (double exp (double))
   76        (double log (double))
   77        (double sqrt (double))
   78        (double cos (double))
   79        (double sin (double))
   80        (double tan (double))
   81        (double cosh (double))
   82        (double sinh (double))
   83        (double tanh (double))
   84        (double acos (double))
   85        (double asin (double))
   86        (double atan (double))
   87        (double atan2 (double double))
   88        (double acosh (double))
   89        (double asinh (double))
   90        (double atanh  (double))
   91        
   92        (int (FP_NAN FP_INFINITE FP_ZERO FP_SUBNORMAL FP_NORMAL))
   93        (double (M_E M_LOG2E M_LOG10E M_LN2 M_LN10 M_PI M_PI_2 M_PI_4 M_1_PI M_2_PI M_2_SQRTPI M_SQRT2 M_SQRT1_2))
   94        
   95        (C-macro (char* __VERSION__))
   96        (C-macro (int (__SIZEOF_LONG_LONG__ __SIZEOF_INT__ __SIZEOF_POINTER__ __SIZEOF_LONG__ __SIZEOF_LONG_DOUBLE__ __SIZEOF_SIZE_T__ 
   97               __SIZEOF_FLOAT__ __SIZEOF_SHORT__ __SIZEOF_DOUBLE__ __CHAR_BIT__ __DBL_MIN_EXP__ __DBL_MIN_10_EXP__ __LDBL_MAX_EXP__ 
   98               __DBL_DIG__ __DECIMAL_DIG__ __BIGGEST_ALIGNMENT__ __DBL_MAX_EXP__ __LONG_LONG_MAX__ __FLT_MIN_EXP__ __FLT_MANT_DIG__ 
   99               __FLT_RADIX__ __FLT_MAX_10_EXP__ __LONG_MAX__ __LDBL_MANT_DIG__ __FLT_DIG__ __INT_MAX__ __FLT_MAX_EXP__ 
  100               __DBL_MANT_DIG__ __LDBL_MIN_EXP__ __LDBL_MAX_10_EXP__ __INTMAX_MAX__ __FLT_MIN_10_EXP__ __DBL_MAX_10_EXP__ 
  101               __LDBL_MIN_10_EXP__ __LDBL_DIG__)))
  102        (C-macro (double (__FLT_MIN__ __DBL_DENORM_MIN__ __LDBL_MAX__ __FLT_EPSILON__ __LDBL_MIN__ __DBL_MAX__ __DBL_MIN__ 
  103                  __LDBL_EPSILON__ __DBL_EPSILON__ __FLT_DENORM_MIN__ __FLT_MAX__ __LDBL_DENORM_MIN__)))
  104        
  105        ;; these have arg by reference, return list in s7
  106        (in-C "
  107 static s7_pointer g_remquo(s7_scheme *sc, s7_pointer args)
  108 {
  109   if (s7_is_real(s7_car(args)))
  110     {
  111       if (s7_is_real(s7_cadr(args)))
  112         {
  113           int quo = 0;
  114           double rem;
  115           rem = remquo(s7_number_to_real(sc, s7_car(args)), s7_number_to_real(sc, s7_cadr(args)), &quo);
  116           return(s7_list(sc, 2, s7_make_real(sc, rem), s7_make_integer(sc, quo)));
  117         }
  118       return(s7_wrong_type_arg_error(sc, \"remquo\", 2, s7_cadr(args), \"a real\"));
  119      }
  120   return(s7_wrong_type_arg_error(sc, \"remquo\", 1, s7_car(args), \"a real\"));
  121 }
  122 static s7_pointer g_frexp(s7_scheme *sc, s7_pointer args)
  123 {
  124   if (s7_is_real(s7_car(args)))
  125     {
  126       int ex = 0;
  127       double frac;
  128       frac = frexp(s7_number_to_real(sc, s7_car(args)), &ex);
  129       return(s7_list(sc, 2, s7_make_real(sc, frac), s7_make_integer(sc, ex)));
  130      }
  131   return(s7_wrong_type_arg_error(sc, \"frexp\", 1, s7_car(args), \"a real\"));
  132 }
  133 static s7_pointer g_modf(s7_scheme *sc, s7_pointer args)
  134 {
  135   if (s7_is_real(s7_car(args)))
  136     {
  137       double frac, ip = 0.0;
  138       frac = modf(s7_number_to_real(sc, s7_car(args)), &ip);
  139       return(s7_list(sc, 2, s7_make_real(sc, frac), s7_make_real(sc, ip)));
  140      }
  141   return(s7_wrong_type_arg_error(sc, \"modf\", 1, s7_car(args), \"a real\"));
  142 }
  143 ")
  144                     (C-function ("remquo" g_remquo "(remquo x y) returns a list: (remainder messed-up-quotient)" 2))
  145                     (C-function ("frexp" g_frexp "(frexp x) returns a list: (fraction exponent)" 1))
  146                     (C-function ("modf" g_modf "(modf x) returns a list: (int-part frac-part) -- this is not the same as fmod!" 1))
  147             )
  148           "" "math.h" "" "" "libm_s7")
  149     
  150     (curlet))))
  151 
  152 *libm*
  153 ;; the loader will return *libm*
  154