Commit | Line | Data |
---|---|---|
ab4779ff AW |
1 | ;;;; Copyright (C) 2010 Free Software Foundation, Inc. |
2 | ;;;; | |
3 | ;;;; This library is free software; you can redistribute it and/or | |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
6 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
7 | ;;;; | |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
16 | ;;;; | |
17 | \f | |
18 | ||
19 | (define-module (system foreign) | |
07d22c02 | 20 | #:use-module (rnrs bytevectors) |
7387c231 | 21 | #:use-module (srfi srfi-1) |
ab4779ff AW |
22 | #:export (void |
23 | float double | |
dd1464bf | 24 | int unsigned-int long unsigned-long size_t |
ab4779ff AW |
25 | int8 uint8 |
26 | uint16 int16 | |
27 | uint32 int32 | |
28 | uint64 int64 | |
29 | ||
70ea39f7 AW |
30 | sizeof alignof |
31 | ||
d4149a51 LC |
32 | %null-pointer |
33 | null-pointer? | |
34 | make-pointer | |
5b46a8c2 | 35 | pointer-address |
d4149a51 | 36 | |
5b46a8c2 LC |
37 | pointer->bytevector |
38 | bytevector->pointer | |
39 | set-pointer-finalizer! | |
40 | ||
fa2a89a6 LC |
41 | dereference-pointer |
42 | string->pointer | |
43 | pointer->string | |
44 | ||
2ee07358 | 45 | pointer->procedure |
33186356 | 46 | ;; procedure->pointer (see below) |
70ea39f7 | 47 | make-c-struct parse-c-struct)) |
ab4779ff | 48 | |
44602b08 AW |
49 | (load-extension (string-append "libguile-" (effective-version)) |
50 | "scm_init_foreign") | |
70ea39f7 | 51 | |
d4149a51 LC |
52 | \f |
53 | ;;; | |
54 | ;;; Pointers. | |
55 | ;;; | |
56 | ||
57 | (define (null-pointer? pointer) | |
183a2a22 | 58 | "Return true if POINTER is the null pointer." |
5b46a8c2 | 59 | (= (pointer-address pointer) 0)) |
d4149a51 | 60 | |
33186356 LC |
61 | (if (defined? 'procedure->pointer) |
62 | (export procedure->pointer)) | |
d4149a51 LC |
63 | |
64 | \f | |
65 | ;;; | |
66 | ;;; Structures. | |
67 | ;;; | |
68 | ||
70ea39f7 AW |
69 | (define *writers* |
70 | `((,float . ,bytevector-ieee-single-native-set!) | |
71 | (,double . ,bytevector-ieee-double-native-set!) | |
72 | (,int8 . ,bytevector-s8-set!) | |
73 | (,uint8 . ,bytevector-u8-set!) | |
74 | (,int16 . ,bytevector-s16-native-set!) | |
75 | (,uint16 . ,bytevector-u16-native-set!) | |
76 | (,int32 . ,bytevector-s32-native-set!) | |
77 | (,uint32 . ,bytevector-u32-native-set!) | |
78 | (,int64 . ,bytevector-s64-native-set!) | |
79 | (,uint64 . ,bytevector-u64-native-set!))) | |
80 | ||
81 | (define *readers* | |
82 | `((,float . ,bytevector-ieee-single-native-ref) | |
83 | (,double . ,bytevector-ieee-double-native-ref) | |
84 | (,int8 . ,bytevector-s8-ref) | |
85 | (,uint8 . ,bytevector-u8-ref) | |
86 | (,int16 . ,bytevector-s16-native-ref) | |
87 | (,uint16 . ,bytevector-u16-native-ref) | |
88 | (,int32 . ,bytevector-s32-native-ref) | |
89 | (,uint32 . ,bytevector-u32-native-ref) | |
90 | (,int64 . ,bytevector-s64-native-ref) | |
91 | (,uint64 . ,bytevector-u64-native-ref))) | |
92 | ||
93 | (define (align off alignment) | |
94 | (1+ (logior (1- off) (1- alignment)))) | |
95 | ||
96 | (define (write-c-struct bv offset types vals) | |
97 | (let lp ((offset offset) (types types) (vals vals)) | |
98 | (cond | |
99 | ((not (pair? types)) | |
100 | (or (null? vals) | |
101 | (error "too many values" vals))) | |
102 | ((not (pair? vals)) | |
103 | (error "too few values" types)) | |
104 | (else | |
105 | ;; alignof will error-check | |
106 | (let* ((type (car types)) | |
107 | (offset (align offset (alignof type)))) | |
108 | (if (pair? type) | |
109 | (write-c-struct bv offset (car types) (car vals)) | |
110 | ((assv-ref *writers* type) bv offset (car vals))) | |
111 | (lp (+ offset (sizeof type)) (cdr types) (cdr vals))))))) | |
112 | ||
113 | (define (read-c-struct bv offset types) | |
114 | (let lp ((offset offset) (types types) (vals '())) | |
115 | (cond | |
116 | ((not (pair? types)) | |
117 | (reverse vals)) | |
118 | (else | |
119 | ;; alignof will error-check | |
120 | (let* ((type (car types)) | |
121 | (offset (align offset (alignof type)))) | |
122 | (lp (+ offset (sizeof type)) (cdr types) | |
123 | (cons (if (pair? type) | |
124 | (read-c-struct bv offset (car types)) | |
125 | ((assv-ref *readers* type) bv offset)) | |
126 | vals))))))) | |
127 | ||
128 | (define (make-c-struct types vals) | |
129 | (let ((bv (make-bytevector (sizeof types) 0))) | |
130 | (write-c-struct bv 0 types vals) | |
5b46a8c2 | 131 | (bytevector->pointer bv))) |
70ea39f7 AW |
132 | |
133 | (define (parse-c-struct foreign types) | |
7387c231 LC |
134 | (let ((size (fold (lambda (type total) |
135 | (+ (sizeof type) total)) | |
136 | 0 | |
137 | types))) | |
138 | (read-c-struct (pointer->bytevector foreign size) 0 types))) |