klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

ffi-gsl.k (2064B)

      1 ;;
      2 ;; Dynamic FFI callback example.
      3 ;; Interfacing GNU Scientific Library.
      4 ;;
      5 ;; struct gsl_function_struct {
      6 ;;    double (* function) (double x, void * params);
      7 ;;    void * params;
      8 ;; };
      9 ;; typedef struct gsl_function_struct gsl_function ;
     10 ;;
     11 ;; int gsl_deriv_central (const gsl_function * f, double x, double h, double * result, double * abserr)
     12 ;;
     13 ;; (ffi-make-callback APPLICATIVE CALL-INTERFACE) creates a C callable
     14 ;; function with interface CALL-INTERFACE and returns pointer
     15 ;; to the entry point. The function will in turn call APPLICATIVE.
     16 ;;
     17 
     18 ($define! gsl (ffi-load-library "libgsl.so"))
     19 ($define! abi "FFI_DEFAULT_ABI")
     20 
     21 ($define! make-gsl-function
     22   ($let
     23     ( ((pointer-size alingment ref set!) (ffi-type-suite "pointer"))
     24       (cif (ffi-make-call-interface abi "double" (list "double" "pointer"))) )
     25   ($lambda (f)
     26     ($let
     27       ( (gslf (make-bytevector (* 2 pointer-size)) )
     28         (aux ($lambda (x params) (f x))))
     29       (set! (list gslf 0) (ffi-make-callback aux cif))
     30       gslf))))
     31 
     32 ($define! gsl-deriv-central
     33   ($let
     34     ( (gsl_deriv_central (ffi-make-applicative gsl "gsl_deriv_central"
     35         (ffi-make-call-interface abi "sint" (list "pointer" "double" "double" "pointer" "pointer"))))
     36       ((double-size alingment ref set!) (ffi-type-suite "double")))
     37     ($lambda (f)
     38       ($let
     39         ((gslf (make-gsl-function f)))
     40         ($lambda (x h)
     41           ($let
     42             ( (result (make-bytevector double-size))
     43               (abserr (make-bytevector double-size)))
     44            (gsl_deriv_central gslf x h result abserr)
     45            (list (ref result) (ref abserr))))))))
     46 
     47 (display "Testing gsl_deriv_central...")
     48 (newline)
     49 
     50 ($define! f
     51   ($lambda (x)
     52     (display (list "callback called with x = " x))
     53     (newline)
     54     (+ (* 2.0 x x) 3.0)))
     55 ($define! df (gsl-deriv-central f))
     56 
     57 (for-each
     58   ($lambda (x)
     59     ($let*
     60       ( (fx (f x))
     61         ((dfx abserr) (df x 0.001)))
     62       (for-each
     63         display
     64         (list "x = " x ", f(x) = " fx ", f'(x) = " dfx ", |error| <= " abserr))
     65       (newline)))
     66   (list -1.0 0.0 1.0 2.0))