diff options
| -rw-r--r-- | NEWS | 5 | ||||
| -rw-r--r-- | doc/ref/api-foreign.texi | 5 | ||||
| -rw-r--r-- | libguile/foreign.c | 71 | ||||
| -rw-r--r-- | libguile/foreign.h | 6 | ||||
| -rw-r--r-- | module/system/foreign.scm | 16 | ||||
| -rw-r--r-- | test-suite/tests/foreign.test | 9 |
6 files changed, 110 insertions, 2 deletions
@@ -49,6 +49,11 @@ Bytevectors" in the manual. Compared to the previous versions, these accept range arguments. See "Accessing and Modifying Vector Contents" in the manual. +** (system foreign) supports C99 complex types + +The types `complex-float' and `complex-double' stand for C99 `float +_Complex' and `double _Complex` respectively. + Changes in 3.0.7 (since 3.0.6) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index a1a1016b0..540fbbaf5 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -465,8 +465,11 @@ C types. @defvrx {Scheme Variable} int64 @defvrx {Scheme Variable} float @defvrx {Scheme Variable} double +@defvrx {Scheme Variable} complex-double +@defvrx {Scheme Variable} complex-float These values represent the C numeric types of the specified sizes and -signednesses. +signednesses. @code{complex-float} and @code{complex-double} stand for +C99 @code{float _Complex} and @code{double _Complex} respecively. @end defvr In addition there are some convenience bindings for indicating types of diff --git a/libguile/foreign.c b/libguile/foreign.c index 1368cc9da..1f594b0e4 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -29,6 +29,10 @@ #include <ffi.h> +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE +#include <complex.h> +#endif + #include "boolean.h" #include "bytevectors.h" #include "dynwind.h" @@ -63,6 +67,10 @@ SCM_SYMBOL (sym_void, "void"); SCM_SYMBOL (sym_float, "float"); SCM_SYMBOL (sym_double, "double"); +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE +SCM_SYMBOL (sym_complex_float, "complex-float"); +SCM_SYMBOL (sym_complex_double, "complex-double"); +#endif SCM_SYMBOL (sym_uint8, "uint8"); SCM_SYMBOL (sym_int8, "int8"); SCM_SYMBOL (sym_uint16, "uint16"); @@ -470,6 +478,12 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type), return scm_from_size_t (alignof_type (float)); case SCM_FOREIGN_TYPE_DOUBLE: return scm_from_size_t (alignof_type (double)); +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + case SCM_FOREIGN_TYPE_COMPLEX_FLOAT: + return scm_from_size_t (alignof_type (float _Complex)); + case SCM_FOREIGN_TYPE_COMPLEX_DOUBLE: + return scm_from_size_t (alignof_type (double _Complex)); +#endif case SCM_FOREIGN_TYPE_UINT8: return scm_from_size_t (alignof_type (uint8_t)); case SCM_FOREIGN_TYPE_INT8: @@ -534,6 +548,12 @@ SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), return scm_from_size_t (sizeof (float)); case SCM_FOREIGN_TYPE_DOUBLE: return scm_from_size_t (sizeof (double)); +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + case SCM_FOREIGN_TYPE_COMPLEX_FLOAT: + return scm_from_size_t (sizeof (float _Complex)); + case SCM_FOREIGN_TYPE_COMPLEX_DOUBLE: + return scm_from_size_t (sizeof (double _Complex)); +#endif case SCM_FOREIGN_TYPE_UINT8: return scm_from_size_t (sizeof (uint8_t)); case SCM_FOREIGN_TYPE_INT8: @@ -626,6 +646,14 @@ fill_ffi_type (SCM type, ffi_type *ftype, ffi_type ***type_ptrs, case SCM_FOREIGN_TYPE_DOUBLE: *ftype = ffi_type_double; return; +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + case SCM_FOREIGN_TYPE_COMPLEX_FLOAT: + *ftype = ffi_type_complex_float; + return; + case SCM_FOREIGN_TYPE_COMPLEX_DOUBLE: + *ftype = ffi_type_complex_double; + return; +#endif case SCM_FOREIGN_TYPE_UINT8: *ftype = ffi_type_uint8; return; @@ -882,6 +910,23 @@ unpack (const ffi_type *type, void *loc, SCM x, int return_value_p) *(double *) loc = scm_to_double (x); break; + /* no FFI_TYPE_xxx_COMPLEX or (FFI_TYPE_COMPLEX_xxx) :-| */ + +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + case FFI_TYPE_COMPLEX: + { + double re = scm_to_double (scm_real_part(x)); + double im = scm_to_double (scm_imag_part(x)); + if (sizeof (float _Complex) == type->size) + *(float _Complex *) loc = (float)re + _Complex_I * (float)im; + else if (sizeof (double _Complex) == type->size) + *(double _Complex *) loc = re + _Complex_I * im; + else + abort(); + } + break; +#endif + /* For integer return values smaller than `int', libffi expects the result in an `ffi_arg'-long buffer. */ @@ -960,6 +1005,28 @@ pack (const ffi_type * type, const void *loc, int return_value_p) case FFI_TYPE_DOUBLE: return scm_from_double (*(double *) loc); + /* no FFI_TYPE_xxx_COMPLEX or (FFI_TYPE_COMPLEX_xxx) :-| */ + +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + case FFI_TYPE_COMPLEX: + { + double re, im; + if (sizeof (float _Complex) == type->size) + { + re = crealf(*(float _Complex *) loc); + im = cimagf(*(float _Complex *) loc); + } + else if (sizeof (double _Complex) == type->size) + { + re = creal(*(double _Complex *) loc); + im = cimag(*(double _Complex *) loc); + } + else + abort (); + return scm_make_rectangular (scm_from_double (re), scm_from_double (im)); + } +#endif + /* For integer return values smaller than `int', libffi stores the result in an `ffi_arg'-long buffer, of which only the significant bits must be kept---hence the pair of casts below. @@ -1172,6 +1239,10 @@ scm_init_foreign (void) scm_define (sym_void, scm_from_uint8 (SCM_FOREIGN_TYPE_VOID)); scm_define (sym_float, scm_from_uint8 (SCM_FOREIGN_TYPE_FLOAT)); scm_define (sym_double, scm_from_uint8 (SCM_FOREIGN_TYPE_DOUBLE)); +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + scm_define (sym_complex_float, scm_from_uint8 (SCM_FOREIGN_TYPE_COMPLEX_FLOAT)); + scm_define (sym_complex_double, scm_from_uint8 (SCM_FOREIGN_TYPE_COMPLEX_DOUBLE)); +#endif scm_define (sym_uint8, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT8)); scm_define (sym_int8, scm_from_uint8 (SCM_FOREIGN_TYPE_INT8)); scm_define (sym_uint16, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16)); diff --git a/libguile/foreign.h b/libguile/foreign.h index 41f26b335..33ce6311a 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -43,7 +43,13 @@ enum scm_t_foreign_type SCM_FOREIGN_TYPE_INT32, SCM_FOREIGN_TYPE_UINT64, SCM_FOREIGN_TYPE_INT64, +#ifdef FFI_TARGET_HAS_COMPLEX_TYPE + SCM_FOREIGN_TYPE_COMPLEX_FLOAT, + SCM_FOREIGN_TYPE_COMPLEX_DOUBLE, + SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_COMPLEX_DOUBLE +#else SCM_FOREIGN_TYPE_LAST = SCM_FOREIGN_TYPE_INT64 +#endif }; typedef enum scm_t_foreign_type scm_t_foreign_type; diff --git a/module/system/foreign.scm b/module/system/foreign.scm index d1c2ceb96..4458dc783 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -23,6 +23,7 @@ #:use-module (srfi srfi-9 gnu) #:export (void float double + complex-float complex-double short unsigned-short int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t @@ -93,9 +94,22 @@ (bytevector-u32-native-set! bv offset (pointer-address ptr)))) (else (error "what machine is this?")))) +(define (writer-complex set size) + (lambda (bv i val) + (set bv i (real-part val)) + (set bv (+ i size) (imag-part val)))) + +(define (reader-complex ref size) + (lambda (bv i) + (make-rectangular + (ref bv i) + (ref bv (+ i size))))) + (define *writers* `((,float . ,bytevector-ieee-single-native-set!) (,double . ,bytevector-ieee-double-native-set!) + (,complex-float . ,(writer-complex bytevector-ieee-single-native-set! (sizeof float))) + (,complex-double . ,(writer-complex bytevector-ieee-double-native-set! (sizeof double))) (,int8 . ,bytevector-s8-set!) (,uint8 . ,bytevector-u8-set!) (,int16 . ,bytevector-s16-native-set!) @@ -109,6 +123,8 @@ (define *readers* `((,float . ,bytevector-ieee-single-native-ref) (,double . ,bytevector-ieee-double-native-ref) + (,complex-float . ,(reader-complex bytevector-ieee-single-native-ref (sizeof float))) + (,complex-double . ,(reader-complex bytevector-ieee-double-native-ref (sizeof double))) (,int8 . ,bytevector-s8-ref) (,uint8 . ,bytevector-u8-ref) (,int16 . ,bytevector-s16-native-ref) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index fd0e276e2..28d7b5df8 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -416,7 +416,14 @@ (data (list 77 (list 42 4.2 55) 88))) (equal? (parse-c-struct (make-c-struct layout data) layout) - data)))) + data))) + + (when (defined? 'complex-float) + (pass-if "complex types" + (let ((layout (list complex-float int complex-double)) + (data '(1+3i 99 3-1i))) + (equal? data (parse-c-struct (make-c-struct layout data) + layout)))))) (with-test-prefix "lib->cyg" |