New function: trim-path-seps

* stream.c (trim_path_seps): New function.
(stream_init): trim-path-seps intrinsic registered.

* stream.c (trim_path_seps): Declared.

* tests/018/path.tl: New tests.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

5 files changed, 111 insertions, 0 deletions

diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 7301068a..ea778779 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -2045,6 +2045,7 @@
       ("trie-value-at" "N-012A1BAD")
       ("trim-left" "N-00CF29CC")
       ("trim-long-suffix" "N-03CAC692")
+      ("trim-path-seps" "N-0362D31C")
       ("trim-right" "N-00CF29CC")
       ("trim-short-suffix" "N-03CAC692")
       ("trim-str" "N-00E6E63B")
diff --git a/stream.c b/stream.c
index 34a5ae31..fb0dae68 100644
--- a/stream.c
+++ b/stream.c
@@ -5236,6 +5236,24 @@ val trim_long_suffix(val name)
   }
 }
 
+val trim_path_seps(val name)
+{
+  val self = lit("trim-path-seps");
+  const wchar_t *str = c_str(name, self);
+  const wchar_t *psc = L"/\\";
+  const wchar_t *fsl = 0;
+  cnum len = c_num(length_str(name), self);
+
+  if (portable_abs_path_p(name))
+    fsl = wcspbrk(str, psc);
+
+  while (len-- > 0)
+    if (!wcschr(psc, str[len]) || str + len == fsl)
+      break;
+
+  return string_own(chk_substrdup(str, 0, len + 1));
+}
+
 val add_suffix(val name, val suffix)
 {
   val self = lit("add-suffix");
@@ -5604,6 +5622,7 @@ void stream_init(void)
   reg_fun(intern(lit("long-suffix"), user_package), func_n2o(long_suffix, 1));
   reg_fun(intern(lit("trim-short-suffix"), user_package), func_n1(trim_short_suffix));
   reg_fun(intern(lit("trim-long-suffix"), user_package), func_n1(trim_long_suffix));
+  reg_fun(intern(lit("trim-path-seps"), user_package), func_n1(trim_path_seps));
   reg_fun(intern(lit("path-cat"), user_package), func_n0v(path_vcat));
   reg_fun(intern(lit("add-suffix"), user_package), func_n2(add_suffix));
   reg_varl(intern(lit("path-sep-chars"), user_package), static_str(path_sep_chars));
diff --git a/stream.h b/stream.h
index bb041d60..91fc0ecb 100644
--- a/stream.h
+++ b/stream.h
@@ -263,6 +263,7 @@ val short_suffix(val name, val alt_in);
 val long_suffix(val name, val alt_in);
 val trim_short_suffix(val name);
 val trim_long_suffix(val name);
+val trim_path_seps(val name);
 val path_cat(val dir_name, val base_name);
 val add_suffix(val name, val suffix);
 val make_byte_input_stream(val obj);
diff --git a/tests/018/path.tl b/tests/018/path.tl
index 49aebe11..dd22339f 100644
--- a/tests/018/path.tl
+++ b/tests/018/path.tl
@@ -280,3 +280,41 @@
   (pure-rel-path-p "abc/.") t
   (pure-rel-path-p "abc\\def") t
   (pure-rel-path-p "abc\\.") t)
+
+(mtest
+  (trim-path-seps "") ""
+  (trim-path-seps "/") "/"
+  (trim-path-seps "//") "/"
+  (trim-path-seps "///") "/"
+  (trim-path-seps "a///") "a"
+  (trim-path-seps "/a///") "/a")
+
+(mtest
+  (trim-path-seps "c:/") "c:/"
+  (trim-path-seps "c://") "c:/"
+  (trim-path-seps "c:///") "c:/"
+  (trim-path-seps "c:a///") "c:a"
+  (trim-path-seps "/c:/a///") "/c:/a"
+  (trim-path-seps "/c://///") "/c:")
+
+(mtest
+  (trim-path-seps "\\") "\\"
+  (trim-path-seps "\\\\") "\\"
+  (trim-path-seps "\\\\\\") "\\"
+  (trim-path-seps "a\\\\\\") "a"
+  (trim-path-seps "\\a\\\\\\") "\\a")
+
+(mtest
+  (trim-path-seps "c:\\") "c:\\"
+  (trim-path-seps "c:\\\\") "c:\\"
+  (trim-path-seps "c:\\\\\\") "c:\\"
+  (trim-path-seps "c:a\\\\\\") "c:a"
+  (trim-path-seps "\\c:\\a\\\\\\") "\\c:\\a"
+  (trim-path-seps "\\c:\\\\\\\\\\") "\\c:")
+
+(mtest
+  (trim-path-seps "/c:\\") "/c:"
+  (trim-path-seps "c:/\\/\\/") "c:/"
+  (trim-path-seps "c:a\\\\\\") "c:a"
+  (trim-path-seps "\\c:\\a/\\\\\\") "\\c:\\a"
+  (trim-path-seps "/c:\\\\\\\\\\") "/c:")
diff --git a/txr.1 b/txr.1
index 16f8868e..3f7a4170 100644
--- a/txr.1
+++ b/txr.1
@@ -61248,6 +61248,58 @@ The above semantics imply that the following equivalence holds:
   (path-cat "a" "b" "" "c" "/")  -->  "a/b/c/"
 .brev
 
+.coNP Function @ trim-path-seps
+.synb
+.mets (trim-path-seps << path )
+.syne
+.desc
+The
+.code trim-path-seps
+function removes a consecutive run of one or more trailing separators from the
+end of the input string
+.metn path .
+
+The function treats the
+.mets path
+in a system-independent way: both the backslash and forward slash
+are considered a trailing separator.
+
+The function preserves any necessary trailing separators, such as that of
+the absolute path
+.str /
+or the trailing slashes in volume absolute paths such as
+.strn c:/ .
+
+.TP* Examples:
+
+.verb
+  (trim-path-seps "") -> ""
+  (trim-path-seps "/") -> "/"
+  (trim-path-seps "//") -> "/"
+  (trim-path-seps "a///") -> "a"
+  (trim-path-seps "/a///") -> "/a")
+
+  (trim-path-seps "\e\e") -> "\e\e"
+  (trim-path-seps "\e\e\e\e") -> "\e\e"
+  (trim-path-seps "\e\ea\e\e\e\e\e\e") -> "\e\ea")
+
+  (trim-path-seps "c:/") -> "c:/"
+  (trim-path-seps "c://") -> "c:/"
+  (trim-path-seps "c:///") -> "c:/"
+  (trim-path-seps "c:a///") -> "c:a"
+
+  ;; not a volume prefix:
+  (trim-path-seps "/c:/a///") -> "/c:/a"
+  (trim-path-seps "/c://///") -> "/c:")
+
+  (trim-path-seps "c:\e\e") -> "c:\e\e"
+  (trim-path-seps "c:\e\e\e\e") -> "c:\e\e"
+  (trim-path-seps "c:a\e\e\e\e\e\e") -> "c:a"
+
+  ;; mixtures
+  (trim-path-seps "c:/\e\e/\e\e/") -> "c:/"
+.brev
+
 .coNP Function @ rel-path
 .synb
 .mets (rel-path < from-path << to-path )