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) |
ab4779ff AW |
21 | #:export (void |
22 | float double | |
dd1464bf | 23 | int unsigned-int long unsigned-long size_t |
ab4779ff AW |
24 | int8 uint8 |
25 | uint16 int16 | |
26 | uint32 int32 | |
27 | uint64 int64 | |
28 | ||
70ea39f7 AW |
29 | sizeof alignof |
30 | ||
d4149a51 LC |
31 | %null-pointer |
32 | null-pointer? | |
33 | make-pointer | |
34 | foreign-address | |
17fc9efe | 35 | dereference-pointer |
d4149a51 | 36 | |
d8b04f04 | 37 | foreign->bytevector bytevector->foreign |
3435f3c0 | 38 | foreign-set-finalizer! |
70ea39f7 AW |
39 | make-foreign-function |
40 | make-c-struct parse-c-struct)) | |
ab4779ff | 41 | |
44602b08 AW |
42 | (load-extension (string-append "libguile-" (effective-version)) |
43 | "scm_init_foreign") | |
70ea39f7 | 44 | |
d4149a51 LC |
45 | \f |
46 | ;;; | |
47 | ;;; Pointers. | |
48 | ;;; | |
49 | ||
50 | (define (null-pointer? pointer) | |
51 | (= (foreign-address pointer) 0)) | |
52 | ||
53 | ||
54 | \f | |
55 | ;;; | |
56 | ;;; Structures. | |
57 | ;;; | |
58 | ||
70ea39f7 AW |
59 | (define *writers* |
60 | `((,float . ,bytevector-ieee-single-native-set!) | |
61 | (,double . ,bytevector-ieee-double-native-set!) | |
62 | (,int8 . ,bytevector-s8-set!) | |
63 | (,uint8 . ,bytevector-u8-set!) | |
64 | (,int16 . ,bytevector-s16-native-set!) | |
65 | (,uint16 . ,bytevector-u16-native-set!) | |
66 | (,int32 . ,bytevector-s32-native-set!) | |
67 | (,uint32 . ,bytevector-u32-native-set!) | |
68 | (,int64 . ,bytevector-s64-native-set!) | |
69 | (,uint64 . ,bytevector-u64-native-set!))) | |
70 | ||
71 | (define *readers* | |
72 | `((,float . ,bytevector-ieee-single-native-ref) | |
73 | (,double . ,bytevector-ieee-double-native-ref) | |
74 | (,int8 . ,bytevector-s8-ref) | |
75 | (,uint8 . ,bytevector-u8-ref) | |
76 | (,int16 . ,bytevector-s16-native-ref) | |
77 | (,uint16 . ,bytevector-u16-native-ref) | |
78 | (,int32 . ,bytevector-s32-native-ref) | |
79 | (,uint32 . ,bytevector-u32-native-ref) | |
80 | (,int64 . ,bytevector-s64-native-ref) | |
81 | (,uint64 . ,bytevector-u64-native-ref))) | |
82 | ||
83 | (define (align off alignment) | |
84 | (1+ (logior (1- off) (1- alignment)))) | |
85 | ||
86 | (define (write-c-struct bv offset types vals) | |
87 | (let lp ((offset offset) (types types) (vals vals)) | |
88 | (cond | |
89 | ((not (pair? types)) | |
90 | (or (null? vals) | |
91 | (error "too many values" vals))) | |
92 | ((not (pair? vals)) | |
93 | (error "too few values" types)) | |
94 | (else | |
95 | ;; alignof will error-check | |
96 | (let* ((type (car types)) | |
97 | (offset (align offset (alignof type)))) | |
98 | (if (pair? type) | |
99 | (write-c-struct bv offset (car types) (car vals)) | |
100 | ((assv-ref *writers* type) bv offset (car vals))) | |
101 | (lp (+ offset (sizeof type)) (cdr types) (cdr vals))))))) | |
102 | ||
103 | (define (read-c-struct bv offset types) | |
104 | (let lp ((offset offset) (types types) (vals '())) | |
105 | (cond | |
106 | ((not (pair? types)) | |
107 | (reverse vals)) | |
108 | (else | |
109 | ;; alignof will error-check | |
110 | (let* ((type (car types)) | |
111 | (offset (align offset (alignof type)))) | |
112 | (lp (+ offset (sizeof type)) (cdr types) | |
113 | (cons (if (pair? type) | |
114 | (read-c-struct bv offset (car types)) | |
115 | ((assv-ref *readers* type) bv offset)) | |
116 | vals))))))) | |
117 | ||
118 | (define (make-c-struct types vals) | |
119 | (let ((bv (make-bytevector (sizeof types) 0))) | |
120 | (write-c-struct bv 0 types vals) | |
121 | (bytevector->foreign bv))) | |
122 | ||
123 | (define (parse-c-struct foreign types) | |
124 | (read-c-struct (foreign->bytevector foreign) 0 types)) |