example.scm

   1 (use-modules (system foreign))
   2 (use-modules (ice-9 iconv))
   3 (use-modules (ice-9 match))
   4 (use-modules (srfi srfi-1))
   5
   6 (define-syntax-rule (lambda-case <clause> ...)
   7     (lambda (obj) (case obj <clause> ...)))
   8 (define-syntax-rule (lambda-match <clause> ...)
   9     (lambda (obj) (match obj <clause> ...)))
  10 ;; These functions are called from `define-ffi' marco, so `eval-when' used.
  11 (eval-when (compile load eval)
  12   (define (symbol:scheme->c symbol)
  13     "Convert scheme symbol to string with corresponding C symbol."
  14     (string-map (lambda-case ((#\-) #\_)
  15                   (else => identity))
  16       (symbol->string symbol)))
  17
  18   (define (string-last-char str)
  19     "Return last char of non-null string."
  20     (last (string->list str)))
  21   (define (drop-last-char str)
  22     "Return string without last char."
  23     (list->string (drop-right (string->list str) 1)))
  24
  25   (define (argspec-symbol spec)
  26     "Return symbol, describing type of argument."
  27     (let  ((symbol (if (list? spec) (car spec) spec)))
  28       (unless (symbol? symbol) (throw 'invalid-argspec spec))
  29       symbol))
  30
  31   (define (encoder-symbol type)
  32     "Return symbol of encoder for type."
  33     (string->symbol (format #f "~a->pointer" type)))
  34   (define (decoder-symbol s)
  35     "Return symbol of decoder for type."
  36     (string->symbol (format #f "pointer->~a" s)))
  37
  38
  39   (define (argspec-dynamic-type spec)
  40     "Return symbol, describing argument type, to pass to `pointer->procedure'."
  41     (let* ((symbol (argspec-symbol spec))
  42             (symbol-name (symbol->string symbol)))
  43       (case (string-last-char symbol-name)
  44         ((#\* #\%) ''*)
  45         (else symbol))))
  46
  47   (define (encode-form argspec arg)
  48     "Encode ARG according ARCSPEC. See `define-ffi'."
  49     (let* ((symbol (argspec-symbol argspec))
  50            (symbol-name (symbol->string symbol)))
  51       (if (eq? '* symbol) arg ;; Raw pointer argument specification.
  52         (case (string-last-char symbol-name)
  53           ((#\*) `(,(encoder-symbol (drop-last-char symbol-name)) ,arg))
  54           ((#\%) `(if ,arg (,(encoder-symbol (drop-last-char symbol-name)) ,arg)
  55                     %null-pointer))
  56           (else arg)))))
  57
  58   (define (decode-form argspec arg)
  59     "Decode ARG according ARGSPEC. See `define-ffi'."
  60     (let* ((symbol (argspec-symbol argspec))
  61            (symbol-name (symbol->string symbol)))
  62       (if (eq? symbol) arg
  63         (case (string-last-char symbol-name)
  64           ((#\*) `(,(decoder-symbol (drop-last-char symbol-name)) ,arg))
  65           ((#\%) `((let ((value ,arg))
  66                      (if (equal? value %null-pointer) #f
  67                        (,(decoder-symbol (drop-last-char symbol-name)) value)))))
  68           (else arg))))))
  69
  70 (define-syntax-rule
  71   (with-unsafe-syntax <env> ((<var> <syntax>) ...) <exprs> ...)
  72   (datum->syntax <env>
  73     (let ((<var> (syntax->datum <syntax>)) ...)
  74       <exprs> ...)))
  75
  76 (define-syntax-rule
  77   (unsafe-syntax <env> (<args> ... <arg>))
  78   (datum->syntax <env> (<args> ... (syntax->datum <arg>))))
  79
  80
  81 ;; Define binding to C function, hiding most of pointer-related work.
  82 ;; If for example, we want to get from standart library `atoi' function,
  83 ;; we would invoke marco following way:
  84 ;; (define-ffi atoi ((string* #:string) -> int) :from (dynamic-link))
  85 ;; What happens here?
  86 ;; First argument, `atoi' is name of Scheme function to be defined.
  87 ;; With common sence and `symbol:scheme->c' this name is transformed
  88 ;; to name of underlying C symbol.
  89
  90 ;; Next comes ((string* #:string) -> int).
  91 ;; Exprpessions before `->' symbol describes arguments of function.
  92
  93 ;; Each expression may be symbol, or list with symbol as first element.
  94
  95 ;; If symbol name do not ends with * or %, it is passed to `pointer->procedure'
  96 ;; directly. So it should be `int', `uint32' and so on, defined in (system foreign).
  97
  98 ;; If symbol name ends with *, for example `string*', it means, that argument
  99 ;; have pointer type, (quote *) passed to `pointer->procedure', and this
 100 ;; argument is trasformed to pointer via call of `<symbol>->pointer'.
 101 ;; In our example, it means use of `string->pointer'.
 102
 103 ;; If symbol name ends with %, it means same as *, but allows #f to be passed
 104 ;; for this argument, that stands as %null-pointer.
 105
 106 ;; Next part, expression after `->' symbol describes return value.  It follows
 107 ;; same rules, as expressions for arguments, except decoding performed via
 108 ;; `pointer-><type>' function. If symbol ends with %, %null-pointer decoded to
 109 ;; #f.
 110
 111 ;; Last part, `:from (dynamic-link)' tells from where load symbol. It is optional
 112 ;; and defaults to (dynamic-link).
 113
 114 ;; This macro have following limitations, inconviences and simply things to think about.
 115
 116 ;; Unexpected way of argv-like arrays. For example, if we have two C functions
 117 ;; `struct foo** get_foo_list` and `struct bar ** get_bar_list', both of which returns
 118 ;; NULL-terminated list of pointers, we could expect to have way to uniformly
 119 ;; get list of both `foo' and `bar'.
 120 ;; In current implementation, best we can do is
 121 ;; (define-ffi get-foo-list ( -> foo-argv*))
 122 ;; (define-ffi get-bar-list (-> bar-argv*))
 123 ;; and implement `pointer->foo-argv' and `pointer->bar-argv'.
 124 ;; On other hand, this interface is simple and extensible, allowing you
 125 ;; to make encoding and decoding perform arbitary validation.
 126
 127 ;; Absolutely no support for output pointer arguments. It is unclear, what
 128 ;; should return Scheme procedure, wrapping C function with return value and
 129 ;; several output arguments. Maybe, use `values'?
 130
 131 (define-syntax define-ffi
 132   (lambda (env)
 133     (syntax-case env (-> :from)
 134       ((_ <func-name> (<args:spec> ... -> <retval>) :from <dlobj>)
 135         (and (identifier? #'<func-name>))
 136         (with-syntax
 137           ((<retval:dyntype> (unsafe-syntax env
 138                                (argspec-dynamic-type #'<retval>)))
 139             (<args:name> (generate-temporaries #'(<args:spec> ...)))
 140             (<raw-procedure> (datum->syntax env 'raw-procedure))
 141             (<args:dyntype> (with-unsafe-syntax env
 142                               [(argspecs #'(<args:spec> ...))]
 143                               (cons 'list (map argspec-dynamic-type argspecs))))
 144             (<c-func-name> (unsafe-syntax env
 145                              (symbol:scheme->c #'<func-name>))))
 146           (with-syntax ((<decoded-funcall>
 147                    (with-unsafe-syntax env
 148                      ((args-names #'<args:name>)
 149                        (args-specs #'(<args:spec> ...))
 150                        (retspec  #'<retval>))
 151                      (decode-form retspec
 152                        (cons 'raw-procedure
 153                          (map encode-form args-specs args-names))))))
 154             #`(define <func-name>
 155                 (let ((<raw-procedure>
 156                         (pointer->procedure <retval:dyntype>
 157                           (dynamic-func <c-func-name> <dlobj>)
 158                           <args:dyntype>)))
 159                   (lambda <args:name> <decoded-funcall>))))))
 160       ((_ <func-name> (<args:spec> ... -> <retval>))
 161        #'(define-ffi <func-name> (<args:spec> ... -> <retval>)
 162            :from (dynamic-link))))))
 163
 164 (define-ffi atoi (string* -> int))