From cc413849fc0b92fee3c33ffd16378ca6ffa1070d Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 28 Jan 2022 07:42:10 -0800
Subject: New function: copy-cptr.

* eval.c (eval_init): copy-cptr intrinsic registered.

* lib.c (copy_cptr): New function.
(copy): Use copy_cptr for CPTR objects.

* lib.h (copy_cptr): Declared.

* tests/017/ffi-misc.tl: New test cases.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.
---
 eval.c                |  1 +
 lib.c                 |  8 ++++++++
 lib.h                 |  1 +
 stdlib/doc-syms.tl    |  1 +
 tests/017/ffi-misc.tl |  5 +++++
 txr.1                 | 20 +++++++++++++++++++-
 6 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/eval.c b/eval.c
index d7e38d88..dc0c97b3 100644
--- a/eval.c
+++ b/eval.c
@@ -7454,6 +7454,7 @@ void eval_init(void)
   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("copy-cptr"), user_package), func_n1(copy_cptr));
   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));
diff --git a/lib.c b/lib.c
index 488cb0dd..03d6cead 100644
--- a/lib.c
+++ b/lib.c
@@ -9779,6 +9779,12 @@ val cptr_cast(val to_type, val cptr)
   return cptr_typed(ptr, to_type, 0);
 }
 
+val copy_cptr(val cptr)
+{
+  mem_t *ptr = cptr_handle(cptr, nil, lit("cptr-copy"));
+  return cptr_typed(ptr, cptr->cp.cls, 0);
+}
+
 val int_cptr(val cptr)
 {
   return num(coerce(cnum, cptr_handle(cptr, nil, lit("int-cptr"))));
@@ -12185,6 +12191,8 @@ val copy(val seq)
     return copy_fun(seq);
   case TNOD:
     return copy_tnode(seq);
+  case CPTR:
+    return copy_cptr(seq);
   case COBJ:
     if (seq->co.cls == hash_cls)
       return copy_hash(seq);
diff --git a/lib.h b/lib.h
index a8c2b9b9..972f97d2 100644
--- a/lib.h
+++ b/lib.h
@@ -1136,6 +1136,7 @@ val cptr_buf(val buf, val type_sym);
 val cptr_zap(val cptr);
 val cptr_free(val cptr);
 val cptr_cast(val to_type, val cptr);
+val copy_cptr(val cptr);
 val int_cptr(val cptr);
 mem_t *cptr_get(val cptr);
 mem_t *cptr_handle(val cobj, val type_sym, val self);
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index dc8424a5..723ea9c2 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -400,6 +400,7 @@
       ("copy-buf" "N-00BE75E1")
       ("copy-carray" "N-006593D0")
       ("copy-cons" "N-037EBB77")
+      ("copy-cptr" "N-018EBB92")
       ("copy-file" "N-019D6582")
       ("copy-files" "N-019D6582")
       ("copy-fun" "N-003E7671")
diff --git a/tests/017/ffi-misc.tl b/tests/017/ffi-misc.tl
index 377d7572..7053f78e 100644
--- a/tests/017/ffi-misc.tl
+++ b/tests/017/ffi-misc.tl
@@ -83,3 +83,8 @@
 (each-match ((a b c) (rperm '(fals true) 3))
   (let ((s (new abc a a b b c c)))
     (test (ffi-get (ffi-put s (ffi abc)) (ffi-abc)) s)))
+
+(mstest
+  (copy-cptr (cptr-int 3)) "#<cptr: 3>"
+  (copy (cptr-int 3)) "#<cptr: 3>"
+  (copy-cptr 3) :error)
diff --git a/txr.1 b/txr.1
index d6c7f39d..81ee2846 100644
--- a/txr.1
+++ b/txr.1
@@ -20742,6 +20742,10 @@ the type of the argument, as follows:
 .mono
 .meti (copy-tree-iter << object )
 .onom
+.coIP cptr
+.mono
+.meti (copy-cptr << object )
+.onom
 .RE
 
 .IP
@@ -55051,7 +55055,7 @@ The
 .code copy-tnode
 function creates a new
 .code tnode
-objects, whose
+object, whose
 .codn key ,
 .code left
 and
@@ -62382,6 +62386,20 @@ circumvents the safety mechanism which
 .code cptr
 type tagging provides.
 
+.coNP Function @ copy-cptr
+.synb
+.mets (cptr-copy << cptr )
+.syne
+.desc
+The
+.code copy-cptr
+function creates a new
+.code cptr
+object similar to
+.codn cptr ,
+which has the same address and type symbol as
+.codn cptr .
+
 .coNP Function @ cptr-zap
 .synb
 .mets (cptr-zap << cptr )
-- 
cgit v1.2.3