From 437aabddf643e69ba40e53ef3e8622b1bb8a556d Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 Oct 2023 13:51:37 +0900 Subject: [PATCH] Update procedures `take-right` and `drop-right` to built-in Signed-off-by: yamacir-kit --- README.md | 6 ++-- VERSION | 2 +- basis/srfi-1.ss | 17 ++-------- include/meevax/kernel/list.hpp | 19 ++++------- src/kernel/boot.cpp | 10 ++++++ src/kernel/list.cpp | 58 ++++++++++++++++++++++++++++++++++ test/srfi-1.ss | 26 ++++++++++++++- 7 files changed, 106 insertions(+), 32 deletions(-) diff --git a/README.md b/README.md index 798c4d0af..e651639bc 100644 --- a/README.md +++ b/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 diff --git a/VERSION b/VERSION index 0ab079f88..b19530f3d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.48 +0.5.49 diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index fea0e844c..efac2028e 100644 --- a/basis/srfi-1.ss +++ b/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) diff --git a/include/meevax/kernel/list.hpp b/include/meevax/kernel/list.hpp index 2b114a64e..423d27b9f 100644 --- a/include/meevax/kernel/list.hpp +++ b/include/meevax/kernel/list.hpp @@ -159,18 +159,13 @@ inline namespace kernel auto take(object &, std::size_t) -> object; - template - auto drop(T&& x, std::size_t k) -> decltype(x) - { - if (0 < k) - { - return drop(cdr(std::forward(x)), k - 1); - } - else - { - return std::forward(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; diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index c60254f2f..fdd0bb08f 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -717,11 +717,21 @@ inline namespace kernel return take(xs[0], xs[1].as()); }); + library.define("take-right", [](let const& xs) + { + return take_right(xs[0], xs[1].as()); + }); + library.define("drop", [](let const& xs) { return drop(xs[0], xs[1].as()); }); + library.define("drop-right", [](let const& xs) + { + return drop_right(xs[0], xs[1].as()); + }); + library.define("memq", [](let const& xs) -> auto const& { return memq(xs[0], xs[1]); diff --git a/src/kernel/list.cpp b/src/kernel/list.cpp index 35330ae99..33d10a056 100644 --- a/src/kernel/list.cpp +++ b/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()) + { + 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()) + { + 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()); diff --git a/test/srfi-1.ss b/test/srfi-1.ss index e00179938..1c6b82a70 100644 --- a/test/srfi-1.ss +++ b/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))