Support C99 complex types in (system foreign)

* libguile/foreign.h (SCM_FOREIGN_TYPE_COMPLEX_FLOAT,
  SCM_FOREIGN_TYPE_COMPLEX_DOUBLE): New enums.
* module/system/foreign.scm (complex-float, complex-double): Export new types.
  (make-c-struct, parse-c-struct): Support the new types.
* libguile/foreign.c (complex-float, complex-double): Define new types.
  (alignof, sizeof, pack, unpack): Support the new types.
* test-suite/tests/foreign.test: Test.

NEWS

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

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

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

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;

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)

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"