Support SRFI 111

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

Author: yamacir-kit

README.md

@@ -55,6 +55,7 @@ Subset of R7RS-small.
 | [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html)   | Lightweight testing                                    | [`(srfi 78)`](./basis/srfi-78.ss)   | Except `check-ec` |
 | [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html)   | => in case clauses                                     |                                     | R7RS 4.2.1        |
 | [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html)   | An interface to access environment variables           | [`(srfi 98)`](./basis/srfi-98.ss)   | R7RS 6.14         |
+| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes                                                  | [`(srfi 111)`](./basis/srfi-111.ss) |                   |
 | [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions                 | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2        |
 
 ## Installation
@@ -73,7 +74,7 @@ Subset of R7RS-small.
 cmake -B build -DCMAKE_BUILD_TYPE=Release
 cd build
 make package
-sudo apt install build/meevax_0.4.778_amd64.deb
+sudo apt install build/meevax_0.4.779_amd64.deb
 ```
 
 or
@@ -105,15 +106,15 @@ sudo rm -rf /usr/local/share/meevax
 
 | Target Name     | Description
 |-----------------|-------------
-| `all` (default) | Build shared-library `libmeevax.0.4.778.so` and executable `meevax`
+| `all` (default) | Build shared-library `libmeevax.0.4.779.so` and executable `meevax`
 | `test`          | Test executable `meevax`
-| `package`       | Generate debian package `meevax_0.4.778_amd64.deb`
+| `package`       | Generate debian package `meevax_0.4.779_amd64.deb`
 | `install`       | Copy files into `/usr/local` directly
 
 ## Usage
 
 ```
-Meevax Lisp 0.4.778
+Meevax Lisp 0.4.779
 
 Usage:
   meevax [option...] [file...]

VERSION

@@ -1 +1 @@
-0.4.778
+0.4.779

basis/srfi-111.ss

@@ -0,0 +1,3 @@
+(define-library (srfi 111)
+  (import (meevax box))
+  (export box box? (rename box-ref unbox) (rename box-set! set-box!)))

configure/README.md

@@ -55,6 +55,7 @@ Subset of R7RS-small.
 | [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html)   | Lightweight testing                                    | [`(srfi 78)`](./basis/srfi-78.ss)   | Except `check-ec` |
 | [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html)   | => in case clauses                                     |                                     | R7RS 4.2.1        |
 | [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html)   | An interface to access environment variables           | [`(srfi 98)`](./basis/srfi-98.ss)   | R7RS 6.14         |
+| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes                                                  | [`(srfi 111)`](./basis/srfi-111.ss) |                   |
 | [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions                 | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2        |
 
 ## Installation

configure/basis.cpp

@@ -44,6 +44,7 @@ inline namespace kernel
       R"##(${${PROJECT_NAME}_BASIS_srfi-45.ss})##",
       R"##(${${PROJECT_NAME}_BASIS_srfi-78.ss})##",
       R"##(${${PROJECT_NAME}_BASIS_srfi-98.ss})##",
+      R"##(${${PROJECT_NAME}_BASIS_srfi-111.ss})##",
       R"##(${${PROJECT_NAME}_BASIS_srfi-149.ss})##",
     };
   }

include/meevax/kernel/box.hpp

@@ -0,0 +1,35 @@
+/*
+   Copyright 2018-2023 Tatsuya Yamasaki.
+
+   Licensed under the Apache License, Version 2.0 (the "License");
+   you may not use this file except in compliance with the License.
+   You may obtain a copy of the License at
+
+       http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS,
+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+   See the License for the specific language governing permissions and
+   limitations under the License.
+*/
+
+#ifndef INCLUDED_MEEVAX_KERNEL_BOX_HPP
+#define INCLUDED_MEEVAX_KERNEL_BOX_HPP
+
+#include <meevax/kernel/pair.hpp>
+
+namespace meevax
+{
+inline namespace kernel
+{
+  struct box : public virtual pair // (value . unit)
+  {
+    using pair::pair;
+  };
+
+  auto operator <<(std::ostream &, box const&) -> std::ostream &;
+} // namespace kernel
+} // namespace meevax
+
+#endif // INCLUDED_MEEVAX_KERNEL_BOX_HPP

src/kernel/box.cpp

@@ -0,0 +1,28 @@
+/*
+   Copyright 2018-2023 Tatsuya Yamasaki.
+
+   Licensed under the Apache License, Version 2.0 (the "License");
+   you may not use this file except in compliance with the License.
+   You may obtain a copy of the License at
+
+       http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS,
+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+   See the License for the specific language governing permissions and
+   limitations under the License.
+*/
+
+#include <meevax/kernel/box.hpp>
+
+namespace meevax
+{
+inline namespace kernel
+{
+  auto operator <<(std::ostream & os, box const& datum) -> std::ostream &
+  {
+    return os << magenta("#,(") << green("box ") << datum.first << magenta(")");
+  }
+} // namespace kernel
+} // namespace meevax

src/kernel/comparator.cpp

@@ -14,45 +14,25 @@
    limitations under the License.
 */
 
+#include <meevax/kernel/box.hpp>
 #include <meevax/kernel/list.hpp>
 
 namespace meevax
 {
 inline namespace kernel
 {
-  struct box : public virtual pair // (value . unit)
-  {
-    auto unbox() -> object &
-    {
-      return first;
-    }
-
-    auto unbox() const -> object const&
-    {
-      return first;
-    }
-
-    auto set(object const& x) -> object const&
-    {
-      return first = x;
-    }
-  };
-
   auto find(let const& b) -> object const&
   {
-    if (let x = b.as<box>().unbox(); x.is<box>())
+    if (let & x = car(b); x.is<box>())
     {
-      return b.as<box>().set(find(x));
+      return x = find(x);
     }
     else
     {
       return b;
     }
   }
 
-  /*
-     Efficient Nondestructive Equality Checking for Trees and Graphs
-  */
   auto union_find(object const& x, object const& y, std::unordered_map<object, object> & forest)
   {
     using rank = std::uint32_t;
@@ -68,16 +48,16 @@ inline namespace kernel
         }
         else
         {
-          if (auto rank_x = root_x.as<box>().unbox().as<rank>(),
-                   rank_y = root_y.as<box>().unbox().as<rank>(); rank_x > rank_y)
+          if (auto rank_x = car(root_x).as<rank>(),
+                   rank_y = car(root_y).as<rank>(); rank_x > rank_y)
           {
-            root_x.as<box>().set(make<rank>(rank_x + rank_y));
-            root_y.as<box>().set(root_x);
+            car(root_x) = make<rank>(rank_x + rank_y);
+            car(root_y) = root_x;
           }
           else
           {
-            root_x.as<box>().set(root_y);
-            root_y.as<box>().set(make<rank>(rank_x + rank_y));
+            car(root_x) = root_y;
+            car(root_y) = make<rank>(rank_x + rank_y);
           }
         }
       }
@@ -103,6 +83,9 @@ inline namespace kernel
     return false;
   }
 
+  /*
+     Efficient Nondestructive Equality Checking for Trees and Graphs
+  */
   auto equal(object const& x, object const& y, std::unordered_map<object, object> & forest) -> bool
   {
     return eqv(x, y) or (x.is<pair>() and

src/kernel/library.cpp

@@ -21,6 +21,7 @@
 #include <meevax/kernel/basis.hpp>
 #include <meevax/kernel/binary_input_file_port.hpp>
 #include <meevax/kernel/binary_output_file_port.hpp>
+#include <meevax/kernel/box.hpp>
 #include <meevax/kernel/disassemble.hpp>
 #include <meevax/kernel/input_file_port.hpp>
 #include <meevax/kernel/input_homogeneous_vector_port.hpp>
@@ -126,6 +127,29 @@ inline namespace kernel
 
   auto boot() -> void
   {
+    define<library>("(meevax box)", [](library & library)
+    {
+      library.define<procedure>("box", [](let const& xs)
+      {
+        return make<box>(car(xs));
+      });
+
+      library.define<procedure>("box?", [](let const& xs)
+      {
+        return car(xs).is<box>();
+      });
+
+      library.define<procedure>("box-ref", [](let const& xs)
+      {
+        return caar(xs);
+      });
+
+      library.define<procedure>("box-set!", [](let const& xs)
+      {
+        return caar(xs) = cadr(xs);
+      });
+    });
+
     define<library>("(meevax character)", [](library & library)
     {
       library.define<procedure>("char?", [](let const& xs)

test/r7rs.ss

@@ -50,8 +50,8 @@
 ; ---- 2.2. --------------------------------------------------------------------
 
 #|
-  The FACT procedure computes the factorial
-  of a non-negative integer.
+   The FACT procedure computes the factorial
+   of a non-negative integer.
 |#
 (define fact
   (lambda (n)