From c1170bd0f3425eac4600e1daf30cd13afd77f1d9 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 31 Oct 2013 12:23:20 -0700
Subject: [PATCH] ffi: Add flovec_* functions and abort_to_c for shims.

Add flovec_length, flovec_loc and flovec_ref.  The abort_to_c function
allows the Gtk shim's run_gtk() to stop Scheme and return to the
toolkit.
---
 src/microcode/pruxffi.c | 38 +++++++++++++++++++++++++++++++++++---
 src/microcode/pruxffi.h |  3 +++
 2 files changed, 38 insertions(+), 3 deletions(-)

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 0f3f35f91..cbef761d6 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -697,6 +697,15 @@ DEFINE_PRIMITIVE ("RETURN-TO-C", Prim_return_to_c, 0, 0, 0)
   }
 }
 
+/* This is mainly for src/gtk/gtkio.c, so it does not need to include
+   prim.h, scheme.h and everything. */
+void
+abort_to_c (void)
+{
+  PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
+  /* NOTREACHED */
+}
+
 char *
 callback_lunseal (CallbackKernel expected)
 {
@@ -824,11 +833,11 @@ arg_alien_entry (int argn)
 void *
 arg_pointer (int argn)
 {
-  /* Accept an alien, string, xstring handle (positive integer),
-     or zero (for a NULL pointer). */
+  /* Accept an alien, string, flovec, xstring handle (positive
+     integer), or zero (for a NULL pointer). */
 
   SCM arg = ARG_REF (argn);
-  if (integer_zero_p (arg))
+  if ((INTEGER_P (arg)) && (integer_zero_p (arg)))
     return ((void *)0);
   if (STRING_P (arg))
     return ((void *) (STRING_POINTER (arg)));
@@ -841,6 +850,8 @@ arg_pointer (int argn)
     }
   if (is_alien (arg))
     return (alien_address (arg));
+  if (FLONUM_P (arg))
+    return ((void *) (OBJECT_ADDRESS (arg)));
 
   error_wrong_type_arg (argn);
   /*NOTREACHED*/
@@ -1056,6 +1067,27 @@ empty_list (void)
   return (EMPTY_LIST);
 }
 
+int
+flovec_length (SCM vector)
+{
+  return (FLOATING_VECTOR_LENGTH (vector));
+}
+
+double*
+flovec_loc (SCM vector)
+{
+  return (FLOATING_VECTOR_LOC (vector, 0));
+}
+
+double
+flovec_ref (SCM vector, int index)
+{
+  int len = FLOATING_VECTOR_LENGTH (vector);
+  if (0 <= index && index < len)
+    return (FLOATING_VECTOR_REF (vector, index));
+  error_external_return ();
+}
+
 DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
 {
   /* To avoid the normal i/o system when debugging a callback. */
diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index 017d64ac5..59c6465ec 100644
--- a/src/microcode/pruxffi.h
+++ b/src/microcode/pruxffi.h
@@ -90,6 +90,9 @@ extern void* pointer_value (void);
 extern void check_number_of_args (int num);
 extern SCM unspecific (void);
 extern SCM empty_list (void);
+extern int flovec_length (SCM vector);
+extern double* flovec_loc (SCM vector);
+extern double flovec_ref (SCM vector, int index);
 
 #ifndef MIT_SCHEME /* Do not include in the microcode, just shims. */
 extern SCM cons (SCM car, SCM cdr);
-- 
2.25.1