guile-hurd/mach/ffi.scm

;; Author: Maxime Devos
(define-module (mach ffi)
  #:export (define-bitfield define-ffi wrap-bits unwrap-bits
            ffi:pointer ffi:unsigned-int ffi:off_t ffi:int
            ffi:bool bool->ffi-int define-ffi-enum
	    with-foreign-variable with-foreign-variables*)
  #:re-export (pointer-address null-pointer? define-wrapped-pointer-type
               make-pointer make-c-struct dereference-pointer %null-pointer)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 receive))

(define ffi:int int)
(define ffi:bool ffi:int) ;; XXX
;; XXX check
(define (bool->ffi-int bool)
  (if bool 1 0))

(define ffi:pointer '*)
(define ffi:unsigned-int unsigned-int)
(define ffi:off_t unsigned-int) ;; XXX verify

;; TODO: check whethe VALUE ... are disjoint.
;; TODO: it would be nice if separate bitfield types were disjoint.
(define-syntax-rule (define-bitfield bitfield-name (name value) ...)
  (begin (define name value) ...))

(define-syntax-rule (wrap-bits bitfield)
  (lambda (x) x))
(define-syntax-rule (unwrap-bits bitfield)
  (lambda (x) x))

(define-syntax-rule (define-ffi (cname name) (return wrap) (arg type unwrap) ...)
  "Define a binding NAME to the C function NAME, lowering each argument ARG
using UNWRAP to the C representation TYPE, and wrapping the return value
of type RETURN with WRAP.  Resolving is delayed, to aid development on
GNU/Linux and cross-compilation."
  (define name
    (let ((c (delay (pointer->procedure return
                                        (dynamic-func cname (dynamic-link))
                                        (list type ...)
                                        #:return-errno? #t))))
      (lambda (arg ...)
        (receive (result errno)
          (apply (force c) (unwrap arg) ...)
          (values (wrap result) errno))))))

;; TODO: check whether VALUE ... are disjoint.
;; TODO: it would be nice if separate bitfield types were disjoint.
;;
;; ffi:base: underlying C type (ffi:int, ffi:unsigned-int, ...)
(define-syntax-rule (define-ffi-enum (ffi:name ffi:base) (%wrap-enum %unwrap-enum) (name value) ...)
  (begin (define ffi:name ffi:base)
         (define name value) ...
         (define (%wrap-enum x) x)
         (define (%unwrap-enum x) x)))

(define-syntax with-foreign-variable
  (lambda (s)
    "Allocate a region of foreign memory for holding a @code{ffi:type}.

Bind @var{box} to this region of foreign memory, such that it can be
referenced (yielding a @code{ffi:type}) and @code{set!} as an ordinary
Scheme variable.  Its initial value is @var{init}.

@var{box} is also available as a pointer @var{%box}."
    (syntax-case s ()
      ((_ (box %box ffi:type init) exp exp* ...)
       (not (free-identifier=? #'box #'%box))
       #'(let* ((type ffi:type)
		(%box (make-c-struct (list type) (list init))))
	   (let-syntax ((box (make-variable-transformer
			      (lambda (x)
				(syntax-case x ()
				  (var (identifier? #'var)
				       #'(%dereference %box type))
				  ;; XXX can we assume set == set!
				  ;; and var == box here?
				  ((set var value)
				   #'(%assign! %box type value)))))))
	     exp exp* ...))))))

(define-syntax with-foreign-variables*
  (syntax-rules ()
    ((_ () . exps) (let () . exps))
    ((_ (binding . rest) . exps)
     (with-foreign-variable binding
       (with-foreign-variables* rest . exps)))))

;; TODO: ideally, these two wouldn't require any memory allocations ...
(define (%dereference %box type)
  (car (parse-c-struct %box (list type))))
(define (%assign! %box type value)
  (let ((%value (make-c-struct (list type) (list value)))
	(size (sizeof type)))
    (bytevector-copy! (pointer->bytevector %value size) 0
		      (pointer->bytevector %box size) 0
		      size)))