base-name: optionally remove suffix.

The base-name function now takes a second argument which is
optional, specifying a suffix to be removed. The behavior is
similar to that of the second argument of the POSIX basename
command.

* stream.c (base_name): Second argument added. If present, the
returned value is adjusted by trimming the suffix, unless that
would cause an empty string to be returned.
(stream_init): Update registration of base-name intrinsic.

* stream.h (base_name): Declaration updated.

* txr.1: New base-name parameter documented.

3 files changed, 20 insertions, 5 deletions

diff --git a/stream.c b/stream.c
index 4cad323d..5e0073ed 100644
--- a/stream.c
+++ b/stream.c
@@ -4486,7 +4486,7 @@ static void detect_path_separators(void)
 #endif
 }
 
-val base_name(val path)
+val base_name(val path, val suff)
 {
   const wchar_t *wpath = c_str(path);
   const wchar_t *end = wpath + c_num(length_str(path));
@@ -4510,7 +4510,11 @@ val base_name(val path)
 
   {
     val base = mkustring(num_fast(end - rsep));
-    return init_str(base, rsep);
+    init_str(base, rsep);
+    return if3(!null_or_missing_p(suff) && ends_with(suff, base, nil, nil) &&
+               neql(length(suff), length(base)),
+               sub(base, zero, neg(length(suff))),
+               base);
   }
 }
 
@@ -4771,7 +4775,7 @@ void stream_init(void)
   reg_fun(intern(lit("open-files*"), user_package), func_n2o(open_files_star, 1));
   reg_fun(intern(lit("abs-path-p"), user_package), func_n1(abs_path_p));
   reg_fun(intern(lit("pure-rel-path-p"), user_package), func_n1(pure_rel_path_p));
-  reg_fun(intern(lit("base-name"), user_package), func_n1(base_name));
+  reg_fun(intern(lit("base-name"), user_package), func_n2o(base_name, 1));
   reg_fun(intern(lit("dir-name"), user_package), func_n1(dir_name));
   reg_fun(intern(lit("path-cat"), user_package), func_n2(path_cat));
   reg_varl(intern(lit("path-sep-chars"), user_package), static_str(path_sep_chars));
diff --git a/stream.h b/stream.h
index bc83122c..9bae897c 100644
--- a/stream.h
+++ b/stream.h
@@ -236,7 +236,7 @@ val remove_path(val path, val throw_on_error);
 val rename_path(val from, val to);
 val abs_path_p(val path);
 val pure_rel_path_p(val path);
-val base_name(val path);
+val base_name(val path, val suff);
 val dir_name(val path);
 val path_cat(val dir_name, val base_name);
 val make_byte_input_stream(val obj);
diff --git a/txr.1 b/txr.1
index ae2f3563..c46a07a5 100644
--- a/txr.1
+++ b/txr.1
@@ -48234,7 +48234,7 @@ Examples of strings which are not pure relative paths:
 .coNP Functions @ dir-name and @ base-name
 .synb
 .mets (dir-name << path )
-.mets (base-name << path )
+.mets (base-name < path <> [ suffix ])
 .syne
 .desc
 The
@@ -48300,6 +48300,17 @@ The
 function returns the remaining part of the effective path, after
 the raw directory prefix.
 
+If the
+.meta suffix
+argument is given to
+.codn base-name ,
+then the returned base name is adjusted as follows. If the base
+name ends in
+.meta suffix
+then a trimmed version of the base name is returned instead, with that suffix
+removed. This adjustment isn't performed if it would result in an empty
+string being returned.
+
 .coNP Function @ path-cat
 .synb
 .mets (path-cat < dir-path << rel-path )