-
Notifications
You must be signed in to change notification settings - Fork 0
/
ffi.scm
103 lines (80 loc) · 2.89 KB
/
ffi.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
(define-module (shorthand ffi)
#:use-module (shorthand oop)
#:use-module (shorthand syntax)
#:use-module (shorthand functions)
#:use-module (oop goops)
#:use-module (system foreign)
#:use-module (system foreign-library)
#:duplicates (merge-generics)
#:export (->pointer ->pointer!))
(define-syntax define-ffi
(lambda (stx)
(syntax-case stx ()
[(_ dyn-lib) #f]
[(_ dyn-lib (name (ret-type c-name (args ...))) rest ...)
(let [(raw-pointer-name (map-syntax (lambda (s) (string->symbol (format #f "$~a" s)))
#'name))]
#`(begin
(define-public #,raw-pointer-name
(foreign-library-pointer
dyn-lib
#,(symbol->string (syntax->datum #'c-name))))
(define-public name
(pointer->procedure
ret-type #,raw-pointer-name
(list args ...)))
(define-ffi dyn-lib rest ...)))])))
(export-syntax define-ffi)
(define-public ptr '*)
(define-public NULL %null-pointer)
(define-syntax-rule (assert-not-null value)
(let [(v value)]
(if (and (pointer? v) (null-pointer? v))
(assertion-violation 'assert-not-null "Expected non-null value" 'value)
v)))
(export-syntax assert-not-null)
(define-method (->pointer (obj <top>))
(if (pointer? obj)
obj
NULL))
(define-method (->pointer (obj <boolean>))
NULL)
(define-method (->pointer (obj <integer>))
;; TODO: Make this not a magic number
(define MAX-POINTER 18446744073709551615)
(if (and (not (negative? obj)) (<= obj MAX-POINTER))
(make-pointer obj)
NULL))
(define-method (->pointer (obj <string>))
(string->pointer obj))
(define-syntax-rule (->pointer! obj ...)
(begin (set! obj (->pointer obj))
...))
(define-struct <wrapped-pointer> pointer)
(define-method (->pointer (obj <wrapped-pointer>))
(pointer obj))
(define-method (write (obj <wrapped-pointer>) port)
(let ((p (pointer obj)))
(format port "#<~a at 0x~x>"
(class-name (class-of obj))
(pointer-address p))))
(export <wrapped-pointer> pointer
write)
(define-public (allocate-array type . items)
"Allocates several items of 'type' lined up consecutively"
(values (make-c-struct (map (lambda _ type) items)
items)
(length items)))
(export make-array)
(define-public (pointer-with-finalizer ptr finalizer)
"Returns the pointer object ptr, but with a C function which is called when
the pointer object goes out of scope"
(make-pointer (pointer-address ptr) finalizer))
(define-public (boolean->integer x)
"Converts boolean values into integers"
(if x 1 0))
(define-public (integer->boolean x)
"Converts an integer into a boolean"
(not (zero? x)))
(define-struct (<blob> <wrapped-pointer>) size)
(export <blob> size)