1 ;;;; Copyright (C) 2010 Free Software Foundation, Inc.
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.
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.
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
19 (define-module (system foreign)
20 #:use-module (rnrs bytevectors)
23 int unsigned-int long unsigned-long size_t
39 set-pointer-finalizer!
42 make-c-struct parse-c-struct))
44 (load-extension (string-append "libguile-" (effective-version))
52 (define (null-pointer? pointer)
53 (= (pointer-address pointer) 0))
62 `((,float . ,bytevector-ieee-single-native-set!)
63 (,double . ,bytevector-ieee-double-native-set!)
64 (,int8 . ,bytevector-s8-set!)
65 (,uint8 . ,bytevector-u8-set!)
66 (,int16 . ,bytevector-s16-native-set!)
67 (,uint16 . ,bytevector-u16-native-set!)
68 (,int32 . ,bytevector-s32-native-set!)
69 (,uint32 . ,bytevector-u32-native-set!)
70 (,int64 . ,bytevector-s64-native-set!)
71 (,uint64 . ,bytevector-u64-native-set!)))
74 `((,float . ,bytevector-ieee-single-native-ref)
75 (,double . ,bytevector-ieee-double-native-ref)
76 (,int8 . ,bytevector-s8-ref)
77 (,uint8 . ,bytevector-u8-ref)
78 (,int16 . ,bytevector-s16-native-ref)
79 (,uint16 . ,bytevector-u16-native-ref)
80 (,int32 . ,bytevector-s32-native-ref)
81 (,uint32 . ,bytevector-u32-native-ref)
82 (,int64 . ,bytevector-s64-native-ref)
83 (,uint64 . ,bytevector-u64-native-ref)))
85 (define (align off alignment)
86 (1+ (logior (1- off) (1- alignment))))
88 (define (write-c-struct bv offset types vals)
89 (let lp ((offset offset) (types types) (vals vals))
93 (error "too many values" vals)))
95 (error "too few values" types))
97 ;; alignof will error-check
98 (let* ((type (car types))
99 (offset (align offset (alignof type))))
101 (write-c-struct bv offset (car types) (car vals))
102 ((assv-ref *writers* type) bv offset (car vals)))
103 (lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
105 (define (read-c-struct bv offset types)
106 (let lp ((offset offset) (types types) (vals '()))
111 ;; alignof will error-check
112 (let* ((type (car types))
113 (offset (align offset (alignof type))))
114 (lp (+ offset (sizeof type)) (cdr types)
115 (cons (if (pair? type)
116 (read-c-struct bv offset (car types))
117 ((assv-ref *readers* type) bv offset))
120 (define (make-c-struct types vals)
121 (let ((bv (make-bytevector (sizeof types) 0)))
122 (write-c-struct bv 0 types vals)
123 (bytevector->pointer bv)))
125 (define (parse-c-struct foreign types)
126 (read-c-struct (pointer->bytevector foreign) 0 types))