From 2a95a47be9d431fbcb3fe65c1d02a9926441bbaf Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 11 Nov 2021 15:47:42 +0100
Subject: [PATCH] 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.
---
 NEWS                      |  5 +++
 doc/ref/api-foreign.texi  |  5 ++-
 libguile/foreign.c        | 66 +++++++++++++++++++++++++++++++++++++++
 libguile/foreign.h        |  6 ++++
 module/system/foreign.scm | 16 ++++++++++
 5 files changed, 97 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index f41e772ad..710b8ddda 100644
--- a/NEWS
+++ b/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)
 
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..fdf1001dc 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,22 @@ 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 +1004,24 @@ 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 +1234,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..24e14a0cd 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)
-- 
2.30.2

