Update procedures take-right and drop-right to built-in

Signed-off-by: yamacir-kit <[email protected]>

README.md

@@ -91,7 +91,7 @@ Procedures for each standard are provided by the following R7RS-style libraries:
 cmake -B build -DCMAKE_BUILD_TYPE=Release
 cd build
 make package
-sudo apt install build/meevax_0.5.48_amd64.deb
+sudo apt install build/meevax_0.5.49_amd64.deb
 ```
 
 or
@@ -123,9 +123,9 @@ sudo rm -rf /usr/local/share/meevax
 
 | Target Name | Description
 |-------------|-------------
-| `all`       | Build shared-library `libmeevax.0.5.48.so` and executable `meevax`
+| `all`       | Build shared-library `libmeevax.0.5.49.so` and executable `meevax`
 | `test`      | Test executable `meevax`
-| `package`   | Generate debian package `meevax_0.5.48_amd64.deb`
+| `package`   | Generate debian package `meevax_0.5.49_amd64.deb`
 | `install`   | Copy files into `/usr/local` directly
 
 ## Usage

VERSION

@@ -1 +1 @@
-0.5.48
+0.5.49

basis/srfi-1.ss

@@ -25,6 +25,8 @@
                 ; car+cdr
                 take take!
                 drop
+                take-right
+                drop-right
 
                 last
                 last-pair
@@ -91,21 +93,6 @@
            (values (car pair)
                    (cdr pair)))
 
-         (define (take-right x k)
-           (let lp ((lag x)
-                    (lead (drop x k)))
-             (if (pair? lead)
-                 (lp (cdr lag)
-                     (cdr lead))
-                 lag)))
-
-         (define (drop-right x k)
-           (let rec ((lag x) (lead (drop x k)))
-             (if (pair? lead)
-                 (cons (car lag)
-                       (rec (cdr lag) (cdr lead)))
-                 '())))
-
          (define (drop-right! x k)
            (let ((lead (drop x k)))
              (if (pair? lead)

include/meevax/kernel/list.hpp

@@ -159,18 +159,13 @@ inline namespace kernel
 
   auto take(object &, std::size_t) -> object;
 
-  template <typename T>
-  auto drop(T&& x, std::size_t k) -> decltype(x)
-  {
-    if (0 < k)
-    {
-      return drop(cdr(std::forward<decltype(x)>(x)), k - 1);
-    }
-    else
-    {
-      return std::forward<decltype(x)>(x);
-    }
-  }
+  auto take_right(object const&, std::size_t) -> object const&;
+
+  auto drop(object const&, std::size_t) -> object const&;
+
+  auto drop(object &, std::size_t) -> object &;
+
+  auto drop_right(object const&, std::size_t) -> object;
 
   auto length(object const&) -> std::size_t;
 

src/kernel/boot.cpp

@@ -717,11 +717,21 @@ inline namespace kernel
         return take(xs[0], xs[1].as<exact_integer>());
       });
 
+      library.define<procedure>("take-right", [](let const& xs)
+      {
+        return take_right(xs[0], xs[1].as<exact_integer>());
+      });
+
       library.define<procedure>("drop", [](let const& xs)
       {
         return drop(xs[0], xs[1].as<exact_integer>());
       });
 
+      library.define<procedure>("drop-right", [](let const& xs)
+      {
+        return drop_right(xs[0], xs[1].as<exact_integer>());
+      });
+
       library.define<procedure>("memq", [](let const& xs) -> auto const&
       {
         return memq(xs[0], xs[1]);

src/kernel/list.cpp

@@ -163,6 +163,64 @@ inline namespace kernel
     }
   }
 
+  auto take_right(object const& x, object const& y) -> object const&
+  {
+    if (y.is<pair>())
+    {
+      return take_right(cdr(x), cdr(y));
+    }
+    else
+    {
+      return x;
+    }
+  }
+
+  auto take_right(object const& x, std::size_t k) -> object const&
+  {
+    return take_right(x, drop(x, k));
+  }
+
+  auto drop(object const& x, std::size_t k) -> object const&
+  {
+    if (0 < k)
+    {
+      return drop(cdr(x), k - 1);
+    }
+    else
+    {
+      return x;
+    }
+  }
+
+  auto drop(object & x, std::size_t k) -> object &
+  {
+    if (0 < k)
+    {
+      return drop(cdr(x), k - 1);
+    }
+    else
+    {
+      return x;
+    }
+  }
+
+  auto drop_right(object const& x, object const& y) -> object
+  {
+    if (y.is<pair>())
+    {
+      return cons(car(x), drop_right(cdr(x), cdr(y)));
+    }
+    else
+    {
+      return unit;
+    }
+  }
+
+  auto drop_right(object const& x, std::size_t k) -> object
+  {
+    return drop_right(x, drop(x, k));
+  }
+
   auto length(object const& xs) -> std::size_t
   {
     return std::distance(xs.begin(), xs.end());

test/srfi-1.ss

@@ -14,6 +14,8 @@
               first second third fourth fifth sixth seventh eighth ninth tenth
               take take!
               drop
+              take-right
+              drop-right
               last
               last-pair
               length+
@@ -81,6 +83,28 @@
 (check (drop '(a b c d e) 4) => '(e))
 (check (drop '(a b c d e) 5) => '())
 
+(check (take-right '(a b c d e) 0) => '())
+(check (take-right '(a b c d e) 1) => '(e))
+(check (take-right '(a b c d e) 2) => '(d e))
+(check (take-right '(a b c d e) 3) => '(c d e))
+(check (take-right '(a b c d e) 4) => '(b c d e))
+(check (take-right '(a b c d e) 5) => '(a b c d e))
+(check (take-right '(a b c . x) 0) => 'x)
+(check (take-right '(a b c . x) 1) => '(c . x))
+(check (take-right '(a b c . x) 2) => '(b c . x))
+(check (take-right '(a b c . x) 3) => '(a b c . x))
+
+(check (drop-right '(a b c d e) 0) => '(a b c d e))
+(check (drop-right '(a b c d e) 1) => '(a b c d))
+(check (drop-right '(a b c d e) 2) => '(a b c))
+(check (drop-right '(a b c d e) 3) => '(a b))
+(check (drop-right '(a b c d e) 4) => '(a))
+(check (drop-right '(a b c d e) 5) => '())
+(check (drop-right '(a b c . x) 0) => '(a b c))
+(check (drop-right '(a b c . x) 1) => '(a b))
+(check (drop-right '(a b c . x) 2) => '(a))
+(check (drop-right '(a b c . x) 3) => '())
+
 (let ((x '(a b c d e))) (check (take! x 0) => '()) (check x => '(a b c d e)))
 (let ((x '(a b c d e))) (check (take! x 1) => '(a)) (check x => '(a)))
 (let ((x '(a b c d e))) (check (take! x 2) => '(a b)) (check x => '(a b)))
@@ -103,4 +127,4 @@
 
 (check-report)
 
-(exit (check-passed? 69))
+(exit (check-passed? 89))