ffi: provide support for unions.

* ffi.c (union_s): New symbol variable.
(ffi_find_memb, ffi_memb_not_found): New static functions.
(ffi_union_in, ffi_union_put, ffi_union_get): New static
functions.
(make_ffi_type_union): New static function.
(ffi_struct_compile): Handle union syntax using
ffi_struct_compile to compile the member definitions to types,
and make_ffi_type_union to produce the type node.
(struct uni): New struct type.
(uni_struct, uni_struct_checked): New static functions.
(union_destroy_op, union_mark_op): New static functions.
(union_ops): New static struct.
(make_union_common, make_union_tft): New static functions.
(union_get_ptr, make_union, union_members, union_get,
union_put, union_in, union_out): New functions.
(ffi_init): Initialize union_s. Register intrinsics
make-union, union-members, union-get, union-put, union-in,
union-out.

* ffi.h (union_s, union_get_ptr, make_union, union_members,
union_get, union_put, union_in, union_out): Declared.

* txr.1: Documented unions.

3 files changed, 490 insertions, 3 deletions

diff --git a/ffi.c b/ffi.c
index 6bbcc035..3e73f1fb 100644
--- a/ffi.c
+++ b/ffi.c
@@ -110,7 +110,7 @@ val le_float_s, le_double_s;
 
 val array_s, zarray_s, carray_s;
 
-val struct_s;
+val struct_s, union_s;
 
 val str_d_s, wstr_s, wstr_d_s, bstr_s, bstr_d_s;
 
@@ -2628,6 +2628,52 @@ static val ffi_enum_rget(struct txr_ffi_type *tft, mem_t *src, val self)
 
 #endif
 
+static struct txr_ffi_type *ffi_find_memb(struct txr_ffi_type *tft, val name)
+{
+  cnum i;
+  for (i = 0; i < tft->nelem; i++) {
+    if (tft->memb[i].mname == name)
+      return tft->memb[i].mtft;
+  }
+
+  return 0;
+}
+
+static void ffi_memb_not_found(val type, val name, val self)
+{
+  uw_throwf(error_s, lit("~a: ~s doesn't name a member of ~s"),
+            type, name, self, nao);
+}
+
+static val make_union_tft(mem_t *buf, struct txr_ffi_type *tft);
+
+static val ffi_union_in(struct txr_ffi_type *tft, int copy, mem_t *src,
+                        val uni, val self)
+{
+  if (copy) {
+    if (uni == nil) {
+      uni = make_union_tft(src, tft);
+    } else {
+      mem_t *ptr = union_get_ptr(uni);
+      memcpy(ptr, src, tft->size);
+    }
+  }
+
+  return uni;
+}
+
+static void ffi_union_put(struct txr_ffi_type *tft, val uni,
+                          mem_t *dst, val self)
+{
+  mem_t *ptr = union_get_ptr(uni);
+  memcpy(dst, ptr, tft->size);
+}
+
+static val ffi_union_get(struct txr_ffi_type *tft, mem_t *src, val self)
+{
+  return make_union_tft(src, tft);
+}
+
 static val bitfield_syntax_p(val syntax)
 {
   if (!consp(syntax)) {
@@ -2870,6 +2916,86 @@ static val make_ffi_type_struct(val syntax, val lisp_type,
   return obj;
 }
 
+static val make_ffi_type_union(val syntax, val lisp_type,
+                               val slots, val types)
+{
+  struct txr_ffi_type *tft = coerce(struct txr_ffi_type *,
+                                    chk_calloc(1, sizeof *tft));
+  ffi_type *ft = coerce(ffi_type *, chk_calloc(1, sizeof *ft));
+
+  cnum nmemb = c_num(length(types)), i;
+  struct smemb *memb = coerce(struct smemb *,
+                              chk_calloc(nmemb, sizeof *memb));
+  val obj = cobj(coerce(mem_t *, tft), ffi_type_s, &ffi_type_enum_ops);
+  ucnum most_align = 0;
+  ucnum biggest_size = 0;
+  const unsigned bits_int = 8 * sizeof(int);
+
+  tft->self = obj;
+  tft->ft = ft;
+  tft->syntax = syntax;
+  tft->lt = lisp_type;
+  tft->nelem = nmemb;
+  tft->clone = ffi_struct_clone;
+  tft->put = ffi_union_put;
+  tft->get = ffi_union_get;
+  tft->in = ffi_union_in;
+  tft->alloc = ffi_fixed_alloc;
+  tft->free = free;
+  tft->memb = memb;
+
+  for (i = 0; i < nmemb; i++) {
+    val type = pop(&types);
+    val slot = pop(&slots);
+    struct txr_ffi_type *mtft = ffi_type_struct(type);
+
+    memb[i].mtype = type;
+    memb[i].mname = slot;
+    memb[i].mtft = mtft;
+    memb[i].offs = 0;
+
+    if (most_align < (ucnum) mtft->align)
+      most_align = mtft->align;
+
+    if (biggest_size < (ucnum) mtft->size)
+      biggest_size = mtft->size;
+
+    if (bitfield_syntax_p(mtft->syntax)) {
+      ucnum bits = mtft->nelem;
+
+      if (bits == 0) {
+        nmemb--, i--;
+        continue;
+      }
+
+#if HAVE_LITTLE_ENDIAN
+      mtft->shift = 0;
+#else
+      mtft->shift = bits_int - bits;
+#endif
+      if (bits == bits_int)
+        mtft->mask = UINT_MAX;
+      else
+        mtft->mask = ((1U << bits) - 1) << mtft->shift;
+    }
+  }
+
+  tft->nelem = i;
+
+  tft->size = biggest_size;
+  tft->align = most_align;
+
+#if HAVE_LIBFFI
+  ft->type = FFI_TYPE_STRUCT;
+  ft->size = tft->size;
+  ft->alignment = tft->align;
+  ft->elements = tft->elements;
+#endif
+
+  return obj;
+}
+
+
 static struct txr_ffi_type *ffi_array_clone(struct txr_ffi_type *orig)
 {
   struct txr_ffi_type *copy = ffi_simple_clone(orig);
@@ -3045,7 +3171,8 @@ static val ffi_struct_compile(val membs, val *ptypes, val self)
       uw_throwf(error_s, lit("~a: excess elements in type-member pair ~s"),
                 self, mp, nao);
     if (ctft->size == 0)
-      uw_throwf(error_s, lit("~a: incomplete type ~s cannot be struct member"),
+      uw_throwf(error_s,
+                lit("~a: incomplete type ~s cannot be struct/union member"),
                 self, type, nao);
     pttail = list_collect(pttail, comp_type);
     pstail = list_collect(pstail, name);
@@ -3076,6 +3203,15 @@ val ffi_type_compile(val syntax)
       val xsyntax = cons(struct_s,
                          cons(sname, membs));
       return make_ffi_type_struct(xsyntax, stype, slots, types);
+    } else if (sym == union_s) {
+      val name = cadr(syntax);
+      val membs = cddr(syntax);
+      val sname = if3(name, name, gensym(lit("ffi-union-")));
+      val types;
+      val slots = ffi_struct_compile(membs, &types, self);
+      val xsyntax = cons(struct_s,
+                         cons(sname, membs));
+      return make_ffi_type_union(xsyntax, union_s, slots, types);
     } else if (sym == array_s || sym == zarray_s) {
       if (length(syntax) == two) {
         val eltype_syntax = cadr(syntax);
@@ -4938,6 +5074,130 @@ val fill_carray(val carray, val offs, val stream)
   return ret;
 }
 
+struct uni {
+  struct txr_ffi_type *tft;
+  mem_t *data;
+};
+
+static struct uni *uni_struct(val obj)
+{
+  return coerce(struct uni *, obj->co.handle);
+}
+
+static struct uni *uni_struct_checked(val obj)
+{
+  return coerce(struct uni *, cobj_handle(obj, union_s));
+}
+
+static void union_destroy_op(val obj)
+{
+  struct uni *us = uni_struct(obj);
+  free(us->data);
+  us->data = 0;
+  free(us);
+}
+
+static void union_mark_op(val obj)
+{
+  struct uni *us = uni_struct(obj);
+  gc_mark(us->tft->self);
+}
+
+static struct cobj_ops union_ops =
+  cobj_ops_init(eq,
+                cobj_print_op,
+                union_destroy_op,
+                union_mark_op,
+                cobj_eq_hash_op);
+
+static val make_union_common(mem_t *data, struct txr_ffi_type *tft)
+{
+  struct uni *us = coerce(struct uni *, chk_calloc(1, sizeof *us));
+  val obj = cobj(coerce(mem_t *, us), union_s, &union_ops);
+  us->tft = tft;
+  us->data = data;
+  return obj;
+}
+
+static val make_union_tft(mem_t *data_in, struct txr_ffi_type *tft)
+{
+  mem_t *data = chk_copy_obj(data_in, tft->size);
+  return make_union_common(data, tft);
+}
+
+mem_t *union_get_ptr(val uni)
+{
+  struct uni *us = uni_struct_checked(uni);
+  return us->data;
+}
+
+val make_union(val type)
+{
+  struct txr_ffi_type *tft = ffi_type_struct_checked(type);
+  mem_t *data = chk_calloc(1, tft->size);
+  return make_union_common(data, tft);
+}
+
+val union_members(val uni)
+{
+  struct uni *us = uni_struct_checked(uni);
+  struct txr_ffi_type *tft = us->tft;
+  cnum i;
+  list_collect_decl (out, ptail);
+
+  for (i = 0; i < tft->nelem; i++)
+    ptail = list_collect(ptail, tft->memb[i].mname);
+
+  return out;
+}
+
+val union_get(val uni, val memb)
+{
+  val self = lit("union-get");
+  struct uni *us = uni_struct_checked(uni);
+  struct txr_ffi_type *tft = us->tft;
+  struct txr_ffi_type *mtft = ffi_find_memb(tft, memb);
+  if (mtft == 0)
+    ffi_memb_not_found(tft->self, memb, self);
+  return mtft->get(mtft, us->data, self);
+}
+
+val union_put(val uni, val memb, val newval)
+{
+  val self = lit("union-put");
+  struct uni *us = uni_struct_checked(uni);
+  struct txr_ffi_type *tft = us->tft;
+  struct txr_ffi_type *mtft = ffi_find_memb(tft, memb);
+  if (mtft == 0)
+    ffi_memb_not_found(tft->self, memb, self);
+  mtft->put(mtft, newval, us->data, self);
+  return newval;
+}
+
+val union_in(val uni, val memb, val memb_obj)
+{
+  val self = lit("union-in");
+  struct uni *us = uni_struct_checked(uni);
+  struct txr_ffi_type *tft = us->tft;
+  struct txr_ffi_type *mtft = ffi_find_memb(tft, memb);
+  if (mtft == 0)
+    ffi_memb_not_found(tft->self, memb, self);
+  return mtft->in(mtft, 0, us->data, memb_obj, self);
+}
+
+val union_out(val uni, val memb, val memb_obj)
+{
+  val self = lit("union-out");
+  struct uni *us = uni_struct_checked(uni);
+  struct txr_ffi_type *tft = us->tft;
+  struct txr_ffi_type *mtft = ffi_find_memb(tft, memb);
+  if (mtft == 0)
+    ffi_memb_not_found(tft->self, memb, self);
+  mtft->out(mtft, 0, memb_obj, us->data, self);
+  return memb_obj;
+}
+
+
 void ffi_init(void)
 {
   prot1(&ffi_typedef_hash);
@@ -4983,6 +5243,7 @@ void ffi_init(void)
   zarray_s = intern(lit("zarray"), user_package);
   carray_s = intern(lit("carray"), user_package);
   struct_s = intern(lit("struct"), user_package);
+  union_s = intern(lit("union"), user_package);
   str_d_s = intern(lit("str-d"), user_package);
   wstr_s = intern(lit("wstr"), user_package);
   wstr_d_s = intern(lit("wstr-d"), user_package);
@@ -5054,6 +5315,12 @@ void ffi_init(void)
   reg_fun(intern(lit("num-carray"), user_package), func_n1(num_carray));
   reg_fun(intern(lit("put-carray"), user_package), func_n3o(put_carray, 1));
   reg_fun(intern(lit("fill-carray"), user_package), func_n3o(fill_carray, 1));
+  reg_fun(intern(lit("make-union"), user_package), func_n1(make_union));
+  reg_fun(intern(lit("union-members"), user_package), func_n1(union_members));
+  reg_fun(intern(lit("union-get"), user_package), func_n2(union_get));
+  reg_fun(intern(lit("union-put"), user_package), func_n3(union_put));
+  reg_fun(intern(lit("union-in"), user_package), func_n3(union_in));
+  reg_fun(intern(lit("union-out"), user_package), func_n3(union_out));
   ffi_typedef_hash = make_hash(nil, nil, nil);
   ffi_init_types();
   ffi_init_extra_types();
diff --git a/ffi.h b/ffi.h
index ee09ebf5..34aca3c6 100644
--- a/ffi.h
+++ b/ffi.h
@@ -51,7 +51,7 @@ extern val le_float_s, le_double_s;
 
 extern val array_s, zarray_s, carray_s;
 
-extern val struct_s;
+extern val struct_s, union_s;
 
 extern val str_d_s, wstr_s, wstr_d_s, bstr_s, bstr_d_s;
 
@@ -121,4 +121,11 @@ val unum_carray(val carray);
 val num_carray(val carray);
 val put_carray(val carray, val offs, val stream);
 val fill_carray(val carray, val offs, val stream);
+mem_t *union_get_ptr(val uni);
+val make_union(val type);
+val union_members(val uni);
+val union_get(val uni, val memb);
+val union_put(val uni, val memb, val newval);
+val union_in(val uni, val memb, val memb_obj);
+val union_out(val uni, val memb, val memb_obj);
 void ffi_init(void);
diff --git a/txr.1 b/txr.1
index c0d35b4b..7f5072ec 100644
--- a/txr.1
+++ b/txr.1
@@ -54497,6 +54497,67 @@ Structure members may be bitfields, which are described using the
 and
 .code bit
 compound type operators.
+
+.meIP (union < name >> {( slot << type )}*)
+The FFI
+.code union
+type resembles the
+.code struct
+type syntactically. It provides handling for foreign objects of C
+.code union
+type.
+
+Unlike the FFI
+.code struct
+type, the
+.code union
+type doesn't provide automatic conversion between C and Lisp data.
+This is because the
+.code union
+is inherently unsafe, due to its placement of multiple types into the
+same storage, and lack of any information to discriminate which type
+is currently stored. Instead, the FFI
+.code union
+creates a correspondence between a C union that is regarded as just
+a region of memory, and a \*(TL data type called
+.codn union .
+
+An instance of the Lisp
+.code union
+type holds a copy of the C union memory, and also contains type information
+about the unions members. Functions are provided to store and retrieve the
+members; it is these functions which provide the conversion between the
+Lisp types and the foreign representations stored in the C union.
+This is done under control of the application, because due to the inherent
+lack of safety of the C
+.codn union ,
+only the application program knows which member of the union may be accessed.
+
+Conversion between the C
+.code union
+and the Lisp
+.code union
+consists of just a memory copying operation.
+
+The following functions are provided for manipulating unions:
+.code make-union
+instantiates a new union object;
+.code union-members
+retrieves a list of the symbols serving as the union's member names;
+.code union-get
+retrieves a specified member from the union's storage, converting it
+to a Lisp object;
+.code union-put
+places a Lisp object into a union, using the specified member's type
+to convert it to a foreign representation;
+.code union-in
+performs the "in semantics" on the specified member of a union,
+propagating modifications in that member back to a Lisp object; and
+.code union-out
+performs "out semantics" on the specified member of a union,
+propagating modifications done on a previously retrieved Lisp object
+back into the union.
+
 .meIP (array < dim << type )
 The FFI
 .code array
@@ -55476,6 +55537,7 @@ Lastly, the size of the structure is then padded up to a size
 which is a multiple of the alignment of the most strictly aligned
 member.
 
+
 .NP* FFI Call Descriptors
 
 The FFI mechanism makes use of a type-like representation called the "call
@@ -56414,6 +56476,157 @@ following equivalence holds:
   (ffi expr)  <-->  (ffi-type-compile 'expr)
 .cble
 
+.coNP Function @ make-union
+.synb
+.mets (make-union << type )
+.syne
+.desc
+The
+.code make-union
+function instantiates a new object of type
+.codn union ,
+based on the FFI type specified by the
+.meta type
+parameter, which must be compiled FFI
+.code union
+type.
+
+The object provides storage for the foreign representation of
+.codn type ,
+and that storage is initialized to all zero bytes.
+
+.coNP Function @ union-members
+.synb
+.mets (union-members << union )
+.syne
+.desc
+The
+.code union-members
+function retrieves the list of symbols which name the members of
+.metn union .
+These are derived from the object's FFI type.
+It is unspecified whether the list is freshly allocated on each call,
+or whether the same list is returned; applications shouldn't
+destructively manipulate this list.
+
+.coNP Function @ union-get
+.synb
+.mets (union-get < union << member )
+.syne
+.desc
+The
+.code union-get
+function performs the get semantics (conversion from a foreign
+representation to Lisp) on the member of
+.meta union
+which is specified by the
+.meta member
+argument. That argument must be a symbol corresponding to one of the member
+names.
+
+The
+.meta union
+object's storage buffer is treated as an object of the foreign
+type indicated by that member's type information, and converted
+accordingly to a Lisp object that is returned.
+
+.coNP Function @ union-put
+.synb
+.mets (union-put < union < member << new-value )
+.syne
+.desc
+The
+.code union-put
+function performs the put semantics (conversion from a Lisp object
+to foreign representation) on the member of
+.meta union
+which is specified by the
+.meta member
+argument. That argument must be a symbol corresponding to one of the member
+names.
+
+The object given as
+.meta new-value
+is converted to the foreign representation according to the type
+information of the indicated member, and that representation is
+placed into the
+.meta union
+object's storage buffer.
+
+The return value is
+.metn new-value .
+
+.coNP Functions @ union-in and @ union-out
+.synb
+.mets (union-in < union < memb << memb-obj )
+.mets (union-out < union < memb << memb-obj )
+.syne
+.desc
+The
+.code union-in
+and
+.code union-out
+functions perform the FFI in semantics and out semantics, respectively.
+These semantics are involved in two-way data transfers between foreign
+representations and Lisp objects.
+
+The
+.meta union
+argument must be a
+.code union
+object and the
+.meta memb
+argument a symbol which matches one of that object's member names.
+
+In the case of
+.codn union-in ,
+.meta memb-obj
+is a Lisp object that was previously stored into
+.meta union
+using the
+.code union-put
+operation, into the same member that is currently indicated by
+.metn member .
+
+In the case of
+.codn union-out ,
+.meta memb-obj
+is a Lisp object that was previously retrieved from
+.meta union
+using the
+.code union-get
+operation, from the same member that is currently indicated by
+.metn member .
+
+The
+.code union-in
+performs the by-value nuance of the in semantics on the indicated
+member: if the member contains pointers to any objects, those
+objects are updated from their counterparts in
+.meta memb-obj
+using their respective by-reference in semantics, recursively.
+
+Similarly
+.code union-out
+performs the by-value nuance of the out semantics on the indicated
+member: if the member contains pointers to any objects, those
+objects are updated with their Lisp counterparts in
+.meta memb-obj
+using their respective by-reference out semantics, recursively.
+
+Note:
+.code union-in
+is intended to be used after a FFI call, on a union-typed by-value
+argument, or a union-typed object contained in an argument,
+in situations when the function is expected to have updated
+the contents of the union. The
+.code union-out
+function is intended to be used in a FFI callback, on a union-typed
+callback argument or union-typed object contained in such
+an argument, in cases when the callback has updated the Lisp
+object corresponding to a union member, and that change needs
+to be propagated to the foreign caller.
+
 .coNP Functions @ ffi-put and @ ffi-put-into
 .synb
 .mets (ffi-put < obj << type )