Сделал, чтобы Racket мог создавать функции на основании их описания из GObjectIntrospection. Сейчас смотрю на то, что получилсоь и понимаю, что «настоящий программист может написать программу на ФортранеКоммон Лиспе на любом языке».
Задача стоит так: есть описание функции в виде описаний входящих и исходящих параметров (исходящие — значит по ссылке). _fun использовать нельзя, так как массив передаётся в FFI (и если исходящий, то собирается из) двух параметров: указатель + длина.
Прошу совета как сделать правильно. Сейчас build-function строит исходный текст подстановки макроса (в стиле defmacro), а затем build-ffi подтсавляет его в datum->syntax.
Если пытаться делать без datum->syntax, то вылазят две проблемы: что делать с локальными define'ами и как генерировать имена переменных. С другой стороны, надеюсь решить проблему с именаим параметров: у меня сейчас !arg — входящий параметр, %arg — он же, преобразованный в Си, &arg — указатель на него.
(define-syntax (define-gi-definer stx)
(syntax-case stx ()
[(_ id) #'(define-gi-definer id id)]
[(_ id repository)
(with-syntax ([string-rep (->string (syntax-e #'repository))])
(repository-require (syntax-e #'string-rep))
#'(define-syntax (id stx)
(syntax-case stx ()
[(_ object)
(with-syntax ([string-obj (->string (syntax-e #'object))])
(hash-ref! instance-hash (cons string-rep (syntax-e #'string-obj))
(λ () (syntax-local-lift-expression
(build-ffi stx (syntax-e #'string-rep) (syntax-e #'string-obj))))))])))]))
(define-for-syntax (build-ffi stx rep obj)
(define res (find-gi rep obj))
(datum->syntax stx res))
(define (find-gi repository name)
(define info (rep:find repository name))
(unless info
(raise-argument-error 'find-gi "name of object in repository" name))
(define type (g-base-info-get-type info))
(case type
[(constant) (const-value info)]
[(function) (build-function info)]))
(define (build-function info)
(define %args (args info))
(define (in-arg? arg) (memq (g-arg-info-get-direction arg) '(in inout)))
(define (out-arg? arg) (memq (g-arg-info-get-direction arg) '(out inout)))
(define (array-pos arg)
(define type (g-arg-info-get-type arg))
(if (eq? (g-type-info-get-tag type) 'array)
(g-type-info-get-array-length type)
-1))
(define res-type-symbol (tag->symbol_type
(g-type-info-get-tag (g-callable-info-get-return-type info))))
(define fun-type (append (list '_fun)
(for/list ([arg (in-list %args)])
(if (out-arg? arg) '_pointer ((tag->symbol_type
(g-type-info-get-tag (g-arg-info-get-type arg))))))
(list '-> res-type-symbol)))
(define vector-lengths (for/list ([arg (in-list %args)]
#:when (> (array-pos arg) -1))
(list-ref %args (array-pos arg))))
(define in-args (filter (λ (arg) (and (not (memq arg vector-lengths)) (in-arg? arg))) %args))
(define out-args (filter out-arg? %args))
(define ((prefix-name prefix) arg) (string->symbol (string-append prefix (g-base-info-get-name arg))))
(define ref-name (prefix-name "&"))
(define init-name (prefix-name "!"))
(define parsed-name (prefix-name "%"))
(define fun-args (for/list ([arg (in-list %args)])
(if (out-arg? arg)
(ref-name arg)
(parsed-name arg))))
(define (array-of type-info) (g-type-info-get-tag (g-type-info-get-param-type type-info 0)))
(define parse-exprs
(for/fold ([define-parsed null])
([in-arg (in-list in-args)])
(define type-info (g-arg-info-get-type in-arg))
(define tag (g-type-info-get-tag type-info))
(if (eq? (g-type-info-get-tag type-info) 'array)
(cons `(define ,(parsed-name in-arg) (pvector-ptr ,(init-name in-arg) ,(tag->symbol_type (array-of type-info))))
(if (> (array-pos in-arg) -1)
(cons `(define ,(parsed-name (list-ref %args (array-pos in-arg))) (pvector-length ,(init-name in-arg))) define-parsed)
define-parsed))
(cons `(define ,(parsed-name in-arg) ,(init-name in-arg))))))
(define-values (total define-outs set-outs out-refs)
(call-with-values
(λ ()
(for/fold ([sum 0] [define-outs null] [set-outs null] [out-refs null])
([out-arg (in-list %args)] #:when (out-arg? out-arg))
(define type-info (g-arg-info-get-type out-arg))
(define tag (g-type-info-get-tag type-info))
(values (+ sum (ctype-sizeof (tag->_type tag)))
(cons `(define ,(ref-name out-arg) ,(if (= sum 0) 'ptr `(ptr-add ptr ,sum))) define-outs)
(if (in-arg? out-arg)
(cons `(ptr-set! ,(ref-name out-arg) ,(tag->symbol_type tag) ,(parsed-name out-arg)) set-outs)
set-outs)
(cond
[(eq? tag 'array)
(cons `(pvector ,(tag->symbol_type (array-of type-info))
(ptr-ref ,(ref-name out-arg))
,@(if (> (array-pos out-arg) -1)
(list `(ptr-ref ,(ref-name (list-ref %args (array-pos out-arg)))))
null)) out-refs)]
[(not (memq out-arg vector-lengths))
(cons `(ptr-ref ,(ref-name out-arg) ,(tag->symbol_type tag)) out-refs)]
[else out-refs]))))
(λ (sum l1 l2 l3) (values sum (reverse l1) (reverse l2) (reverse l3)))))
`(let ([fun (get-ffi-obj ,(g-function-info-get-symbol info) #f ,fun-type)])
(lambda ,(map init-name in-args)
,@parse-exprs
,@(if (> total 0)
(append (list `(define ptr (malloc ,total)))
define-outs)
null)
,(if (eq? res-type-symbol '_void)
`(fun ,@fun-args)
`(define res (fun ,@fun-args)))
,(if (eq? res-type-symbol '_void)
`(values ,@out-refs)
`(values res ,@out-refs)))))
Пример раскрытого макроса:
(let ((fun (get-ffi-obj "gtk_init" #f (_fun _pointer _pointer -> _void))))
(lambda (!argv)
(define %argv (pvector-ptr !argv _string))
(define %argc (pvector-length !argv))
(define ptr (malloc 8))
(define &argc ptr)
(define &argv (ptr-add ptr 4))
(fun &argc &argv)
(values (pvector _string (ptr-ref &argv) (ptr-ref &argc)))))
