summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-12-12 23:13:08 +0100
committerAndy Wingo <wingo@pobox.com>2010-12-12 23:13:08 +0100
commita6b1b27aad9072945cfa1cde908325f506c015b9 (patch)
tree2d0efa6483bc6cabc1a8bfcb11a91a40124d2f63
parentef6b0e8d483d862fdbd119ff235d2a52843cad1f (diff)
downloadguile-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.scm118
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))))