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:
parent
ef6b0e8d48
commit
a6b1b27aad
1 changed files with 16 additions and 100 deletions
|
@ -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))))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue