private/ffi-utils.ss
(module ffi-utils mzscheme
  (require
   "define-utils.ss"
   (only (lib "13.ss" "srfi") string-index)
   (lib "list.ss")
   (all-except (lib "contract.ss") ->)
   (rename (lib "contract.ss") => ->)
   (lib "foreign.ss")) (unsafe!)
  
  (require-for-syntax (lib "list.ss"))
  
  (provide ffi-func/contract
           cstring->string
           define-handle
           define-clist-struct
           define-ctype-struct
           define/provide-ctype-struct)
  
  
  ;; ffi-func/contract : ffi-lib ([name (contract) (body)] ...)
  ;; Defines multiple ffi functions
  (define-syntax ffi-func/contract
    (lambda (stx)
      (let ([make-string (lambda (var)
                           (datum->syntax-object
                            var
                            (symbol->string (syntax-e var))))])
        (syntax-case stx ()
          ; Base
          [(_ lib regexp ([name (contr ...) (type ...)]))
           (with-syntax ([str-name (make-string #'name)]
                         [str-lib (make-string #'lib)]
                         ;; The contract with have two extra args the -> and the return value
                         [(vars ...) (cdr (cdr (generate-temporaries #'(contr ...))))])
             #'(define/contract name
                 (contr ...)
                 (get-ffi-obj (regexp-replaces (quote name) (quote regexp)) 
                              lib
                              (type ...)
                              (lambda () 
                                (lambda (vars ...) 
                                  (raise 
                                   (make-exn:fail:unsupported 
                                    (string->immutable-string (format "Procedure ~a not found in ~a" str-name str-lib))
                                    (current-continuation-marks))))))))]
          [(_ lib regexp ([name (contr ...) (type ...)]))
           #'(ffi-func/contract lib regexp ([name (contr ...) (type ...)]))]
          
          ;; Allow for list of definitions for a single library
          [(_ lib regexp ([name (contr ...) (type ...)]
                          [names (contrs ...) (types ...)] ...))
           #'(begin
               (ffi-func/contract lib regexp ([name (contr ...) (type ...)]))
               (ffi-func/contract lib regexp ([names (contrs ...) (types ...)] ... )))]))))
  
  
  ;; cstring->string : bytes -> string
  ;; Converts a null terminated cstring to a string
  (define (cstring->string byts)
    (let* ((str (bytes->string/utf-8 byts))
           (i (string-index str #\nul)))
      (if i
          (substring str 0 i)
          str)))
  
  
  ;; Defines a type (structure that provides a this opaque wrapper around something)
  (define-syntax (define-handle stx)
    (let ([make-identifier (lambda (var fmt)
                             (datum->syntax-object
                              var
                              (string->symbol
                               (format fmt (syntax-e var)))))])
      (syntax-case stx ()
        [(_ name)
         (with-syntax ([name? (make-identifier #'name "~a?")]
                       [_name (make-identifier #'name "_~a")]
                       [name-data (make-identifier #'name "~a-data")]
                       [make-name (make-identifier #'name "make-~a")])
           #'(begin
               (define-struct name (data))
               (provide name?)
               (define _name
                 (make-ctype _pointer
                             name-data
                             (lambda (ptr)
                               (if ptr
                                   (make-name ptr)
                                   #f))))))])))
  
  
  ;; (listof any/c) integer -> (values any/c (listof any/c))
  (define (remove-item lst index)
    (let ([item (list-ref lst index)])
      (values item (remove item lst))))
  
  ;; _pointer next-pointer-index structure-format
  (define (clinked-list->list ptr index format)
    (if (not ptr)
        '()
        (let-values ([(item lst) (remove-item (ptr-ref ptr (apply _list-struct format) 0) index)])
          (cons
           lst
           (clinked-list->list item index format)))))
  
  ;; Replaces the ith item in the list
  (define (replace item index lst)
    (if (= 0 index)
        (cons item (rest lst))
        (cons (first lst)
              (replace item (- index 1) (rest lst)))))
  
  
  ;; Given a next pointer type and a structure definition generate a ctype for dealing with C style linked lists
  (define-syntax (define-clist-struct stx)
    (let ([remove-next (lambda (clist names types)
                         (reverse
                          (foldl
                           (lambda (n t acc)
                             (if (eq? t (syntax-object->datum clist))
                                 acc
                                 (cons n acc)))
                           '()
                           (syntax-object->datum names) 
                           (syntax-object->datum types))))]
          [index-of (lambda (clist types)
                      (let loop ([count 0][lst (syntax-object->datum types)])
                        (cond
                          [(empty? lst) -1]
                          [(eq? (first lst) (syntax-object->datum clist)) count]
                          [else (loop (+ 1 count) (rest lst))])))]
          [make-identifier (lambda (form name)
                             (datum->syntax-object name
                                                   (string->symbol
                                                    (format form (syntax-object->datum name)))))])
      (syntax-case stx ()
        ((_ clist-type struct ((names types) ...) destructor)
         (with-syntax (((names-without-next ...) (remove-next #'clist-type #'(names ...) #'(types ...)))
                       (i (index-of #'clist-type #'(types ...)))
                       (make-struct (make-identifier "make-~a" #'struct)))
           #'(begin
               (define-struct/provide struct (names-without-next ...) (make-inspector))
               (define clist-type
                 (make-ctype _pointer
                             #f
                             (lambda (ptr)
                               (register-finalizer ptr destructor)
                               (map
                                (lambda (lst)
                                  (apply make-struct lst))
                                (clinked-list->list ptr 0 
                                                    (replace _pointer i (list types ...))))))))))
        ((_ clist struct ((names types) ...))
         #'(define-clist-struct clist struct ((names types) ...) (lambda (ptr) ptr))))))
  
  
  ;; Defines a structure and a coresponding ctype
  (define-syntax (define-ctype-struct stx)
    (let ([make-identifier (lambda (var fmt)
                             (datum->syntax-object
                              var
                              (string->symbol
                               (format fmt (syntax-e var)))))]
          [gen-accessors (lambda (strct fields)
                           (map
                            (lambda (field)
                              (datum->syntax-object
                               strct
                               (string->symbol
                                (format "~a-~a" (syntax-object->datum strct) field))))
                            (syntax-object->datum fields)))])
      (syntax-case stx ()
        ((_ struct-name ctype-name ((names types) ...) inspector)
         (with-syntax ([make-struct-name (make-identifier #'struct-name "make-~a")]
                       [(accessors ...) (gen-accessors #'struct-name #'(names ...))])
           #'(begin
               (define-struct struct-name (names ...) inspector)
               
               (define ctype-name
                 (make-ctype (_list-struct types ...)
                             (lambda (str)
                               (list (accessors str) ...))
                             (lambda (lst)
                               (apply make-struct-name lst)))))))
        
        ((_ struct-name ctype-name ((names types) ...))
         #'(define-ctype-struct struct-name ctype-name ((names types) ...) (current-inspector))))))
  
  
  ;; define-ctype-struct with a provide
  (define-syntax (define/provide-ctype-struct stx)
    (syntax-case stx ()
      ((_ struct-name ctype-name ((names types) ...) inspector)
       #'(begin
           (define-ctype-struct struct-name ctype-name ((names types) ...) inspector)
           (provide (struct struct-name (names ...)))))
      ((_ struct-name ctype-name ((names types) ...))
       #'(define/provide-ctype-struct struct-name ctype-name ((names types) ...) (current-inspector)))))
  
  )