diff options
author | Andy Wingo <wingo@pobox.com> | 2010-12-12 23:13:08 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-12-12 23:13:08 +0100 |
commit | a6b1b27aad9072945cfa1cde908325f506c015b9 (patch) | |
tree | 2d0efa6483bc6cabc1a8bfcb11a91a40124d2f63 | |
parent | ef6b0e8d483d862fdbd119ff235d2a52843cad1f (diff) | |
download | guile-a6b1b27aad9072945cfa1cde908325f506c015b9.tar.gz |
foreign: c-struct parsing simplification
* module/system/foreign.scm: Revert much of fb636a1cce. Short et al are
not distinct types -- they are all aliases to e.g. int16. The only
case that was not covered before was the pointer case.
(bytevector-pointer-ref, bytevector-pointer-set!): Implement these,
and use them for pointers.
-rw-r--r-- | module/system/foreign.scm | 118 |
1 files changed, 17 insertions, 101 deletions
diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 7f6031773..b15577b2a 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -69,85 +69,21 @@ ;;; Structures. ;;; -(define-syntax compile-time-value - (syntax-rules () - "Evaluate the given expression at compile time. The expression must -evaluate to a simple datum." - ((_ exp) - (let-syntax ((v (lambda (s) - (let ((val exp)) - (syntax-case s () - (_ (datum->syntax s val))))))) - v)))) - -(eval-when (eval compile load) - ;; The procedures below are used at compile time by the macros below. - - (define (integer-ref type signed?) - (case (sizeof type) - ((8) (if signed? - 'bytevector-s64-native-ref - 'bytevector-u64-native-ref)) - ((4) (if signed? - 'bytevector-s32-native-ref - 'bytevector-u32-native-ref)) - ((2) (if signed? - 'bytevector-s16-native-ref - 'bytevector-u16-native-ref)) - (else - (error "what machine is this?" type (sizeof type))))) - - (define (integer-set type signed?) - (case (sizeof type) - ((8) (if signed? - 'bytevector-s64-native-set! - 'bytevector-u64-native-set!)) - ((4) (if signed? - 'bytevector-s32-native-set! - 'bytevector-u32-native-set!)) - ((2) (if signed? - 'bytevector-s16-native-set! - 'bytevector-u16-native-set!)) - (else - (error "what machine is this?" type (sizeof type)))))) - -(define-syntax define-integer-reader - (syntax-rules () - ((_ name type signed?) - (letrec-syntax ((ref (identifier-syntax - (compile-time-value - (integer-ref type signed?))))) - (define name ref))))) - -(define-syntax define-integer-writer - (syntax-rules () - ((_ name type signed?) - (letrec-syntax ((set (identifier-syntax - (compile-time-value - (integer-set type signed?))))) - (define name set))))) - - -(define-integer-reader %read-short short #t) -(define-integer-reader %read-int int #t) -(define-integer-reader %read-long long #t) -(define-integer-writer %write-short! short #t) -(define-integer-writer %write-int! int #t) -(define-integer-writer %write-long! long #t) - -(define-integer-reader %read-unsigned-short unsigned-short #f) -(define-integer-reader %read-unsigned-int unsigned-int #f) -(define-integer-reader %read-unsigned-long unsigned-long #f) -(define-integer-writer %write-unsigned-short! unsigned-short #f) -(define-integer-writer %write-unsigned-int! unsigned-int #f) -(define-integer-writer %write-unsigned-long! unsigned-long #f) - -(define-integer-reader %read-size_t size_t #f) -(define-integer-writer %write-size_t! size_t #f) - -(define-integer-reader %read-pointer '* #f) -(define-integer-writer %write-pointer! '* #f) - +(define bytevector-pointer-ref + (case (sizeof '*) + ((8) (lambda (bv offset) + (make-pointer (bytevector-u64-native-ref bv offset)))) + ((4) (lambda (bv offset) + (make-pointer (bytevector-u32-native-ref bv offset)))) + (else (error "what machine is this?")))) + +(define bytevector-pointer-set! + (case (sizeof '*) + ((8) (lambda (bv offset ptr) + (bytevector-u64-native-set! bv offset (pointer-address ptr)))) + ((4) (lambda (bv offset ptr) + (bytevector-u32-native-set! bv offset (pointer-address ptr)))) + (else (error "what machine is this?")))) (define *writers* `((,float . ,bytevector-ieee-single-native-set!) @@ -160,18 +96,7 @@ evaluate to a simple datum." (,uint32 . ,bytevector-u32-native-set!) (,int64 . ,bytevector-s64-native-set!) (,uint64 . ,bytevector-u64-native-set!) - - (,short . ,%write-short!) - (,unsigned-short . ,%write-unsigned-short!) - (,int . ,%write-int!) - (,unsigned-int . ,%write-unsigned-int!) - (,long . ,%write-long!) - (,unsigned-long . ,%write-unsigned-long!) - (,size_t . ,%write-size_t!) - - (* . ,(lambda (bv offset ptr) - (%write-pointer! bv offset - (pointer-address ptr)))))) + (* . ,bytevector-pointer-set!))) (define *readers* `((,float . ,bytevector-ieee-single-native-ref) @@ -184,17 +109,8 @@ evaluate to a simple datum." (,uint32 . ,bytevector-u32-native-ref) (,int64 . ,bytevector-s64-native-ref) (,uint64 . ,bytevector-u64-native-ref) + (* . ,bytevector-pointer-ref))) - (,short . ,%read-short) - (,unsigned-short . ,%read-unsigned-short) - (,int . ,%read-int) - (,unsigned-int . ,%read-unsigned-int) - (,long . ,%read-long) - (,unsigned-long . ,%read-unsigned-long) - (,size_t . ,%read-size_t) - - (* . ,(lambda (bv offset) - (make-pointer (%read-pointer bv offset)))))) (define (align off alignment) (1+ (logior (1- off) (1- alignment)))) |