mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

add make-c-struct, parse-c-struct

Browse source 
* module/system/foreign.scm: Export alignof and sizeof.
  (make-c-struct, parse-c-struct): New public functions.
This commit is contained in:
Andy Wingo 2010-01-26 22:18:42 +01:00
parent 9a396cbdbe
commit 70ea39f70f
1 changed files with 72 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

73
module/system/foreign.scm
View file

@ -17,6 +17,7 @@
(define-module (system foreign)
#:use-module (rnrs bytevector)
#:export (void
float double
int8 uint8
@ -24,8 +25,78 @@
uint32 int32
uint64 int64
sizeof alignof
foreign-ref foreign-set!
foreign->bytevector bytevector->foreign
make-foreign-function))
make-foreign-function
make-c-struct parse-c-struct))
(load-extension "libguile" "scm_init_foreign")
(define *writers*
`((,float . ,bytevector-ieee-single-native-set!)
(,double . ,bytevector-ieee-double-native-set!)
(,int8 . ,bytevector-s8-set!)
(,uint8 . ,bytevector-u8-set!)
(,int16 . ,bytevector-s16-native-set!)
(,uint16 . ,bytevector-u16-native-set!)
(,int32 . ,bytevector-s32-native-set!)
(,uint32 . ,bytevector-u32-native-set!)
(,int64 . ,bytevector-s64-native-set!)
(,uint64 . ,bytevector-u64-native-set!)))
(define *readers*
`((,float . ,bytevector-ieee-single-native-ref)
(,double . ,bytevector-ieee-double-native-ref)
(,int8 . ,bytevector-s8-ref)
(,uint8 . ,bytevector-u8-ref)
(,int16 . ,bytevector-s16-native-ref)
(,uint16 . ,bytevector-u16-native-ref)
(,int32 . ,bytevector-s32-native-ref)
(,uint32 . ,bytevector-u32-native-ref)
(,int64 . ,bytevector-s64-native-ref)
(,uint64 . ,bytevector-u64-native-ref)))
(define (align off alignment)
(1+ (logior (1- off) (1- alignment))))
(define (write-c-struct bv offset types vals)
(let lp ((offset offset) (types types) (vals vals))
(cond
((not (pair? types))
(or (null? vals)
(error "too many values" vals)))
((not (pair? vals))
(error "too few values" types))
(else
;; alignof will error-check
(let* ((type (car types))
(offset (align offset (alignof type))))
(if (pair? type)
(write-c-struct bv offset (car types) (car vals))
((assv-ref *writers* type) bv offset (car vals)))
(lp (+ offset (sizeof type)) (cdr types) (cdr vals)))))))
(define (read-c-struct bv offset types)
(let lp ((offset offset) (types types) (vals '()))
(cond
((not (pair? types))
(reverse vals))
(else
;; alignof will error-check
(let* ((type (car types))
(offset (align offset (alignof type))))
(lp (+ offset (sizeof type)) (cdr types)
(cons (if (pair? type)
(read-c-struct bv offset (car types))
((assv-ref *readers* type) bv offset))
vals)))))))
(define (make-c-struct types vals)
(let ((bv (make-bytevector (sizeof types) 0)))
(write-c-struct bv 0 types vals)
(bytevector->foreign bv)))
(define (parse-c-struct foreign types)
(read-c-struct (foreign->bytevector foreign) 0 types))