From afbca6b306ddd07e84c44f4d47bd04ddd3cada86 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 16 Oct 2019 06:46:19 -0700
Subject: tree: node set functions and syntactic places.

* lisplib.c (defset_set_entries): Autoload entries for left,
right and key.

* share/txr/stdlib/defset.tl (left, right, key): New
simple-form defsets.

* tree.c (set_left, set_right, set_key): New functions.
(tree_init): Register intrinsics set-left, set-right and
set-key.

* tree.h (set_left, set_right, set_key): Declared.

* txr.1: key, left and right classified as accessors.
Documented set-key, set-left and set-right.
---
 lisplib.c                  |  1 +
 share/txr/stdlib/defset.tl |  9 +++++++
 tree.c                     | 24 ++++++++++++++++++
 tree.h                     |  3 +++
 txr.1                      | 62 +++++++++++++++++++++++++++++++++++++++++++++-
 5 files changed, 98 insertions(+), 1 deletion(-)

diff --git a/lisplib.c b/lisplib.c
index 43c9e5d1..62b41b3b 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -792,6 +792,7 @@ static val defset_set_entries(val dlt, val fun)
 {
   val name[] = {
     lit("defset"), lit("sub-list"), lit("sub-vec"), lit("sub-str"),
+    lit("left"), lit("right"), lit("key"),
     nil
   };
   set_dlt_entries(dlt, name, fun);
diff --git a/share/txr/stdlib/defset.tl b/share/txr/stdlib/defset.tl
index 9920e925..f15afe4b 100644
--- a/share/txr/stdlib/defset.tl
+++ b/share/txr/stdlib/defset.tl
@@ -119,3 +119,12 @@
 
 (defset sub-str (str : (from 0) (to t)) items
   ^(progn (replace-str ,str ,items ,from ,to) ,items))
+
+(defset left (node) nleft
+  ^(progn (set-left ,node ,nleft) ,nleft))
+
+(defset right (node) nright
+  ^(progn (set-right ,node ,nright) ,nright))
+
+(defset key (node) nkey
+  ^(progn (set-key ,node ,nkey) ,nkey))
diff --git a/tree.c b/tree.c
index 43330c06..70e43158 100644
--- a/tree.c
+++ b/tree.c
@@ -119,6 +119,27 @@ val key(val node)
   return node->tn.key;
 }
 
+val set_left(val node, val nleft)
+{
+  type_check(lit("set-left"), node, TNOD);
+  node->tn.left = nleft;
+  return node;
+}
+
+val set_right(val node, val nright)
+{
+  type_check(lit("set-right"), node, TNOD);
+  node->tn.right = nright;
+  return node;
+}
+
+val set_key(val node, val nkey)
+{
+  type_check(lit("set-key"), node, TNOD);
+  node->tn.key = nkey;
+  return node;
+}
+
 val copy_tnode(val node)
 {
   val obj = (type_check(lit("copy-tnode"), node, TNOD), make_obj());
@@ -684,6 +705,9 @@ void tree_init(void)
   reg_fun(intern(lit("left"), user_package), func_n1(left));
   reg_fun(intern(lit("right"), user_package), func_n1(right));
   reg_fun(intern(lit("key"), user_package), func_n1(key));
+  reg_fun(intern(lit("set-left"), user_package), func_n2(set_left));
+  reg_fun(intern(lit("set-right"), user_package), func_n2(set_right));
+  reg_fun(intern(lit("set-key"), user_package), func_n2(set_key));
   reg_fun(intern(lit("copy-tnode"), user_package), func_n1(copy_tnode));
   reg_fun(tree_s, func_n4o(tree, 0));
   reg_fun(tree_construct_s, func_n2(tree_construct));
diff --git a/tree.h b/tree.h
index 0f056429..528bae7b 100644
--- a/tree.h
+++ b/tree.h
@@ -34,6 +34,9 @@ val tnodep(val obj);
 val left(val node);
 val right(val node);
 val key(val node);
+val set_left(val node, val nleft);
+val set_right(val node, val nright);
+val set_key(val node, val nkey);
 val copy_tnode(val node);
 val tree(val keys, val key_fn, val less_fn, val equal_fn);
 val treep(val obj);
diff --git a/txr.1 b/txr.1
index 5bc31393..7f718700 100644
--- a/txr.1
+++ b/txr.1
@@ -12804,6 +12804,9 @@ defined by \*(TX programs.
 .mets (sock-peer << socket )
 .mets (carray-sub < carray >> [ from <> [ to ]])
 .mets (sub-buf < buf >> [ from <> [ to ]])
+.mets (left << node )
+.mets (right << node )
+.mets (key << node )
 .onom
 
 .NP* Built-In Place-Mutating Operators
@@ -45215,11 +45218,15 @@ if
 is a tree node. Otherwise, it returns
 .codn nil .
 
-.coNP Functions @, key @ left and @ right
+.coNP Accessors @, key @ left and @ right
 .synb
 .mets (key << node )
 .mets (left << node )
 .mets (right << node )
+.mets (set (car << object ) << new-value )
+.mets (set (key << node ) << new-key )
+.mets (set (left << node ) << new-left )
+.mets (set (right << node ) << new-right )
 .syne
 .desc
 The
@@ -45232,6 +45239,59 @@ functions retrieve the corresponding fields of the
 object, which must be of type
 .codn tnode .
 
+Forms based on the
+.codn key ,
+.code left
+and
+.code right
+symbol are defined as syntactic places.
+Assigning a value
+.code v
+to
+.code "(key n)"
+using the
+.code set
+operator, as in
+.codn "(set (key n) v)" ,
+is equivalent to
+.code "(set-key n v)"
+except that the value of the expression is
+.code v
+rather than
+.codn n .
+Similar statements hold true for
+.code left
+and
+.code right
+in relation to
+.code set-left
+and
+.codn set-right .
+
+.coNP Functions @, set-key @ set-left and @ set-right
+.synb
+.mets (set-key < node << new-key )
+.mets (set-left < node << new-left )
+.mets (set-right < node << new-right )
+.syne
+.desc
+The
+.codn set-key ,
+.code set-left
+and
+.code set-right
+functions replace the corresponding fields of
+.meta node
+with new values.
+
+The
+.meta node
+argument must be of type
+.codn tnode .
+
+These functions all return
+.metn node .
+
 .coNP Function @ copy-tnode
 .synb
 .mets (copy-tnode << node )
-- 
cgit v1.2.3