lisp/system/ffi.scm

   1 ;;; ffi.scm ---
   2
   3 ;; Copyright (C) 2014  <Dmitry Bogatov <KAction@gnu.org>>
   4
   5 ;; Author:  <Dmitry Bogatov <KAction@gnu.org>>
   6
   7 ;; This program is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the GNU General Public License
   9 ;; as published by the Free Software Foundation; either version 3
  10 ;; of the License, or (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This module defines structure <ffi-object> describing scheme
  23 ;; representation of C datatype. It contains of following fields:
  24 ;;
  25 ;;  * type, see (system foreign)
  26 ;;  * encoder, that convert Scheme object to C datatype
  27 ;;  * decoder, that convert C datatype to Scheme object
  28 ;;  * size, for pointer types.
  29 ;;
  30 ;;  Either encoder or decoder, but not both can be #f, this means
  31 ;;  than operation is not supported. If both are supported,
  32 ;;       decoder . encoder == id
  33 ;;  Reverse is not necessary correct, since decoding can omit some
  34 ;;  details of original object.
  35 ;;
  36 ;;  This object is used by macros in (syntax ffi)
  37 ;;
  38 ;;  Also, this module provides set of macros to define <ffi>s
  39 ;;  for common datatypes, encountered in C.
  40 ;;
  41 ;;  The most generic form is `define-ffi-object`, that is little more,
  42 ;;  than keyword wrapper around <ffi-object> constructor. It have form
  43 ;;
  44 ;;      (define-ffi-object object:
  45 ;;          #:decoder pointer->object
  46 ;;          #:encoder object->pointer
  47 ;;          #:type '* ;; Not needed, pointer is default)
  48 ;;
  49 ;;  It is recommended, that if type is '*, to name decoders and encoders
  50 ;;  like in example, and if type is integral, use integral->object and
  51 ;;  object->integral naming. By convention name of <ffi> variable
  52 ;;  ends with colon.
  53 ;;
  54 ;;  If type is '*, `define-ffi-object` also defines `?object:` variable,
  55 ;;  that in addition can convert #f <-> %null-pointer.
  56 ;;
  57 ;;  Second provided macro is `define-ffi-enum`. It is called in form
  58 ;;      (define-ffi-enum enum/foo: (empty (half 75) full))
  59 ;;  which corresponds to following C declaration
  60 ;;      enum foo { empty, half = 75, full };
  61 ;;  Generated encoders/decoders converts symbols to/from int.
  62 ;;
  63 ;;  Next, macro than corresponds to bitmasks, `define-ffi-mask`. Example:
  64 ;;  (define-ffi-mask mask/bar:
  65 ;;      ((nice #x1) (bad #x3))
  66 ;;      #:type int8)
  67 ;;
  68 ;;  Next, dealing with structs. For example, in C
  69 ;;      struct foo_struct { int a; char *s; int i_do_not_care; };
  70 ;;  can be directly translated with `define-ffi-struct`
  71 ;;  (define-ffi-struct foo: ((int a) (?string: s) int))
  72 ;;
  73 ;;  It defines srfi-9 struct <foo> with fields `a' and `b'.  If not
  74 ;;  every field given name in `define-ffi-struct`, during decoding
  75 ;;  such fields are ignored, and during encoding are filled with
  76 ;;  specially-prepared garbage.
  77 ;;
  78 ;;  Not very often, but we need to deal with function pointers.  It
  79 ;;  can be nicely handled with
  80 ;;      (define-ffi-func func/make: ((string: name) (string: value) -> void))
  81 ;;
  82 ;;  The most annoying part of C from ffi part of view are unions,
  83 ;;  since they cannot be parsed without context. Your best bet is
  84 ;;  define dummy struct of needed size in place of union, and count
  85 ;;  offsets yourself.
  86 ;;
  87 ;;; Code:
  88
  89 (define-module (system ffi)
  90   #:replace (equal?)
  91   #:export (guard)
  92   #:export (*: void: ?*: string: ?string:)
  93   #:export (call-with-provided-memory)
  94   #:export (define-extern)
  95   #:export (define-ffi)
  96   #:export (define-ffi-enum)
  97   #:export (define-ffi-func)
  98   #:export (define-ffi-mask)
  99   #:export (define-ffi-object)
 100   #:export (define-ffi-struct)
 101   #:export (extern)
 102   #:export (extern-pointer)
 103   #:export (extern-pointer-array)
 104   #:export (make-ffi-enum)
 105   #:export (make-ffi-func-decoder)
 106   #:export (make-ffi-func-encoder)
 107   #:export (make-ffi-make)
 108   #:export (?pointer->string ?string->pointer)
 109   #:export (make-ffi-struct)
 110   #:export (offset-of)
 111   #:export (size-of)
 112   #:export (unsafe)
 113   #:export (with-provided-memory)
 114   #:export (c-free c-malloc c-memmove c-strdup c-strlen))
 115
 116 (use-modules (ice-9 control))
 117 (use-modules (ice-9 q))
 118 (use-modules (oop goops))
 119 (use-modules (ice-9 decorate))
 120 (use-modules (ice-9 curried-definitions))
 121 (use-modules (ice-9 match))
 122 (use-modules (srfi srfi-9))
 123 (use-modules (ice-9 optargs))
 124 (use-modules (rnrs bytevectors))
 125 (use-modules (srfi srfi-1))
 126 (use-modules (syntax export))
 127 (use-modules (syntax functional))
 128 (use-modules (syntax implicit))
 129 (use-modules (syntax record))
 130 (use-modules (system foreign))
 131 (use-modules (texinfo string-utils))
 132
 133 ;; Many primitive types have identity as encoder and/or decoder,
 134 ;; but to make procedure names more meaningful, each one receive
 135 ;; it's own instance of identity function.
 136 (define (make-identity)
 137   (lambda (x) x))
 138
 139
 140 (define-class <ffi-object> ()
 141   (ffi-decoder #:init-keyword #:decoder #:accessor .ffi-decoder
 142                #:init-form (cute error "No decoder" <...>))
 143   (ffi-encoder #:init-keyword #:encoder #:accessor .ffi-encoder
 144                #:init-form (cute error "No encoder" <...>))
 145   (ffi-type    #:init-keyword #:type    #:accessor .ffi-type
 146                #:init-value '*)
 147   (ffi-clone   #:init-keyword #:clone   #:accessor .ffi-clone
 148                #:init-form (make-identity))
 149   (ffi-free    #:init-keyword #:free    #:accessor .ffi-free
 150                #:init-form (make-identity)))
 151 (define guard (make-guardian))
 152
 153 (define-record-type <unsafe>
 154   (unsafe value)
 155   unsafe?
 156   (value unsafe-coerce))
 157
 158 (define-syntax-rule (promise-overload method-name)
 159   (define-method (method-name (promise <promise>) . args)
 160     (apply method-name (force promise) args)))
 161 (promise-overload .ffi-decoder)
 162 (promise-overload .ffi-encoder)
 163 (promise-overload .ffi-type)
 164 (promise-overload .ffi-clone)
 165 (promise-overload .ffi-free)
 166
 167 (define (force* x)
 168   (if (promise? x)
 169       (force x)
 170     x))
 171
 172 (define ((use-ffi-accessor accessor) obj value)
 173   ((accessor obj) value))
 174 (define clone (use-ffi-accessor .ffi-clone))
 175 (define free  (use-ffi-accessor .ffi-free))
 176
 177 (define* (decode ffi-obj c-value #:key free-after?)
 178   (define scm-value ((.ffi-decoder ffi-obj) c-value))
 179   (when free-after?
 180     (free ffi-obj c-value))
 181   scm-value)
 182
 183 (define* (encode ffi-obj scm-value #:key (clone-after? #t))
 184   (if (unsafe? scm-value)
 185       (unsafe-coerce scm-value)
 186     (let ((c-value ((.ffi-encoder ffi-obj) scm-value)))
 187       ;; If scm-value is #f it means that we are encoding either
 188       ;; boolean or %null-pointer. In both cases cloning is not
 189       ;; needed, in second it is a problem, since clone function
 190       ;; expects valid pointer, not null one.
 191       (if (and scm-value clone-after?)
 192           (clone ffi-obj c-value)
 193         c-value))))
 194
 195 (define-record-type* field (accessor ffi-object))
 196 (define-class <ffi-struct> (<ffi-object>)
 197   (struct-class #:init-keyword #:struct-class #:accessor .struct-class)
 198   (ffi-objects  #:init-keyword #:ffi-objects))
 199 (promise-overload .struct-class)
 200 (define-method (.ffi-objects (obj <ffi-struct>))
 201   (map force* (slot-ref obj 'ffi-objects)))
 202
 203 (define-method (size-of (struct <ffi-struct>))
 204   (sizeof (map .ffi-type (.ffi-objects struct))))
 205 (define-method (size-of x)
 206   (sizeof x))
 207
 208 (define-method (equal? x y)
 209   ((@ (guile) equal?) x y))
 210
 211 (define-method (equal? (this <object>) (other <object>))
 212   (let* ((class_ (class-of this))
 213          (slots (map car (class-slots class_))))
 214     (define (slot-values instance)
 215       (map (cute slot-ref instance <>) slots))
 216     (if (eq? class_ (class-of other))
 217         (false-if-exception (every equal? (slot-values this) (slot-values other)))
 218       #f)))
 219
 220 (define-method (offset-of (struct <ffi-struct>) (field-name <symbol>))
 221   (define field-names (map car (class-slots (.struct-class struct))))
 222   (define ffi-objs (.ffi-objects struct))
 223   (unless (member field-name field-names)
 224     (error "Struct do not have such field:" struct field-name))
 225   (let* ((fields-before# (list-index (cute eq? field-name <>) field-names)))
 226     (if (zero? fields-before#)
 227         0
 228       (let* ((ffi-objects-before (take ffi-objs fields-before#))
 229              (c-types-before      (map .ffi-type ffi-objects-before)))
 230         (sizeof c-types-before)))))
 231
 232 (define-method (offset-of (struct <ffi-struct>) (base <foreign>) (field-name <symbol>))
 233   (make-pointer (+ (pointer-address base) (offset-of struct field-name))))
 234
 235 (define decorate:null-decoder
 236   (make-decorator 'null-decoder ((f ptr))
 237                   (if (null-pointer? ptr)
 238                       #f
 239                     (f ptr))))
 240
 241 (define decorate:null-clone
 242   (make-decorator 'null-clone ((f ptr))
 243                   (if (null-pointer? ptr)
 244                       %null-pointer
 245                     (f ptr))))
 246
 247 (define decorate:null-encoder
 248   (make-decorator 'null-encoder ((f value))
 249                   (if value
 250                       (f value)
 251                     %null-pointer)))
 252
 253 (define (slot-modify obj slot fn)
 254   (slot-set! obj slot (fn (slot-ref obj slot))))
 255
 256 (define (force-ffi-objects ffi-struct)
 257   (slot-modify ffi-struct 'ffi-objects (cute map force* <>)))
 258
 259 (define (make-nullable obj)
 260   (define new (shallow-clone obj))
 261   (slot-modify new 'ffi-encoder decorate:null-encoder)
 262   (slot-modify new 'ffi-decoder decorate:null-decoder)
 263   (slot-modify new 'ffi-clone   decorate:null-clone)
 264   new)
 265
 266 ;; A bit hacky way to get integer->foo functions on toplevel, allowing
 267 ;; to avoid some macros and simplifying others.
 268 (define (toplevel-define-accessors ffi-obj-name)
 269   (define symbol (normalize-ffi-object-name ffi-obj-name))
 270   (define int/encoder-name (symbol-append symbol '->integer))
 271   (define int/decoder-name (symbol-append 'integer-> symbol))
 272   (define pointer/encoder-name (symbol-append symbol '->pointer))
 273   (define pointer/decoder-name (symbol-append 'pointer-> symbol))
 274   (define pointer/free-name (symbol-append 'free- symbol '-pointer))
 275   (define pointer/clone-name (symbol-append 'clone- symbol '-pointer))
 276   (define ffi-object (module-ref (current-module) ffi-obj-name))
 277   (define (current-module-define! symbol proc)
 278     (module-define! (current-module) symbol proc)
 279     (set-procedure-property! proc 'name symbol))
 280   (define (toplevel-define-field symbol field)
 281     (current-module-define! symbol (slot-ref ffi-object field)))
 282   (if (eq? '* (slot-ref ffi-object 'ffi-type))
 283       (begin
 284         (toplevel-define-field pointer/decoder-name 'ffi-decoder)
 285         (toplevel-define-field pointer/encoder-name 'ffi-encoder)
 286         (toplevel-define-field pointer/free-name    'ffi-free)
 287         (toplevel-define-field pointer/clone-name   'ffi-clone))
 288     (begin
 289       (toplevel-define-field int/decoder-name 'ffi-decoder)
 290       (toplevel-define-field int/encoder-name 'ffi-encoder))))
 291
 292 (define (string-last str)
 293   (string-ref str (1- (string-length str))))
 294
 295 (define (string-init str)
 296   (substring str 0 (1- (string-length str))))
 297
 298 (define (normalize-ffi-object-name name)
 299   ;; Just strip trailing colon, if any.
 300   ;; There should be one, really.
 301   (define name-str (symbol->string name))
 302   (unless (eqv? (string-last name-str) #\:)
 303     (error "Wrong ffi object name (should end with colon):" name))
 304   (string->symbol (string-init name-str)))
 305
 306 (define (toplevel-maybe-define-nullable name)
 307   (define object (module-ref (current-module) name))
 308   (define nullable-name (symbol-append '? name))
 309   (when (eq? '* (.ffi-type object))
 310     (module-define! (current-module) nullable-name
 311                     (make-nullable object))
 312     (toplevel-define-accessors nullable-name)))
 313
 314 (define-syntax-rule (define-ffi-object name kw ...)
 315   (begin
 316     (define name (make <ffi-object> kw ...))
 317     (toplevel-define-accessors 'name)
 318     (toplevel-maybe-define-nullable 'name)))
 319
 320 (define ((enum-lambda alist) key)
 321   (or (assq-ref alist key)
 322       (error "enum-lambda: key not found:" alist key)))
 323
 324 (define (regenerate-enum-values lst)
 325   (let ((prev-value -1))
 326     (define (regenerate x)
 327       (match x
 328         ((key value)   (cons key value))
 329         ((key . value) (cons key value))
 330         (key           (let ((value (1+ prev-value)))
 331                          (set! prev-value value)
 332                          (cons key value)))))
 333     (map-in-order regenerate lst)))
 334
 335 (define (reverse-cons pair)
 336   (call-with-values (cute car+cdr pair) xcons))
 337
 338 (define* (make-ffi-enum alist #:key (type int))
 339   (let ((full-form-alist (regenerate-enum-values alist)))
 340     (make <ffi-object>
 341       #:encoder (enum-lambda  full-form-alist)
 342       #:decoder (enum-lambda (map reverse-cons full-form-alist))
 343       #:type type)))
 344
 345 (define-syntax-rule (define-ffi-enum name (clause ...) kw ...)
 346   (begin
 347     (define name (make-ffi-enum '(clause ...) kw ...))
 348     (toplevel-define-accessors 'name)))
 349
 350 (define* (make-ffi-mask alist #:key (type int))
 351   (define mask-values (map cdr alist))
 352   (define key->value (enum-lambda alist))
 353   (define value->key (enum-lambda (map reverse-cons alist)))
 354   (define (encoder symbols)
 355     (apply logior (map key->value symbols)))
 356   (define (decoder val)
 357     (define (mask-present? mask)
 358       (eqv? mask (logand mask val)))
 359     (map value->key (filter mask-present? mask-values)))
 360   (make <ffi-object>
 361     #:encoder encoder
 362     #:decoder decoder
 363     #:type type))
 364
 365 (define-syntax-rule (define-ffi-mask name ((key value) ...) kw ...)
 366   (begin
 367     (define name (make-ffi-mask '((key . value) ...) kw ...))
 368     (toplevel-define-accessors 'name)))
 369
 370 (define (call-with-provided-memory ffi-structs producer consumer)
 371   (define (make-vector-for-ffi st)
 372     (make-bytevector (slot-ref st 'struct-size)))
 373   (let* ((vectors  (map make-vector-for-ffi ffi-structs))
 374          (pointers (map bytevector->pointer vectors))
 375          (retvalue (apply producer pointers)))
 376     (apply consumer retvalue (map decode ffi-structs pointers))))
 377
 378 (define-syntax with-provided-memory
 379   (syntax-rules (=)
 380     ((_ ((ffi-obj name) ...) (result = memaction) exp exp* ...)
 381      (call-with-provided-memory
 382       (list ffi-obj ...)
 383       (lambda (name ...) memaction)
 384       (lambda (result name ...) exp exp* ...)))))
 385
 386 \f
 387 ;; function->pointer transformation
 388
 389
 390 ;; Every arg-spec is cons pair (free-after? . ffi-object)
 391 (define ((make-ffi-func-encoder ret-obj clone-retval? arg-specs) scm-fn)
 392   (define (proxy . c-value-args)
 393     (define (decode-and-maybe-free arg-spec c-value)
 394       (decode (cdr arg-spec) c-value #:free-after? (car arg-spec)))
 395     (define scm-value-args (map decode-and-maybe-free arg-specs c-value-args))
 396     (define scm-ret-value (apply scm-fn scm-value-args))
 397     (define c-ret-value (encode ret-obj scm-ret-value #:clone-after? clone-retval?))
 398     c-ret-value)
 399   (define (arg-spec-ffi-type arg-spec)
 400     (.ffi-type (cdr arg-spec)))
 401   (procedure->pointer (slot-ref ret-obj 'ffi-type)
 402                       proxy
 403                       (map arg-spec-ffi-type arg-specs)))
 404
 405 (define-syntax unify-encode-clause
 406   (syntax-rules ()
 407     ((_ (#:const ffi-obj _ ...)) (cons #f ffi-obj))
 408     ((_ (#:alloc ffi-obj _ ...)) (cons #t ffi-obj))
 409     ((_ (ffi-obj _ ...))         (cons #f ffi-obj))
 410     ((_ ffi-obj)                 (cons #f ffi-obj))))
 411
 412 (define-syntax define-ffi-func
 413   (syntax-rules (->)
 414     ((_ name (arg ... -> #:const ret-obj))
 415      (define-ffi-object name
 416        #:decoder unsafe
 417        #:encoder (make-ffi-func-encoder
 418                   ret-obj #f
 419                   (list (unify-encode-clause arg) ...))))
 420     ((_ name (arg ... -> #:alloc ret-obj))
 421      (define-ffi-object name
 422        #:decoder unsafe
 423        #:encoder (make-ffi-func-encoder
 424                   ret-obj #f
 425                   (list (unify-encode-clause arg) ...))))
 426     ((_ name (arg ... -> ret-obj))
 427      (define-ffi-func name (arg ... -> #:const ret-obj)))))
 428
 429 \f
 430 ;; pointer->function transformation.
 431
 432 (define (make-raw-procedure ret-obj args-objs foreign-address)
 433   (pointer->procedure (.ffi-type ret-obj) foreign-address
 434                       (map .ffi-type args-objs)))
 435
 436 (define (make-c-values arg-specs scm-args provided-args)
 437   (define (xenq! el q) (enq! q el))
 438   (define scm-args-q (fold xenq! (make-q) scm-args))
 439   (define provided-args-q (fold xenq! (make-q) provided-args))
 440   (define (process-arg-spec arg-spec)
 441     (match arg-spec
 442       (('fix ffi-obj value) value)
 443       (('provide ffi-obj)   (deq! provided-args-q))
 444       (('const  ffi-obj)    (encode ffi-obj (deq! scm-args-q) #:clone-after? #f))
 445       (('normal ffi-obj)    (encode ffi-obj (deq! scm-args-q) #:clone-after? #t))))
 446   (define c-values (map process-arg-spec arg-specs))
 447   (unless (q-empty? scm-args-q)
 448     (error "Wrong number of arguments (too much):" (car scm-args-q)))
 449   c-values)
 450
 451 ;; Every element of ARG-SPECS is expected to be a list, describing
 452 ;; argument of function. Here is possibilities:
 453 ;;
 454 ;; (fix <ffi-object> <fixed-value>)
 455 ;; (normal <ffi-object>)
 456 ;; (const <ffi-object>)
 457 ;; (provide <ffi-object)
 458 (define ((make-ffi-func-decoder ret-obj free-retval? arg-specs) foreign-address)
 459   (define arg-spec-ffi-object second)
 460   (define (arg-spec-type-provide? arg-spec)
 461     (eq? (car arg-spec) 'provide))
 462   (define args-ffi-objs (map arg-spec-ffi-object arg-specs))
 463   (define raw-procedure (make-raw-procedure ret-obj args-ffi-objs foreign-address))
 464   (define provide-ffi-objs (filter arg-spec-type-provide? arg-specs))
 465   (lambda scm-args
 466     (call-with-provided-memory
 467      provide-ffi-objs
 468      (lambda provided-pointers
 469        (define c-values (make-c-values arg-specs scm-args provided-pointers))
 470        (define c-ret-value (apply raw-procedure c-values))
 471        (decode ret-obj c-ret-value #:free-after? free-retval?))
 472      (lambda (scm-ret-value . provided-scm-values)
 473        (if (null? provided-scm-values)
 474            scm-ret-value
 475          (cons scm-ret-value provided-scm-values))))))
 476
 477
 478
 479 (define (bool->integer b)
 480   (if b 1 0))
 481
 482 (define (integer->bool value)
 483   (not (zero? value)))
 484
 485 (define-ffi-object void: #:decoder (const *unspecified*) #:type void)
 486 (define-ffi-object *: #:decoder (make-identity) #:encoder (make-identity))
 487 (define-ffi-object bool: #:decoder integer->bool #:encoder bool->integer #:type int)
 488
 489 (define (mirror-at-toplevel type-name)
 490   (define type (module-ref (current-module) type-name))
 491   (define varname (symbol-append type-name ':))
 492   (module-define! (current-module) varname
 493     (make <ffi-object> #:encoder (make-identity) #:decoder (make-identity) #:type type))
 494   (module-export! (current-module) (list varname)))
 495
 496 (for-each mirror-at-toplevel
 497   '(size_t int long ptrdiff_t int8 int16 int32 int64 uint8 uint16 uint32 uint64))
 498
 499 (define-syntax unify-decode-clause
 500   (syntax-rules (:=)
 501     ((_ (ffi-obj := value))        (list 'fix ffi-obj value))
 502     ((_ (#:alloc ffi-obj _ ...))   (list 'normal  ffi-obj))
 503     ((_ (#:const ffi-obj _ ...))   (list 'const   ffi-obj))
 504     ((_ (ffi-obj _ ...))           (list 'normal  ffi-obj))
 505     ((_ ffi-obj)                   (list 'normal  ffi-obj))
 506     ((_ (#:provide ffi-obj _ ...)) (list 'provide ffi-obj))))
 507
 508 (define (scm-symbol->c-symbol symb)
 509   (transform-string (symbol->string symb) #\- #\_))
 510
 511 (define* (dynamic-pointer* def-symbol #:key symbol (from (dynamic-link)))
 512   (define c-symbol-str (or symbol (scm-symbol->c-symbol def-symbol)))
 513   (dynamic-pointer c-symbol-str from))
 514
 515 (define (toplevel-define-ffi name ret-obj free-retval? arg-specs . kw)
 516   (define (make-procedure* ret*)
 517     (define make-decoder* (make-ffi-func-decoder ret* free-retval? arg-specs))
 518     (define foreign-pointer (false-if-exception (apply dynamic-pointer* name kw)))
 519     (when foreign-pointer
 520       (make-decoder* foreign-pointer)))
 521   (define (wrap-q-empty proc)
 522     (lambda args
 523       (catch 'q-empty (cute apply proc args)
 524         (lambda args (error "Not enough arguments:" name )))))
 525
 526   (module-define! (current-module) name
 527     (wrap-q-empty (make-procedure* ret-obj)))
 528   (when (eq? '* (.ffi-type ret-obj))
 529     (module-define! (current-module) (symbol-append name '*)
 530       (wrap-q-empty (make-procedure* ?*:)))))
 531
 532 (define-syntax define-ffi
 533   (syntax-rules (-> ::)
 534     ((_ name (arg-clause ... -> free-retval? ret-obj) kw ...)
 535      (toplevel-define-ffi 'name ret-obj free-retval?
 536                           (list (unify-decode-clause arg-clause) ...)
 537                           kw ...))
 538     ((_ name (arg-clause ... -> #:const ret-obj) kw ...)
 539      (define-ffi name (arg-clause ... -> #f ret-obj) kw ...))
 540     ((_ name (arg-clause ... -> #:alloc ret-obj) kw ... )
 541      (define-ffi name (arg-clause ... -> #t ret-obj) kw ...))
 542     ((_ name (arg-clause ... -> ret-obj) kw ...)
 543      (define-ffi name (arg-clause ... -> #f ret-obj) kw ...))
 544     ((_ name :: #:const ret-obj kw ...)
 545      (define-ffi (-> #f ret-obj) kw ...))
 546     ((_ name :: #:alloc ret-obj kw ...)
 547      (define-ffi (-> #t ret-obj) kw ...))))
 548
 549 (define-ffi c-free (*: -> void:) #:symbol "free")
 550 (define-ffi c-memmove ((*: dest) (*: src) (size_t: n) -> *:) #:symbol "memmove")
 551 (define-ffi c-strdup (*: -> *:) #:symbol "strdup")
 552 (define-ffi c-malloc (size_t: -> *:) #:symbol "malloc")
 553
 554 (define-ffi-object string:
 555   #:decoder pointer->string
 556   #:encoder string->pointer
 557   #:clone c-strdup
 558   #:free c-free)
 559
 560 (define (string-like->pointer obj)
 561   (string->pointer
 562    (let loop ((object obj))
 563      (let/ec return
 564        (when (string? object)
 565          (return object))
 566        (when (symbol? object)
 567          (return (loop (symbol->string object))))
 568        (when (keyword? object)
 569          (return (loop (keyword->symbol object))))
 570        (scm-error 'wrong-type-arg "string-like->pointer"
 571                   "Unsupported value ~A" (list obj))))))
 572
 573 (define (pointer->string-like ptr)
 574   (string->symbol (pointer->string ptr)))
 575
 576 (export string-like:)
 577 (define-ffi-object string-like:
 578   #:decoder pointer->string-like
 579   #:encoder string-like->pointer
 580   #:clone c-strdup
 581   #:free c-free)
 582
 583 (define (toplevel-define-scm-struct-class struct-name field-names)
 584   (define class-name (symbol-append '<struct- struct-name '>))
 585   (define (make-slot-spec field-name)
 586     (list field-name #:init-keyword (symbol->keyword field-name)))
 587   (define slot-specs (map make-slot-spec field-names))
 588   (define class_ (make <class>
 589                    #:dsupers (list <object>)
 590                    #:slots slot-specs
 591                    #:name class-name))
 592   (module-define! (current-module) class-name class_)
 593   class_)
 594
 595 (define (make-ffi-struct name fields-alist)
 596   (define ffi-objs    (map cdr fields-alist))
 597   (define field-names (map car fields-alist))
 598   (define struct-class_  (toplevel-define-scm-struct-class name field-names))
 599   (define c-types (delay (map .ffi-type ffi-objs)))
 600
 601   (define (parse-c-values foreign-pointer)
 602     (parse-c-struct foreign-pointer (force c-types)))
 603   (define (%encoder struct)
 604     (define scm-values (map (cute slot-ref struct <>) field-names))
 605     (define c-values (map (cute encode <> <> #:clone-after? #f) ffi-objs scm-values))
 606     (make-c-struct (force c-types) c-values))
 607   (define (%decoder foreign-pointer)
 608     (define c-values (parse-c-values foreign-pointer))
 609     (define scm-values (map decode ffi-objs c-values))
 610     (define result-struct (make struct-class_))
 611     (map (cute slot-set! result-struct <> <>) field-names scm-values)
 612     result-struct)
 613   (define (%clone foreign-pointer)
 614     (define sizeof-struct (sizeof (force c-types)))
 615     (define c-values (parse-c-values foreign-pointer))
 616     (define cloned-c-values (map clone ffi-objs c-values))
 617     (define new-memory (c-malloc sizeof-struct))
 618     (when (null-pointer? new-memory)
 619       (error "No memory:" sizeof-struct))
 620     (c-memmove new-memory (make-c-struct (force c-types) c-values) sizeof-struct))
 621   (define (%free foreign-pointer)
 622     (define c-values (parse-c-values foreign-pointer))
 623     (for-each free ffi-objs c-values)
 624     (c-free foreign-pointer))
 625   (make <ffi-struct>
 626     #:encoder %encoder
 627     #:decoder %decoder
 628     #:free %free
 629     #:clone %clone
 630     #:type '*
 631     #:struct-class struct-class_
 632     #:ffi-objects ffi-objs))
 633
 634 (define-syntax-rule (define-ffi-struct name ((ffi-obj field-name) ...))
 635   (begin
 636     (define name (make-ffi-struct (normalize-ffi-object-name 'name)
 637                                   (list (cons 'field-name (delay ffi-obj)) ...)))
 638     (toplevel-define-accessors 'name)
 639     (toplevel-maybe-define-nullable 'name)))
 640
 641
 642 (define (parse-c-type ptr type)
 643   (car (parse-c-struct ptr (list type))))
 644 (define (value-memory type value)
 645   (make-c-struct (list type) (list value)))
 646
 647 (define ((extern ffi-obj) pointer)
 648   (define objtype (.ffi-type ffi-obj))
 649   (define objsize (size-of objtype))
 650   (define (get)
 651     (decode ffi-obj (parse-c-type pointer objtype)))
 652   (define (set value)
 653     (c-memmove pointer (value-memory objtype (encode ffi-obj value)) objsize))
 654   (make-procedure-with-setter get set))
 655
 656 (define* (extern-pointer ffi-obj #:key (free-on-set? #f) (clone-on-set? #t))
 657   (unless (eq? (.ffi-type ffi-obj) '*)
 658     (error "extern-pointer can only be used with pointer ffi-objects" ffi-obj))
 659   (lambda (address)
 660     (define pointer (dereference-pointer address))
 661     (define (get)
 662       (decode ffi-obj pointer))
 663     (define (set value)
 664       (define new-pointer
 665         (let ((new-pointer* (encode ffi-obj value)))
 666           (if clone-on-set?
 667               (clone ffi-obj new-pointer*)
 668             new-pointer*)))
 669       (when free-on-set?
 670         (free ffi-obj pointer))
 671       (c-memmove address (value-memory '* new-pointer) (sizeof '*)))
 672     (make-procedure-with-setter get set)))
 673
 674 (define-syntax-rule (define-extern (ffi-obj name) kw ...)
 675   (define name (false-if-exception
 676                 ((extern ffi-obj) (dynamic-pointer* 'name kw ...)))))
 677
 678 (define* (extern-pointer-array ffi-obj base-address array-size
 679                                #:key (free-on-set? #f) (clone-on-set? #t))
 680   (define (void*-offset count)
 681     (define offset (* count (sizeof '*)))
 682     (make-pointer (+ (pointer-address base-address) offset)))
 683   (define pointers (map void*-offset (iota array-size)))
 684   (define pointer->accessor
 685     (extern-pointer ffi-obj
 686                     #:free-on-set? free-on-set?
 687                     #:clone-on-set? clone-on-set?))
 688   (define variables (list->vector (map pointer->accessor pointers)))
 689   (lambda (n)
 690     (vector-ref variables n)))