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

VERSION

@@ -1 +1 @@
-0.5.47
+0.5.48

basis/srfi-1.ss

@@ -20,11 +20,10 @@
                 circular-list?
                 dotted-list?
                 null-list?
-                ; list=
                 list-ref
                 first second third fourth fifth sixth seventh eighth ninth tenth
                 ; car+cdr
-                take
+                take take!
                 drop
 
                 last
@@ -92,10 +91,6 @@
            (values (car pair)
                    (cdr pair)))
 
-         (define (take! x k)
-           (if (zero? k)
-               (begin (set-cdr! (drop x (- k 1)) '()) x)))
-
          (define (take-right x k)
            (let lp ((lag x)
                     (lead (drop x k)))

include/meevax/kernel/heterogeneous.hpp

@@ -51,7 +51,7 @@ inline namespace kernel
 
       auto compare([[maybe_unused]] Top const* top) const -> bool override
       {
-        if constexpr (is_equality_comparable_v<Bound>)
+        if constexpr (is_equality_comparable_v<Bound const&>)
         {
           if (auto const* bound = dynamic_cast<Bound const*>(top); bound)
           {
@@ -75,7 +75,7 @@ inline namespace kernel
 
       auto write(std::ostream & os) const -> std::ostream & override
       {
-        if constexpr (is_output_streamable_v<Bound>)
+        if constexpr (is_output_streamable_v<Bound const&>)
         {
           return os << static_cast<Bound const&>(*this);
         }
@@ -87,7 +87,7 @@ inline namespace kernel
 
       auto operator []([[maybe_unused]] std::size_t k) const -> heterogeneous const& override
       {
-        if constexpr (is_array_subscriptable_v<Bound>)
+        if constexpr (is_array_subscriptable_v<Bound const&>)
         {
           return static_cast<Bound const&>(*this)[k];
         }
@@ -96,6 +96,18 @@ inline namespace kernel
           throw std::runtime_error(lexical_cast<std::string>("no viable array subscript operator for ", demangle(type())));
         }
       }
+
+      auto operator []([[maybe_unused]] std::size_t k) -> heterogeneous & override
+      {
+        if constexpr (is_array_subscriptable_v<Bound &>)
+        {
+          return static_cast<Bound &>(*this)[k];
+        }
+        else
+        {
+          throw std::runtime_error(lexical_cast<std::string>("no viable array subscript operator for ", demangle(type())));
+        }
+      }
     };
 
   public:
@@ -236,6 +248,18 @@ inline namespace kernel
       }
     }
 
+    inline auto operator [](std::size_t k) -> heterogeneous &
+    {
+      if (dereferenceable() and *this)
+      {
+        return get()->operator [](k);
+      }
+      else
+      {
+        throw std::runtime_error(lexical_cast<std::string>("no viable array subscript operator for ", demangle(type())));
+      }
+    }
+
     friend auto operator <<(std::ostream & os, heterogeneous const& datum) -> std::ostream &
     {
       return datum.write(os);

include/meevax/kernel/list.hpp

@@ -157,6 +157,8 @@ inline namespace kernel
 
   auto take(object const&, std::size_t) -> object;
 
+  auto take(object &, std::size_t) -> object;
+
   template <typename T>
   auto drop(T&& x, std::size_t k) -> decltype(x)
   {

include/meevax/kernel/pair.hpp

@@ -52,22 +52,22 @@ inline namespace kernel
 
   struct pair : public std::pair<object, object>
   {
-    template <auto ReadOnly>
+    template <auto Const>
     struct forward_iterator
     {
       using iterator_category = std::forward_iterator_tag;
 
       using value_type = object;
 
-      using reference = std::add_lvalue_reference_t<std::conditional_t<ReadOnly, std::add_const_t<value_type>, value_type>>;
+      using reference = std::add_lvalue_reference_t<std::conditional_t<Const, std::add_const_t<value_type>, value_type>>;
 
       using pointer = std::add_pointer_t<reference>;
 
       using difference_type = std::ptrdiff_t;
 
       using size_type = std::size_t;
 
-      using node_type = std::conditional_t<ReadOnly, pair const*, pair *>;
+      using node_type = std::conditional_t<Const, pair const*, pair *>;
 
       node_type current = nullptr;
 
@@ -141,6 +141,8 @@ inline namespace kernel
 
     virtual auto operator [](std::size_t) const -> object const&;
 
+    virtual auto operator [](std::size_t) -> object &;
+
     constexpr auto begin() noexcept
     {
       return iterator(this);

include/meevax/kernel/vector.hpp

@@ -39,6 +39,8 @@ inline namespace kernel
     {}
 
     auto operator [](std::size_t) const -> object const&;
+
+    auto operator [](std::size_t) -> object &;
   };
 
   auto operator ==(heterogeneous_vector const&, heterogeneous_vector const&) -> bool;

src/kernel/boot.cpp

@@ -712,6 +712,11 @@ inline namespace kernel
         return take(xs[0], xs[1].as<exact_integer>());
       });
 
+      library.define<procedure>("take!", [](let & xs)
+      {
+        return take(xs[0], xs[1].as<exact_integer>());
+      });
+
       library.define<procedure>("drop", [](let const& xs)
       {
         return drop(xs[0], xs[1].as<exact_integer>());
@@ -1764,7 +1769,7 @@ inline namespace kernel
 
       library.define<procedure>("vector-set!", [](let & xs)
       {
-        xs[0].as<vector>().vector[xs[1].as<exact_integer>()] = xs[2];
+        xs[0][xs[1].as<exact_integer>()] = xs[2];
       });
 
       library.define<procedure>("vector->list", [](let const& xs)

src/kernel/list.cpp

@@ -128,7 +128,14 @@ inline namespace kernel
 
   auto list_copy(object const& xs) -> object
   {
-    return xs.is<pair>() ? cons(car(xs), list_copy(cdr(xs))) : xs;
+    if (xs.is<pair>())
+    {
+      return cons(car(xs), list_copy(cdr(xs)));
+    }
+    else
+    {
+      return xs;
+    }
   }
 
   auto take(object const& x, std::size_t k) -> object
@@ -143,6 +150,19 @@ inline namespace kernel
     }
   }
 
+  auto take(object & x, std::size_t k) -> object
+  {
+    if (0 < k)
+    {
+      cdr(drop(x, k - 1)) = unit;
+      return x;
+    }
+    else
+    {
+      return unit;
+    }
+  }
+
   auto length(object const& xs) -> std::size_t
   {
     return std::distance(xs.begin(), xs.end());

src/kernel/pair.cpp

@@ -46,6 +46,11 @@ inline namespace kernel
     return 0 < k ? second[--k] : first;
   }
 
+  auto pair::operator [](std::size_t k) -> object &
+  {
+    return 0 < k ? second[--k] : first;
+  }
+
   auto operator <<(std::ostream & os, pair const& datum) -> std::ostream &
   {
     if (is_circular_list(cdr(datum)))

src/kernel/vector.cpp

@@ -39,6 +39,11 @@ inline namespace kernel
     return vector[index];
   }
 
+  auto heterogeneous_vector::operator [](std::size_t index) -> object &
+  {
+    return vector[index];
+  }
+
   auto operator ==(heterogeneous_vector const& v, heterogeneous_vector const& u) -> bool
   {
     return std::equal(std::begin(v.vector), std::end(v.vector),

test/srfi-1.ss

@@ -12,7 +12,7 @@
               null-list?
               list=
               first second third fourth fifth sixth seventh eighth ninth tenth
-              take
+              take take!
               drop
               last
               last-pair
@@ -81,6 +81,13 @@
 (check (drop '(a b c d e) 4) => '(e))
 (check (drop '(a b c d e) 5) => '())
 
+(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)))
+
 (check (last '(a)) => 'a)
 (check (last '(a b)) => 'b)
 (check (last '(a b c)) => 'c)
@@ -96,4 +103,4 @@
 
 (check-report)
 
-(exit (check-passed? 57))
+(exit (check-passed? 69))