Commit | Line | Data |
---|---|---|
8925f36f AW |
1 | ;;; figl |
2 | ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com> | |
3 | ;;; | |
4 | ;;; Figl is free software: you can redistribute it and/or modify it | |
5 | ;;; under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; Figl is distributed in the hope that it will be useful, but WITHOUT | |
10 | ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY | |
11 | ;;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General | |
12 | ;;; Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;; | |
20 | ;; figl is the Foreign Interface to GL. | |
21 | ;; | |
22 | ;;; Code: | |
23 | ||
7ec693ed | 24 | (define-module (figl runtime) |
e9dbe4b7 | 25 | #:use-module (system foreign) |
25072f02 | 26 | #:export (define-foreign-procedure |
93f72ad8 AW |
27 | define-foreign-procedures |
28 | define-foreign-type | |
092cacd7 AW |
29 | define-simple-foreign-type |
30 | define-enumeration | |
31 | define-bitfield)) | |
b59ebd7a | 32 | |
e9dbe4b7 | 33 | (define-syntax foreign-trampoline |
25072f02 AW |
34 | (syntax-rules (->) |
35 | ((_ trampoline resolve-name (pname ptype) ... -> type) | |
36 | (lambda (pname ...) | |
37 | (set! trampoline | |
38 | (pointer->procedure (type) | |
39 | resolve-name | |
40 | (list (ptype) ...))) | |
41 | (trampoline pname ...))))) | |
e9dbe4b7 | 42 | |
7ec693ed | 43 | (define-syntax define-foreign-procedure |
bb894c9d | 44 | (syntax-rules (->) |
f53f928c | 45 | ((define-foreign-procedure (name (pname ptype) ... -> type) |
25072f02 | 46 | resolve-name |
f53f928c AW |
47 | docstring) |
48 | (define name | |
49 | (letrec ((trampoline | |
25072f02 AW |
50 | (foreign-trampoline trampoline resolve-name |
51 | (pname ptype) ... -> type)) | |
f53f928c AW |
52 | (name (lambda (pname ...) |
53 | docstring | |
93f72ad8 AW |
54 | (let ((pname (ptype #:unwrap pname)) |
55 | ...) | |
56 | (type #:wrap (trampoline pname ...)))))) | |
f53f928c AW |
57 | name))))) |
58 | ||
59 | (define-syntax define-foreign-procedures | |
60 | (syntax-rules () | |
61 | ((define-foreign-procedures ((name prototype ...) ...) | |
25072f02 | 62 | resolve-name |
bb894c9d AW |
63 | docstring) |
64 | (begin | |
f53f928c | 65 | (define-foreign-procedure (name prototype ...) |
25072f02 | 66 | resolve-name |
f53f928c | 67 | docstring) |
bb894c9d | 68 | ...)))) |
93f72ad8 AW |
69 | |
70 | (define-syntax define-foreign-type | |
71 | (syntax-rules () | |
72 | ((_ name ffi-type unwrap wrap) | |
73 | (define-syntax name | |
74 | (syntax-rules () | |
75 | ((_) ffi-type) | |
76 | ((_ #:wrap x) (wrap x)) | |
77 | ((_ #:unwrap x) (unwrap x))))))) | |
78 | ||
79 | (define-syntax define-simple-foreign-type | |
80 | (syntax-rules () | |
81 | ((_ name ffi-type) | |
82 | ;; We could dispatch through to define-foreign-type via: | |
83 | ;; | |
84 | ;; (define-foreign-type name | |
85 | ;; ffi-type | |
86 | ;; (lambda (x) x) | |
87 | ;; (lambda (x) x)) | |
88 | ;; | |
89 | ;; However the resulting wrap expression: | |
90 | ;; | |
91 | ;; ((lambda (x) x) (trampoline arg ...)) | |
92 | ;; | |
93 | ;; would not be in tail position, as the optimizer doesn't know | |
94 | ;; that the foreign function just returns one value. This hack | |
95 | ;; just passes the wrapped expression through, allowing it to be in | |
96 | ;; tail position. | |
97 | (define-syntax name | |
98 | (syntax-rules () | |
99 | ((_) ffi-type) | |
100 | ((_ #:wrap x) x) | |
101 | ((_ #:unwrap x) x)))))) | |
092cacd7 AW |
102 | |
103 | (define-syntax-rule (define-enumeration enumerator (name value) ...) | |
104 | (define-syntax enumerator | |
105 | (lambda (x) | |
106 | (syntax-case x () | |
107 | ((_) | |
108 | #''(name ...)) | |
109 | ((_ enum) (number? (syntax->datum #'enum)) | |
110 | #'enum) | |
111 | ((_ enum) | |
112 | (or (assq-ref '((name . value) ...) | |
113 | (syntax->datum #'enum)) | |
114 | (syntax-violation 'enumerator "invalid enumerated value" | |
115 | #'enum))))))) | |
116 | ||
117 | (define-syntax-rule (define-bitfield bitfield (name value) ...) | |
118 | (define-syntax bitfield | |
119 | (lambda (x) | |
120 | (syntax-case x () | |
121 | ((_) | |
122 | #''(name ...)) | |
123 | ((_ bit (... ...)) | |
124 | #`(logior | |
125 | #,@(map | |
126 | (lambda (bit) | |
127 | (let ((datum (syntax->datum bit))) | |
128 | (if (number? datum) | |
129 | datum | |
130 | (or (assq-ref '((name . value) ...) datum) | |
131 | (syntax-violation 'bitfield "invalid bitfield value" | |
132 | bit))))) | |
133 | #'(bit (... ...))))))))) |