diff --git a/module/system/foreign.scm b/module/system/foreign.scm index 29905212b..c3601a630 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -46,8 +46,9 @@ ;; procedure->pointer (see below) make-c-struct parse-c-struct)) -(load-extension (string-append "libguile-" (effective-version)) - "scm_init_foreign") +(eval-when (load eval compile) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_foreign")) ;;; @@ -66,6 +67,76 @@ ;;; 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)) + (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!)) + (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-int int #t) +(define-integer-reader %read-long long #t) +(define-integer-writer %write-int! int #t) +(define-integer-writer %write-long! long #t) + +(define-integer-reader %read-unsigned-int unsigned-int #f) +(define-integer-reader %read-unsigned-long unsigned-long #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 *writers* `((,float . ,bytevector-ieee-single-native-set!) (,double . ,bytevector-ieee-double-native-set!) @@ -76,7 +147,17 @@ (,int32 . ,bytevector-s32-native-set!) (,uint32 . ,bytevector-u32-native-set!) (,int64 . ,bytevector-s64-native-set!) - (,uint64 . ,bytevector-u64-native-set!))) + (,uint64 . ,bytevector-u64-native-set!) + + (,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)))))) (define *readers* `((,float . ,bytevector-ieee-single-native-ref) @@ -88,7 +169,16 @@ (,int32 . ,bytevector-s32-native-ref) (,uint32 . ,bytevector-u32-native-ref) (,int64 . ,bytevector-s64-native-ref) - (,uint64 . ,bytevector-u64-native-ref))) + (,uint64 . ,bytevector-u64-native-ref) + + (,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)))) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 05846eda7..d741b7e44 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -187,6 +187,27 @@ (pass-if "alignment constraints honored" (let ((layout (list int8 double)) (data (list -7 3.14))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "int8, pointer" + (let ((layout (list uint8 '*)) + (data (list 222 (make-pointer 7777)))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "unsigned-long, int8, size_t" + (let ((layout (list unsigned-long int8 size_t)) + (data (list (expt 2 17) -128 (expt 2 18)))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "long, int, pointer" + (let ((layout (list long int '*)) + (data (list (- (expt 2 17)) -222 (make-pointer 777)))) (equal? (parse-c-struct (make-c-struct layout data) layout) data))))