├── .gitignore ├── LICENSE ├── README.md ├── gir ├── base.rkt ├── const.rkt ├── contract.rkt ├── enum.rkt ├── field.rkt ├── function.rkt ├── gir.scrbl ├── glib.rkt ├── gtype.rkt ├── info.rkt ├── interface.rkt ├── loadlib.rkt ├── main.rkt ├── minimal-test.rkt ├── object.rkt ├── property.rkt ├── signal.rkt ├── struct.rkt ├── test.rkt ├── translator.rkt └── utils.rkt └── info.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#* 3 | .DS_store 4 | compiled/ 5 | *.bak 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Roman Klochkov 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | GObject Introspection 2 | 3 | ```racket 4 | (require gir) 5 | ``` 6 | 7 | # 1. Main interface 8 | 9 | This is Gobject FFI. 10 | 11 | Usage example: 12 | 13 | ```racket 14 | (define gtk (gi-ffi "Gtk")) 15 | (gtk 'init 0 #f) 16 | (let ([window (gtk 'Window 'new 0)]) 17 | (window 'show) 18 | (gtk 'main)) 19 | ``` 20 | 21 | Interface with the GObjectIntrospection is based on repositories. Main 22 | function is 23 | 24 | ```racket 25 | (gi-ffi repository-name [version]) -> procedure? 26 | repository-name : string? 27 | version : string? = "" 28 | ``` 29 | 30 | Returns interface to repository with name `repository-name` 31 | 32 | # 2. Get FFI element 33 | 34 | ```racket 35 | (repository func-name func-arg ...) -> any/c 36 | func-name : (or/c string? symbol?) 37 | func-arg : any/c 38 | (repository const-name) -> any/c 39 | const-name : (or/c string? symbol?) 40 | (repository enum-name enum-value-name) -> exact-integer? 41 | enum-name : (or/c string? symbol?) 42 | enum-value-name : (or/c string? symbol?) 43 | (repository class-name constructor-name) -> procedure? 44 | class-name : (or/c string? symbol?) 45 | constructor-name : (or/c string? symbol?) 46 | ``` 47 | 48 | This interface takes as a first argument name of foreign object. Name 49 | could be `string?` or `symbol?`. In both cases it’s allowed to replace 50 | "\_" with "-". So you can write either "get\_name" or ’get-name with the 51 | same result. 52 | 53 | If first argument is a name of function, then rest arguments are the 54 | arguments of the function and it returns result of the function. In 55 | example 56 | 57 | ```racket 58 | (define gtk (gi-ffi "Gtk")) 59 | (gtk 'init 0 #f) 60 | ``` 61 | 62 | gtk\_init is called with 0 and null pointer. 63 | 64 | If first argument is a name of constant, then it returns value of the 65 | constant. For example, 66 | 67 | `(gtk` `'MAJOR-VERSION)` 68 | 69 | returns 2 for GTK2 or 3 for GTK3. 70 | 71 | If first argument is a name of enumeration, then second arguments should 72 | be value name. It returns integer value. For example, 73 | 74 | `(gtk` `'WindowType` `':toplevel)` 75 | 76 | Returns 0. 77 | 78 | If first argument is a name of class (or struct), then the second 79 | argument should be a name of class constructor (in GTK it is usually 80 | "new"), rest arguments are the arguments of the constructor. 81 | 82 | `(define` `window` `(gtk` `'Window` `'new` `0))` 83 | 84 | This call will return a representation of object. 85 | 86 | # 3. Foreign objects 87 | 88 | ```racket 89 | (object method-name method-arg ...) -> any/c 90 | method-name : (or/c string? symbol?) 91 | method-arg : any/c 92 | ``` 93 | 94 | Representation of an object is also a function. First argument of it 95 | should be either name of method (`string?` or `symbol?`) or special 96 | name. 97 | 98 | `(window` `'add` `button)` 99 | 100 | will call method "add" with argument "button". 101 | 102 | ## 3.1. Pointer to object 103 | 104 | To get C pointer to an object call it with "method" :this. 105 | 106 | `(window` `':this)` 107 | 108 | ## 3.2. Fields 109 | 110 | Getting and setting field values are done with :field and :set-field!. 111 | 112 | ```racket 113 | (define entry (gtk 'TargetEntry 'new "ok" 0 0)) 114 | 115 | > (entry ':field 'flags) 116 | 0 117 | > (entry ':set-field! 'flags 1) 118 | > (entry ':field 'flags) 119 | 1 120 | ``` 121 | 122 | But you cannot set with :set-field! complex types such as structs, 123 | unions or even strings. It is a restriction of GObjectIntrospection. 124 | 125 | ## 3.3. Properties 126 | 127 | Getting and setting field values are done with :properties and 128 | :set-properties!. You may get or set several properties at once. 129 | 130 | ```racket 131 | (define-values (width height) 132 | (window ':properties 'width-request 'height-request)) 133 | (window ':set-properties! 'width-request 100 'height-request 200) 134 | ``` 135 | 136 | # 4. Signals 137 | 138 | ```racket 139 | (connect object signal-name handler) -> void? 140 | object : procedure? 141 | signal-name : (or/c symbol? string?) 142 | handler : (or/c procedure? cpointer?) 143 | ``` 144 | 145 | # 5. Alternative interface 146 | 147 | If you like more traditional interface, you may use `gir/interface` 148 | module 149 | 150 | ```racket 151 | (require gir/interface) 152 | ``` 153 | 154 | It provides interface in style of `racket/class`: `send`, `send/apply`, 155 | `dynamic-send`, `set-field!`, `get-field`, `dynamic-get-field`, 156 | `dynamic-set-field!`. 157 | 158 | Besides, it provides functional interface for object pointers and 159 | properties: 160 | 161 | ```racket 162 | (pointer object) -> cpointer? 163 | object : procedure? 164 | ``` 165 | 166 | Returns pointer to object 167 | 168 | ```racket 169 | (get-properties object property-name ...+) -> any/c ...+ 170 | object : procedure? 171 | property-name : (or/c string? symbol?) 172 | ``` 173 | 174 | ```racket 175 | (set-properties! object 176 | property-name 177 | property-value ...+ 178 | ...+) -> void? 179 | object : procedure? 180 | property-name : (or/c string? symbol?) 181 | property-value : any/c 182 | ``` 183 | -------------------------------------------------------------------------------- /gir/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "loadlib.rkt" ffi/unsafe ffi/unsafe/alloc racket/function) 3 | (provide _info g-base-info-get-name g-base-info-get-type) 4 | 5 | (define-gi* g-base-info-unref (_fun _pointer -> _void) 6 | #:wrap (deallocator)) 7 | 8 | (define-gi* g-base-info-get-name (_fun _pointer -> _string)) 9 | 10 | (define-gi* g-base-info-get-type (_fun _pointer -> 11 | (_enum '(invalid function callback struct boxed 12 | enum flags object interface constant 13 | invalid union value signal vfunc 14 | property field arg type unresolved)))) 15 | 16 | (define _info (make-ctype _pointer #f ((allocator g-base-info-unref) identity))) -------------------------------------------------------------------------------- /gir/const.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide get-const) 4 | (require "loadlib.rkt" "base.rkt" "translator.rkt" ffi/unsafe) 5 | 6 | (define-gi* g-constant-info-get-type (_fun _pointer -> _info)) 7 | (define-gi* g-constant-info-get-value (_fun _pointer _pointer -> _int)) 8 | 9 | (define (get-const info) 10 | (define giarg-res (make-giarg)) 11 | (g-constant-info-get-value info giarg-res) 12 | (make-out (build-translator (g-constant-info-get-type info)) giarg-res)) -------------------------------------------------------------------------------- /gir/contract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base (only-in ffi/unsafe cpointer?)) 4 | 5 | (provide ffi-builder? ffi-function-builder? contract-out) 6 | 7 | (define ffi-builder? 8 | ((and/c (not/c #f) cpointer?) . -> . (->* ((or/c symbol? string?)) #:rest (listof any/c) any))) 9 | 10 | (define ffi-function-builder? 11 | ((and/c (not/c #f) cpointer?) . -> . (->* () #:rest (listof any/c) any))) 12 | 13 | -------------------------------------------------------------------------------- /gir/enum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "contract.rkt") 4 | (provide (contract-out (build-enum ffi-builder?))) 5 | 6 | (require "base.rkt" "loadlib.rkt" "function.rkt" ffi/unsafe) 7 | ;; (gtk 'WindowType ':toplevel) => 0 8 | 9 | (define-gi* g-enum-info-get-n-values (_fun _pointer -> _int)) 10 | (define-gi* g-enum-info-get-value (_fun _pointer _int -> _info)) 11 | (define-gi* g-value-info-get-value (_fun _pointer -> _int64)) 12 | (define-gi* g-enum-info-get-n-methods (_fun _pointer -> _int)) 13 | (define-gi* g-enum-info-get-method (_fun _pointer _int -> _info)) 14 | 15 | 16 | (define (build-enum info) 17 | (define values-dict 18 | (for/list ([i (in-range (g-enum-info-get-n-values info))]) 19 | (define value-info (g-enum-info-get-value info i)) 20 | (cons (g-base-info-get-name value-info) 21 | (g-value-info-get-value value-info)))) 22 | (define methods-dict 23 | (for/list ([i (in-range (g-enum-info-get-n-methods info))]) 24 | (define func-info (g-enum-info-get-method info i)) 25 | (cons (g-base-info-get-name func-info) 26 | (build-function func-info)))) 27 | (λ (name . args) 28 | (define name* (c-name name)) 29 | (if (char=? (string-ref name* 0) #\:) 30 | (cdr (or (assoc (substring name* 1) values-dict) 31 | (raise-argument-error 'build-enum "FFI enum value name" name))) 32 | (apply (cdr (or (assoc name* methods-dict) 33 | (raise-argument-error 'build-enum 34 | "FFI method name" name))) 35 | args)))) -------------------------------------------------------------------------------- /gir/field.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide get set) 4 | (require "loadlib.rkt" "translator.rkt" "base.rkt" ffi/unsafe) 5 | 6 | (define-gi* g-field-info-get-field (_fun _pointer _pointer _pointer -> _bool)) 7 | (define-gi* g-field-info-set-field (_fun _pointer _pointer _pointer -> _bool)) 8 | (define-gi* g-field-info-get-type (_fun _pointer -> _pointer)) 9 | 10 | (define (get ptr field) 11 | (define giarg-res (make-giarg)) 12 | (unless (g-field-info-get-field field ptr giarg-res) 13 | (error "FFI get field failed:" (g-base-info-get-name field))) 14 | (make-out (build-translator (g-field-info-get-type field)) giarg-res)) 15 | 16 | (define (set ptr field value) 17 | (define translators (list (build-translator (g-field-info-get-type field)))) 18 | (define giargs-out (giargs translators (list value))) 19 | (unless (g-field-info-set-field field ptr giargs-out) 20 | (error "FFI set field failed:" (g-base-info-get-name field)))) 21 | -------------------------------------------------------------------------------- /gir/function.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "contract.rkt") 4 | (provide (contract-out (build-function ffi-function-builder?))) 5 | 6 | (require "loadlib.rkt" "base.rkt" "glib.rkt" "translator.rkt" ffi/unsafe racket/format) 7 | 8 | (define-gi* g-function-info-invoke (_fun _pointer _pointer _int 9 | _pointer _int _pointer _pointer -> _bool)) 10 | (define-gi* g-function-info-get-flags 11 | (_fun _pointer -> (_bitmask '(method = 1 12 | constructor = 2 13 | getter = 4 14 | setter = 8 15 | wraps-vfunc = 16 16 | throws = 32)))) 17 | 18 | (define _transfer (_enum '(nothing container everything))) 19 | (define _direction (_enum '(in out inout))) 20 | 21 | (define-gi* g-callable-info-get-n-args (_fun _pointer -> _int)) 22 | (define-gi* g-callable-info-get-arg (_fun _pointer _int -> _info)) 23 | (define-gi* g-callable-info-get-return-type (_fun _pointer -> _info)) 24 | (define-gi* g-callable-info-get-caller-owns (_fun _pointer -> _transfer)) 25 | 26 | (define-gi* g-arg-info-get-ownership-transfer (_fun _pointer -> _transfer)) 27 | (define-gi* g-arg-info-get-direction (_fun _pointer -> _direction)) 28 | (define-gi* g-arg-info-get-type (_fun _pointer -> _info)) 29 | 30 | (define (get-args info) 31 | ;; if construct, then add in-arg 32 | (define n-args (g-callable-info-get-n-args info)) 33 | (define (method? flags) 34 | (and (memq 'method flags) (not (memq 'constructor flags)))) 35 | (let inner ([i 0] 36 | [in (if (method? (g-function-info-get-flags info)) 37 | (list pointer-translator) 38 | null)] 39 | [out null]) 40 | (if (= i n-args) 41 | (values (reverse in) (reverse out)) 42 | (let* ([arg (g-callable-info-get-arg info i)] 43 | [type (g-arg-info-get-type arg)] 44 | [direction (g-arg-info-get-direction arg)] 45 | [builder (build-translator type)]) 46 | (inner (add1 i) 47 | (if (memq direction '(in inout)) (cons builder in) in) 48 | (if (memq direction '(out inout)) (cons builder out) out)))))) 49 | 50 | (define (return-giarg-trans info) 51 | (build-translator (g-callable-info-get-return-type info))) 52 | 53 | (define (build-function info) 54 | (define-values (in-trans out-trans) (get-args info)) 55 | (define res-trans (return-giarg-trans info)) 56 | (define name (g-base-info-get-name info)) 57 | (λ args 58 | (check-args args in-trans name) 59 | (define giargs-in (giargs in-trans args)) 60 | (define giargs-out (giargs out-trans)) 61 | (define giarg-res (make-giarg)) 62 | (with-g-error (g-error) 63 | (if (g-function-info-invoke info 64 | giargs-in (length in-trans) 65 | giargs-out (length out-trans) giarg-res g-error) 66 | (make-out res-trans giarg-res out-trans giargs-out) 67 | (raise-g-error g-error))))) 68 | -------------------------------------------------------------------------------- /gir/gir.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @(require (for-label racket/base racket/class ffi/unsafe gir 3 | (only-in "interface.rkt" pointer 4 | get-properties set-properties!))) 5 | 6 | @title{GObject Introspection} 7 | 8 | @(defmodule gir) 9 | 10 | @section{Main interface} 11 | 12 | This is Gobject FFI. 13 | 14 | Usage example: 15 | 16 | @racketblock[ 17 | (define gtk (gi-ffi "Gtk")) 18 | (gtk 'init 0 #f) 19 | (let ([window (gtk 'Window 'new 0)]) 20 | (window 'show) 21 | (gtk 'main)) 22 | ] 23 | 24 | Interface with the GObjectIntrospection is based on repositories. Main function is 25 | 26 | @defproc[(gi-ffi [repository-name string?] [version string? ""]) procedure?]{ 27 | Returns interface to repository with name @racket[repository-name] 28 | } 29 | 30 | @section{Get FFI element} 31 | 32 | @(defproc* ([(repository [func-name (or/c string? symbol?)] [func-arg any/c] ...) any/c] 33 | [(repository [const-name (or/c string? symbol?)]) any/c] 34 | [(repository [enum-name (or/c string? symbol?)] [enum-value-name (or/c string? symbol?)]) exact-integer?] 35 | [(repository [class-name (or/c string? symbol?)] [constructor-name (or/c string? symbol?)]) procedure?])) 36 | 37 | This interface takes as a first argument name of foreign object. Name could be @racket[string?] 38 | or @racket[symbol?]. In both cases it's allowed to replace "_" with "-". So you can write either 39 | "get_name" or 'get-name with the same result. 40 | 41 | If first argument is a name of function, then rest arguments are the arguments of the function and 42 | it returns result of the function. 43 | In example 44 | @racketblock[ 45 | (define gtk (gi-ffi "Gtk")) 46 | (gtk 'init 0 #f) 47 | ] 48 | gtk_init is called with 0 and null pointer. 49 | 50 | If first argument is a name of constant, then it returns value of the constant. 51 | For example, 52 | @racketblock[ 53 | (gtk 'MAJOR-VERSION) 54 | ] 55 | returns 2 for GTK2 or 3 for GTK3. 56 | 57 | If first argument is a name of enumeration, then second arguments should be value name. It returns integer value. 58 | For example, 59 | @racketblock[ 60 | (gtk 'WindowType ':toplevel) 61 | ] 62 | Returns 0. 63 | 64 | If first argument is a name of class (or struct), then the second argument should be a name of class constructor 65 | (in GTK it is usually "new"), rest arguments are the arguments of the constructor. 66 | @racketblock[ 67 | (define window (gtk 'Window 'new 0)) 68 | ] 69 | This call will return a representation of object. 70 | 71 | @section{Foreign objects} 72 | 73 | @(defproc (object [method-name (or/c string? symbol?)] [method-arg any/c] ...) any/c) 74 | 75 | Representation of an object is also a function. First argument of it should be either name of method 76 | (@racket[string?] or @racket[symbol?]) or special name. 77 | 78 | @racketblock[ 79 | (window 'add button) 80 | ] 81 | will call method "add" with argument "button". 82 | 83 | @subsection{Pointer to object} 84 | 85 | To get C pointer to an object call it with "method" :this. 86 | @racketblock[ 87 | (window ':this) 88 | ] 89 | 90 | @subsection{Fields} 91 | 92 | Getting and setting field values are done with :field and :set-field!. 93 | @racketblock[ 94 | (define entry (gtk 'TargetEntry 'new "ok" 0 0)) 95 | 96 | > (entry ':field 'flags) 97 | 0 98 | > (entry ':set-field! 'flags 1) 99 | > (entry ':field 'flags) 100 | 1 101 | ] 102 | 103 | But you cannot set with :set-field! complex types such as structs, unions or even strings. 104 | It is a restriction of GObjectIntrospection. 105 | 106 | @subsection{Properties} 107 | 108 | Getting and setting field values are done with :properties and :set-properties!. 109 | You may get or set several properties at once. 110 | 111 | @racketblock[ 112 | (define-values (width height) 113 | (window ':properties 'width-request 'height-request)) 114 | (window ':set-properties! 'width-request 100 'height-request 200) 115 | ] 116 | 117 | @section{Signals} 118 | 119 | @defproc[(connect [object procedure?] [signal-name (or/c symbol? string?)] [handler (or/c procedure? cpointer?)]) void?] 120 | 121 | @section{Alternative interface} 122 | 123 | If you like more traditional interface, you may use @racketmod[gir/interface] module 124 | 125 | @defmodule[gir/interface] 126 | 127 | It provides interface in style of @racket[racket/class]: @racket[send], @racket[send/apply], @racket[dynamic-send], 128 | @racket[set-field!], @racket[get-field], @racket[dynamic-get-field], @racket[dynamic-set-field!]. 129 | 130 | Besides, it provides functional interface for object pointers and properties: 131 | 132 | @(defproc (pointer [object procedure?]) cpointer? "Returns pointer to object") 133 | 134 | @(defproc (get-properties [object procedure?] [property-name (or/c string? symbol?)] ...+) (values any/c ...+)) 135 | 136 | @(defproc (set-properties! [object procedure?] 137 | [property-name (or/c string? symbol?)] 138 | [property-value any/c] 139 | ...+ 140 | ...+) void?) 141 | -------------------------------------------------------------------------------- /gir/glib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide with-g-error raise-g-error) 4 | 5 | (require "loadlib.rkt" ffi/unsafe) 6 | 7 | ;;; GError 8 | 9 | (define-struct (exn:fail:g-error exn:fail) ()) 10 | 11 | (define-syntax-rule (with-g-error (g-error) body ...) 12 | (let ([g-error (malloc _pointer)]) 13 | body ...)) 14 | 15 | (define-cstruct _g-error 16 | ([domain _uint32] 17 | [code _int] 18 | [message _string])) 19 | 20 | 21 | (define-gobject* g-quark-to-string (_fun _uint32 -> _string)) 22 | 23 | (define (make-message g-error) 24 | ; g-error = GError** 25 | (let ([s (ptr-ref g-error _g-error-pointer)]) 26 | (format "GError: ~a: ~a (code ~a)" 27 | (g-quark-to-string (g-error-domain s)) 28 | (g-error-message s) (g-error-code s)))) 29 | 30 | (define (raise-g-error g-error) 31 | (raise (make-exn:fail:g-error (make-message g-error) (current-continuation-marks)))) -------------------------------------------------------------------------------- /gir/gtype.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base "utils.rkt") ffi/unsafe) 4 | 5 | (provide case-gtype _gtype gtype) 6 | 7 | (define _gtype _ulong) 8 | 9 | (define (gtype obj) (ptr-ref (ptr-ref obj _pointer) _ulong)) 10 | 11 | (define-for-syntax gtypes '(invalid void interface char uchar boolean 12 | int uint long ulong int64 uint64 13 | enum flags float double string 14 | pointer boxed param object)) 15 | 16 | (define-syntax (case-gtype stx) 17 | (define (substitute vals) 18 | (for/list ([val (in-list (syntax->list vals))]) 19 | (or (find-pos (syntax-e val) gtypes) val))) 20 | (define (process exprs) 21 | (for/list ([expr (in-list (syntax->list exprs))]) 22 | (define expr-list (syntax->list expr)) 23 | (cond 24 | [(pair? (syntax-e (car expr-list))) 25 | (cons (substitute (car expr-list)) (cdr expr-list))] 26 | [else expr]))) 27 | (syntax-case stx () 28 | [(_ var 29 | exprs ...) 30 | #`(case (quotient var 4) #,@(process #'(exprs ...)))])) 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /gir/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | 3 | (define name "GI-FFI") 4 | (define blurb 5 | '("GI-FFI is a foreign function interface to the GObjectIntrospection" 6 | "which is a modern interface to GTK, GNOME, DBus and so on")) 7 | (define primary-file "main.rkt") 8 | (define categories '(system ui)) 9 | (define version "0.2") 10 | (define scribblings '(("gir.scrbl" () (library)))) 11 | (define release-notes 12 | (list '(ul 13 | (li "0.1: Initial release ") 14 | (li "0.2: Added (connect ...)") 15 | (li "0.9: Added (set-field ...) (field ...) (get-properties 16 | ...)")))) 17 | -------------------------------------------------------------------------------- /gir/interface.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "main.rkt") 4 | (provide pointer get-field set-field! get-properties set-properties! 5 | send dynamic-send gi-ffi connect) 6 | 7 | (define (dynamic-send obj method-name . vs) (apply obj method-name vs)) 8 | 9 | (define-syntax-rule (send obj method-id arg ...) 10 | (obj 'method-id arg ... arg-list)) 11 | 12 | (define-syntax-rule (send/apply obj method-id arg ... . arg-list) 13 | (apply obj 'method-id arg ... arg-list)) 14 | 15 | (define (pointer obj) (obj ':this)) 16 | 17 | (define (dynamic-get-field field-name obj) (obj ':field field-name)) 18 | 19 | (define-syntax-rule (get-field id obj) (obj ':field 'id)) 20 | 21 | (define (dynamic-set-field! field-name obj v) (obj ':set-field! field-name v)) 22 | 23 | (define-syntax-rule (set-field! id obj expr) (obj ':set-field! 'id expr)) 24 | 25 | (define (get-properties obj . args) (apply obj ':properties args)) 26 | 27 | (define (set-properties! obj . args) (apply obj ':set-properties! args)) 28 | -------------------------------------------------------------------------------- /gir/loadlib.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide define-gobject* define-gobject define-gi* define-gi g-type-init c-name); g-signal-connect-data) 3 | 4 | (require "utils.rkt" ffi/unsafe ffi/unsafe/define 5 | (for-syntax racket/base syntax/parse)) 6 | 7 | (define gobject-lib 8 | (ffi-lib (case (system-type) 9 | [(windows) "libgobject-2.0-0"] 10 | [else "libgobject-2.0"]) 11 | #:fail (λ () #f))) 12 | 13 | (define gi-lib 14 | (ffi-lib (case (system-type) 15 | [(windows) "libgirepository-win32-1-0"] 16 | [else "libgirepository-1.0"]) 17 | #:fail (λ () #f))) 18 | 19 | (define-ffi-definer define-gobject gobject-lib #:default-make-fail make-not-available) 20 | (define-ffi-definer define-gi gi-lib #:default-make-fail make-not-available) 21 | 22 | (module c-name racket/base 23 | (provide c-name) 24 | (require racket/string) 25 | 26 | (define (c-name name) 27 | (if (symbol? name) 28 | (c-name (symbol->string name)) 29 | (string-replace name "-" "_")))) 30 | (require 'c-name (for-syntax 'c-name)) 31 | 32 | (with-template 33 | (src dst) 34 | ([define-gi define-gi*] 35 | [define-gobject define-gobject*]) 36 | (define-syntax (dst stx) 37 | (syntax-parse stx 38 | [(_ id:id expr:expr 39 | (~or params:expr 40 | (~and (~seq (~seq kw:keyword arg:expr)) (~seq kwd ...)) 41 | (~optional (~seq #:c-id c-id) 42 | #:defaults ([c-id (datum->syntax 43 | #'id 44 | (string->symbol 45 | (c-name (syntax-e #'id))))]))) ...) 46 | (syntax-protect (syntax/loc stx (src id expr params ... kwd ... ... #:c-id c-id)))]))) 47 | 48 | (define-gobject* g-type-init (_fun -> _void)) 49 | (when gobject-lib 50 | (g-type-init)) -------------------------------------------------------------------------------- /gir/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (except-in racket/contract ->)) 3 | (provide (contract-out 4 | [gi-ffi (->* (string?) (string?) procedure?)] 5 | [connect (->* (procedure? string? procedure?) (list?) exact-integer?)])) 6 | ;get-properties set-properties! 7 | ;pointer field set-field!) 8 | 9 | (require "signal.rkt" "loadlib.rkt" "glib.rkt" ffi/unsafe 10 | "base.rkt" "function.rkt" "object.rkt" "struct.rkt" "enum.rkt" "const.rkt" "property.rkt") 11 | 12 | 13 | (define-gi* g-irepository-require (_fun (_pointer = #f) _string _string _int _pointer -> _pointer)) 14 | 15 | (define (require-repository namespace #:version [version #f] #:lazy [lazy #f]) 16 | (with-g-error (g-error) 17 | (or (g-irepository-require namespace version (if lazy 1 0) g-error) 18 | (raise-g-error g-error)))) 19 | 20 | ;(define-gi* g-irepository-get-info (_fun (_pointer = #f) _string _int -> _pointer)) 21 | ;(define-gi* g-irepository-get-n-infos (_fun (_pointer = #f) _string -> _int)) 22 | 23 | (define-gi* g-irepository-find-by-name (_fun (_pointer = #f) _string _string -> _info)) 24 | 25 | (define (build-interface info args) 26 | (case (g-base-info-get-type info) 27 | [(function) (apply (build-function info) args)] 28 | [(object) (apply (build-object info) args)] 29 | [(struct) (apply (build-struct info) args)] 30 | [(enum) (apply (build-enum info) args)] 31 | [(constant) (get-const info)])) 32 | 33 | 34 | (define (gi-ffi namespace [version #f]) 35 | (require-repository namespace #:version version) 36 | (λ (name . rest) 37 | (let ([info (g-irepository-find-by-name namespace (c-name name))]) 38 | (if info 39 | (build-interface info rest) 40 | (raise-argument-error 'gi-ffi "name of FFI bind" name))))) -------------------------------------------------------------------------------- /gir/minimal-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; This is test for GTK without GObjectIntrospection 4 | 5 | (require ffi/unsafe ffi/unsafe/define) 6 | (provide gtk_init gtk_get_major_version gtk_get_minor_version test) 7 | 8 | (define gtk-lib (case (system-type) 9 | [(windows) 10 | (ffi-lib "libgtk-win32-3-0" #:fail (λ () #f))] 11 | [else (ffi-lib "libgtk-3" '("0" "") #:fail (λ () #f))])) 12 | 13 | (define-ffi-definer define-gtk gtk-lib #:default-make-fail make-not-available) 14 | 15 | (define-gtk gtk_init (_fun _pointer _pointer -> _void)) 16 | (define-gtk gtk_get_major_version (_fun -> _int)) 17 | (define-gtk gtk_get_minor_version (_fun -> _int)) 18 | 19 | (define-gtk gtk_window_new (_fun _int -> _pointer)) 20 | (define-gtk g_signal_connect_data (_fun _pointer _string _pointer _pointer _pointer -> _pointer)) 21 | (define-gtk gtk_widget_show (_fun _pointer -> _void)) 22 | (define-gtk gtk_main (_fun -> _void)) 23 | 24 | (define (test) 25 | (let ([window (gtk_window_new 0)]) 26 | (g_signal_connect_data window "destroy" (ffi-obj-ref "gtk_main_quit" gtk-lib) #f #f) 27 | (gtk_widget_show window) 28 | (gtk_main))) 29 | -------------------------------------------------------------------------------- /gir/object.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "contract.rkt") 4 | (provide (contract-out (build-object ffi-builder?)) 5 | build-object-ptr _gobject gtype->ffi set!-set-properties! set!-get-properties) 6 | 7 | (require "loadlib.rkt" "base.rkt" ffi/unsafe ffi/unsafe/alloc "function.rkt" "translator.rkt" "gtype.rkt" 8 | racket/match (prefix-in f: "field.rkt")) 9 | 10 | (define-gi* g-object-info-find-method (_fun _pointer _string -> _info)) 11 | (define-gi* g-object-info-get-parent (_fun _pointer -> _info)) 12 | (define-gi* g-object-info-get-n-fields (_fun _pointer -> _int)) 13 | (define-gi* g-object-info-get-field (_fun _pointer _int -> _info)) 14 | 15 | (define (find-method info name) 16 | (and info 17 | (or (g-object-info-find-method info name) 18 | (find-method (g-object-info-get-parent info) name)))) 19 | 20 | (define-gobject* g-object-unref (_fun _pointer -> _void) #:wrap (deallocator)) 21 | (define-gobject* g-object-ref-sink (_fun _pointer -> _pointer) #:wrap (allocator g-object-unref)) 22 | 23 | ;;; will be defined in property.rkt 24 | (define set-properties! #f) 25 | (define (set!-set-properties! arg) (set! set-properties! arg)) 26 | (define get-properties #f) 27 | (define (set!-get-properties arg) (set! get-properties arg)) 28 | 29 | (define (closures info) 30 | (define (call name args) 31 | (define function-info (find-method info (c-name name))) 32 | (if function-info 33 | (apply (build-function function-info) args) 34 | (raise-argument-error 'build-object "FFI method name" name))) 35 | (define fields-dict 36 | (for/list ([i (in-range (g-object-info-get-n-fields info))]) 37 | (define field-info (g-object-info-get-field info i)) 38 | (cons (g-base-info-get-name field-info) field-info))) 39 | (define (find-field name) 40 | (cdr (or (assoc (c-name name) fields-dict) 41 | (raise-argument-error 'build-object "FFI field name" name)))) 42 | (define (closure this) 43 | (define signals (box null)) 44 | (λ (name . args) 45 | (case name 46 | [(:this) this] 47 | [(:signals) signals] 48 | [(:field) 49 | (match args 50 | [(list name) (f:get this (find-field name))])] 51 | [(:set-field!) 52 | (match args 53 | [(list name value) (f:set this (find-field name) value)])] 54 | [(:set-properties!) 55 | (set-properties! this args)] 56 | [(:properties) 57 | (get-properties this args)] 58 | [else (call name (cons this args))]))) 59 | (values call closure)) 60 | 61 | (define (build-object info) 62 | (define-values (call closure) (closures info)) 63 | (λ (name . args) 64 | (define this (g-object-ref-sink (call name args))) 65 | (closure this))) 66 | 67 | (define (build-object-ptr info ptr) 68 | (define-values (call closure) (closures info)) 69 | (closure ptr)) 70 | 71 | (define-gi* g-irepository-find-by-gtype (_fun (_pointer = #f) _long -> _pointer)) 72 | 73 | (define (gobject gtype ptr) 74 | (let ([info (g-irepository-find-by-gtype gtype)]) 75 | (if (and info (eq? (g-base-info-get-type info) 'object)) 76 | (build-object-ptr info ptr) 77 | (raise-argument-error 'gi-ffi "gtype not found in GI" gtype)))) 78 | 79 | (define _gobject (make-ctype _pointer (λ (x) (x ':this)) (λ (x) (gobject (gtype x) x)))) 80 | 81 | (define (gtype->ffi gtype) 82 | (case-gtype gtype 83 | [(invalid void) _void] 84 | [(char) _byte] 85 | [(uchar) _ubyte] 86 | [(boolean) _bool] 87 | [(int) _int] 88 | [(uint) _uint] 89 | [(long) _long] 90 | [(ulong) _ulong] 91 | [(int64) _int64] 92 | [(uint64) _uint64] 93 | [(float) _float] 94 | [(double) _double] 95 | [(pointer) _pointer] 96 | [(string) _string] 97 | [else _gobject])) 98 | 99 | -------------------------------------------------------------------------------- /gir/property.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "loadlib.rkt" "object.rkt" "gtype.rkt" ffi/unsafe racket/list) 4 | 5 | (define-cstruct _gparam ([instance _pointer] 6 | [name _string] 7 | [_flags _int] 8 | [gtype _gtype] 9 | [owner-gtype _gtype])) 10 | 11 | (define-gobject* g-object-class-find-property (_fun _pointer _string -> _pointer)) 12 | 13 | (define (property-gtype object name) 14 | (define param (g-object-class-find-property (ptr-ref object _pointer) name)) 15 | (unless param 16 | (raise-argument-error 'property 17 | "property name" name)) 18 | (gparam-gtype (ptr-ref param _gparam))) 19 | 20 | (set!-set-properties! 21 | (λ (object properties) 22 | (define (make-type gtypes) 23 | (_cprocedure 24 | (append 25 | (list _pointer) 26 | (for*/list ([type (in-list gtypes)] 27 | [i (in-range 2)]) 28 | (if (= i 1) (gtype->ffi type) _string)) 29 | (list _pointer)) 30 | _void)) 31 | (define-values (type args) 32 | (let loop ([properties properties] 33 | [gtypes null] 34 | [args null]) 35 | (cond 36 | [(null? properties) 37 | (values (make-type (reverse gtypes)) (reverse (cons #f args)))] 38 | [(and (pair? properties) (pair? (cdr properties))) 39 | (define arg (c-name (first properties))) 40 | (define val (second properties)) 41 | (loop (cddr properties) 42 | (cons (property-gtype object arg) gtypes) 43 | (cons val (cons arg args)))]))) 44 | (apply (get-ffi-obj "g_object_set" #f type) object args))) 45 | 46 | (set!-get-properties 47 | (λ (object properties) 48 | (define (make-type gtypes) 49 | (_cprocedure 50 | (append 51 | (list _pointer) 52 | (for*/list ([type (in-list gtypes)] 53 | [i (in-range 2)]) 54 | (if (= i 1) _pointer _string)) 55 | (list _pointer)) 56 | _void)) 57 | (define-values (type arg-types args) 58 | (let loop ([properties properties] 59 | [gtypes null] 60 | [arg-types null] 61 | [args null]) 62 | (cond 63 | [(null? properties) 64 | (values (make-type (reverse gtypes)) (reverse arg-types) (reverse (cons #f args)))] 65 | [else 66 | (define arg (c-name (first properties))) 67 | (define gtype (property-gtype object arg)) 68 | (define arg-type (gtype->ffi gtype)) 69 | (define val (malloc arg-type)) 70 | (loop (cdr properties) 71 | (cons gtype gtypes) 72 | (cons arg-type arg-types) 73 | (cons val (cons arg args)))]))) 74 | (apply (get-ffi-obj "g_object_get" #f type) object args) 75 | (apply values 76 | (let loop ([vals null] [args args] [arg-types arg-types]) 77 | (cond 78 | [(null? arg-types) (reverse vals)] 79 | [else 80 | (define val (ptr-ref (second args) (car arg-types))) 81 | (loop (cons val vals) (cddr args) (cdr arg-types))]))))) -------------------------------------------------------------------------------- /gir/signal.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide connect) 3 | (require "loadlib.rkt" "object.rkt" "gtype.rkt" ffi/unsafe) 4 | (define _signal-flags (_bitmask '(run-first 5 | = 1 6 | run-last = 2 7 | run-cleanup = 4 8 | no-recurse = 8 9 | detailed = 16 10 | action = 32 11 | no-hooks = 64 12 | must-collect = 128 13 | deprecated = 256))) 14 | 15 | (define-cstruct _signal-query ([id _uint] 16 | [name _string] 17 | [itype _gtype] 18 | [flags _signal-flags] 19 | [return-type _gtype] 20 | [n-params _uint] 21 | [params _pointer])) 22 | 23 | 24 | (define-gobject* g-signal-query (_fun _int (q : (_ptr o _signal-query)) -> _void -> q)) 25 | (define-gobject* g-signal-lookup (_fun _string _ulong -> _uint)) 26 | (define-gobject* g-type-name (_fun _ulong -> _string)) 27 | 28 | 29 | 30 | (define (build-signal-handler object signal-name signals-box) 31 | (define query (g-signal-query (g-signal-lookup signal-name (gtype object)))) 32 | (_cprocedure (cons _gobject 33 | (for/list ([i (in-range (signal-query-n-params query))]) 34 | (gtype->ffi (ptr-ref (signal-query-params query) _gtype i)))) 35 | (gtype->ffi (signal-query-return-type query)) #:keep signals-box)) 36 | 37 | (define-gobject* g-signal-connect-data (_fun _pointer 38 | _string 39 | _pointer 40 | (_pointer = #f) ; data 41 | (_pointer = #f) ; notify 42 | (_bitmask '(after = 1 swapped = 2)) -> _ulong)) 43 | 44 | (define (connect object signal function [flags null]) 45 | (define object-ptr (object ':this)) 46 | (define real-type (build-signal-handler object-ptr signal (object ':signals))) 47 | (g-signal-connect-data object-ptr signal (cast function real-type _pointer) flags)) -------------------------------------------------------------------------------- /gir/struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "contract.rkt") 3 | (provide (contract-out (build-struct ffi-builder?)) build-struct-ptr) 4 | 5 | (require "loadlib.rkt" "base.rkt" ffi/unsafe "function.rkt" "translator.rkt" 6 | racket/match (prefix-in f: "field.rkt")) 7 | 8 | (define-gi* g-struct-info-find-method (_fun _pointer _string -> _info)) 9 | (define-gi* g-struct-info-get-n-fields (_fun _pointer -> _int)) 10 | (define-gi* g-struct-info-get-field (_fun _pointer _int -> _info)) 11 | (define-gi* g-struct-info-get-n-methods (_fun _pointer -> _int)) 12 | (define-gi* g-struct-info-get-method (_fun _pointer _int -> _info)) 13 | 14 | 15 | (define (closures info) 16 | (define (call name args) 17 | (define function-info (g-struct-info-find-method info (c-name name))) 18 | (if function-info 19 | (apply (build-function function-info) args) 20 | (raise-argument-error 'build-struct "FFI method name" name))) 21 | (define fields-dict 22 | (for/list ([i (in-range (g-struct-info-get-n-fields info))]) 23 | (define field-info (g-struct-info-get-field info i)) 24 | (cons (g-base-info-get-name field-info) field-info))) 25 | (define (find-field name) 26 | (cdr (or (assoc (c-name name) fields-dict) 27 | (raise-argument-error 'build-struct "FFI field name" name)))) 28 | (define (closure this) 29 | (define signals (box null)) 30 | (λ (name . args) 31 | (case name 32 | [(:this) this] 33 | [(:signals) signals] 34 | [(:field) 35 | (match args 36 | [(list name) (f:get this (find-field name))])] 37 | [(:set-field!) 38 | (match args 39 | [(list name value) (f:set this (find-field name) value)])] 40 | [else (call name (cons this args))]))) 41 | (values call closure)) 42 | 43 | (define (build-struct info) 44 | (define-values (call closure) (closures info)) 45 | (λ (name . args) 46 | (define this (call name args)) 47 | (closure this))) 48 | 49 | (define (build-struct-ptr info ptr) 50 | (define-values (call closure) (closures info)) 51 | (closure ptr)) -------------------------------------------------------------------------------- /gir/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "main.rkt") 4 | (provide gtk run) 5 | 6 | (define gtk 7 | (with-handlers ([exn:fail? (λ _ #f)]) 8 | (gi-ffi "Gtk"))) ; "2.0")) 9 | 10 | (define (run) 11 | (gtk 'init 0 #f) 12 | (define win (gtk 'Window 'new (gtk 'WindowType ':toplevel))) 13 | (connect win "destroy" (λ (window) (gtk 'main-quit))) 14 | (define button (gtk 'Button 'new-with-label "Hello, world")) 15 | (connect button "clicked" (λ (btn) 16 | (displayln (btn 'get-label)) 17 | (displayln (btn ':properties 'xalign)) 18 | (let-values ([(width height) (btn ':properties 'width-request 'height-request)]) 19 | (display width) (display " ") (displayln height)) 20 | (btn ':set-properties! 'label "OK"))) 21 | (button 'show) 22 | (win 'add button) 23 | (win 'show) 24 | (gtk 'main)) 25 | -------------------------------------------------------------------------------- /gir/translator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide build-translator pointer-translator make-giarg giargs make-out check-args) 4 | (require "loadlib.rkt" "base.rkt" "glib.rkt" "utils.rkt" ffi/unsafe racket/format) 5 | 6 | (define tag-list '(void boolean int8 uint8 int16 uint16 int32 uint32 int64 uint64 7 | float double gtype utf8 filename array interface glist gslist 8 | ghash error unichar)) 9 | 10 | (define-gi* g-type-info-get-tag (_fun _pointer -> (_enum tag-list))) 11 | (define-gi* g-type-info-is-pointer (_fun _pointer -> _bool)) 12 | (define-gi* g-type-info-get-param-type (_fun _pointer _int -> _info)) 13 | (define-gi* g-type-info-get-interface (_fun _pointer -> _info)) 14 | (define-gi* g-type-info-get-array-length (_fun _pointer -> _int)) 15 | (define-gi* g-type-info-get-array-fixed-size (_fun _pointer -> _int)) 16 | (define-gi* g-type-info-is-zero-terminated (_fun _pointer -> _bool)) 17 | 18 | (define-struct translator 19 | (>giarg >value check description)) 20 | 21 | (define _giarg (_union _bool _int8 _uint8 _int16 _uint16 22 | _int32 _uint32 _int64 _uint64 23 | _float _double _long _ulong _pointer _string)) 24 | 25 | (define (make-giarg) (malloc _giarg)) 26 | 27 | (define (pointer->giarg giarg value) 28 | (ptr-set! giarg _pointer (if (procedure? value) (value ':this) value))) 29 | 30 | (define (giarg->pointer giarg) 31 | (ptr-ref giarg _pointer)) 32 | 33 | (define (describe-type type-info) 34 | (define tag (g-type-info-get-tag type-info)) 35 | (~a (if (g-type-info-is-pointer type-info) "pointer to " "") 36 | tag 37 | (case tag 38 | ((interface) 39 | (~a " to " (g-type-info-get-interface type-info))) 40 | ((array) 41 | (~a " of " (describe-type (g-type-info-get-param-type type-info 0)) 42 | ", length param: " (g-type-info-get-array-length type-info) 43 | ", fixed length: " (g-type-info-get-array-fixed-size type-info) 44 | (if (g-type-info-is-zero-terminated type-info) ", zero terminated" ""))) 45 | ((ghash) 46 | (~a " of {" (describe-type (g-type-info-get-param-type type-info 0)) 47 | ", " (describe-type (g-type-info-get-param-type type-info 1)) 48 | "}")) 49 | (else "")))) 50 | 51 | (define pointer-translator (make-translator pointer->giarg giarg->pointer 52 | cpointer? "instance pointer")) 53 | 54 | (define (build-translator type) 55 | (define tag (g-type-info-get-tag type)) 56 | (define pos (- (find-pos tag tag-list) 1)) 57 | (define pointer? (g-type-info-is-pointer type)) 58 | (define value->giarg 59 | (if pointer? 60 | (case tag 61 | [(utf8 filename) (λ (giarg value) 62 | (ptr-set! giarg _string value))] 63 | [else pointer->giarg]) 64 | (case tag 65 | [(void) (λ (giarg value) (ptr-set! giarg _pointer #f))] 66 | [(boolean int8 uint8 int16 uint16 67 | int32 uint32 int64 uint64 float double) (λ (giarg value) 68 | (union-set! 69 | (ptr-ref giarg _giarg) 70 | pos value))] 71 | [(gtype interface) (λ (giarg value) 72 | (ptr-set! giarg _ulong value))] 73 | [else pointer->giarg]))) 74 | (define giarg->value 75 | (if pointer? 76 | (case tag 77 | [(utf8 filename) (λ (giarg) 78 | (ptr-ref giarg _string))] 79 | [else giarg->pointer]) 80 | (case tag 81 | [(void) (λ (giarg) #f)] 82 | [(boolean int8 uint8 int16 uint16 83 | int32 uint32 int64 uint64 float double) (λ (giarg) 84 | (union-ref 85 | (ptr-ref giarg _giarg) 86 | pos))] 87 | [(gtype interface) (λ (giarg) 88 | (ptr-ref giarg _ulong))] 89 | [else giarg->pointer]))) 90 | (define check-value 91 | (if pointer? 92 | (case tag 93 | [(utf8 filename) string?] 94 | [else (λ (x) (or (cpointer? x) (and (procedure? x) (cpointer? (x ':this)))))]) 95 | (case tag 96 | [(void) 97 | (λ (value) #t)] 98 | [(boolean) boolean?] 99 | [(gtype interface int8 uint8 int16 uint16 100 | int32 uint32 int64 uint64) exact-integer?] 101 | [(float double) flonum?] 102 | [else cpointer?]))) 103 | (define description (describe-type type)) 104 | (make-translator value->giarg giarg->value check-value description)) 105 | 106 | (define (giargs translators [values null]) 107 | (define ptr (malloc _giarg (length translators))) 108 | (for ([translator (in-list translators)] 109 | [value (in-list values)] 110 | [i (in-naturals)]) 111 | ((translator->giarg translator) (ptr-add ptr i _giarg) value)) 112 | ptr) 113 | 114 | (define (make-out res-trans giarg-res [out-translators null] [giargs-out #f]) 115 | (apply values (cons 116 | ((translator->value res-trans) giarg-res) 117 | (for/list ([translator (in-list out-translators)] 118 | [i (in-naturals)]) 119 | ((translator->value translator) (ptr-add giargs-out i _giarg)))))) 120 | 121 | (define (check-args args translators name) 122 | (unless (= (length args) (length translators)) 123 | (apply raise-arity-error (string->symbol name) (length translators) args)) 124 | (for ([arg (in-list args)] 125 | [translator (in-list translators)]) 126 | (unless ((translator-check translator) arg) 127 | (raise-argument-error (string->symbol name) (translator-description translator) arg)))) 128 | -------------------------------------------------------------------------------- /gir/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide with-template find-pos) 4 | 5 | (define (find-pos elt list) 6 | (for/first ([cur-elt list] 7 | [i (in-naturals)] 8 | #:when (eq? cur-elt elt)) 9 | i)) 10 | 11 | (define-syntax-rule (with-template (var ...) ([form ...] ...) body ...) 12 | (begin (define-syntax-rule (inner var ...) (begin ((... ...) body) ...)) 13 | (inner form ...) ...)) 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define version "0.90") 3 | (define collection 'multi) 4 | (define deps '("base" "scribble-lib" "racket-doc")) 5 | --------------------------------------------------------------------------------