From 374509f247df16d40d2535a34237fa2f5dd5863e Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 28 Oct 2019 07:00:26 -0700
Subject: New function: identity*

An version of identity with lax argument conventions.

* eval.c (eval_init): Register identity* intrinsic.

* lib.c (identity_star_f): New symbol variable.
(identity_star): New function.
(obj_init): gc-protect identity_star_f variable, and
initialize it.

* lib.h (identity_star_f): Declared.

* txr.1: Documented.
---
 eval.c |  1 +
 lib.c  | 15 +++++++++++++--
 lib.h  |  3 ++-
 txr.1  | 11 +++++++++--
 4 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/eval.c b/eval.c
index 4e1c7aad..665c5d2a 100644
--- a/eval.c
+++ b/eval.c
@@ -6395,6 +6395,7 @@ void eval_init(void)
   reg_fun(list_s, list_f);
   reg_fun(list_star_s, func_n0v(list_star_intrinsic));
   reg_fun(identity_s, identity_f);
+  reg_fun(intern(lit("identity*"), user_package), identity_star_f);
   reg_fun(intern(lit("use"), user_package), identity_f);
   reg_fun(intern(lit("typeof"), user_package), func_n1(typeof));
   reg_fun(intern(lit("subtypep"), user_package), func_n2(subtypep));
diff --git a/lib.c b/lib.c
index 304bee3a..93b0a1fa 100644
--- a/lib.c
+++ b/lib.c
@@ -125,7 +125,8 @@ val null_string;
 val nil_string;
 val null_list;
 
-val identity_f, equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
+val identity_f, identity_star_f;
+val equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
 val list_f, less_f, greater_f;
 
 val prog_string;
@@ -164,6 +165,14 @@ val identity(val obj)
   return obj;
 }
 
+static val identity_star(varg args)
+{
+  int index = 0;
+  if (args_more(args, index))
+    return args_get(args, &index);
+  return nil;
+}
+
 static val code2type(int code)
 {
   switch (convert(type_t, code)) {
@@ -11026,7 +11035,8 @@ static void obj_init(void)
           &user_package, &public_package,
           &null_list, &equal_f, &eq_f, &eql_f,
           &car_f, &cdr_f, &null_f, &list_f,
-          &identity_f, &less_f, &greater_f, &prog_string, &env_list,
+          &identity_f, &identity_star_f, &less_f, &greater_f,
+          &prog_string, &env_list,
           convert(val *, 0));
 
   nil_string = lit("nil");
@@ -11184,6 +11194,7 @@ static void obj_init(void)
   eq_f = func_n2(eq);
   eql_f = func_n2(eql);
   identity_f = func_n1(identity);
+  identity_star_f = func_n0v(identity_star);
   car_f = func_n1(car);
   cdr_f = func_n1(cdr);
   null_f = func_n1(null);
diff --git a/lib.h b/lib.h
index 27ae3a20..4ac4f3b1 100644
--- a/lib.h
+++ b/lib.h
@@ -516,7 +516,8 @@ extern val nothrow_k, args_k, colon_k, auto_k, fun_k;
 extern val null_string;
 extern val null_list; /* (nil) */
 
-extern val identity_f, equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
+extern val identity_f, identity_star_f;
+extern val equal_f, eql_f, eq_f, car_f, cdr_f, null_f;
 extern val list_f, less_f, greater_f;
 
 extern val prog_string;
diff --git a/txr.1 b/txr.1
index c4d2dd98..2cf8eb8c 100644
--- a/txr.1
+++ b/txr.1
@@ -17743,9 +17743,10 @@ previous clauses match.
 
 .SS* Object Equivalence
 
-.coNP Functions @ identity and @ use
+.coNP Functions @, identity @ identity and @ use
 .synb
 .mets (identity << value )
+.mets (identity* << value *)
 .mets (use << value )
 .syne
 .desc
@@ -17753,9 +17754,15 @@ The
 .code identity
 function returns its argument.
 
+If the
+.code identity*
+function is given at least one argument, then it returns its
+leftmost argument, otherwise it returns nil.
+
 The
 .code use
-function is a synonym.
+function is a synonym of
+.codn identity .
 
 .TP* Notes:
 The
-- 
cgit v1.2.3