Splitting cptr object into separate CPTR tag.

CPTR shares representation and a lot of implementation with
COBJ.  The COBJ class symbol is the CPTR type tag. There is no
hierarchy among CPTR tags. The nil tag is used for a modicum
of type looseness, so that we don't straitjacket ourselves
too much into this tag-based typing scheme.

All existing cptr objects are becoming CPTR, and all
get a nil tag, except for dlopen library handles, and
dlsym symbols, which are tagged as dlhandle and dlsym.

The FFI framework will support tag-declared cptr's. This will
help with safety. For instance, suppose an API has half a
dozen different kinds of opaque handles. If they are all just
cptr on the TXR Lisp side, it's easy to mix them up, passing
the wrong one to the wrong C function.

* lib.h (enum type): New enum member, CPTR.
(cptr_print_op, cptr_typed, cptrp, cptr_type, cptr_handle):
Declared.
(cptr_addr_of): Parameters added.

* lib.c (code2type): Map CPTR type code to cptr_s.
(equal): Handle CPTR objects. They are only equal to other
CPTR objects which have the same operations, and
are equal under the equal function of those operations.
(cptr_print_op): New function.
(cptr_ops): Use cptr_print_op rather than cobj_print_op.
(cptr_typed): New function.
(cptr): Use cptr_typed to make a cptr with tag nil,
rather than using cobj.
(cptrp, cptr_handle, cptr_type): New functions.
(cptr_get): Go through cptr_handle rather than cobj_handle.
(cptr_addr_of, cptr_zap, cptr_free): Use call to cptr_handle
rather than cobj_handle for the type checking side effect.
New parameters for type and parent function name.
(obj_print_impl): Handle CPTR with same case as COBJ.

* gc.c (finalize, mark_obj): Handle CPTR cases using
common code with COBJ.

* hash.c (equal_hash): Handle CPTR just like COBJ.

* eval.c (eval_init): Register cptrp and cptr-type intrinsic
functions.

* ffi.c (ffi_cptr_put, ffi_cptr_get, ffi_cptr_alloc): Use the
potentially type-safe cptr_handle, instead of cptr_get.
However, for an untagged cptr, there is no type safety because
tft->mtypes is nil. The argument can be any kind of cptr.

* sysif.c (dlhandle_s, dlsym_s): New symbol variables.
(cptr_dl_ops): Use cptr_print_op.
(dlopen_wrap, dlclose_wrap): Use typed cptr with
dlhandle as the type.
(dlsym_wrap, dlsym_checked, dlvsym_wrap, dlvsym_checked):
Recognize only a cptr of type dlhandle for the library.
Construct a typed cptr of type dlsym.
(sysif_init): Initialize dlhandle_s and dlsym_s.
Register dlsym function using dlsym_s.

1 files changed, 54 insertions, 7 deletions

diff --git a/lib.c b/lib.c
index 7e79297a..f1309a72 100644
--- a/lib.c
+++ b/lib.c
@@ -173,6 +173,7 @@ static val code2type(int code)
   case LCONS: return lcons_s;
   case LSTR: return lstr_s;
   case COBJ: return cobj_s;
+  case CPTR: return cptr_s;
   case ENV: return env_s;
   case BGNUM: return bignum_s;
   case FLNUM: return float_s;
@@ -2520,6 +2521,9 @@ val equal(val left, val right)
       return left->co.ops->equal(left, right);
 
     return nil;
+  case CPTR:
+    if (type(right) == CPTR && left->co.ops == right->co.ops)
+      return left->co.ops->equal(left, right);
   }
 
   if (type(right) != COBJ)
@@ -7379,6 +7383,17 @@ void cobj_print_op(val obj, val out, val pretty, struct strm_ctx *ctx)
   format(out, lit(": ~p>"), coerce(val, obj->co.handle), nao);
 }
 
+void cptr_print_op(val obj, val out, val pretty, struct strm_ctx *ctx)
+{
+  put_string(lit("#<cptr"), out);
+  if (obj->co.cls) {
+    put_char(chr(' '), out);
+    obj_print_impl(obj->co.cls, out, pretty, ctx);
+  }
+  format(out, lit(": ~p>"), coerce(val, obj->co.handle), nao);
+}
+
+
 val cobj_equal_handle_op(val left, val right)
 {
   return (left->co.handle == right->co.handle) ? t : nil;
@@ -7392,15 +7407,36 @@ cnum cobj_handle_hash_op(val obj, int *count)
 
 static struct cobj_ops cptr_ops = {
   cobj_equal_handle_op,
-  cobj_print_op,
+  cptr_print_op,
   cobj_destroy_stub_op,
   cobj_mark_op,
   cobj_handle_hash_op
 };
 
+val cptr_typed(mem_t *handle, val type_sym, struct cobj_ops *ops)
+{
+  val obj = make_obj();
+  obj->co.type = CPTR;
+  obj->co.handle = handle;
+  obj->co.ops = (ops != 0 ? ops : &cptr_ops);
+  obj->co.cls = type_sym;
+  return obj;
+}
+
 val cptr(mem_t *ptr)
 {
-  return cobj(ptr, cptr_s, &cptr_ops);
+  return cptr_typed(ptr, nil, &cptr_ops);
+}
+
+val cptrp(val obj)
+{
+  return type(obj) == CPTR ? t : nil;
+}
+
+val cptr_type(val cptr)
+{
+  (void) cptr_handle(cptr, nil, lit("cptr-type"));
+  return cptr->co.cls;
 }
 
 val cptr_int(val n)
@@ -7415,27 +7451,37 @@ val cptr_obj(val obj)
 
 val cptr_zap(val cptr)
 {
-  (void) cobj_handle(cptr, cptr_s);
+  (void) cptr_handle(cptr, nil, lit("cptr-zap"));
   cptr->co.handle = 0;
   return cptr;
 }
 
 val cptr_free(val cptr)
 {
-  (void) cobj_handle(cptr, cptr_s);
+  (void) cptr_handle(cptr, nil, lit("cptr-free"));
   free(cptr->co.handle);
   cptr->co.handle = 0;
   return cptr;
 }
 
+mem_t *cptr_handle(val cptr, val type_sym, val self)
+{
+  if (type(cptr) != CPTR)
+    uw_throwf(error_s, lit("~a: ~s isn't a cptr"), self, cptr, nao);
+  if (type_sym && cptr->co.cls != type_sym)
+    uw_throwf(error_s, lit("~a: cptr ~s isn't of type ~s"), self, cptr,
+              type_sym, nao);
+  return cptr->co.handle;
+}
+
 mem_t *cptr_get(val cptr)
 {
-  return cobj_handle(cptr, cptr_s);
+  return cptr_handle(cptr, nil, lit("cptr-get"));
 }
 
-mem_t **cptr_addr_of(val cptr)
+mem_t **cptr_addr_of(val cptr, val type_sym, val self)
 {
-  (void) cobj_handle(cptr, cptr_s);
+  (void) cptr_handle(cptr, type_sym, self);
   return &cptr->co.handle;
 }
 
@@ -10335,6 +10381,7 @@ dot:
     }
     break;
   case COBJ:
+  case CPTR:
     obj->co.ops->print(obj, out, pretty, ctx);
     break;
   case ENV: