1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00

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.
This commit is contained in:
Andy Wingo 2010-12-12 23:13:08 +01:00
parent ef6b0e8d48
commit a6b1b27aad

View file

@ -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))))