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.

7 files changed, 94 insertions, 25 deletions

diff --git a/eval.c b/eval.c
index 97004bd5..4e6766d0 100644
--- a/eval.c
+++ b/eval.c
@@ -6161,6 +6161,8 @@ void eval_init(void)
   reg_fun(intern(lit("cptr-obj"), user_package), func_n1(cptr_obj));
   reg_fun(intern(lit("cptr-zap"), user_package), func_n1(cptr_zap));
   reg_fun(intern(lit("cptr-free"), user_package), func_n1(cptr_free));
+  reg_fun(intern(lit("cptrp"), user_package), func_n1(cptrp));
+  reg_fun(intern(lit("cptr-type"), user_package), func_n1(cptr_type));
   reg_varl(intern(lit("cptr-null"), user_package), cptr(0));
 
   eval_error_s = intern(lit("eval-error"), user_package);
diff --git a/ffi.c b/ffi.c
index e72b3d1f..15b862f9 100644
--- a/ffi.c
+++ b/ffi.c
@@ -566,19 +566,19 @@ static val ffi_wchar_get(struct txr_ffi_type *tft, mem_t *src, val self)
 static void ffi_cptr_put(struct txr_ffi_type *tft, val n, mem_t *dst,
                          val self)
 {
-  mem_t *p = cptr_get(n);
+  mem_t *p = cptr_handle(n, tft->mtypes, self);
   *coerce(mem_t **, dst) = p;
 }
 
 static val ffi_cptr_get(struct txr_ffi_type *tft, mem_t *src, val self)
 {
   mem_t *p = *coerce(mem_t **, src);
-  return cptr(p);
+  return cptr_typed(p, tft->mtypes, 0);
 }
 
 static mem_t *ffi_cptr_alloc(struct txr_ffi_type *tft, val ptr, val self)
 {
-  return coerce(mem_t *, cptr_addr_of(ptr));
+  return coerce(mem_t *, cptr_addr_of(ptr, tft->mtypes, self));
 }
 
 static val ffi_str_in(struct txr_ffi_type *tft, int copy,
diff --git a/gc.c b/gc.c
index 9d5897b4..cb67d156 100644
--- a/gc.c
+++ b/gc.c
@@ -274,6 +274,7 @@ static void finalize(val obj)
     obj->v.vec = 0;
     return;
   case COBJ:
+  case CPTR:
     obj->co.ops->destroy(obj);
     obj->co.handle = 0;
     return;
@@ -392,6 +393,7 @@ tail_call:
     mark_obj(obj->ls.props->term);
     mark_obj_tail(obj->ls.list);
   case COBJ:
+  case CPTR:
     obj->co.ops->mark(obj);
     mark_obj_tail(obj->co.cls);
   case ENV:
diff --git a/hash.c b/hash.c
index 2b838ae6..159fbc2d 100644
--- a/hash.c
+++ b/hash.c
@@ -220,6 +220,7 @@ cnum equal_hash(val obj, int *count)
   case FLNUM:
     return hash_double(obj->fl.n);
   case COBJ:
+  case CPTR:
     if (obj->co.ops->equalsub) {
       val sub = obj->co.ops->equalsub(obj);
       if (sub)
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:
diff --git a/lib.h b/lib.h
index 04440b39..bd5ddff8 100644
--- a/lib.h
+++ b/lib.h
@@ -59,7 +59,7 @@ typedef uint_ptr_t ucnum;
 
 typedef enum type {
   NIL = TAG_PTR, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, CONS,
-  STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, ENV,
+  STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, CPTR, ENV,
   BGNUM, FLNUM, RNG, BUF, MAXTYPE = BUF
   /* If extending, check TYPE_SHIFT and all ocurrences of MAX_TYPE */
 } type_t;
@@ -253,6 +253,7 @@ struct cobj_ops {
  */
 
 void cobj_print_op(val, val, val, struct strm_ctx *);
+void cptr_print_op(val, val, val, struct strm_ctx *);
 val cobj_equal_handle_op(val left, val right);
 void cobj_destroy_stub_op(val);
 void cobj_destroy_free_op(val);
@@ -939,12 +940,16 @@ val cobjp(val obj);
 mem_t *cobj_handle(val cobj, val cls_sym);
 struct cobj_ops *cobj_ops(val cobj, val cls_sym);
 val cptr(mem_t *ptr);
+val cptr_typed(mem_t *handle, val type_sym, struct cobj_ops *ops);
+val cptrp(val obj);
+val cptr_type(val cptr);
 val cptr_int(val n);
 val cptr_obj(val obj);
 val cptr_zap(val cptr);
 val cptr_free(val cptr);
 mem_t *cptr_get(val cptr);
-mem_t **cptr_addr_of(val cptr);
+mem_t *cptr_handle(val cobj, val type_sym, val self);
+mem_t **cptr_addr_of(val cptr, val type_sym, val self);
 val assoc(val key, val list);
 val assql(val key, val list);
 val rassoc(val key, val list);
diff --git a/sysif.c b/sysif.c
index 78dcda6c..3e14ba97 100644
--- a/sysif.c
+++ b/sysif.c
@@ -110,6 +110,10 @@ val utsname_s, sysname_s, nodename_s, release_s, version_s, machine_s;
 val domainname_s;
 #endif
 
+#if HAVE_DLOPEN
+val dlhandle_s, dlsym_s;
+#endif
+
 static val at_exit_list;
 
 static val errno_wrap(val newval)
@@ -1467,7 +1471,7 @@ static void cptr_dl_destroy_op(val obj)
 
 static struct cobj_ops cptr_dl_ops = {
   cobj_equal_handle_op,
-  cobj_print_op,
+  cptr_print_op,
   cptr_dl_destroy_op,
   cobj_mark_op,
   cobj_handle_hash_op
@@ -1488,15 +1492,16 @@ static val dlopen_wrap(val name, val flags)
     else
       uw_throwf(error_s, lit("dlopen failed on ~a"), name, nao);
   }
-  return cobj(ptr, cptr_s, &cptr_dl_ops);
+  return cptr_typed(ptr, dlhandle_s, &cptr_dl_ops);
 }
 
 static val dlclose_wrap(val cptr)
 {
-  mem_t *ptr = cptr_get(cptr);
+  val self = lit("dlclose");
+  mem_t *ptr = cptr_handle(cptr, dlhandle_s, self);
   if (cptr->co.ops != &cptr_dl_ops)
-    uw_throwf(error_s, lit("dlclose: object ~s isn't a handle from dlopen"),
-              cptr, nao);
+    uw_throwf(error_s, lit("~s: object ~s isn't a handle from dlopen"),
+              self, cptr, nao);
   if (ptr != 0) {
     int res = dlclose(ptr);
     cptr->co.handle = 0;
@@ -1507,12 +1512,13 @@ static val dlclose_wrap(val cptr)
 
 static val dlsym_wrap(val dlptr, val name)
 {
+  val self = lit("dlsym");
   const wchar_t *name_ws = c_str(name);
   char *name_u8 = utf8_dup_to(name_ws);
-  mem_t *dl = cptr_get(dlptr);
+  mem_t *dl = cptr_handle(dlptr, dlhandle_s, self);
   mem_t *sym = coerce(mem_t *, dlsym(dl, name_u8));
   free(name_u8);
-  return cptr(sym);
+  return cptr_typed(sym, dlsym_s, 0);
 }
 
 static void dlsym_error(val dlptr, val name, val self)
@@ -1527,15 +1533,18 @@ static void dlsym_error(val dlptr, val name, val self)
 
 static val dlsym_checked(val dlptr, val name)
 {
+  val self = lit("dlsym-checked");
   val ptr = (dlerror(), dlsym_wrap(dlptr, name));
-  if (cptr_get(ptr) == 0)
-    dlsym_error(dlptr, name, lit("dlsym-checked"));
+  if (cptr_handle(ptr, dlsym_s, self) == 0)
+    dlsym_error(dlptr, name, self);
   return ptr;
 }
 
 #if HAVE_DLVSYM
 static val dlvsym_wrap(val dlptr, val name, val ver)
 {
+  val self = lit("dlvsym");
+
   if (null_or_missing_p(ver)) {
     return dlsym_wrap(dlptr, name);
   } else {
@@ -1543,7 +1552,7 @@ static val dlvsym_wrap(val dlptr, val name, val ver)
     const wchar_t *ver_ws = c_str(ver);
     char *name_u8 = utf8_dup_to(name_ws);
     char *ver_u8 = utf8_dup_to(ver_ws);
-    mem_t *dl = cptr_get(dlptr);
+    mem_t *dl = cptr_handle(dlptr, dlhandle_s, self);
     mem_t *sym = coerce(mem_t *, dlvsym(dl, name_u8, ver_u8));
     free(name_u8);
     free(ver_u8);
@@ -1553,9 +1562,10 @@ static val dlvsym_wrap(val dlptr, val name, val ver)
 
 static val dlvsym_checked(val dlptr, val name, val ver)
 {
+  val self = lit("dlvsym-checked");
   val ptr = (dlerror(), dlvsym_wrap(dlptr, name, ver));
-  if (cptr_get(ptr) == 0)
-    dlsym_error(dlptr, name, lit("dlvsym-checked"));
+  if (cptr_handle(ptr, dlsym_s, self) == 0)
+    dlsym_error(dlptr, name, self);
   return ptr;
 }
 #endif
@@ -1905,9 +1915,11 @@ void sysif_init(void)
 #endif
 
 #if HAVE_DLOPEN
+  dlhandle_s = intern(lit("dlhandle"), user_package);
+  dlsym_s = intern(lit("dlsym"), user_package);
   reg_fun(intern(lit("dlopen"), user_package), func_n2o(dlopen_wrap, 0));
   reg_fun(intern(lit("dlclose"), user_package), func_n1(dlclose_wrap));
-  reg_fun(intern(lit("dlsym"), user_package), func_n2(dlsym_wrap));
+  reg_fun(dlsym_s, func_n2(dlsym_wrap));
   reg_fun(intern(lit("dlsym-checked"), user_package), func_n2(dlsym_checked));
 #if HAVE_DLVSYM
   reg_fun(intern(lit("dlvsym"), user_package), func_n3o(dlvsym_wrap, 2));