[Guile-commits] branch main updated: Support C99 complex types in (system foreign)

[Daniel Llorens]

This is an automated email from the git hooks/post-receive script.

lloda pushed a commit to branch main
in repository guile.

The following commit(s) were added to refs/heads/main by this push:
     new eb9ad61  Support C99 complex types in (system foreign)
eb9ad61 is described below

commit eb9ad615fea0047b40ad0c27e6ca5d041c5b5190
Author: Daniel Llorens <lloda@sarc.name>
AuthorDate: Thu Nov 11 15:47:42 2021 +0100

    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                          |  5 ++++
 doc/ref/api-foreign.texi      |  5 +++-
 libguile/foreign.c            | 66 +++++++++++++++++++++++++++++++++++++++++++
 libguile/foreign.h            |  6 ++++
 module/system/foreign.scm     | 16 +++++++++++
 test-suite/tests/foreign.test |  9 +++++-
 6 files changed, 105 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index f41e772..710b8dd 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 a1a1016..540fbba 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 1368cc9..1e46921 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 41f26b3..33ce631 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 d1c2ceb..4458dc7 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 fd0e276..28d7b5d 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"