Update procedure 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.49_amd64.deb
+sudo apt install build/meevax_0.5.50_amd64.deb
 ```
 
 or
@@ -123,9 +123,9 @@ sudo rm -rf /usr/local/share/meevax
 
 | Target Name | Description
 |-------------|-------------
-| `all`       | Build shared-library `libmeevax.0.5.49.so` and executable `meevax`
+| `all`       | Build shared-library `libmeevax.0.5.50.so` and executable `meevax`
 | `test`      | Test executable `meevax`
-| `package`   | Generate debian package `meevax_0.5.49_amd64.deb`
+| `package`   | Generate debian package `meevax_0.5.50_amd64.deb`
 | `install`   | Copy files into `/usr/local` directly
 
 ## Usage

VERSION

@@ -1 +1 @@
-0.5.49
+0.5.50

basis/srfi-1.ss

@@ -16,17 +16,10 @@
                 )
           (only (meevax list)
                 list make-list list-copy circular-list iota null?
-                list?
-                circular-list?
-                dotted-list?
-                null-list?
-                list-ref
-                first second third fourth fifth sixth seventh eighth ninth tenth
-                ; car+cdr
-                take take!
-                drop
-                take-right
-                drop-right
+                list? circular-list? dotted-list? null-list?
+                list-ref first second third fourth fifth sixth seventh eighth ninth tenth
+                take take! take-right
+                drop drop-right drop-right!
 
                 last
                 last-pair
@@ -93,17 +86,6 @@
            (values (car pair)
                    (cdr pair)))
 
-         (define (drop-right! x k)
-           (let ((lead (drop x k)))
-             (if (pair? lead)
-                 (let rec ((lag x)
-                           (lead (cdr lead)))
-                   (if (pair? lead)
-                       (rec (cdr lag)
-                            (cdr lead))
-                       (begin (set-cdr! lag '()) x)))
-                 '())))
-
          (define (split-at x k)
            (let recur ((lis x) (k k))
              (if (zero? k) (values '() lis)

include/meevax/kernel/list.hpp

@@ -167,6 +167,8 @@ inline namespace kernel
 
   auto drop_right(object const&, std::size_t) -> object;
 
+  auto drop_right(object &, std::size_t) -> object;
+
   auto length(object const&) -> std::size_t;
 
   auto append(object const&, object const&) -> object;

src/kernel/boot.cpp

@@ -732,6 +732,11 @@ inline namespace kernel
         return drop_right(xs[0], xs[1].as<exact_integer>());
       });
 
+      library.define<procedure>("drop-right!", [](let & 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

@@ -221,6 +221,31 @@ inline namespace kernel
     return drop_right(x, drop(x, k));
   }
 
+  auto drop_right(object & x, object const& y) -> void
+  {
+    if (y.is<pair>())
+    {
+      drop_right(cdr(x), cdr(y));
+    }
+    else
+    {
+      cdr(x) = unit;
+    }
+  }
+
+  auto drop_right(object & x, std::size_t k) -> object
+  {
+    if (let const y = drop(x, k); y.is<pair>())
+    {
+      drop_right(x, cdr(y));
+      return x;
+    }
+    else
+    {
+      return unit;
+    }
+  }
+
   auto length(object const& xs) -> std::size_t
   {
     return std::distance(xs.begin(), xs.end());

test/srfi-1.ss

@@ -15,7 +15,7 @@
               take take!
               drop
               take-right
-              drop-right
+              drop-right drop-right!
               last
               last-pair
               length+
@@ -105,13 +105,24 @@
 (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)))
-(let ((x '(a b c d e))) (check (take! x 3) => '(a b c)) (check x => '(a b c)))
-(let ((x '(a b c d e))) (check (take! x 4) => '(a b c d)) (check x => '(a b c d)))
+(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)))
+(let ((x '(a b c d e))) (check (take! x 3) => '(a b c))     (check x => '(a b c)))
+(let ((x '(a b c d e))) (check (take! x 4) => '(a b c d))   (check x => '(a b c d)))
 (let ((x '(a b c d e))) (check (take! x 5) => '(a b c d e)) (check x => '(a b c d e)))
 
+(let ((x '(a b c d e))) (check (drop-right! x 0) => '(a b c d e)) (check x => '(a b c d e)))
+(let ((x '(a b c d e))) (check (drop-right! x 1) => '(a b c d))   (check x => '(a b c d)))
+(let ((x '(a b c d e))) (check (drop-right! x 2) => '(a b c))     (check x => '(a b c)))
+(let ((x '(a b c d e))) (check (drop-right! x 3) => '(a b))       (check x => '(a b)))
+(let ((x '(a b c d e))) (check (drop-right! x 4) => '(a))         (check x => '(a)))
+(let ((x '(a b c d e))) (check (drop-right! x 5) => '())          (check x => '(a b c d e)))
+(let ((x '(a b c . z))) (check (drop-right! x 0) => '(a b c))     (check x => '(a b c)))
+(let ((x '(a b c . z))) (check (drop-right! x 1) => '(a b))       (check x => '(a b)))
+(let ((x '(a b c . z))) (check (drop-right! x 2) => '(a))         (check x => '(a)))
+(let ((x '(a b c . z))) (check (drop-right! x 3) => '())          (check x => '(a b c . z)))
+
 (check (last '(a)) => 'a)
 (check (last '(a b)) => 'b)
 (check (last '(a b c)) => 'c)
@@ -127,4 +138,4 @@
 
 (check-report)
 
-(exit (check-passed? 89))
+(exit (check-passed? 109))