From 86d5c1a3fcf5f9fcbcbf312eea3d6fad7f6bd10d Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 26 Jun 2017 06:39:24 -0700
Subject: New cptr functions cptr-cast and int-cptr.

* eval.c (eval_init): Register new intrinsics cptr-cast and
int-cptr.

* lib.c (cptr_cast, int_cptr): New functions.

* lib.h (cptr_cast, int_cptr): Declared.

* txr.1: Documented.
---
 eval.c |  2 ++
 lib.c  | 11 +++++++++++
 lib.h  |  2 ++
 txr.1  | 44 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 59 insertions(+)

diff --git a/eval.c b/eval.c
index 46c9bb72..3bdb29f5 100644
--- a/eval.c
+++ b/eval.c
@@ -6161,6 +6161,8 @@ void eval_init(void)
   reg_fun(intern(lit("cptr-obj"), user_package), func_n2o(cptr_obj, 1));
   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("cptr-cast"), user_package), func_n2(cptr_cast));
+  reg_fun(intern(lit("int-cptr"), user_package), func_n1(int_cptr));
   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));
diff --git a/lib.c b/lib.c
index 80d056b4..fc70090a 100644
--- a/lib.c
+++ b/lib.c
@@ -7558,6 +7558,17 @@ val cptr_free(val cptr)
   return cptr;
 }
 
+val cptr_cast(val to_type, val cptr)
+{
+  mem_t *ptr = cptr_handle(cptr, nil, lit("cptr-cast"));
+  return cptr_typed(ptr, to_type, 0);
+}
+
+val int_cptr(val cptr)
+{
+  return num(coerce(cnum, cptr_handle(cptr, nil, lit("int-cptr"))));
+}
+
 mem_t *cptr_handle(val cptr, val type_sym, val self)
 {
   if (type(cptr) != CPTR)
diff --git a/lib.h b/lib.h
index ffe10c84..63771912 100644
--- a/lib.h
+++ b/lib.h
@@ -961,6 +961,8 @@ val cptr_int(val n, val type_sym);
 val cptr_obj(val obj, val type_sym);
 val cptr_zap(val cptr);
 val cptr_free(val cptr);
+val cptr_cast(val to_type, val cptr);
+val int_cptr(val cptr);
 mem_t *cptr_get(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);
diff --git a/txr.1 b/txr.1
index f5c75efb..dcbaecc1 100644
--- a/txr.1
+++ b/txr.1
@@ -53668,6 +53668,50 @@ This symbol becomes the
 .code cptr
 object's type tag.
 
+.coNP Function @ int-cptr
+.synb
+.mets (int-cptr << cptr )
+.syne
+.desc
+The
+.code int-cptr
+function retrieves the pointer value of the
+.meta cptr
+object as an integer.
+
+If an integer
+.meta n
+is in a range convertible to
+.code cptr
+type, then the expression
+.cblk
+.meti (int-cptr (cptr-int << n ))
+.cble
+reproduces
+.metn n .
+
+.coNP Function @ cptr-cast
+.synb
+.mets (cptr-cast < type-symbol << cptr )
+.syne
+.desc
+The
+.code cptr-cast
+function produces a new
+.code cptr
+object which has the same pointer as
+.meta cptr
+but whose type is given by
+.metn type-symbol .
+
+Casting
+.meta cptr
+objects with
+.code cptr-cast
+circumvents the safety mechanism which
+.code cptr
+type tagging provides.
+
 .coNP Function @ cptr-zap
 .synb
 .mets (cptr-zap << cptr )
-- 
cgit v1.2.3