(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)
(define-syntax ffi-func/contract
(lambda (stx)
(let ([make-string (lambda (var)
(datum->syntax-object
var
(symbol->string (syntax-e var))))])
(syntax-case stx ()
[(_ lib regexp ([name (contr ...) (type ...)]))
(with-syntax ([str-name (make-string #'name)]
[str-lib (make-string #'lib)]
[(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 ...)]))]
[(_ 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 ...)] ... )))]))))
(define (cstring->string byts)
(let* ((str (bytes->string/utf-8 byts))
(i (string-index str #\nul)))
(if i
(substring str 0 i)
str)))
(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))))))])))
(define (remove-item lst index)
(let ([item (list-ref lst index)])
(values item (remove item lst))))
(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)))))
(define (replace item index lst)
(if (= 0 index)
(cons item (rest lst))
(cons (first lst)
(replace item (- index 1) (rest lst)))))
(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))))))
(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-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)))))
)