From 403621e02a8c36becd66847497fad642241f71ac Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 May 2022 04:38:46 +0900 Subject: [PATCH 01/49] Remove member function template `import(std::integer_sequence) -> void` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- include/meevax/kernel/environment.hpp | 16 +++++-- src/library/meevax.cpp | 65 +-------------------------- src/main.cpp | 2 +- test/environment.cpp | 2 +- 6 files changed, 19 insertions(+), 74 deletions(-) diff --git a/README.md b/README.md index ea3b8fd77..c937df02c 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.970.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.972.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.970_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.972_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.970 +Meevax Lisp System, version 0.3.972 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index b07bb1d95..3ef1f35fd 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.970 +0.3.972 diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 25a3a4903..532f41cae 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -27,6 +27,14 @@ namespace meevax { inline namespace kernel { + inline namespace experimental + { + struct master_t + { + explicit master_t() = default; + } constexpr master; + } // namespace experimental + class environment : public virtual pair , public configurator , public machine @@ -51,8 +59,11 @@ inline namespace kernel explicit environment(environment const&) = default; + explicit environment(master_t); + template ...)> explicit environment(Ts&&... xs) + : environment { master } { import(), (import(xs), ...); } @@ -79,7 +90,7 @@ inline namespace kernel auto execute(const_reference) -> object; - auto fork() const + auto fork() const -> object { return make(*this); } @@ -95,9 +106,6 @@ inline namespace kernel auto global() const noexcept -> const_reference; - template - auto import(std::integer_sequence) -> void; - auto import() -> void; auto load(std::string const&) -> object; diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 6a1524d47..47f6e3240 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -20,8 +20,7 @@ namespace meevax { - template <> - auto environment::import(decltype("(meevax base)"_s)) -> void + environment::environment(master_t) { define("begin", machine::begin); define("call-with-current-continuation!", call_with_current_continuation); @@ -1557,11 +1556,7 @@ namespace meevax { return features(); }); - } - template <> - auto environment::import(decltype("(meevax character)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (digit-value char) char library procedure @@ -1603,11 +1598,7 @@ namespace meevax * arguments before invoking the corresponding procedures without "-ci". * * ---------------------------------------------------------------------- */ - } - template <> - auto environment::import(decltype("(meevax cxr)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (caaar pair) cxr library procedure @@ -1652,11 +1643,7 @@ namespace meevax define("cddadr", [](let const& xs) { return cddadr(car(xs)); }); define("cdddar", [](let const& xs) { return cdddar(car(xs)); }); define("cddddr", [](let const& xs) { return cddddr(car(xs)); }); - } - template <> - auto environment::import(decltype("(meevax evaluate)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (eval expr-or-def environment-specifier) eval library procedure @@ -1673,11 +1660,7 @@ namespace meevax { return cadr(xs).as().mac_env.as().evaluate(car(xs)); // DIRTY HACK! }); - } - template <> - auto environment::import(decltype("(meevax inexact)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (finite? z) inexact library procedure @@ -1767,11 +1750,7 @@ namespace meevax throw invalid_application(intern("atan") | xs); } }); - } - template <> - auto environment::import(decltype("(meevax load)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (load filename) load library procedure @@ -1799,11 +1778,7 @@ namespace meevax { return load(car(xs).as()); }); - } - template <> - auto environment::import(decltype("(meevax process-context)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (emergency-exit) process-context library procedure @@ -1840,11 +1815,7 @@ namespace meevax throw invalid_application(intern("emergency-exit") | xs); } }); - } - template <> - auto environment::import(decltype("(meevax read)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (read) read library procedure @@ -1895,11 +1866,7 @@ namespace meevax return make(error); } }); - } - template <> - auto environment::import(decltype("(meevax write)"_s)) -> void - { /* ------------------------------------------------------------------------- * * (write-simple obj) write library procedure @@ -1916,11 +1883,7 @@ namespace meevax write(cadr(xs), car(xs)); return unspecified_object; }); - } - template <> - auto environment::import(decltype("(meevax experimental)"_s)) -> void - { define("make-syntactic-closure", [](let const& xs) { return make(car(xs), cadr(xs), caddr(xs)); @@ -2074,11 +2037,7 @@ namespace meevax return standard_output; }); - } - template <> - auto environment::import(decltype("(meevax garbage-collector)"_s)) -> void - { define("gc-collect", [](auto&&...) { return make(gc.collect()); @@ -2088,11 +2047,7 @@ namespace meevax { return make(gc.count()); }); - } - template <> - auto environment::import(decltype("(meevax srfis)"_s)) -> void - { std::vector const codes { overture, srfi_8, @@ -2117,22 +2072,4 @@ namespace meevax } } } - - template <> - auto environment::import(decltype("(meevax interaction-environment)"_s)) -> void - { - import("(meevax base)"_s); - import("(meevax character)"_s); - import("(meevax cxr)"_s); - import("(meevax evaluate)"_s); - import("(meevax inexact)"_s); - import("(meevax load)"_s); - import("(meevax process-context)"_s); - import("(meevax read)"_s); - import("(meevax write)"_s); - - import("(meevax experimental)"_s); - import("(meevax garbage-collector)"_s); - import("(meevax srfis)"_s); - } } // namespace meevax diff --git a/src/main.cpp b/src/main.cpp index b6678d88c..65cad07bb 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -23,7 +23,7 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - auto main = environment("(meevax interaction-environment)"_s); + auto main = environment(master); main.configure(argc, argv); diff --git a/test/environment.cpp b/test/environment.cpp index 84f3263a8..d82b6556c 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,7 +24,7 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - auto root = environment("(meevax interaction-environment)"_s); + auto root = environment(master); } environment::symbols.clear(); From 8c296c0ff8a53b60752c4340915bc74b2c41eacf Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 May 2022 05:09:20 +0900 Subject: [PATCH 02/49] Remove member function `environment::import` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- include/meevax/kernel/environment.hpp | 18 ++++++++++++++---- src/kernel/environment.cpp | 10 ---------- test/environment.cpp | 4 +++- 5 files changed, 21 insertions(+), 19 deletions(-) diff --git a/README.md b/README.md index c937df02c..d2be4ed5b 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.972.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.973.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.972_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.973_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.972 +Meevax Lisp System, version 0.3.973 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 3ef1f35fd..cf43cd928 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.972 +0.3.973 diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 532f41cae..e202188ad 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -61,11 +61,23 @@ inline namespace kernel explicit environment(master_t); - template ...)> + template ...)> explicit environment(Ts&&... xs) : environment { master } { - import(), (import(xs), ...); + auto import = [](auto&& x) + { + std::cout << x << std::endl; + }; + + (import(xs), ...); + + define("set-batch!", [this](let const& xs, auto&&...) { return batch = car(xs); }); + define("set-debug!", [this](let const& xs, auto&&...) { return debug = car(xs); }); + define("set-interactive!", [this](let const& xs, auto&&...) { return interactive = car(xs); }); + define("set-prompt!", [this](let const& xs, auto&&...) { return prompt = car(xs); }); + define("set-trace!", [this](let const& xs, auto&&...) { return trace = car(xs); }); + define("set-verbose!", [this](let const& xs, auto&&...) { return verbose = car(xs); }); } auto operator [](const_reference) -> const_reference; @@ -106,8 +118,6 @@ inline namespace kernel auto global() const noexcept -> const_reference; - auto import() -> void; - auto load(std::string const&) -> object; auto scope() const noexcept -> const_reference; diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index d368540d6..6e5aa0e49 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -118,16 +118,6 @@ inline namespace kernel return second; } - auto environment::import() -> void - { - define("set-batch!", [this](let const& xs, auto&&...) { return batch = car(xs); }); - define("set-debug!", [this](let const& xs, auto&&...) { return debug = car(xs); }); - define("set-interactive!", [this](let const& xs, auto&&...) { return interactive = car(xs); }); - define("set-prompt!", [this](let const& xs, auto&&...) { return prompt = car(xs); }); - define("set-trace!", [this](let const& xs, auto&&...) { return trace = car(xs); }); - define("set-verbose!", [this](let const& xs, auto&&...) { return verbose = car(xs); }); - } - auto environment::load(std::string const& s) -> object { if (let port = make(s); port and port.as().is_open()) diff --git a/test/environment.cpp b/test/environment.cpp index d82b6556c..03e9c00db 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,7 +24,9 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - auto root = environment(master); + auto root = environment("(scheme base)", + "(scheme char)" + ); } environment::symbols.clear(); From 080212c5acc0302c4151c0c834da1fccda51462b Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 3 May 2022 05:18:30 +0900 Subject: [PATCH 03/49] Remove header `utility/integer_sequence.hpp` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- include/meevax/kernel/environment.hpp | 1 - include/meevax/utility/integer_sequence.hpp | 44 --------------------- 4 files changed, 4 insertions(+), 49 deletions(-) delete mode 100644 include/meevax/utility/integer_sequence.hpp diff --git a/README.md b/README.md index d2be4ed5b..bee5d8432 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.973.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.974.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.973_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.974_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.973 +Meevax Lisp System, version 0.3.974 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index cf43cd928..577cb1e49 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.973 +0.3.974 diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index e202188ad..fa7261a93 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -21,7 +21,6 @@ #include #include #include -#include namespace meevax { diff --git a/include/meevax/utility/integer_sequence.hpp b/include/meevax/utility/integer_sequence.hpp deleted file mode 100644 index 3436dd856..000000000 --- a/include/meevax/utility/integer_sequence.hpp +++ /dev/null @@ -1,44 +0,0 @@ -/* - Copyright 2018-2022 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_UTILITY_INTEGER_SEQUENCE_HPP -#define INCLUDED_MEEVAX_UTILITY_INTEGER_SEQUENCE_HPP - -#include -#include - -namespace meevax -{ -inline namespace utility -{ - template - constexpr auto operator ""_s() -> std::integer_sequence - { - return {}; - } - - template - struct is_integer_sequence : public std::false_type - {}; - - template - struct is_integer_sequence> - : public std::true_type - {}; -} // namespace utility -} // namespace meevax - -#endif // INCLUDED_MEEVAX_UTILITY_INTEGER_SEQUENCE_HPP From 34ad90ccad64994f0ebec01059c0495f9aa4bdd4 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 4 May 2022 05:01:50 +0900 Subject: [PATCH 04/49] Support declaration `import` and `export` experimentally Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 5 -- include/meevax/kernel/environment.hpp | 23 ++++-- include/meevax/kernel/library.hpp | 106 ++++++++++++++++++++++++++ src/kernel/environment.cpp | 78 +++++++++++++------ src/kernel/library.cpp | 64 ++++++++++++++++ src/main.cpp | 11 ++- test/environment.cpp | 4 +- test/letrec-syntax.ss | 4 - 10 files changed, 255 insertions(+), 48 deletions(-) create mode 100644 include/meevax/kernel/library.hpp create mode 100644 src/kernel/library.cpp diff --git a/README.md b/README.md index bee5d8432..f954f1659 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.974.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.975.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.974_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.975_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.974 +Meevax Lisp System, version 0.3.975 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 577cb1e49..379122725 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.974 +0.3.975 diff --git a/basis/overture.ss b/basis/overture.ss index 4ce4cd481..73c365e1a 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -41,11 +41,6 @@ (make-syntactic-closure use-env '() y)))) (f form rename compare))) -(define-syntax import - (er-macro-transformer - (lambda (form rename compare) - (list (rename 'quote) (cons 'import (cdr form)))))) - ; ------------------------------------------------------------------------------ (define-syntax cond diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index fa7261a93..2affc7fff 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -32,6 +32,11 @@ inline namespace kernel { explicit master_t() = default; } constexpr master; + + struct empty_t + { + explicit empty_t() = default; + } constexpr empty; } // namespace experimental class environment : public virtual pair @@ -58,17 +63,15 @@ inline namespace kernel explicit environment(environment const&) = default; - explicit environment(master_t); + explicit environment(empty_t) // FOR MIGRATION + {} + + explicit environment(master_t); // FOR MIGRATION template ...)> explicit environment(Ts&&... xs) : environment { master } { - auto import = [](auto&& x) - { - std::cout << x << std::endl; - }; - (import(xs), ...); define("set-batch!", [this](let const& xs, auto&&...) { return batch = car(xs); }); @@ -87,10 +90,10 @@ inline namespace kernel auto define(const_reference, const_reference = undefined) -> void; - auto define(std::string const&, const_reference = undefined) -> void; + auto define(symbol::value_type const&, const_reference = undefined) -> void; template - auto define(std::string const& name, Ts&&... xs) -> void + auto define(symbol::value_type const& name, Ts&&... xs) -> void { define(name, make(name, std::forward(xs)...)); } @@ -117,6 +120,10 @@ inline namespace kernel auto global() const noexcept -> const_reference; + auto import(const_reference) -> void; + + auto import(std::string const&) -> void; + auto load(std::string const&) -> object; auto scope() const noexcept -> const_reference; diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp new file mode 100644 index 000000000..343fd9a57 --- /dev/null +++ b/include/meevax/kernel/library.hpp @@ -0,0 +1,106 @@ +/* + Copyright 2018-2022 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_LIBRARY_HPP +#define INCLUDED_MEEVAX_KERNEL_LIBRARY_HPP + +#include +#include + +namespace meevax +{ +inline namespace kernel +{ + struct library : public environment + { + std::vector export_specs; + + template )> + explicit library(F&& declare) + : environment { empty } + { + declare(*this); + } + + explicit library(std::string const& declaration) + : environment { empty } + { + auto port = std::stringstream(declaration); + + for (let expression = read(port); expression != eof_object; expression = read(port)) + { + if (expression.is() and car(expression).is() + and car(expression).as().value == "export") + { + for (let const& export_spec : cdr(expression)) + { + export_(export_spec); + } + } + else + { + evaluate(expression); + } + } + } + + auto export_(const_reference export_spec) -> void + { + export_specs.push_back(export_spec); + } + + auto export_(std::string const& s) -> void + { + export_(read(s)); + } + + auto export_to(environment & destination) + { + for (let const& export_spec : export_specs) + { + if (export_spec.is() and car(export_spec).is() + and car(export_spec).as().value == "rename") + { + } + else + { + assert(export_spec.is_also()); + + destination.define(export_spec, (*this)[export_spec]); + } + } + } + + friend auto operator <<(std::ostream & os, library const& library) -> std::ostream & + { + return os << library.global(); + } + }; + + extern std::map libraries; + + template + auto define_library(std::string const& name, Ts&&... xs) + { + std::cout << "; (define-library " << name << " ...)" << std::endl; + return libraries.emplace(name, std::forward(xs)...); + } + + auto bootstrap() -> void; +} // namespace kernel +} // namespace meevax + +#endif // INCLUDED_MEEVAX_KERNEL_LIBRARY_HPP diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 6e5aa0e49..c4be9d50b 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -15,6 +15,7 @@ */ #include +#include namespace meevax { @@ -60,34 +61,39 @@ inline namespace kernel define(intern(name), value); } - auto environment::evaluate(const_reference expression) -> object /* ---------- - * - * Since this member function can be called from various contexts, it is - * necessary to save the register. In particular, note that the - * er-macro-transformer's rename procedure is implemented as an eval with the - * macro transformer object as the environment-specifier, so this member - * function overrides the VM of the transformer during macro expansion. - * - * ------------------------------------------------------------------------- */ + auto environment::evaluate(const_reference expression) -> object { - auto dump = std::make_tuple(std::exchange(s, unit), - std::exchange(e, unit), - std::exchange(c, compile(context::none, *this, expression, scope())), - std::exchange(d, unit)); - - if (is_debug_mode()) + if (expression.is() and car(expression).is() + and car(expression).as().value == "import") { - disassemble(debug_port().as(), c); + for (let const& import_set : cdr(expression)) + { + import(import_set); + } + + return unspecified_object; } + else + { + auto dump = std::make_tuple(std::exchange(s, unit), + std::exchange(e, unit), + std::exchange(c, compile(context::none, *this, expression, scope())), + std::exchange(d, unit)); - let const result = execute(); + if (is_debug_mode()) + { + disassemble(debug_port().as(), c); + } - s = std::get<0>(dump); - e = std::get<1>(dump); - c = std::get<2>(dump); - d = std::get<3>(dump); + let const result = execute(); - return result; + s = std::get<0>(dump); + e = std::get<1>(dump); + c = std::get<2>(dump); + d = std::get<3>(dump); + + return result; + } } auto environment::execute() -> object @@ -118,6 +124,34 @@ inline namespace kernel return second; } + auto environment::import(const_reference import_set) -> void + { + // libraries.at(library_name).define_exported_bindings_to(*this); + // PRINT(import_set); + + if (car(import_set).as().value == "only") + { + } + else if (car(import_set).as().value == "except") + { + } + else if (car(import_set).as().value == "prefix") + { + } + else if (car(import_set).as().value == "rename") + { + } + else // + { + libraries.at(lexical_cast(import_set)).export_to(*this); + } + } + + auto environment::import(std::string const& s) -> void + { + import(read(s)); + } + auto environment::load(std::string const& s) -> object { if (let port = make(s); port and port.as().is_open()) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp new file mode 100644 index 000000000..424c4e55a --- /dev/null +++ b/src/kernel/library.cpp @@ -0,0 +1,64 @@ +/* + Copyright 2018-2022 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 + +namespace meevax +{ +inline namespace kernel +{ + std::map libraries {}; + + auto bootstrap() -> void + { + define_library("(scheme base)", [](library &) + { + }); + + define_library("(scheme char)", [](library &) + { + }); + + define_library("(meevax test)", [](library & library) + { + library.define("test-print", [](let const& xs) + { + std::cout << "; Procedure test-print received " << xs << std::endl; + return unit; + }); + + library.export_("test-print"); + }); + + define_library("(meevax foo)", [](library & library) + { + library.export_("a"); + library.export_("b"); + library.export_("c"); + + library.define("a", [](let const&) + { + LINE(); + return unit; + }); + + library.define("b", make(42)); + + library.define("c", make("dummy")); + }); + } +} // namespace kernel +} // namespace meevax diff --git a/src/main.cpp b/src/main.cpp index 65cad07bb..a121267b3 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -14,7 +14,7 @@ limitations under the License. */ -#include +#include #include auto main(int const argc, char const* const* const argv) -> int @@ -23,7 +23,14 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - auto main = environment(master); + bootstrap(); + + auto main = environment("(meevax test)", + "(only (meevax foo) a b)", + "(except (meevax foo) a)", + "(prefix (meevax foo) foo-)", + "(rename (meevax foo) (a f))" + ); main.configure(argc, argv); diff --git a/test/environment.cpp b/test/environment.cpp index 03e9c00db..952307398 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,9 +24,7 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - auto root = environment("(scheme base)", - "(scheme char)" - ); + auto root = environment(); } environment::symbols.clear(); diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index 933177b39..f4a0f852c 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -1,7 +1,3 @@ -(import (gauche base) - (scheme base) - (srfi 78)) - (letrec-syntax ((my-and (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form)) #t) From 1978852e5fb131636a4a970a4bdd79f507d33a0e Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 4 May 2022 06:08:36 +0900 Subject: [PATCH 05/49] Update `environment::import` and `library::export` to be variadic Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- include/meevax/kernel/environment.hpp | 6 +++++- include/meevax/kernel/library.hpp | 9 ++++++--- src/kernel/environment.cpp | 8 -------- src/kernel/library.cpp | 14 +++++++++----- src/library/meevax.cpp | 10 ---------- src/main.cpp | 3 ++- test/environment.cpp | 2 +- 9 files changed, 27 insertions(+), 33 deletions(-) diff --git a/README.md b/README.md index f954f1659..08cae6b09 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.975.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.976.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.975_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.976_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.975 +Meevax Lisp System, version 0.3.976 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 379122725..6e2aed18a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.975 +0.3.976 diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 2affc7fff..1817ae21e 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -122,7 +122,11 @@ inline namespace kernel auto import(const_reference) -> void; - auto import(std::string const&) -> void; + template ...)> + auto import(Ts&&... xs) -> void + { + (import(read(xs)), ...); + } auto load(std::string const&) -> object; diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 343fd9a57..6638e5f70 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -62,13 +62,16 @@ inline namespace kernel export_specs.push_back(export_spec); } - auto export_(std::string const& s) -> void + template ...)> + auto export_(Ts&&... xs) -> void { - export_(read(s)); + (export_(read(xs)), ...); } auto export_to(environment & destination) { + std::cout << "; importing " << export_specs.size() << " definitions." << std::endl; + for (let const& export_spec : export_specs) { if (export_spec.is() and car(export_spec).is() @@ -78,7 +81,7 @@ inline namespace kernel else { assert(export_spec.is_also()); - + std::cout << "; " << export_spec << std::endl; destination.define(export_spec, (*this)[export_spec]); } } diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index c4be9d50b..9ab813bed 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -126,9 +126,6 @@ inline namespace kernel auto environment::import(const_reference import_set) -> void { - // libraries.at(library_name).define_exported_bindings_to(*this); - // PRINT(import_set); - if (car(import_set).as().value == "only") { } @@ -147,11 +144,6 @@ inline namespace kernel } } - auto environment::import(std::string const& s) -> void - { - import(read(s)); - } - auto environment::load(std::string const& s) -> object { if (let port = make(s); port and port.as().is_open()) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 424c4e55a..f984a898c 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -32,15 +32,19 @@ inline namespace kernel { }); - define_library("(meevax test)", [](library & library) + define_library("(meevax gc)", [](library & meevax_gc) { - library.define("test-print", [](let const& xs) + meevax_gc.define("gc-collect", [](auto&&...) { - std::cout << "; Procedure test-print received " << xs << std::endl; - return unit; + return make(gc.collect()); + }); + + meevax_gc.define("gc-count", [](auto&&...) + { + return make(gc.count()); }); - library.export_("test-print"); + meevax_gc.export_("gc-collect", "gc-count"); }); define_library("(meevax foo)", [](library & library) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 47f6e3240..be77789c3 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -2038,16 +2038,6 @@ namespace meevax return standard_output; }); - define("gc-collect", [](auto&&...) - { - return make(gc.collect()); - }); - - define("gc-count", [](auto&&...) - { - return make(gc.count()); - }); - std::vector const codes { overture, srfi_8, diff --git a/src/main.cpp b/src/main.cpp index a121267b3..42c266ef3 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -25,7 +25,8 @@ auto main(int const argc, char const* const* const argv) -> int { bootstrap(); - auto main = environment("(meevax test)", + auto main = environment("(scheme base)", + // "(meevax gc)", "(only (meevax foo) a b)", "(except (meevax foo) a)", "(prefix (meevax foo) foo-)", diff --git a/test/environment.cpp b/test/environment.cpp index 952307398..d82b6556c 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,7 +24,7 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - auto root = environment(); + auto root = environment(master); } environment::symbols.clear(); From 1f24c1d02d73c52276b5ec4ed59fb467ce313111 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 4 May 2022 06:50:52 +0900 Subject: [PATCH 06/49] Add new builtin library `(scheme cxr)` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- example/example.ss | 2 + src/kernel/library.cpp | 83 ++++++++++++++++++++++++++++++++++++++++++ src/library/meevax.cpp | 58 +---------------------------- test/environment.cpp | 5 ++- 6 files changed, 95 insertions(+), 61 deletions(-) diff --git a/README.md b/README.md index 08cae6b09..ea91d2a20 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.976.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.977.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.976_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.977_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.976 +Meevax Lisp System, version 0.3.977 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 6e2aed18a..e367f2489 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.976 +0.3.977 diff --git a/example/example.ss b/example/example.ss index f3e6f05b7..7a9a976b9 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,3 +1,5 @@ +(import (meevax foreign-function-interface)) + (define dummy-procedure (foreign-function "build/libexample.so" "dummy_procedure")) (check (foreign-function? dummy-procedure) => #t) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index f984a898c..e9461f0d3 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -32,6 +32,79 @@ inline namespace kernel { }); + define_library("(scheme cxr)", [](library & lib) + { + /* ------------------------------------------------------------------------- + * + * (caaar pair) cxr library procedure + * (caadr pair) cxr library procedure + * . . + * . . + * . . + * (cdddar pair) cxr library procedure + * (cddddr pair) cxr library procedure + * + * These twenty-four procedures are further compositions of car and cdr on + * the same principles. For example, caddr could be defined by + * + * (define caddr (lambda (x) (car (cdr (cdr x))))). + * + * Arbitrary compositions up to four deep are provided. + * + * ---------------------------------------------------------------------- */ + + lib.define("caaar", [](let const& xs) { return caaar(car(xs)); }); + lib.define("caadr", [](let const& xs) { return caadr(car(xs)); }); + lib.define("cadar", [](let const& xs) { return cadar(car(xs)); }); + lib.define("caddr", [](let const& xs) { return caddr(car(xs)); }); + lib.define("cdaar", [](let const& xs) { return cdaar(car(xs)); }); + lib.define("cdadr", [](let const& xs) { return cdadr(car(xs)); }); + lib.define("cddar", [](let const& xs) { return cddar(car(xs)); }); + lib.define("cdddr", [](let const& xs) { return cdddr(car(xs)); }); + + lib.define("caaaar", [](let const& xs) { return caaaar(car(xs)); }); + lib.define("caaadr", [](let const& xs) { return caaadr(car(xs)); }); + lib.define("caadar", [](let const& xs) { return caadar(car(xs)); }); + lib.define("caaddr", [](let const& xs) { return caaddr(car(xs)); }); + lib.define("cadaar", [](let const& xs) { return cadaar(car(xs)); }); + lib.define("cadadr", [](let const& xs) { return cadadr(car(xs)); }); + lib.define("caddar", [](let const& xs) { return caddar(car(xs)); }); + lib.define("cadddr", [](let const& xs) { return cadddr(car(xs)); }); + lib.define("cdaaar", [](let const& xs) { return cdaaar(car(xs)); }); + lib.define("cdaadr", [](let const& xs) { return cdaadr(car(xs)); }); + lib.define("cdadar", [](let const& xs) { return cdadar(car(xs)); }); + lib.define("cdaddr", [](let const& xs) { return cdaddr(car(xs)); }); + lib.define("cddaar", [](let const& xs) { return cddaar(car(xs)); }); + lib.define("cddadr", [](let const& xs) { return cddadr(car(xs)); }); + lib.define("cdddar", [](let const& xs) { return cdddar(car(xs)); }); + lib.define("cddddr", [](let const& xs) { return cddddr(car(xs)); }); + + lib.export_("caaar", + "caadr", + "cadar", + "caddr", + "cdaar", + "cdadr", + "cddar", + "cdddr", + "caaaar", + "caaadr", + "caadar", + "caaddr", + "cadaar", + "cadadr", + "caddar", + "cadddr", + "cdaaar", + "cdaadr", + "cdadar", + "cdaddr", + "cddaar", + "cddadr", + "cdddar", + "cddddr"); + }); + define_library("(meevax gc)", [](library & meevax_gc) { meevax_gc.define("gc-collect", [](auto&&...) @@ -47,6 +120,16 @@ inline namespace kernel meevax_gc.export_("gc-collect", "gc-count"); }); + define_library("(meevax foreign-function-interface)", [](library & meevax_ffi) + { + meevax_ffi.define("foreign-function", [](let const& xs) + { + return make(cadr(xs).as(), car(xs).as()); + }); + + meevax_ffi.export_("foreign-function"); + }); + define_library("(meevax foo)", [](library & library) { library.export_("a"); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index be77789c3..5ef0c06f6 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -22,6 +22,8 @@ namespace meevax { environment::environment(master_t) { + import("(scheme cxr)"); + define("begin", machine::begin); define("call-with-current-continuation!", call_with_current_continuation); define("define", machine::define); @@ -1599,51 +1601,6 @@ namespace meevax * * ---------------------------------------------------------------------- */ - /* ------------------------------------------------------------------------- - * - * (caaar pair) cxr library procedure - * (caadr pair) cxr library procedure - * . . - * . . - * . . - * (cdddar pair) cxr library procedure - * (cddddr pair) cxr library procedure - * - * These twenty-four procedures are further compositions of car and cdr on - * the same principles. For example, caddr could be defined by - * - * (define caddr (lambda (x) (car (cdr (cdr x))))). - * - * Arbitrary compositions up to four deep are provided. - * - * ---------------------------------------------------------------------- */ - - define("caaar", [](let const& xs) { return caaar(car(xs)); }); - define("caadr", [](let const& xs) { return caadr(car(xs)); }); - define("cadar", [](let const& xs) { return cadar(car(xs)); }); - define("caddr", [](let const& xs) { return caddr(car(xs)); }); - define("cdaar", [](let const& xs) { return cdaar(car(xs)); }); - define("cdadr", [](let const& xs) { return cdadr(car(xs)); }); - define("cddar", [](let const& xs) { return cddar(car(xs)); }); - define("cdddr", [](let const& xs) { return cdddr(car(xs)); }); - - define("caaaar", [](let const& xs) { return caaaar(car(xs)); }); - define("caaadr", [](let const& xs) { return caaadr(car(xs)); }); - define("caadar", [](let const& xs) { return caadar(car(xs)); }); - define("caaddr", [](let const& xs) { return caaddr(car(xs)); }); - define("cadaar", [](let const& xs) { return cadaar(car(xs)); }); - define("cadadr", [](let const& xs) { return cadadr(car(xs)); }); - define("caddar", [](let const& xs) { return caddar(car(xs)); }); - define("cadddr", [](let const& xs) { return cadddr(car(xs)); }); - define("cdaaar", [](let const& xs) { return cdaaar(car(xs)); }); - define("cdaadr", [](let const& xs) { return cdaadr(car(xs)); }); - define("cdadar", [](let const& xs) { return cdadar(car(xs)); }); - define("cdaddr", [](let const& xs) { return cdaddr(car(xs)); }); - define("cddaar", [](let const& xs) { return cddaar(car(xs)); }); - define("cddadr", [](let const& xs) { return cddadr(car(xs)); }); - define("cdddar", [](let const& xs) { return cdddar(car(xs)); }); - define("cddddr", [](let const& xs) { return cddddr(car(xs)); }); - /* ------------------------------------------------------------------------- * * (eval expr-or-def environment-specifier) eval library procedure @@ -2020,17 +1977,6 @@ namespace meevax return standard_output; }); - /* ------------------------------------------------------------------------- - * - * (foreign-function lib*.so function-name) procedure - * - * ---------------------------------------------------------------------- */ - - define("foreign-function", [](let const& xs) - { - return make(cadr(xs).as(), car(xs).as()); - }); - define("type-of", [](let const& xs) { std::cout << car(xs).type().name() << std::endl; diff --git a/test/environment.cpp b/test/environment.cpp index d82b6556c..049276282 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -1,7 +1,7 @@ #undef NDEBUG #include -#include +#include auto main() -> int { @@ -24,10 +24,13 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { + bootstrap(); + auto root = environment(master); } environment::symbols.clear(); + libraries.clear(); gc.collect(); gc.collect(); // for vector type From 846b262ae9ae7ec206a89ce35a8f8b2787ce701d Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Fri, 6 May 2022 21:43:51 +0900 Subject: [PATCH 07/49] Add builtin libraries Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- include/meevax/kernel/library.hpp | 37 +- src/kernel/library.cpp | 1134 +++++++++++++++-- src/library/meevax.cpp | 1970 +---------------------------- src/main.cpp | 4 +- test/environment.cpp | 2 +- 7 files changed, 1112 insertions(+), 2043 deletions(-) diff --git a/README.md b/README.md index ea91d2a20..1c002d4bc 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.977.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.978.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.977_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.978_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.977 +Meevax Lisp System, version 0.3.978 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index e367f2489..1c212b7f2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.977 +0.3.978 diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 6638e5f70..010ed9118 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -35,7 +35,7 @@ inline namespace kernel declare(*this); } - explicit library(std::string const& declaration) + explicit library(std::string declaration) // This copy is intended. : environment { empty } { auto port = std::stringstream(declaration); @@ -57,6 +57,8 @@ inline namespace kernel } } + static auto boot() -> void; + auto export_(const_reference export_spec) -> void { export_specs.push_back(export_spec); @@ -91,6 +93,37 @@ inline namespace kernel { return os << library.global(); } + + #define DEFINE_BASIS_LIBRARY(NAME) \ + struct NAME##_library_t \ + { \ + explicit NAME##_library_t() = default; \ + } \ + static constexpr NAME##_library {}; \ + \ + explicit library(NAME##_library_t) + + DEFINE_BASIS_LIBRARY(character); + DEFINE_BASIS_LIBRARY(context); + DEFINE_BASIS_LIBRARY(control); + DEFINE_BASIS_LIBRARY(equivalence); + DEFINE_BASIS_LIBRARY(evaluate); + DEFINE_BASIS_LIBRARY(exception); + DEFINE_BASIS_LIBRARY(experimental); + DEFINE_BASIS_LIBRARY(inexact); + DEFINE_BASIS_LIBRARY(list); + DEFINE_BASIS_LIBRARY(macro); + DEFINE_BASIS_LIBRARY(number); + DEFINE_BASIS_LIBRARY(pair); + DEFINE_BASIS_LIBRARY(port); + DEFINE_BASIS_LIBRARY(read); + DEFINE_BASIS_LIBRARY(string); + DEFINE_BASIS_LIBRARY(symbol); + DEFINE_BASIS_LIBRARY(syntax); + DEFINE_BASIS_LIBRARY(vector); + DEFINE_BASIS_LIBRARY(write); + + #undef DEFINE_BASIS_LIBRARY }; extern std::map libraries; @@ -101,8 +134,6 @@ inline namespace kernel std::cout << "; (define-library " << name << " ...)" << std::endl; return libraries.emplace(name, std::forward(xs)...); } - - auto bootstrap() -> void; } // namespace kernel } // namespace meevax diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index e9461f0d3..111e941d7 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -20,91 +20,1061 @@ namespace meevax { inline namespace kernel { - std::map libraries {}; + library::library(syntax_library_t) + { + define("begin", machine::begin); + define("call-with-current-continuation!", call_with_current_continuation); + define("define", machine::define); + define("define-syntax", define_syntax); + define("if", if_); + define("lambda", lambda); + define("let-syntax", let_syntax); + define("letrec", letrec); + define("letrec-syntax", letrec_syntax); + define("quote", quote); + define("quote-syntax", quote_syntax); + define("set!", set); + + export_("begin", + "call-with-current-continuation!", + "define", + "define-syntax", + "if", + "lambda", + "let-syntax", + "letrec", + "letrec-syntax", + "quote", + "quote-syntax", + "set!"); + } + + library::library(equivalence_library_t) + { + define("eq?", [](let const& xs) { return eq (car(xs), cadr(xs)); }); + define("eqv?", [](let const& xs) { return eqv(car(xs), cadr(xs)); }); + + export_("eq?", "eqv?"); + } + + library::library(number_library_t) + { + define("number?", [](let const& xs) { return car(xs).is_also(); }); + define("complex?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_complex (); }); + define("real?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_real (); }); + define("rational?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_rational(); }); + define("integer?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_integer (); }); + define("exact-integer?", [](let const& xs) { return car(xs).is(); }); + define("%complex?", [](let const& xs) { return car(xs).is(); }); + define("ratio?", [](let const& xs) { return car(xs).is(); }); + define("single-float?", [](let const& xs) { return car(xs).is(); }); + define("double-float?", [](let const& xs) { return car(xs).is(); }); + + #define DEFINE(SYMBOL, COMPARE) \ + define(#SYMBOL, [](let const& xs) \ + { \ + return std::adjacent_find( \ + std::begin(xs), std::end(xs), [](let const& a, let const& b) \ + { \ + return not COMPARE(a.as(), b); \ + }) == std::end(xs); \ + }) + + DEFINE(= , std::equal_to ()); + DEFINE(!=, std::not_equal_to ()); + DEFINE(< , std::less ()); + DEFINE(<=, std::less_equal ()); + DEFINE(> , std::greater ()); + DEFINE(>=, std::greater_equal()); + + #undef DEFINE + + define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, [](let const& a, let const& b) { return a + b; }); }); + define("*", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e1, [](let const& a, let const& b) { return a * b; }); }); + + #define DEFINE(SYMBOL, FUNCTION, BASIS) \ + define(SYMBOL, [](let const& xs) \ + { \ + switch (length(xs)) \ + { \ + case 0: \ + throw invalid_application(intern(SYMBOL) | xs); \ + \ + case 1: \ + return FUNCTION(BASIS, car(xs)); \ + \ + default: \ + return std::accumulate( \ + std::next(std::begin(xs)), std::end(xs), car(xs), \ + [](let const& a, let const& b) \ + { \ + return FUNCTION(a, b); \ + }); \ + } \ + }) + + DEFINE("-", sub, e0); + DEFINE("/", div, e1); + DEFINE("%", mod, e1); + + #undef DEFINE + + define("floor", [](let const& xs) { return car(xs).as().floor (); }); + define("ceiling", [](let const& xs) { return car(xs).as().ceil (); }); + define("truncate", [](let const& xs) { return car(xs).as().trunc (); }); + define("round", [](let const& xs) { return car(xs).as().round (); }); + + define("exact", [](let const& xs) { return car(xs).as().exact (); }); + define("inexact", [](let const& xs) { return car(xs).as().inexact(); }); + + define("expt", [](let const& xs) + { + return car(xs).as().pow(cadr(xs)); + }); + + define("integer->char", [](let const& xs) + { + if (xs.is() and car(xs).is()) + { + return make(static_cast(car(xs).as())); + } + else + { + throw invalid_application(intern("integer->char") | xs); + } + }); + + define("number->string", [](auto&& xs) + { + return make(lexical_cast(car(xs))); + }); + + export_("number?", "complex?", "real?", "rational?", "integer?", + "exact-integer?", "%complex?", "ratio?", "single-float?", "double-float?", + + "=", "!=", "<", "<=", ">", ">=", "+", "*", "-", "/", "%", + + "floor", "ceiling", "truncate", "round", + + "expt", + + "exact", "inexact", + + "integer->char", "number->string"); + } + + library::library(inexact_library_t) + { + define("finite?", [](let const& xs) { return car(xs).as().is_finite (); }); + define("infinite?", [](let const& xs) { return car(xs).as().is_infinite(); }); + + define("nan?", [](let const& xs) + { + return car(xs).is_also() and car(xs).as().is_nan(); + }); + + define("exp", [](let const& xs) { return car(xs).as().exp(); }); + define("sqrt", [](let const& xs) { return car(xs).as().sqrt(); }); + + define("log", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return car(xs).as().log(); + + case 2: + return car(xs).as().log() / cadr(xs).as().log(); + + default: + throw invalid_application(intern("log") | xs); + } + }); + + define("sin", [](let const& xs) { return car(xs).as().sin(); }); + define("cos", [](let const& xs) { return car(xs).as().cos(); }); + define("tan", [](let const& xs) { return car(xs).as().tan(); }); + define("asin", [](let const& xs) { return car(xs).as().asin(); }); + define("acos", [](let const& xs) { return car(xs).as().acos(); }); + define("sinh", [](let const& xs) { return car(xs).as().sinh(); }); + define("cosh", [](let const& xs) { return car(xs).as().cosh(); }); + define("tanh", [](let const& xs) { return car(xs).as().tanh(); }); + define("asinh", [](let const& xs) { return car(xs).as().asinh(); }); + define("acosh", [](let const& xs) { return car(xs).as().acosh(); }); + define("atanh", [](let const& xs) { return car(xs).as().atanh(); }); + + define("atan", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return car(xs).as().atan(); + + case 2: + return car(xs).as().atan2(cadr(xs)); + + default: + throw invalid_application(intern("atan") | xs); + } + }); + + export_("finite?", "infinite?", "nan?", + "exp", "sqrt", "log", + "sin", "asin", "sinh", "asinh", + "cos", "acos", "cosh", "acosh", + "tan", "atan", "tanh", "atanh"); + } + + library::library(pair_library_t) + { + define("pair?", [](let const& xs) + { + return car(xs).is(); + }); + + define("cons", cons_, [](let const& xs) + { + return cons(car(xs), cadr(xs)); + }); + + define("car", [](let const& xs) { return caar(xs); }); + define("cdr", [](let const& xs) { return cdar(xs); }); + + define("caar", [](let const& xs) { return caar(car(xs)); }); + define("cadr", [](let const& xs) { return cadr(car(xs)); }); + define("cdar", [](let const& xs) { return cdar(car(xs)); }); + define("cddr", [](let const& xs) { return cddr(car(xs)); }); + + define("caaar", [](let const& xs) { return caaar(car(xs)); }); + define("caadr", [](let const& xs) { return caadr(car(xs)); }); + define("cadar", [](let const& xs) { return cadar(car(xs)); }); + define("caddr", [](let const& xs) { return caddr(car(xs)); }); + define("cdaar", [](let const& xs) { return cdaar(car(xs)); }); + define("cdadr", [](let const& xs) { return cdadr(car(xs)); }); + define("cddar", [](let const& xs) { return cddar(car(xs)); }); + define("cdddr", [](let const& xs) { return cdddr(car(xs)); }); + + define("caaaar", [](let const& xs) { return caaaar(car(xs)); }); + define("caaadr", [](let const& xs) { return caaadr(car(xs)); }); + define("caadar", [](let const& xs) { return caadar(car(xs)); }); + define("caaddr", [](let const& xs) { return caaddr(car(xs)); }); + define("cadaar", [](let const& xs) { return cadaar(car(xs)); }); + define("cadadr", [](let const& xs) { return cadadr(car(xs)); }); + define("caddar", [](let const& xs) { return caddar(car(xs)); }); + define("cadddr", [](let const& xs) { return cadddr(car(xs)); }); + define("cdaaar", [](let const& xs) { return cdaaar(car(xs)); }); + define("cdaadr", [](let const& xs) { return cdaadr(car(xs)); }); + define("cdadar", [](let const& xs) { return cdadar(car(xs)); }); + define("cdaddr", [](let const& xs) { return cdaddr(car(xs)); }); + define("cddaar", [](let const& xs) { return cddaar(car(xs)); }); + define("cddadr", [](let const& xs) { return cddadr(car(xs)); }); + define("cdddar", [](let const& xs) { return cdddar(car(xs)); }); + define("cddddr", [](let const& xs) { return cddddr(car(xs)); }); + + define("set-car!", [](auto&& xs) { return caar(xs) = cadr(xs); }); + define("set-cdr!", [](auto&& xs) { return cdar(xs) = cadr(xs); }); + + export_("pair?", "cons", + + "car", "cdr", + + "caar", "cadr", "cdar", "cddr", + + "caaar", "caadr", "cadar", "caddr", + "cdaar", "cdadr", "cddar", "cdddr", + + "caaaar", "caaadr", "caadar", "caaddr", + "cadaar", "cadadr", "caddar", "cadddr", + "cdaaar", "cdaadr", "cdadar", "cdaddr", + "cddaar", "cddadr", "cdddar", "cddddr", + + "set-car!", "set-cdr!"); + } + + library::library(list_library_t) + { + define("null?", [](let const& xs) + { + return car(xs).is(); + }); + + define("list->string", [](let const& xs) + { + string s; + + for (let const& x : car(xs)) + { + s.push_back(x.as()); + } + + return make(std::move(s)); + }); + + define("list->vector", [](let const& xs) + { + return make(for_each_in, car(xs)); + }); + + export_("null?", + "list->string", + "list->vector"); + } + + library::library(symbol_library_t) + { + define("symbol?", [](let const& xs) + { + return car(xs).is(); + }); + + define("symbol->string", [](let const& xs) + { + return make(car(xs).as()); + }); + + export_("symbol?", "symbol->string"); + } - auto bootstrap() -> void - { - define_library("(scheme base)", [](library &) - { - }); - - define_library("(scheme char)", [](library &) - { - }); - - define_library("(scheme cxr)", [](library & lib) - { - /* ------------------------------------------------------------------------- - * - * (caaar pair) cxr library procedure - * (caadr pair) cxr library procedure - * . . - * . . - * . . - * (cdddar pair) cxr library procedure - * (cddddr pair) cxr library procedure - * - * These twenty-four procedures are further compositions of car and cdr on - * the same principles. For example, caddr could be defined by - * - * (define caddr (lambda (x) (car (cdr (cdr x))))). - * - * Arbitrary compositions up to four deep are provided. - * - * ---------------------------------------------------------------------- */ - - lib.define("caaar", [](let const& xs) { return caaar(car(xs)); }); - lib.define("caadr", [](let const& xs) { return caadr(car(xs)); }); - lib.define("cadar", [](let const& xs) { return cadar(car(xs)); }); - lib.define("caddr", [](let const& xs) { return caddr(car(xs)); }); - lib.define("cdaar", [](let const& xs) { return cdaar(car(xs)); }); - lib.define("cdadr", [](let const& xs) { return cdadr(car(xs)); }); - lib.define("cddar", [](let const& xs) { return cddar(car(xs)); }); - lib.define("cdddr", [](let const& xs) { return cdddr(car(xs)); }); - - lib.define("caaaar", [](let const& xs) { return caaaar(car(xs)); }); - lib.define("caaadr", [](let const& xs) { return caaadr(car(xs)); }); - lib.define("caadar", [](let const& xs) { return caadar(car(xs)); }); - lib.define("caaddr", [](let const& xs) { return caaddr(car(xs)); }); - lib.define("cadaar", [](let const& xs) { return cadaar(car(xs)); }); - lib.define("cadadr", [](let const& xs) { return cadadr(car(xs)); }); - lib.define("caddar", [](let const& xs) { return caddar(car(xs)); }); - lib.define("cadddr", [](let const& xs) { return cadddr(car(xs)); }); - lib.define("cdaaar", [](let const& xs) { return cdaaar(car(xs)); }); - lib.define("cdaadr", [](let const& xs) { return cdaadr(car(xs)); }); - lib.define("cdadar", [](let const& xs) { return cdadar(car(xs)); }); - lib.define("cdaddr", [](let const& xs) { return cdaddr(car(xs)); }); - lib.define("cddaar", [](let const& xs) { return cddaar(car(xs)); }); - lib.define("cddadr", [](let const& xs) { return cddadr(car(xs)); }); - lib.define("cdddar", [](let const& xs) { return cdddar(car(xs)); }); - lib.define("cddddr", [](let const& xs) { return cddddr(car(xs)); }); - - lib.export_("caaar", - "caadr", - "cadar", - "caddr", - "cdaar", - "cdadr", - "cddar", - "cdddr", - "caaaar", - "caaadr", - "caadar", - "caaddr", - "cadaar", - "cadadr", - "caddar", - "cadddr", - "cdaaar", - "cdaadr", - "cdadar", - "cdaddr", - "cddaar", - "cddadr", - "cdddar", - "cddddr"); + library::library(character_library_t) + { + define("char?", [](let const& xs) + { + return car(xs).is(); }); + define("char->integer", [](let const& xs) + { + if (xs.is() and car(xs).is()) + { + return make(car(xs).as().codepoint); + } + else + { + throw invalid_application(intern("char->integer") | xs); + } + }); + + define("digit-value", [](let const& xs) + { + if (auto c = car(xs).as(); std::isdigit(c.codepoint)) + { + return make(c.codepoint - '0'); + } + else + { + return f; + } + }); + + export_("char?", + "char->integer", + "digit-value" // TODO => character:codepoint + ); + } + + library::library(string_library_t) + { + define("string?", [](let const& xs) { return car(xs).is(); }); + + define("make-string", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return make(static_cast(car(xs).as()), character()); + + case 2: + return make(static_cast(car(xs).as()), cadr(xs).as()); + + default: + throw invalid_application(intern("make-string") | xs); + } + }); + + define("string-length", [](let const& xs) + { + return make(car(xs).as().size()); + }); + + define("string-ref", [](let const& xs) + { + return make(car(xs).as().at(static_cast(cadr(xs).as()))); + }); + + define("string-set!", [](let const& xs) + { + car(xs).as().at(static_cast(cadr(xs).as())) = caddr(xs).as(); + return car(xs); + }); + + define("string-append", [](let const& xs) + { + string result; + + for (let const& x : xs) + { + std::copy(std::cbegin(x.as()), std::cend(x.as()), std::back_inserter(result)); + } + + return make(result); + }); + + define("string-copy", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return make(car(xs).as()); + + case 2: + return make(car(xs).as().begin() + static_cast(cadr(xs).as()), + car(xs).as().end()); + case 3: + return make(car(xs).as().begin() + static_cast( cadr(xs).as()), + car(xs).as().begin() + static_cast(caddr(xs).as())); + default: + throw invalid_application(intern("string-copy") | xs); + } + }); + + #define STRING_COMPARE(COMPARE) \ + [](let const& xs) \ + { \ + return std::adjacent_find( \ + std::begin(xs), std::end(xs), [](let const& a, let const& b) \ + { \ + return not COMPARE(a.as_const(), \ + b.as_const()); \ + }) == std::end(xs); \ + } + + define("string=?", STRING_COMPARE(std::equal_to ())); + define("string())); + define("string<=?", STRING_COMPARE(std::less_equal ())); + define("string>?", STRING_COMPARE(std::greater ())); + define("string>=?", STRING_COMPARE(std::greater_equal())); + + #undef STRING_COMPARE + + define("string->number", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return string_to::number(car(xs).as(), 10); + + case 2: + return string_to::number(car(xs).as(), static_cast(cadr(xs).as())); + + default: + throw invalid_application(intern("string->number") | xs); + } + }); + + define("string->list", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return car(xs).as().list(); + + case 2: + return car(xs).as().list(static_cast(cadr(xs).as())); + + case 3: + return car(xs).as().list(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); + + default: + throw invalid_application(intern("string->list") | xs); + } + }); + + define("string->symbol", [](let const& xs) + { + return intern(car(xs).as()); + }); + + export_("string?", "make-string", + + "string-append", + "string-copy", + "string-length", + "string-ref", + "string-set!", + + "string=?", + "string?", + "string>=?", + + "string->list", + "string->number", + "string->symbol" + ); + } + + library::library(vector_library_t) + { + define("vector?", [](let const& xs) + { + return car(xs).is(); + }); + + define("vector", [](let const& xs) + { + return make(for_each_in, xs); + }); + + define("make-vector", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return make(static_cast(car(xs).as()), unspecified_object); + + case 2: + return make(static_cast(car(xs).as()), cadr(xs)); + + default: + throw invalid_application(intern("make-vector") | xs); + } + }); + + define("vector-length", [](let const& xs) + { + return make(car(xs).as().size()); + }); + + define("vector-ref", [](let const& xs) + { + return car(xs).as().at(static_cast(cadr(xs).as())); + }); + + define("vector-set!", [](let const& xs) + { + return car(xs).as().at(static_cast(cadr(xs).as())) = caddr(xs); + }); + + define("vector-fill!", [](let const& xs) + { + switch (length(xs)) + { + case 2: + car(xs).as().fill(cadr(xs)); + break; + + case 3: + car(xs).as().fill(cadr(xs), static_cast(caddr(xs).as())); + break; + + case 4: + car(xs).as().fill(cadr(xs), static_cast(caddr(xs).as()), static_cast(cadddr(xs).as())); + break; + + default: + throw invalid_application(intern("vector-fill!") | xs); + } + + return unspecified_object; + }); + + define("vector->list", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return car(xs).as().list(); + + case 2: + return car(xs).as().list(static_cast(cadr(xs).as())); + + case 3: + return car(xs).as().list(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); + + default: + throw invalid_application(intern("vector->list") | xs); + } + }); + + define("vector->string", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return car(xs).as().string(); + + case 2: + return car(xs).as().string(static_cast(cadr(xs).as())); + + case 3: + return car(xs).as().string(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); + + default: + throw invalid_application(intern("vector->string") | xs); + } + }); + + export_("vector?", + + "vector", "make-vector", + + "vector-length", + "vector-ref", + "vector-set!", + "vector-fill!", + + "vector->list", + "vector->string"); + } + + library::library(control_library_t) + { + define("closure?", [](let const& xs) { return car(xs).is(); }); + define("continuation?", [](let const& xs) { return car(xs).is(); }); + define("foreign-function?", [](let const& xs) { return car(xs).is(); }); + + export_("closure?", + "continuation?", + "foreign-function?"); + } + + library::library(exception_library_t) + { + define("default-exception-handler", [](let const& xs) -> object + { + throw car(xs); + }); + + define("make-error", [](let const& xs) + { + return make(car(xs), cdr(xs)); + }); + + define( "error?", [](let const& xs) { return car(xs).is< error>(); }); + define( "read-error?", [](let const& xs) { return car(xs).is< read_error>(); }); + define( "file-error?", [](let const& xs) { return car(xs).is< file_error>(); }); + define("syntax-error?", [](let const& xs) { return car(xs).is(); }); + + export_("default-exception-handler", + "make-error", + "error?", + "read-error?", + "file-error?", + "syntax-error?"); + } + + library::library(port_library_t) + { + define( "input-port?", [](let const& xs) { return car(xs).is_also(); }); + define( "output-port?", [](let const& xs) { return car(xs).is_also(); }); + define( "binary-port?", [](let const& ) { return false; }); + define("textual-port?", [](let const& xs) { return car(xs).is_also(); }); + define( "port?", [](let const& xs) { return car(xs).is_also(); }); + + define("input-port-open?", [](let const& xs) + { + if (let const& x = car(xs); x.is_also()) + { + return x.as().is_open(); + } + else + { + return x.is_also(); + } + }); + + define("output-port-open?", [](let const& xs) + { + if (let const& x = car(xs); x.is_also()) + { + return x.as().is_open(); + } + else + { + return x.is_also(); + } + }); + + define("standard-input-port", [](auto&&...) { return standard_input; }); + define("standard-output-port", [](auto&&...) { return standard_output; }); + define("standard-error-port", [](auto&&...) { return standard_error; }); + + define("open-input-file", [](let const& xs) { return make< input_file_port>(car(xs).as()); }); + define("open-output-file", [](let const& xs) { return make(car(xs).as()); }); + + define("close-input-port", [](let const& xs) + { + if (let const& x = car(xs); x.is_also()) + { + x.as().close(); + } + + return unspecified_object; + }); + + define("close-output-port", [](let const& xs) + { + if (let const& x = car(xs); x.is_also()) + { + x.as().close(); + } + + return unspecified_object; + }); + + define("open-input-string", [](let const& xs) + { + switch (length(xs)) + { + case 0: + return make(); + + case 1: + return make(car(xs).as()); + + default: + throw invalid_application(intern("open-input-string") | xs); + } + }); + + define("open-output-string", [](let const& xs) + { + switch (length(xs)) + { + case 0: + return make(); + + case 1: + return make(car(xs).as()); + + default: + throw invalid_application(intern("open-output-string") | xs); + } + }); + + define("get-output-string", [](let const& xs) + { + return make(car(xs).as().str()); + }); + + define("%read-char", [](let const& xs) + { + try + { + return make(car(xs).as()); + } + catch (eof const&) + { + return eof_object; + } + catch (read_error const& error) + { + return make(error); + } + }); + + define("%peek-char", [](let const& xs) + { + try + { + auto const g = car(xs).as().tellg(); + let const c = make(car(xs).as()); + car(xs).as().seekg(g); + return c; + } + catch (eof const&) + { + return eof_object; + } + catch (read_error const& error) + { + return make(error); + } + }); + + define("eof-object?", [](let const& xs) + { + return car(xs).is(); + }); + + define("eof-object", [](auto&&...) + { + return eof_object; + }); + + define("%char-ready?", [](let const& xs) + { + return static_cast(car(xs).as()); + }); + + define("%read-string", [](let const& xs) + { + switch (length(xs)) + { + case 2: + return make(cadr(xs).as(), static_cast(car(xs).as())); + + default: + throw invalid_application(intern("read-string") | xs); + } + }); + + define("put-char", [](let const& xs) + { + cadr(xs).as() << static_cast(car(xs).as()); + return unspecified_object; + }); + + define("put-string", [](let const& xs) + { + switch (length(xs)) + { + case 2: + cadr(xs).as() << static_cast(car(xs).as()); + break; + + case 3: // TODO + case 4: // TODO + + default: + throw invalid_application(intern("write-string") | xs); + } + + return unspecified_object; + }); + + define("%flush-output-port", [](let const& xs) + { + car(xs).as() << std::flush; + return unspecified_object; + }); + + export_("input-port?", + "output-port?", + "binary-port?", + "textual-port?", + "port?", + "input-port-open?", + "output-port-open?", + "standard-input-port", + "standard-output-port", + "standard-error-port", + "open-input-file", + "open-output-file", + "close-input-port", + "close-output-port", + "open-input-string", + "open-output-string", + "get-output-string", + "%read-char", + "%peek-char", + "eof-object?", + "eof-object", + "%char-ready?", + "%read-string", + "put-char", + "put-string", + "%flush-output-port"); + } + + library::library(evaluate_library_t) + { + define("eval", [](let const& xs) + { + return cadr(xs).as().mac_env.as().evaluate(car(xs)); // DIRTY HACK! + }); + + export_("eval"); + } + + library::library(read_library_t) + { + define("%read", [this](let const& xs) + { + try + { + switch (length(xs)) + { + case 0: + return read(standard_input); + + case 1: + return read(car(xs)); + + default: + throw invalid_application(intern("read") | xs); + } + } + catch (eof const&) + { + return eof_object; + } + catch (read_error const& error) + { + return make(error); + } + }); + + export_("%read"); + } + + library::library(write_library_t) + { + define("%write-simple", [this](let const& xs) + { + write(cadr(xs), car(xs)); + return unspecified_object; + }); + + define("print", [](let const& xs) + { + for (let const& x : xs) + { + if (x.is()) + { + std::cout << static_cast(x.as()); + } + else + { + std::cout << x; + } + } + + std::cout << std::endl; + + return standard_output; + }); + + export_("%write-simple", "print"); + } + + library::library(macro_library_t) + { + define("identifier?", [](let const& xs) + { + return car(xs).is_also(); + }); + + define("identifier->symbol", [](let const& xs) + { + if (let const& x = car(xs); x.is()) + { + return x.as().expression; + } + else + { + return x; + } + }); + + define("transformer?", [](let const& xs) + { + return car(xs).is_also(); + }); + + define("syntactic-closure?", [](let const& xs) + { + return car(xs).is(); + }); + + define("make-syntactic-closure", [](let const& xs) + { + return make(car(xs), cadr(xs), caddr(xs)); + }); + + export_("identifier?", + "identifier->symbol", + "transformer?", + "syntactic-closure?", + "make-syntactic-closure"); + } + + library::library(experimental_library_t) + { + define("type-of", [](let const& xs) + { + std::cout << car(xs).type().name() << std::endl; + + return standard_output; + }); + + define("disassemble", [](let const& xs) + { + if (0 < length(xs)) + { + if (let const& f = car(xs); f.is()) + { + disassemble(std::cout, car(f)); + } + } + + return standard_output; + }); + + define("ieee-float?", [](auto&&...) + { + return std::numeric_limits::is_iec559; + }); + + export_("type-of", + "disassemble", + "ieee-float?" + ); + } + + library::library(context_library_t) + { + define("emergency-exit", [](let const& xs) -> object + { + switch (length(xs)) + { + case 0: + throw exit_status::success; + + case 1: + if (let const& x = car(xs); x.is()) + { + throw select(x) ? exit_status::success : exit_status::failure; + } + else if (x.is()) + { + throw exit_status(static_cast(x.as())); + } + else [[fallthrough]]; + + default: + throw invalid_application(intern("emergency-exit") | xs); + } + }); + + export_("emergency-exit"); + } + + std::map libraries {}; + + auto library::boot() -> void + { + define_library("(meevax character)", character_library); + define_library("(meevax context)", context_library); + define_library("(meevax control)", control_library); + define_library("(meevax equivalence)", equivalence_library); + define_library("(meevax evaluate)", evaluate_library); + define_library("(meevax exception)", exception_library); + define_library("(meevax experimental)", experimental_library); + define_library("(meevax inexact)", inexact_library); + define_library("(meevax list)", list_library); + define_library("(meevax macro)", macro_library); + define_library("(meevax number)", number_library); + define_library("(meevax pair)", pair_library); + define_library("(meevax port)", port_library); + define_library("(meevax read)", read_library); + define_library("(meevax string)", string_library); + define_library("(meevax symbol)", symbol_library); + define_library("(meevax syntax)", syntax_library); + define_library("(meevax vector)", vector_library); + define_library("(meevax write)", write_library); + define_library("(meevax gc)", [](library & meevax_gc) { meevax_gc.define("gc-collect", [](auto&&...) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 5ef0c06f6..8ee724426 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -22,1968 +22,36 @@ namespace meevax { environment::environment(master_t) { - import("(scheme cxr)"); - - define("begin", machine::begin); - define("call-with-current-continuation!", call_with_current_continuation); - define("define", machine::define); - define("define-syntax", define_syntax); - define("if", if_); - define("lambda", lambda); - define("let-syntax", let_syntax); - define("letrec", letrec); - define("letrec-syntax", letrec_syntax); - define("quote", quote); - define("quote-syntax", quote_syntax); - define("set!", set); - - /* ------------------------------------------------------------------------- - * - * (eqv? obj1 obj2) procedure - * - * The eqv? procedure defines a useful equivalence relation on objects. - * Briefly, it returns #t if obj1 and obj2 are normally regarded as the - * same object. This relation is left slightly open to interpretation, but - * the following partial specification of eqv? holds for all - * implementations of Scheme. - * - * ---------------------------------------------------------------------- */ - - define("eqv?", [](let const& xs) // TODO Rename to value=? - { - return eqv(car(xs), cadr(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (eq? obj1 obj2) procedure - * - * The eq? procedure is similar to eqv? except that in some cases it is - * capable of discerning distinctions finer than those detectable by eqv?. - * It must always return #f when eqv? also would, but may return #f in - * some cases where eqv? would return #t. - * - * On symbols, booleans, the empty list, pairs, and records, and also on - * non-empty strings, vectors, and bytevectors, eq? and eqv? are - * guaranteed to have the same behavior. On procedures, eq? must return - * true if the arguments' location tags are equal. On numbers and - * characters, eq?'s behavior is implementation-dependent, but it will - * always return either true or false. On empty strings, empty vectors, - * and empty bytevectors, eq? may also behave differently from eqv?. - * - * ---------------------------------------------------------------------- */ - - define("eq?", [](auto&& xs) // TODO Rename to reference=? - { - return eq(car(xs), cadr(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (number? obj) procedure - * (complex? obj) procedure - * (real? obj) procedure - * (rational? obj) procedure - * (integer? obj) procedure - * - * These numerical type predicates can be applied to any kind of argument, - * including non-numbers. They return #t if the object is of the named - * type, and otherwise they return #f. In general, if a type predicate is - * true of a number then all higher type predicates are also true of that - * number. Consequently, if a type predicate is false of a number, then - * all lower type predicates are also false of that number. If z is a - * complex number, then (real? z) is true if and only if - * (zero? (imag-part z)) is true. If x is an inexact real number, then - * (integer? x) is true if and only if (= x (round x)). - * - * The numbers +inf.0, -inf.0, and +nan.0 are real but not rational. - * - * ---------------------------------------------------------------------- */ - - define("number?", [](let const& xs) { return car(xs).is_also(); }); - define("complex?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_complex (); }); - define("real?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_real (); }); - define("rational?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_rational(); }); - define("integer?", [](let const& xs) { return car(xs).is_also() and car(xs).as().is_integer (); }); - - define("%complex?", [](let const& xs) { return car(xs).is(); }); - define("ratio?", [](let const& xs) { return car(xs).is(); }); - define("single-float?", [](let const& xs) { return car(xs).is(); }); - define("double-float?", [](let const& xs) { return car(xs).is(); }); - - /* ------------------------------------------------------------------------- - * - * (exact-integer? z) procedure - * - * Returns #t if z is both exact and an integer; otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("exact-integer?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (= z1 z2 z3 ...) procedure - * (< x1 x2 x3 ...) procedure - * (> x1 x2 x3 ...) procedure - * (<= x1 x2 x3 ...) procedure - * (>= x1 x2 x3 ...) procedure - * - * These procedures return #t if their arguments are (respectively): - * equal, monotonically increasing, monotonically decreasing, - * monotonically non-decreasing, or monotonically non-increasing, and #f - * otherwise. If any of the arguments are +nan.0, all the predicates - * return #f. They do not distinguish between inexact zero and inexact - * negative zero. - * - * These predicates are required to be transitive. - * - * Note: The implementation approach of converting all arguments to - * inexact numbers if any argument is inexact is not transitive. For - * example, let big be (expt 2 1000), and assume that big is exact and - * that inexact numbers are represented by 64-bit IEEE binary floating - * point numbers. Then (= (- big 1) (inexact big)) and (= (inexact big) - * (+ big 1)) would both be true with this approach, because of the - * limitations of IEEE representations of large integers, whereas (= (- - * big 1) (+ big 1)) is false. Converting inexact values to exact numbers - * that are the same (in the sense of =) to them will avoid this problem, - * though special care must be taken with infinities. - * - * Note: While it is not an error to compare inexact numbers using these - * predicates, the results are unreliable because a small inaccuracy can - * affect the result; this is especially true of = and zero?. When in - * doubt, consult a numerical analyst. - * - * ---------------------------------------------------------------------- */ - - #define DEFINE(SYMBOL, COMPARE) \ - define(#SYMBOL, [](let const& xs) \ - { \ - return std::adjacent_find( \ - std::begin(xs), std::end(xs), [](let const& a, let const& b) \ - { \ - return not COMPARE(a.as(), b); \ - }) == std::end(xs); \ - }) - - DEFINE(= , std::equal_to ()); - DEFINE(!=, std::not_equal_to ()); - DEFINE(< , std::less ()); - DEFINE(<=, std::less_equal ()); - DEFINE(> , std::greater ()); - DEFINE(>=, std::greater_equal()); - - #undef DEFINE - - /* ------------------------------------------------------------------------- - * - * (+ z1 ...) procedure - * (* z1 ...) procedure - * - * These procedures return the sum or product of their arguments. - * - * ---------------------------------------------------------------------- */ - - define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, [](let const& a, let const& b) { return a + b; }); }); - define("*", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e1, [](let const& a, let const& b) { return a * b; }); }); - - /* ------------------------------------------------------------------------- - * - * (- z) procedure - * (- z1 z2 ...) procedure - * (/ z) procedure - * (/ z1 z2 ...) procedure - * - * With two or more arguments, these procedures return the difference or - * quotient of their arguments, associating to the left. With one - * argument, however, they return the additive or multiplicative inverse - * of their argument. - * - * It is an error if any argument of / other than the first is an exact - * zero. If the first argument is an exact zero, an implementation may - * return an exact zero unless one of the other arguments is a NaN. - * - * ---------------------------------------------------------------------- */ - - #define DEFINE(SYMBOL, FUNCTION, BASIS) \ - define(SYMBOL, [](let const& xs) \ - { \ - switch (length(xs)) \ - { \ - case 0: \ - throw invalid_application(intern(SYMBOL) | xs); \ - \ - case 1: \ - return FUNCTION(BASIS, car(xs)); \ - \ - default: \ - return std::accumulate( \ - std::next(std::begin(xs)), std::end(xs), car(xs), \ - [](let const& a, let const& b) \ - { \ - return FUNCTION(a, b); \ - }); \ - } \ - }) - - DEFINE("-", sub, e0); - DEFINE("/", div, e1); - DEFINE("%", mod, e1); - - #undef DEFINE - - /* ------------------------------------------------------------------------- - * - * (floor x) procedure - * (ceiling x) procedure - * (truncate x) procedure - * (round x) procedure - * - * These procedures return integers. The floor procedure returns the - * largest integer not larger than x. The ceiling procedure returns the - * smallest integer not smaller than x, truncate returns the integer - * closest to x whose absolute value is not larger than the absolute value - * of x, and round returns the closest integer to x, rounding to even when - * x is halfway between two integers. - * - * ---------------------------------------------------------------------- */ - - define("floor", [](let const& xs) { return car(xs).as().floor(); }); - define("ceiling", [](let const& xs) { return car(xs).as().ceil(); }); - define("truncate", [](let const& xs) { return car(xs).as().trunc(); }); - define("round", [](let const& xs) { return car(xs).as().round(); }); - - /* ------------------------------------------------------------------------- - * - * (expt z1 z2) procedure - * - * Returns z1 raised to the power z2. For nonzero z1 , this is - * - * z1^z2 = e^(z2 log z1) - * - * The value of 0 z is 1 if (zero? z), 0 if (real-part z) is positive, and - * an error otherwise. Similarly for 0.0^z , with inexact results. - * - * ---------------------------------------------------------------------- */ - - define("expt", [](let const& xs) - { - return car(xs).as().pow(cadr(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (inexact z) procedure - * (exact z) procedure - * - * The procedure inexact returns an inexact representation of z. The value - * returned is the inexact number that is numerically closest to the - * argument. For inexact arguments, the result is the same as the argument. - * For exact complex numbers, the result is a complex number whose real - * and imaginary parts are the result of applying inexact to the real and - * imaginary parts of the argument, respectively. If an exact argument has - * no reasonably close inexact equivalent (in the sense of =), then a - * violation of an implementation restriction may be reported. - * - * The procedure exact returns an exact representation of z. The value - * returned is the exact number that is numerically closest to the - * argument. For exact arguments, the result is the same as the argument. - * For inexact nonintegral real arguments, the implementation may return a - * rational approximation, or may report an implementation violation. For - * inexact complex arguments, the result is a complex number whose real - * and imaginary parts are the result of applying exact to the real and - * imaginary parts of the argument, respectively. If an inexact argument - * has no reasonably close exact equivalent, (in the sense of =), then a - * violation of an implementation restriction may be reported. - * - * These procedures implement the natural one-to-one correspondence - * between exact and inexact integers throughout an - * implementation-dependent range. See section 6.2.3. - * - * Note: These procedures were known in R5RS as exact->inexact and - * inexact->exact, respectively, but they have always accepted arguments - * of any exactness. The new names are clearer and shorter, as well as - * being compatible with R6RS. - * - * ---------------------------------------------------------------------- */ - - define( "exact", [](let const& xs) { return car(xs).as().exact (); }); - define("inexact", [](let const& xs) { return car(xs).as().inexact(); }); - - /* ------------------------------------------------------------------------- - * - * (number->string z) procedure - * (number->string z radix) procedure - * - * It is an error if radix is not one of 2, 8, 10, or 16. The procedure - * number->string takes a number and a radix and returns as a string an - * external representation of the given number in the given radix such - * that - * - * (let ((number number) - * (radix radix)) - * (eqv? number (string->number (number->string number radix) radix))) - * - * is true. It is an error if no possible result makes this expression - * true. If omitted, radix defaults to 10. - * - * If z is inexact, the radix is 10, and the above expression can be - * satisfied by a result that contains a decimal point, then the result - * contains a decimal point and is expressed using the minimum number of - * digits (exclusive of exponent and trailing zeroes) needed to make the - * above expression true [4, 5]; otherwise the format of the result is - * unspecified. - * - * The result returned by number->string never contains an explicit radix - * prefix. - * - * Note: The error case can occur only when z is not a complex number or - * is a complex number with a non-rational real or imaginary part. - * - * Rationale: If z is an inexact number and the radix is 10, then the - * above expression is normally satisfied by a result containing a decimal - * point. The unspecified case allows for infinities, NaNs, and unusual - * representations. - * - * ---------------------------------------------------------------------- */ - - define("number->string", [](auto&& xs) - { - return make(lexical_cast(car(xs))); - }); - - /* ------------------------------------------------------------------------- - * - * (string->number string) procedure - * (string->number string radix) procedure - * - * Returns a number of the maximally precise representation expressed by - * the given string. It is an error if radix is not 2, 8, 10, or 16. - * - * If supplied, radix is a default radix that will be overridden if an - * explicit radix prefix is present in string (e.g. "#o177"). If radix is - * not supplied, then the default radix is 10. If string is not a - * syntactically valid notation for a number, or would result in a number - * that the implementation cannot represent, then string->number returns - * #f. An error is never signaled due to the content of string. - * - * ---------------------------------------------------------------------- */ - - define("string->number", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return string_to::number(car(xs).as(), 10); - - case 2: - return string_to::number(car(xs).as(), static_cast(cadr(xs).as())); - - default: - throw invalid_application(intern("string->number") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (pair? obj) procedure - * - * The pair? predicate returns #t if obj is a pair, and otherwise returns - * #f. - * - * ---------------------------------------------------------------------- */ - - define("pair?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (cons obj1 obj2) procedure - * - * Returns a newly allocated pair whose car is obj1 and whose cdr is obj2. - * The pair is guaranteed to be different (in the sense of eqv?) from - * every existing object. - * - * ---------------------------------------------------------------------- */ - - define("cons", cons_, [](let const& xs) - { - return cons(car(xs), cadr(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (car pair) procedure - * - * Returns the contents of the car field of pair. Note that it is an error - * to take the car of the empty list. - * - * (cdr pair) procedure - * - * Returns the contents of the cdr field of pair. Note that it is an error - * to take the cdr of the empty list. - * - * ---------------------------------------------------------------------- */ - - define("car", [](let const& xs) { return caar(xs); }); - define("cdr", [](let const& xs) { return cdar(xs); }); - - /* ------------------------------------------------------------------------- - * - * (set-car! pair obj) procedure - * - * Stores obj in the car field of pair. - * - * (set-cdr! pair obj) procedure - * - * Stores obj in the cdr field of pair. - * - * ---------------------------------------------------------------------- */ - - define("set-car!", [](auto&& xs) { return caar(xs) = cadr(xs); }); - define("set-cdr!", [](auto&& xs) { return cdar(xs) = cadr(xs); }); - - /* ------------------------------------------------------------------------- - * - * (caar pair) procedure - * (caar pair) procedure - * (caar pair) procedure - * (caar pair) procedure - * - * These procedures are compositions of car and cdr as follows: - * - * (define (caar x) (car (car x))) - * (define (cadr x) (car (cdr x))) - * (define (cdar x) (cdr (car x))) - * (define (cddr x) (cdr (cdr x))) - * - * ---------------------------------------------------------------------- */ - - define("caar", [](let const& xs) { return caar(car(xs)); }); - define("cadr", [](let const& xs) { return cadr(car(xs)); }); - define("cdar", [](let const& xs) { return cdar(car(xs)); }); - define("cddr", [](let const& xs) { return cddr(car(xs)); }); - - /* ------------------------------------------------------------------------- - * - * (null? obj) procedure - * - * Returns #t if obj is the empty list, otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("null?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (symbol? obj) procedure - * - * Returns #t if obj is a symbol, otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("symbol?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (symbol->string symbol) procedure - * - * Returns the name of symbol as a string, but without adding escapes. It - * is an error to apply mutation procedures like string-set! to strings - * returned by this procedure. - * - * ---------------------------------------------------------------------- */ - - define("symbol->string", [](let const& xs) - { - return make(car(xs).as()); - }); - - /* ------------------------------------------------------------------------- - * - * (string->symbol string) procedure - * - * Returns the symbol whose name is string. This procedure can create - * symbols with names containing special characters that would require - * escaping when written, but does not interpret escapes in its input. - * - * ---------------------------------------------------------------------- */ - - define("string->symbol", [](let const& xs) - { - return intern(car(xs).as()); - }); - - /* ------------------------------------------------------------------------- - * - * (char? obj) procedure - * - * Returns #t if obj is a character, otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("char?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (char->integer char) procedure - * (integer->char n) procedure - * - * Given a Unicode character, char->integer returns an exact integer - * between 0 and #xD7FF or between #xE000 and #x10FFFF which is equal to - * the Unicode scalar value of that character. Given a non-Unicode - * character, it returns an exact integer greater than #x10FFFF. This is - * true independent of whether the implementation uses the Unicode - * representation internally. - * - * Given an exact integer that is the value returned by a character when - * char->integer is applied to it, integer->char returns that character. - * - * ---------------------------------------------------------------------- */ - - define("char->integer", [](let const& xs) - { - if (xs.is() and car(xs).is()) - { - return make(car(xs).as().codepoint); - } - else - { - throw invalid_application(intern("char->integer") | xs); - } - }); - - define("integer->char", [](let const& xs) - { - if (xs.is() and car(xs).is()) - { - return make(static_cast(car(xs).as())); - } - else - { - throw invalid_application(intern("integer->char") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (string? obj) procedure - * - * Returns #t if obj is a string, otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("string?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (make-string k) procedure - * (make-string k char) procedure - * - * The make-string procedure returns a newly allocated string of length k. - * If char is given, then all the characters of the string are initialized - * to char , otherwise the contents of the string are unspecified. - * - * ---------------------------------------------------------------------- */ - - define("make-string", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return make(static_cast(car(xs).as()), character()); - - case 2: - return make(static_cast(car(xs).as()), cadr(xs).as()); - - default: - throw invalid_application(intern("make-string") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (string-length string) procedure - * - * Returns the number of characters in the given string. - * - * ---------------------------------------------------------------------- */ - - define("string-length", [](let const& xs) - { - return make(car(xs).as().size()); - }); - - /* ------------------------------------------------------------------------- - * - * (string-ref string k) procedure - * - * It is an error if k is not a valid index of string. The string-ref - * procedure returns character k of string using zero-origin indexing. - * There is no requirement for this procedure to execute in constant time. - * - * ---------------------------------------------------------------------- */ - - define("string-ref", [](let const& xs) - { - return make(car(xs).as().at(static_cast(cadr(xs).as()))); - }); - - /* ------------------------------------------------------------------------- - * - * (string-set! string k char) procedure - * - * It is an error if k is not a valid index of string. The string-set! - * procedure stores char in element k of string. There is no requirement - * for this procedure to execute in constant time. - * - * (define (f) (make-string 3 #\*)) - * (define (g) "***") - * - * (string-set! (f) 0 #\?) => unspecified - * (string-set! (g) 0 #\?) => error - * - * (string-set! (symbol->string 'immutable) 0 #\?) => error - * - * ---------------------------------------------------------------------- */ - - define("string-set!", [](let const& xs) - { - car(xs).as().at(static_cast(cadr(xs).as())) = caddr(xs).as(); - return car(xs); - }); - - /* ------------------------------------------------------------------------- - * - * (string=? string1 string2 string3 ...) procedure - * - * Returns #t if all the strings are the same length and contain exactly - * the same characters in the same positions, otherwise returns #f. - * - * - * (string? string1 string2 string3 ...) procedure - * (string<=? string1 string2 string3 ...) procedure - * (string>=? string1 string2 string3 ...) procedure - * - * These procedures return #t if their arguments are (respectively): - * monotonically increasing, monotonically decreasing, monotonically - * non-decreasing, or monotonically nonincreasing. These predicates are - * required to be transitive. These procedures compare strings in an - * implementation-defined way. One approach is to make them the - * lexicographic extensions to strings of the corresponding orderings on - * characters. In that case, string?, and must satisfy string<=? if and only if they - * do not satisfy string>? and string>=? if and only if they do not - * satisfy string(), \ - b.as_const()); \ - }) == std::end(xs); \ - } - - define("string=?", STRING_COMPARE(std::equal_to ())); - define("string())); - define("string<=?", STRING_COMPARE(std::less_equal ())); - define("string>?", STRING_COMPARE(std::greater ())); - define("string>=?", STRING_COMPARE(std::greater_equal())); - - #undef STRING_COMPARE - - /* ------------------------------------------------------------------------- - * - * (string-append string ...) procedure - * - * Returns a newly allocated string whose characters are the concatenation - * of the characters in the given strings. - * - * ---------------------------------------------------------------------- */ - - define("string-append", [](let const& xs) - { - string result; - - for (let const& x : xs) - { - std::copy(std::cbegin(x.as()), std::cend(x.as()), std::back_inserter(result)); - } - - return make(result); - }); - - /* ------------------------------------------------------------------------- - * - * (string->list string) procedure - * (string->list string start) procedure - * (string->list string start end) procedure - * - * (list->string list) procedure - * - * It is an error if any element of list is not a character. The - * string->list procedure returns a newly allocated list of the characters - * of string between start and end. list->string returns a newly allocated - * string formed from the elements in the list list. In both procedures, - * order is preserved. string->list and list->string are inverses so far - * as equal? is concerned. - * - * ---------------------------------------------------------------------- */ - - define("string->list", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return car(xs).as().list(); - - case 2: - return car(xs).as().list(static_cast(cadr(xs).as())); - - case 3: - return car(xs).as().list(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); - - default: - throw invalid_application(intern("string->list") | xs); - } - }); - - define("list->string", [](let const& xs) - { - string s; - - for (let const& x : car(xs)) - { - s.push_back(x.as()); - } - - return make(std::move(s)); - }); - - /* ------------------------------------------------------------------------- - * - * (string-copy string) procedure - * (string-copy string start) procedure - * (string-copy string start end) procedure - * - * Returns a newly allocated copy of the part of the given string between - * start and end. - * - * ---------------------------------------------------------------------- */ - - define("string-copy", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return make(car(xs).as()); - - case 2: - return make(car(xs).as().begin() + static_cast(cadr(xs).as()), - car(xs).as().end()); - case 3: - return make(car(xs).as().begin() + static_cast( cadr(xs).as()), - car(xs).as().begin() + static_cast(caddr(xs).as())); - default: - throw invalid_application(intern("string-copy") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (vector? obj) procedure - * - * Returns #t if obj is a vector; otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("vector?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (make-vector k) procedure - * (make-vector k fill) procedure - * - * Returns a newly allocated vector of k elements. If a second argument is - * given, then each element is initialized to fill. Otherwise the initial - * contents of each element is unspecified. - * - * ---------------------------------------------------------------------- */ - - define("make-vector", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return make(static_cast(car(xs).as()), unspecified_object); - - case 2: - return make(static_cast(car(xs).as()), cadr(xs)); - - default: - throw invalid_application(intern("make-vector") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (vector obj ...) procedure - * - * Returns a newly allocated vector whose elements contain the given - * arguments. It is analogous to list. - * - * ---------------------------------------------------------------------- */ - - define("vector", [](let const& xs) - { - return make(for_each_in, xs); - }); - - /* ------------------------------------------------------------------------- - * - * (vector-length vector) procedure - * - * Returns the number of elements in vector as an exact integer. - * - * ---------------------------------------------------------------------- */ - - define("vector-length", [](let const& xs) - { - return make(car(xs).as().size()); - }); - - /* ------------------------------------------------------------------------- - * - * (vector-ref vector k) procedure - * - * It is an error if k is not a valid index of vector. The vector-ref - * procedure returns the contents of element k of vector. - * - * ---------------------------------------------------------------------- */ - - define("vector-ref", [](let const& xs) - { - return car(xs).as().at(static_cast(cadr(xs).as())); - }); - - /* ------------------------------------------------------------------------- - * - * (vector-set! vector k obj) procedure - * - * It is an error if k is not a valid index of vector. The vector-set! - * procedure stores obj in element k of vector. - * - * ---------------------------------------------------------------------- */ - - define("vector-set!", [](let const& xs) - { - return car(xs).as().at(static_cast(cadr(xs).as())) = caddr(xs); - }); - - /* ------------------------------------------------------------------------- - * - * (vector->list vector) procedure - * (vector->list vector start) procedure - * (vector->list vector start end) procedure - * - * (list->vector list) procedure - * - * The vector->list procedure returns a newly allocated list of the - * objects contained in the elements of vector between start and end. The - * list->vector procedure returns a newly created vector initialized to - * the elements of the list list. - * - * ---------------------------------------------------------------------- */ - - define("vector->list", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return car(xs).as().list(); - - case 2: - return car(xs).as().list(static_cast(cadr(xs).as())); - - case 3: - return car(xs).as().list(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); - - default: - throw invalid_application(intern("vector->list") | xs); - } - }); - - define("list->vector", [](let const& xs) - { - return make(for_each_in, car(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (vector->string vector) procedure - * (vector->string vector start) procedure - * (vector->string vector start end) procedure - * - * (string->vector string) procedure - * (string->vector string start) procedure - * (string->vector string start end) procedure - * - * It is an error if any element of vector between start and end is not a - * character. - * - * The vector->string procedure returns a newly allocated string of the - * objects contained in the elements of vector between start and end. The - * string->vector procedure returns a newly created vector initialized to - * the elements of the string string between start and end. - * - * In both procedures, order is preserved. - * - * ---------------------------------------------------------------------- */ - - define("vector->string", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return car(xs).as().string(); - - case 2: - return car(xs).as().string(static_cast(cadr(xs).as())); - - case 3: - return car(xs).as().string(static_cast(cadr(xs).as()), static_cast(caddr(xs).as())); - - default: - throw invalid_application(intern("vector->string") | xs); - } - }); - - // define("string->vector", [](auto&& xs) - // { - // return unspecified_object; - // }); - - // define("vector-copy", [](auto&& xs) - // { - // return unspecified_object; - // }); - - // define("vector-copy!", [](auto&& xs) - // { - // return unspecified_object; - // }); - - // define("vector-append", [](auto&& xs) - // { - // return unspecified_object; - // }); - - /* ------------------------------------------------------------------------- - * - * (vector-fill! vector fill) procedure - * (vector-fill! vector fill start) procedure - * (vector-fill! vector fill start end) procedure - * - * The vector-fill! procedure stores fill in the elements of vector - * between start and end. - * - * ---------------------------------------------------------------------- */ - - define("vector-fill!", [](let const& xs) - { - switch (length(xs)) - { - case 2: - car(xs).as().fill(cadr(xs)); - break; - - case 3: - car(xs).as().fill(cadr(xs), static_cast(caddr(xs).as())); - break; - - case 4: - car(xs).as().fill(cadr(xs), static_cast(caddr(xs).as()), static_cast(cadddr(xs).as())); - break; - - default: - throw invalid_application(intern("vector-fill!") | xs); - } - - return unspecified_object; - }); - - /* ------------------------------------------------------------------------- - * - * (procedure? obj) procedure - * - * Returns #t if obj is a procedure, otherwise returns #f. - * - * ---------------------------------------------------------------------- */ - - define("closure?", [](let const& xs) - { - return car(xs).is(); - }); - - define("continuation?", [](let const& xs) - { - return car(xs).is(); - }); - - define("foreign-function?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (with-exception-handler handler thunk) procedure - * - * It is an error if handler does not accept one argument. It is also an - * error if thunk does not accept zero arguments. - * - * The with-exception-handler procedure returns the results of invoking - * thunk. Handler is installed as the current exception handler in the - * dynamic environment used for the invocation of thunk. - * - * ---------------------------------------------------------------------- */ - - define("default-exception-handler", [](let const& xs) -> object - { - throw car(xs); - }); - - /* ------------------------------------------------------------------------- - * - * (error message obj ...) procedure - * - * Message should be a string. - * - * Raises an exception as if by calling raise on a newly allocated - * implementation-defined object which encapsulates the information - * provided by message, as well as any objs, known as the irritants. The - * procedure error-object? must return #t on such objects. - * - * (define (error . xs) - * (raise (apply make-error xs))) ; SRFI 23 - * - * ---------------------------------------------------------------------- */ - - define("make-error", [](let const& xs) - { - return make(car(xs), cdr(xs)); - }); - - /* ------------------------------------------------------------------------- - * - * (read-error? obj) procedure - * (file-error? obj) procedure - * - * Error type predicates. Returns #t if obj is an object raised by the - * read procedure or by the inability to open an input or output port on a - * file, respectively. Otherwise, it returns #f. - * - * ---------------------------------------------------------------------- */ - - define( "error?", [](let const& xs) { return car(xs).is< error>(); }); - define( "read-error?", [](let const& xs) { return car(xs).is< read_error>(); }); - define( "file-error?", [](let const& xs) { return car(xs).is< file_error>(); }); - define("syntax-error?", [](let const& xs) { return car(xs).is(); }); - - /* ------------------------------------------------------------------------- - * - * (input-port? obj) procedure - * (output-port? obj) procedure - * (textual-port? obj) procedure - * (binary-port? obj) procedure - * (port? obj) procedure - * - * These procedures return #t if obj is an input port, output port, - * textual port, binary port, or any kind of port, respectively. Otherwise - * they return #f. - * - * ---------------------------------------------------------------------- */ - - define( "input-port?", [](let const& xs) { return car(xs).is_also(); }); - define( "output-port?", [](let const& xs) { return car(xs).is_also(); }); - define( "binary-port?", [](let const& ) { return false; }); - define("textual-port?", [](let const& xs) { return car(xs).is_also(); }); - define( "port?", [](let const& xs) { return car(xs).is_also(); }); - - /* ------------------------------------------------------------------------- - * - * (input-port-open? port) procedure - * (output-port-open? port) procedure - * - * Returns #t if port is still open and capable of performing input or - * output, respectively, and #f otherwise. - * - * --------------------------------------------------------------------- */ - - define("input-port-open?", [](let const& xs) - { - if (let const& x = car(xs); x.is_also()) - { - return x.as().is_open(); - } - else - { - return x.is_also(); - } - }); - - define("output-port-open?", [](let const& xs) - { - if (let const& x = car(xs); x.is_also()) - { - return x.as().is_open(); - } - else - { - return x.is_also(); - } - }); - - /* ------------------------------------------------------------------------- - * - * (current-input-port) procedure - * (current-output-port) procedure - * (current-error-port) procedure - * - * Returns the current default input port, output port, or error port (an - * output port), respectively. These procedures are parameter objects, - * which can be overridden with parameterize (see section 4.2.6). The - * initial bindings for these are implementation-defined textual ports. - * - * ---------------------------------------------------------------------- */ - - define("standard-input-port", [](auto&&...) { return standard_input; }); - define("standard-output-port", [](auto&&...) { return standard_output; }); - define("standard-error-port", [](auto&&...) { return standard_error; }); - - /* ------------------------------------------------------------------------- - * - * (open-input-file string) file library procedure - * (open-binary-input-file string) file library procedure - * - * Takes a string for an existing file and returns a textual input port or - * binary input port that is capable of delivering data from the file. If - * the file does not exist or cannot be opened, an error that satisfies - * file-error? is signaled. - * - * ---------------------------------------------------------------------- */ - - define("open-input-file", [](let const& xs) - { - return make(car(xs).as()); - }); - - /* ------------------------------------------------------------------------- - * - * (open-output-file string) file library procedure - * (open-binary-output-file string) file library procedure - * - * Takes a string naming an output file to be created and returns a - * textual output port or binary output port that is capable of writing - * data to a new file by that name. If a file with the given name already - * exists, the effect is unspecified. If the file cannot be opened, an - * error that satisfies file-error? is signaled. - * - * ---------------------------------------------------------------------- */ - - define("open-output-file", [](let const& xs) - { - return make(car(xs).as()); - }); - - /* ------------------------------------------------------------------------- - * - * (close-port port) procedure - * (close-input-port port) procedure - * (close-output-port port) procedure - * - * Closes the resource associated with port, rendering the port incapable - * of delivering or accepting data. It is an error to apply the last two - * procedures to a port which is not an input or output port, respectively. - * Scheme implementations may provide ports which are simultaneously input - * and output ports, such as sockets; the close-input-port and - * close-output-port procedures can then be used to close the input and - * output sides of the port independently. These routines have no effect - * if the port has already been closed. - * - * ---------------------------------------------------------------------- */ - - define("close-input-port", [](let const& xs) - { - if (let const& x = car(xs); x.is_also()) - { - x.as().close(); - } - - return unspecified_object; - }); - - define("close-output-port", [](let const& xs) - { - if (let const& x = car(xs); x.is_also()) - { - x.as().close(); - } - - return unspecified_object; - }); - - /* ------------------------------------------------------------------------- - * - * (open-input-string string) procedure - * - * Takes a string and returns a textual input port that delivers - * characters from the string. If the string is modified, the effect is - * unspecified. - * - * ---------------------------------------------------------------------- */ - - define("open-input-string", [](let const& xs) - { - switch (length(xs)) - { - case 0: - return make(); - - case 1: - return make(car(xs).as()); - - default: - throw invalid_application(intern("open-input-string") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (open-output-string) procedure - * - * Returns a textual output port that will accumulate characters for - * retrieval by get-output-string. - * - * ---------------------------------------------------------------------- */ - - define("open-output-string", [](let const& xs) - { - switch (length(xs)) - { - case 0: - return make(); - - case 1: - return make(car(xs).as()); - - default: - throw invalid_application(intern("open-output-string") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (get-output-string port) procedure - * - * It is an error if port was not created with open-output-string. - * - * Returns a string consisting of the characters that have been output to - * the port so far in the order they were output. If the result string is - * modified, the effect is unspecified. - * - * ---------------------------------------------------------------------- */ - - define("get-output-string", [](let const& xs) - { - return make(car(xs).as().str()); - }); - - /* ------------------------------------------------------------------------- - * - * (read-char) procedure - * (read-char port) procedure - * - * Returns the next character available from the textual input port, - * updating the port to point to the following character. If no more - * characters are available, an end-of-file object is returned. - * - * ---------------------------------------------------------------------- */ - - define("%read-char", [](let const& xs) - { - try - { - return make(car(xs).as()); - } - catch (eof const&) - { - return eof_object; - } - catch (read_error const& error) - { - return make(error); - } - }); - - /* ------------------------------------------------------------------------- - * - * (peek-char) procedure - * (peek-char port) procedure - * - * Returns the next character available from the textual input port, but - * without updating the port to point to the following character. If no - * more characters are available, an end-of-file object is returned. - * - * Note: The value returned by a call to peek-char is the same as the - * value that would have been returned by a call to read-char with the - * same port. The only difference is that the very next call to read-char - * or peek-char on that port will return the value returned by the - * preceding call to peek-char. In particular, a call to peek-char on an - * interactive port will hang waiting for input whenever a call to - * read-char would have hung. - * - * ---------------------------------------------------------------------- */ - - define("%peek-char", [](let const& xs) - { - try - { - auto const g = car(xs).as().tellg(); - let const c = make(car(xs).as()); - car(xs).as().seekg(g); - return c; - } - catch (eof const&) - { - return eof_object; - } - catch (read_error const& error) - { - return make(error); - } - }); - - /* ------------------------------------------------------------------------- - * - * (eof-object? obj) procedure - * - * Returns #t if obj is an end-of-file object, otherwise returns #f. The - * precise set of end-of-file objects will vary among implementations, but - * in any case no end-of-file object will ever be an object that can be - * read in using read. - * - * ---------------------------------------------------------------------- */ - - define("eof-object?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (eof-object) procedure - * - * Returns an end-of-file object, not necessarily unique. - * - * ---------------------------------------------------------------------- */ - - define("eof-object", [](auto&&...) - { - return eof_object; - }); - - /* ------------------------------------------------------------------------- - * - * (char-ready?) procedure - * (char-ready? port) procedure - * - * Returns #t if a character is ready on the textual input port and - * returns #f otherwise. If char-ready returns #t then the next read-char - * operation on the given port is guaranteed not to hang. If the port is - * at end of file then char-ready? returns #t. - * - * Rationale: The char-ready? procedure exists to make it possible for a - * program to accept characters from interactive ports without getting - * stuck waiting for input. Any input editors associated with such ports - * must ensure that characters whose existence has been asserted by - * char-ready? cannot be removed from the input. If char-ready? were to - * return #f at end of file, a port at end of file would be - * indistinguishable from an interactive port that has no ready characters. - * - * ---------------------------------------------------------------------- */ - - define("%char-ready?", [](let const& xs) - { - return static_cast(car(xs).as()); - }); - - /* ------------------------------------------------------------------------- - * - * (read-string k) procedure - * (read-string k port) procedure - * - * Reads the next k characters, or as many as are available before the end - * of file, from the textual input port into a newly allocated string in - * left-to-right order and returns the string. If no characters are - * available before the end of file, an end-of-file object is returned. - * - * ---------------------------------------------------------------------- */ - - define("%read-string", [](let const& xs) - { - switch (length(xs)) - { - case 2: - return make(cadr(xs).as(), static_cast(car(xs).as())); - - default: - throw invalid_application(intern("read-string") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (write-char char) procedure - * (write-char char port) procedure - * - * Writes the character char (not an external representation of the - * character) to the given textual output port and returns an unspecified - * value. - * - * --------------------------------------------------------------------- */ - - define("put-char", [](let const& xs) - { - cadr(xs).as() << static_cast(car(xs).as()); - return unspecified_object; - }); - - /* ------------------------------------------------------------------------- - * - * (write-string string) procedure - * (write-string string port) procedure - * (write-string string port start) procedure - * (write-string string port start end) procedure - * - * Writes the characters of string from start to end in left-to-right - * order to the textual output port. - * - * ---------------------------------------------------------------------- */ - - define("put-string", [](let const& xs) - { - switch (length(xs)) - { - case 2: - cadr(xs).as() << static_cast(car(xs).as()); - break; - - case 3: // TODO - case 4: // TODO - - default: - throw invalid_application(intern("write-string") | xs); - } - - return unspecified_object; - }); - - /* ------------------------------------------------------------------------- - * - * (flush-output-port) procedure - * (flush-output-port port) procedure - * - * Flushes any buffered output from the buffer of output-port to the - * underlying file or device and returns an unspecified value. - * - * ---------------------------------------------------------------------- */ - - define("%flush-output-port", [](let const& xs) - { - car(xs).as() << std::flush; - return unspecified_object; - }); - - /* ------------------------------------------------------------------------- - * - * (features) procedure - * - * Returns a list of the feature identifiers which cond-expand treats as - * true. It is an error to modify this list. Here is an example of what - * features might return: - * - * (features) => - * (r7rs ratios exact-complex full-unicode gnu-linux little-endian - * fantastic-scheme fantastic-scheme-1.0 space-ship-control-system) - * - * ---------------------------------------------------------------------- */ + import("(meevax character)"); + import("(meevax context)"); + import("(meevax control)"); + import("(meevax equivalence)"); + import("(meevax evaluate)"); + import("(meevax exception)"); + import("(meevax experimental)"); + import("(meevax inexact)"); + import("(meevax list)"); + import("(meevax macro)"); + import("(meevax number)"); + import("(meevax pair)"); + import("(meevax port)"); + import("(meevax read)"); + import("(meevax string)"); + import("(meevax symbol)"); + import("(meevax syntax)"); + import("(meevax vector)"); + import("(meevax write)"); define("features", [](auto&&...) { return features(); }); - /* ------------------------------------------------------------------------- - * - * (digit-value char) char library procedure - * - * This procedure returns the numeric value (0 to 9) of its argument if it - * is a numeric digit (that is, if char-numeric? returns #t), or #f on any - * other character. - * - * ---------------------------------------------------------------------- */ - - define("digit-value", [](let const& xs) - { - if (auto c = car(xs).as(); std::isdigit(c.codepoint)) - { - return make(c.codepoint - '0'); - } - else - { - return f; - } - }); - - /* ------------------------------------------------------------------------- - * - * (string-ci=? string1 string2 string3 ...) char library procedure - * - * Returns #t if, after case-folding, all the strings are the same length - * and contain the same characters in the same positions, otherwise - * returns #f. Specifically, these procedures behave as if string-foldcase - * were applied to their arguments before comparing them. - * - * - * (string-ci? string1 string2 string3 ...) char library procedure - * (string-ci<=? string1 string2 string3 ...) char library procedure - * (string-ci>=? string1 string2 string3 ...) char library procedure - * - * The "-ci" procedures behave as if they applied string-foldcase to their - * arguments before invoking the corresponding procedures without "-ci". - * - * ---------------------------------------------------------------------- */ - - /* ------------------------------------------------------------------------- - * - * (eval expr-or-def environment-specifier) eval library procedure - * - * If expr-or-def is an expression, it is evaluated in the specified - * environment and its values are returned. If it is a definition, the - * specified identifier(s) are defined in the specified environment, - * provided the environment is not immutable. Implementations may extend - * eval to allow other objects. - * - * ---------------------------------------------------------------------- */ - - define("eval", [](let const& xs) - { - return cadr(xs).as().mac_env.as().evaluate(car(xs)); // DIRTY HACK! - }); - - /* ------------------------------------------------------------------------- - * - * (finite? z) inexact library procedure - * - * The finite? procedure returns #t on all real numbers except +inf.0, - * -inf.0, and +nan.0, and on complex numbers if their real and imaginary - * parts are both finite. Otherwise it returns #f. - * - * ---------------------------------------------------------------------- */ - - define("finite?", [](let const& xs) - { - return car(xs).as().is_finite(); - }); - - /* ------------------------------------------------------------------------- - * - * (infinite? z) inexact library procedure - * - * The infinite? procedure returns #t on the real numbers +inf.0 and - * -inf.0, and on complex numbers if their real or imaginary parts or both - * are infinite. Otherwise it returns #f. - * - * ---------------------------------------------------------------------- */ - - define("infinite?", [](let const& xs) - { - return car(xs).as().is_infinite(); - }); - - /* ------------------------------------------------------------------------- - * - * (nan? z) inexact library procedure - * - * The nan? procedure returns #t on +nan.0, and on complex numbers if - * their real or imaginary parts or both are +nan.0. Otherwise it returns - * #f. - * - * ---------------------------------------------------------------------- */ - - define("nan?", [](let const& xs) - { - return car(xs).is_also() and car(xs).as().is_nan(); - }); - - define("exp", [](let const& xs) { return car(xs).as().exp(); }); - define("sqrt", [](let const& xs) { return car(xs).as().sqrt(); }); - - define("log", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return car(xs).as().log(); - - case 2: - return car(xs).as().log() / cadr(xs).as().log(); - - default: - throw invalid_application(intern("log") | xs); - } - }); - - define("sin", [](let const& xs) { return car(xs).as().sin(); }); - define("cos", [](let const& xs) { return car(xs).as().cos(); }); - define("tan", [](let const& xs) { return car(xs).as().tan(); }); - define("asin", [](let const& xs) { return car(xs).as().asin(); }); - define("acos", [](let const& xs) { return car(xs).as().acos(); }); - define("sinh", [](let const& xs) { return car(xs).as().sinh(); }); - define("cosh", [](let const& xs) { return car(xs).as().cosh(); }); - define("tanh", [](let const& xs) { return car(xs).as().tanh(); }); - define("asinh", [](let const& xs) { return car(xs).as().asinh(); }); - define("acosh", [](let const& xs) { return car(xs).as().acosh(); }); - define("atanh", [](let const& xs) { return car(xs).as().atanh(); }); - - define("atan", [](let const& xs) - { - switch (length(xs)) - { - case 1: - return car(xs).as().atan(); - - case 2: - return car(xs).as().atan2(cadr(xs)); - - default: - throw invalid_application(intern("atan") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (load filename) load library procedure - * (load filename environment-specifier) load library procedure - * - * It is an error if filename is not a string. An implementation-dependent - * operation is used to transform filename into the name of an existing - * file containing Scheme source code. The load procedure reads - * expressions and definitions from the file and evaluates them - * sequentially in the environment specified by environment-specifier. If - * environment-specifier is omitted, (interaction-environment) is assumed. - * - * It is unspecified whether the results of the expressions are printed. - * The load procedure does not affect the values returned by - * current-input-port and current-output-port. It returns an unspecified - * value. - * - * Rationale: For portability, load must operate on source files. Its - * operation on other kinds of files necessarily varies among - * implementations. - * - * ---------------------------------------------------------------------- */ - define("load", [this](let const& xs) { return load(car(xs).as()); }); - /* ------------------------------------------------------------------------- - * - * (emergency-exit) process-context library procedure - * (emergency-exit obj) process-context library procedure - * - * Terminates the program without running any outstanding dynamic-wind - * after procedures and communicates an exit value to the operating system - * in the same manner as exit. - * - * NOTE: The emergency-exit procedure corresponds to the exit procedure in - * Windows and Posix. - * - * ---------------------------------------------------------------------- */ - - define("emergency-exit", [](let const& xs) -> object - { - switch (length(xs)) - { - case 0: - throw exit_status::success; - - case 1: - if (let const& x = car(xs); x.is()) - { - throw select(x) ? exit_status::success : exit_status::failure; - } - else if (x.is()) - { - throw exit_status(static_cast(x.as())); - } - else [[fallthrough]]; - - default: - throw invalid_application(intern("emergency-exit") | xs); - } - }); - - /* ------------------------------------------------------------------------- - * - * (read) read library procedure - * (read port) read library procedure - * - * The read procedure converts external representations of Scheme objects - * into the objects themselves. That is, it is a parser for the - * non-terminal hdatumi (see sections 7.1.2 and 6.4). It returns the next - * object parsable from the given textual input port, updating port to - * point to the first character past the end of the external - * representation of the object. - * - * Implementations may support extended syntax to represent record types - * or other types that do not have datum representations. - * - * If an end of file is encountered in the input before any characters are - * found that can begin an object, then an end-of-file object is returned. - * The port remains open, and further attempts to read will also return an - * end-of-file object. If an end of file is encountered after the - * beginning of an object’s external representation, but the external - * representation is incomplete and therefore not parsable, an error that - * satisfies read-error? is signaled. - * - * ---------------------------------------------------------------------- */ - - define("%read", [this](let const& xs) - { - try - { - switch (length(xs)) - { - case 0: - return read(standard_input); - - case 1: - return read(car(xs)); - - default: - throw invalid_application(intern("read") | xs); - } - } - catch (eof const&) - { - return eof_object; - } - catch (read_error const& error) - { - return make(error); - } - }); - - /* ------------------------------------------------------------------------- - * - * (write-simple obj) write library procedure - * (write-simple obj port) write library procedure - * - * The write-simple procedure is the same as write, except that shared - * structure is never represented using datum labels. This can cause - * write-simple not to terminate if obj contains circular structure. - * - * ---------------------------------------------------------------------- */ - - define("%write-simple", [this](let const& xs) - { - write(cadr(xs), car(xs)); - return unspecified_object; - }); - - define("make-syntactic-closure", [](let const& xs) - { - return make(car(xs), cadr(xs), caddr(xs)); - }); - - define("syntactic-closure?", [](let const& xs) - { - return car(xs).is(); - }); - - /* ------------------------------------------------------------------------- - * - * (identifier? syntax-object) procedure - * - * Returns #t if syntax-object represents an identifier, otherwise returns - * #f. - * - * (identifier? (syntax x)) => #t - * - * (identifier? (quote x)) => #f - * - * (identifier? 3) => #f - * - * ---------------------------------------------------------------------- */ - - define("identifier?", [](let const& xs) - { - return car(xs).is_also(); - }); - - /* ------------------------------------------------------------------------- - * - * (free-identifier=? id1 id2) procedure - * - * Returns #t if the original occurrences of id 1 and id 2 have the same - * binding, otherwise returns #f. free-identifier=? is used to look for a - * literal identifier in the argument to a transformer, such as else in a - * cond clause. A macro definition for syntax-rules would use - * free-identifier=? to look for literals in the input. - * - * ---------------------------------------------------------------------- */ - - // define("free-identifier=?", [](let const& xs) - // { - // return f; - // }); - - /* ------------------------------------------------------------------------- - * - * (bound-identifier=? id1 id2) procedure - * - * Returns #t if a binding for one of the two identifiers id 1 and id 2 - * would shadow free references to the other, otherwise returns #f. Two - * identifiers can be free-identifier=? without being bound-identifier=? - * if they were introduced at different stages in the expansion process. - * Bound-identifier=? can be used, for example, to detect duplicate - * identifiers in bound-variable lists. A macro definition of syntax-rules - * would use bound-identifier=? to look for pattern variables from the - * input pattern in the output template. - * - * ---------------------------------------------------------------------- */ - - // define("bound-identifier=?", [](let const& xs) - // { - // return f; - // }); - - /* ------------------------------------------------------------------------- - * - * (identifier->symbol id) procedure - * - * Returns a symbol representing the original name of id. - * Identifier->symbol is used to examine identifiers that appear in - * literal contexts, i.e., identifiers that will appear in quoted - * structures. - * - * ---------------------------------------------------------------------- */ - - define("identifier->symbol", [](let const& xs) - { - switch (length(xs)) - { - case 1: - if (let const& x = car(xs); x.is()) - { - return x; - } - else [[fallthrough]]; - - default: - throw invalid_application(intern("identifier->symbol") | xs); - } - }); - - define("transformer?", [](let const& xs) - { - return car(xs).is_also(); - }); - - define("disassemble", [](let const& xs) - { - if (0 < length(xs)) - { - if (let const& f = car(xs); f.is()) - { - disassemble(std::cout, car(f)); - } - } - - return standard_output; - }); - - define("ieee-float?", [](auto&&...) - { - return std::numeric_limits::is_iec559; - }); - - define("print", [](let const& xs) - { - for (let const& x : xs) - { - if (x.is()) - { - std::cout << static_cast(x.as()); - } - else - { - std::cout << x; - } - } - - std::cout << std::endl; - - return standard_output; - }); - - define("type-of", [](let const& xs) - { - std::cout << car(xs).type().name() << std::endl; - - return standard_output; - }); - std::vector const codes { overture, srfi_8, diff --git a/src/main.cpp b/src/main.cpp index 42c266ef3..a62706575 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -23,9 +23,9 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - bootstrap(); + library::boot(); - auto main = environment("(scheme base)", + auto main = environment( // "(meevax gc)", "(only (meevax foo) a b)", "(except (meevax foo) a)", diff --git a/test/environment.cpp b/test/environment.cpp index 049276282..83f1e2c70 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,7 +24,7 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - bootstrap(); + library::boot(); auto root = environment(master); } From 97e83100bad650c0fad828a6cf0abe1dec5c4641 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Fri, 6 May 2022 23:02:12 +0900 Subject: [PATCH 08/49] Support declaration `define-library` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/overture.ss | 11 +++++++++-- include/meevax/kernel/library.hpp | 6 ++---- src/kernel/environment.cpp | 6 ++++++ 5 files changed, 21 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 1c002d4bc..94f4ceea4 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.978.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.979.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.978_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.979_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.978 +Meevax Lisp System, version 0.3.979 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 1c212b7f2..2d01797bf 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.978 +0.3.979 diff --git a/basis/overture.ss b/basis/overture.ss index 73c365e1a..cf770d9ae 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,6 +1,13 @@ -(define (identity x) x) +(define-library (scheme base) + (import (meevax syntax)) -(define (list . xs) xs) + (define (list . xs) xs) + + (export list + ) + ) + +(import (scheme base)) (define (unspecified) (if #f #f)) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 010ed9118..ff293d88f 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -35,12 +35,10 @@ inline namespace kernel declare(*this); } - explicit library(std::string declaration) // This copy is intended. + explicit library(const_reference declaration) : environment { empty } { - auto port = std::stringstream(declaration); - - for (let expression = read(port); expression != eof_object; expression = read(port)) + for (let const& expression : declaration) { if (expression.is() and car(expression).is() and car(expression).as().value == "export") diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 9ab813bed..14a968b87 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -73,6 +73,12 @@ inline namespace kernel return unspecified_object; } + else if (expression.is() and car(expression).is() + and car(expression).as().value == "define-library") + { + define_library(lexical_cast(cadr(expression)), cddr(expression)); + return cadr(expression); + } else { auto dump = std::make_tuple(std::exchange(s, unit), From 3d79d13e68222675c896aa96004ba44ce8992c47 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 May 2022 00:38:44 +0900 Subject: [PATCH 09/49] Support SRFI library `(srfi 211 explicit-renaming)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 330 ++++++++++++++++++++++++++++++++----- src/kernel/environment.cpp | 14 +- src/main.cpp | 8 +- 5 files changed, 305 insertions(+), 55 deletions(-) diff --git a/README.md b/README.md index 94f4ceea4..f8f4fd6e1 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.979.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.980.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.979_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.980_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.979 +Meevax Lisp System, version 0.3.980 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 2d01797bf..34ae7927d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.979 +0.3.980 diff --git a/basis/overture.ss b/basis/overture.ss index cf770d9ae..8cd028229 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,13 +1,300 @@ -(define-library (scheme base) - (import (meevax syntax)) - - (define (list . xs) xs) +(define-library (srfi 211 syntactic-closures) + (import (meevax macro) + (meevax syntax)) + (begin (define (sc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure mac-env '() (f form use-env)))) + (define (rsc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure use-env '() (f form mac-env))))) + (export sc-macro-transformer + rsc-macro-transformer + make-syntactic-closure + identifier?)) + +(define-library (srfi 211 explicit-renaming) + (import (meevax equivalence) + (meevax list) + (meevax macro) + (meevax pair) + (meevax syntax)) + (begin (define (list . xs) xs) + (define (er-macro-transformer f) + (lambda (form use-env mac-env) + (define rename:list (list)) + (define (rename x) + (letrec ((assq (lambda (x alist) + (if (null? alist) #f + (if (eq? x (caar alist)) + (car alist) + (assq x (cdr alist)))))) + (alist-cons (lambda (key x alist) + (cons (cons key x) alist)))) + (define cell (assq x rename:list)) + (if cell + (cdr cell) + (begin (set! rename:list (alist-cons x (make-syntactic-closure mac-env '() x) rename:list)) + (cdar rename:list))))) + (define (compare x y) + (eqv? (if (syntactic-closure? x) x + (make-syntactic-closure use-env '() x)) + (if (syntactic-closure? y) y + (make-syntactic-closure use-env '() y)))) + (f form rename compare)))) + (export er-macro-transformer + identifier?)) - (export list +(define-library (scheme base) + (import (meevax control) + (meevax syntax) + ) + (begin (define (list . xs) xs) + ) + (export ; * + ; + + ; - + ; ... + ; / + ; < + ; <= + ; = + ; => + ; > + ; >= + ; _ + ; abs + ; and + ; append + ; apply + ; assoc + ; assq + ; assv + ; begin + ; binary-port? + ; boolean=? + ; boolean? + ; bytevector + ; bytevector-append + ; bytevector-copy + ; bytevector-copy! + ; bytevector-length + ; bytevector-u8-ref + ; bytevector-u8-set! + ; bytevector? + ; caar + ; cadr + ; call-with-current-continuation + ; call-with-port + ; call-with-values + ; call/cc + ; car + ; case + ; cdar + ; cddr + ; cdr + ; ceiling + ; char->integer + ; char-ready? + ; char<=? + ; char=? + ; char>? + ; char? + ; close-input-port + ; close-output-port + ; close-port + ; complex? + ; cond + ; cond-expand + ; cons + ; current-error-port + ; current-input-port + ; current-output-port + ; define + ; define-record-type + ; define-syntax + ; define-values + ; denominator + ; do + ; dynamic-wind + ; else + ; eof-object + ; eof-object? + ; eq? + ; equal? + ; eqv? + ; error + ; error-object-irritants + ; error-object-message + ; error-object? + ; even? + ; exact + ; exact-integer-sqrt + ; exact-integer? + ; exact? + ; expt + ; features + ; file-error? + ; floor + ; floor-quotient + ; floor-remainder + ; floor/ + ; flush-output-port + ; for-each + ; gcd + ; get-output-bytevector + ; get-output-string + ; guard + ; if + ; include + ; include-ci + ; inexact + ; inexact? + ; input-port-open? + ; input-port? + ; integer->char + ; integer? + ; lambda + ; lcm + ; length + ; let + ; let* + ; let*-values + ; let-syntax + ; let-values + ; letrec + ; letrec* + ; letrec-syntax + list + ; list->string + ; list->vector + ; list-copy + ; list-ref + ; list-set! + ; list-tail + ; list? + ; make-bytevector + ; make-list + ; make-parameter + ; make-string + ; make-vector + ; map + ; max + ; member + ; memq + ; memv + ; min + ; modulo + ; negative? + ; newline + ; not + ; null? + ; number->string + ; number? + ; numerator + ; odd? + ; open-input-bytevector + ; open-input-string + ; open-output-bytevector + ; open-output-string + ; or + ; output-port-open? + ; output-port? + ; pair? + ; parameterize + ; peek-char + ; peek-u8 + ; port? + ; positive? + ; procedure? + ; quasiquote + ; quote + ; quotient + ; raise + ; raise-continuable + ; rational? + ; rationalize + ; read-bytevector + ; read-bytevector! + ; read-char + ; read-error? + ; read-line + ; read-string + ; read-u8 + ; real? + ; remainder + ; reverse + ; round + ; set! + ; set-car! + ; set-cdr! + ; square + ; string + ; string->list + ; string->number + ; string->symbol + ; string->utf8 + ; string->vector + ; string-append + ; string-copy + ; string-copy! + ; string-fill! + ; string-for-each + ; string-length + ; string-map + ; string-ref + ; string-set! + ; string<=? + ; string=? + ; string>? + ; string? + ; substring + ; symbol->string + ; symbol=? + ; symbol? + ; syntax-error + ; syntax-rules + ; textual-port? + ; truncate + ; truncate-quotient + ; truncate-remainder + ; truncate/ + ; u8-ready? + ; unless + ; unquote + ; unquote-splicing + ; utf8->string + ; values + ; vector + ; vector->list + ; vector->string + ; vector-append + ; vector-copy + ; vector-copy! + ; vector-fill! + ; vector-for-each + ; vector-length + ; vector-map + ; vector-ref + ; vector-set! + ; vector? + ; when + ; with-exception-handler + ; write-bytevector + ; write-char + ; write-string + ; write-u8 + ; zero? ) ) -(import (scheme base)) +(import (scheme base) + (srfi 211 explicit-renaming) + (srfi 211 syntactic-closures) + ) (define (unspecified) (if #f #f)) @@ -17,37 +304,6 @@ (lambda (form use-env mac-env) (apply f (cdr form)))) -(define (sc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure mac-env '() (f form use-env)))) - -(define (rsc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure use-env '() (f form mac-env)))) - -(define (er-macro-transformer f) - (lambda (form use-env mac-env) - (define rename:list (list)) - (define (rename x) - (letrec ((assq (lambda (x alist) - (if (null? alist) #f - (if (eq? x (caar alist)) - (car alist) - (assq x (cdr alist)))))) - (alist-cons (lambda (key x alist) - (cons (cons key x) alist)))) - (define cell (assq x rename:list)) - (if cell - (cdr cell) - (begin (set! rename:list (alist-cons x (make-syntactic-closure mac-env '() x) rename:list)) - (cdar rename:list))))) - (define (compare x y) - (eqv? (if (syntactic-closure? x) x - (make-syntactic-closure use-env '() x)) - (if (syntactic-closure? y) y - (make-syntactic-closure use-env '() y)))) - (f form rename compare))) - ; ------------------------------------------------------------------------------ (define-syntax cond diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 14a968b87..ab9c7327d 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -64,7 +64,13 @@ inline namespace kernel auto environment::evaluate(const_reference expression) -> object { if (expression.is() and car(expression).is() - and car(expression).as().value == "import") + and car(expression).as().value == "define-library") + { + define_library(lexical_cast(cadr(expression)), cddr(expression)); + return cadr(expression); + } + else if (expression.is() and car(expression).is() + and car(expression).as().value == "import") { for (let const& import_set : cdr(expression)) { @@ -73,12 +79,6 @@ inline namespace kernel return unspecified_object; } - else if (expression.is() and car(expression).is() - and car(expression).as().value == "define-library") - { - define_library(lexical_cast(cadr(expression)), cddr(expression)); - return cadr(expression); - } else { auto dump = std::make_tuple(std::exchange(s, unit), diff --git a/src/main.cpp b/src/main.cpp index a62706575..ad46f07ab 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -25,13 +25,7 @@ auto main(int const argc, char const* const* const argv) -> int { library::boot(); - auto main = environment( - // "(meevax gc)", - "(only (meevax foo) a b)", - "(except (meevax foo) a)", - "(prefix (meevax foo) foo-)", - "(rename (meevax foo) (a f))" - ); + auto main = environment(master); main.configure(argc, argv); From 24c4e5b1787f850b3e24a442516a2b8c634e1d66 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 May 2022 01:33:15 +0900 Subject: [PATCH 10/49] Update `library` to treat toplevel `begin` as declaration Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 133 ++++++++++++++++-------------- include/meevax/kernel/library.hpp | 37 ++++++--- 4 files changed, 102 insertions(+), 76 deletions(-) diff --git a/README.md b/README.md index f8f4fd6e1..cbd90bd56 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.980.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.981.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.980_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.981_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.980 +Meevax Lisp System, version 0.3.981 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 34ae7927d..6e616cb26 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.980 +0.3.981 diff --git a/basis/overture.ss b/basis/overture.ss index 8cd028229..e099b91ec 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,12 +1,15 @@ (define-library (srfi 211 syntactic-closures) (import (meevax macro) (meevax syntax)) + (begin (define (sc-macro-transformer f) (lambda (form use-env mac-env) (make-syntactic-closure mac-env '() (f form use-env)))) + (define (rsc-macro-transformer f) (lambda (form use-env mac-env) (make-syntactic-closure use-env '() (f form mac-env))))) + (export sc-macro-transformer rsc-macro-transformer make-syntactic-closure @@ -18,7 +21,9 @@ (meevax macro) (meevax pair) (meevax syntax)) + (begin (define (list . xs) xs) + (define (er-macro-transformer f) (lambda (form use-env mac-env) (define rename:list (list)) @@ -30,9 +35,9 @@ (assq x (cdr alist)))))) (alist-cons (lambda (key x alist) (cons (cons key x) alist)))) - (define cell (assq x rename:list)) - (if cell - (cdr cell) + (define key/value (assq x rename:list)) + (if key/value + (cdr key/value) (begin (set! rename:list (alist-cons x (make-syntactic-closure mac-env '() x) rename:list)) (cdar rename:list))))) (define (compare x y) @@ -41,14 +46,75 @@ (if (syntactic-closure? y) y (make-syntactic-closure use-env '() y)))) (f form rename compare)))) + (export er-macro-transformer identifier?)) (define-library (scheme base) - (import (meevax control) + (import (srfi 211 explicit-renaming) + (meevax control) + (meevax equivalence) + (meevax list) + (meevax pair) (meevax syntax) ) (begin (define (list . xs) xs) + + (define (unspecified) (if #f #f)) + + (define-syntax cond + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cdr form)) + (unspecified) + ((lambda (clause) + (if (compare (rename 'else) (car clause)) + (cons (rename 'begin) (cdr clause)) + (if (if (null? (cdr clause)) #t + (compare (rename '=>) (cadr clause))) + (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (if (null? (cdr clause)) + (rename 'result) + (list (caddr clause) + (rename 'result))) + (cons (rename 'cond) (cddr form)))) + (car clause)) + (list (rename 'if) + (car clause) + (cons (rename 'begin) (cdr clause)) + (cons (rename 'cond) (cddr form)))))) + (cadr form)))))) + + (define-syntax and + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form))) + ((null? (cddr form)) + (cadr form)) + (else (list (rename 'if) + (cadr form) + (cons (rename 'and) + (cddr form)) + #f)))))) + + (define-syntax or + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form)) #f) + ((null? (cddr form)) + (cadr form)) + (else (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (rename 'result) + (cons (rename 'or) + (cddr form)))) + (cadr form))))))) + ) (export ; * ; + @@ -63,7 +129,7 @@ ; >= ; _ ; abs - ; and + and ; append ; apply ; assoc @@ -105,7 +171,7 @@ ; close-output-port ; close-port ; complex? - ; cond + cond ; cond-expand ; cons ; current-error-port @@ -198,7 +264,7 @@ ; open-input-string ; open-output-bytevector ; open-output-string - ; or + or ; output-port-open? ; output-port? ; pair? @@ -306,59 +372,6 @@ ; ------------------------------------------------------------------------------ -(define-syntax cond - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cdr form)) - (unspecified) - ((lambda (clause) - (if (compare (rename 'else) (car clause)) - (cons (rename 'begin) (cdr clause)) - (if (if (null? (cdr clause)) #t - (compare (rename '=>) (cadr clause))) - (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (if (null? (cdr clause)) - (rename 'result) - (list (caddr clause) - (rename 'result))) - (cons (rename 'cond) (cddr form)))) - (car clause)) - (list (rename 'if) - (car clause) - (cons (rename 'begin) (cdr clause)) - (cons (rename 'cond) (cddr form)))))) - (cadr form)))))) - -(define-syntax and - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form))) - ((null? (cddr form)) - (cadr form)) - (else (list (rename 'if) - (cadr form) - (cons (rename 'and) - (cddr form)) - #f)))))) - -(define-syntax or - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form)) #f) - ((null? (cddr form)) - (cadr form)) - (else (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (rename 'result) - (cons (rename 'or) - (cddr form)))) - (cadr form))))))) - (define (append-2 x y) (if (null? x) y (cons (car x) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index ff293d88f..7253d29ef 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -35,28 +35,41 @@ inline namespace kernel declare(*this); } - explicit library(const_reference declaration) + explicit library(const_reference declarations) : environment { empty } { - for (let const& expression : declaration) + for (let const& declaration : declarations) { - if (expression.is() and car(expression).is() - and car(expression).as().value == "export") + declare(declaration); + } + } + + static auto boot() -> void; + + auto declare(const_reference declaration) -> void + { + if (declaration.is() and car(declaration).is() + and car(declaration).as().value == "export") + { + for (let const& export_spec : cdr(declaration)) { - for (let const& export_spec : cdr(expression)) - { - export_(export_spec); - } + export_(export_spec); } - else + } + else if (declaration.is() and car(declaration).is() + and car(declaration).as().value == "begin") + { + for (let const& command_or_definition : declaration) { - evaluate(expression); + declare(command_or_definition); } } + else + { + evaluate(declaration); // Non-standard extension. + } } - static auto boot() -> void; - auto export_(const_reference export_spec) -> void { export_specs.push_back(export_spec); From cd318e597b95152992fad610db68c46e9cd5a4a3 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 May 2022 04:48:59 +0900 Subject: [PATCH 11/49] Support standard library `(scheme cxr)` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- basis/overture.ss | 115 ++++++++++++++++++++++------------------- src/library/meevax.cpp | 3 -- 4 files changed, 67 insertions(+), 59 deletions(-) diff --git a/README.md b/README.md index cbd90bd56..23c0e7475 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.981.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.982.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.981_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.982_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.981 +Meevax Lisp System, version 0.3.982 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 6e616cb26..d752a21ea 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.981 +0.3.982 diff --git a/basis/overture.ss b/basis/overture.ss index e099b91ec..3cde31eb5 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -55,12 +55,14 @@ (meevax control) (meevax equivalence) (meevax list) + (meevax number) (meevax pair) (meevax syntax) + (meevax vector) ) - (begin (define (list . xs) xs) + (begin (define (unspecified) (if #f #f)) - (define (unspecified) (if #f #f)) + (define (list . xs) xs) (define-syntax cond (er-macro-transformer @@ -116,17 +118,17 @@ (cadr form))))))) ) - (export ; * - ; + - ; - + (export * + + + - ; ... - ; / - ; < - ; <= - ; = + / + < + <= + = ; => - ; > - ; >= + > + >= ; _ ; abs and @@ -147,18 +149,18 @@ ; bytevector-u8-ref ; bytevector-u8-set! ; bytevector? - ; caar - ; cadr + caar + cadr ; call-with-current-continuation ; call-with-port ; call-with-values ; call/cc - ; car + car ; case - ; cdar - ; cddr - ; cdr - ; ceiling + cdar + cddr + cdr + ceiling ; char->integer ; char-ready? ; char<=? @@ -170,10 +172,10 @@ ; close-input-port ; close-output-port ; close-port - ; complex? + complex? cond ; cond-expand - ; cons + cons ; current-error-port ; current-input-port ; current-output-port @@ -187,22 +189,22 @@ ; else ; eof-object ; eof-object? - ; eq? + eq? ; equal? - ; eqv? + eqv? ; error ; error-object-irritants ; error-object-message ; error-object? ; even? - ; exact + exact ; exact-integer-sqrt - ; exact-integer? + exact-integer? ; exact? - ; expt + expt ; features ; file-error? - ; floor + floor ; floor-quotient ; floor-remainder ; floor/ @@ -215,12 +217,12 @@ ; if ; include ; include-ci - ; inexact + inexact ; inexact? ; input-port-open? ; input-port? - ; integer->char - ; integer? + integer->char + integer? ; lambda ; lcm ; length @@ -233,8 +235,8 @@ ; letrec* ; letrec-syntax list - ; list->string - ; list->vector + list->string + list->vector ; list-copy ; list-ref ; list-set! @@ -255,9 +257,9 @@ ; negative? ; newline ; not - ; null? - ; number->string - ; number? + null? + number->string + number? ; numerator ; odd? ; open-input-bytevector @@ -267,7 +269,7 @@ or ; output-port-open? ; output-port? - ; pair? + pair? ; parameterize ; peek-char ; peek-u8 @@ -279,7 +281,7 @@ ; quotient ; raise ; raise-continuable - ; rational? + rational? ; rationalize ; read-bytevector ; read-bytevector! @@ -288,13 +290,13 @@ ; read-line ; read-string ; read-u8 - ; real? + real? ; remainder ; reverse - ; round + round ; set! - ; set-car! - ; set-cdr! + set-car! + set-cdr! ; square ; string ; string->list @@ -324,7 +326,7 @@ ; syntax-error ; syntax-rules ; textual-port? - ; truncate + truncate ; truncate-quotient ; truncate-remainder ; truncate/ @@ -357,7 +359,17 @@ ) ) +(define-library (scheme cxr) + (import (meevax pair)) + (export caaar caadr cadar caddr + cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr + cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr)) + (import (scheme base) + (scheme cxr) (srfi 211 explicit-renaming) (srfi 211 syntactic-closures) ) @@ -382,17 +394,16 @@ (append-2 (reverse (cdr x)) (list (car x))))) -(define (append . xs) ; redefine - (define (append-aux x xs) - (if (null? x) xs - (append-aux (cdr xs) - (append-2 (car x) xs)))) - - (if (null? xs) '() - ((lambda (xs) - (append-aux (cdr xs) - (car xs))) - (reverse xs)))) +(define (append . xs) + (letrec ((append-aux (lambda (x xs) + (if (null? x) xs + (append-aux (cdr xs) + (append-2 (car x) xs)))))) + (if (null? xs) '() + ((lambda (xs) + (append-aux (cdr xs) + (car xs))) + (reverse xs))))) (define-syntax quasiquote (er-macro-transformer diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 8ee724426..2b8ad6b08 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -25,15 +25,12 @@ namespace meevax import("(meevax character)"); import("(meevax context)"); import("(meevax control)"); - import("(meevax equivalence)"); import("(meevax evaluate)"); import("(meevax exception)"); import("(meevax experimental)"); import("(meevax inexact)"); - import("(meevax list)"); import("(meevax macro)"); import("(meevax number)"); - import("(meevax pair)"); import("(meevax port)"); import("(meevax read)"); import("(meevax string)"); From 37543016b551a778d1c9f9b17cd9ee175b7ddfbd Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 7 May 2022 16:52:52 +0900 Subject: [PATCH 12/49] Macroexpand some SRFI-1 procedure definitions Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- basis/overture.ss | 12 +++-- basis/srfi-1.ss | 71 ++++++++++++++++++------------ include/meevax/kernel/library.hpp | 4 -- include/meevax/kernel/overview.hpp | 2 +- 6 files changed, 54 insertions(+), 43 deletions(-) diff --git a/README.md b/README.md index 23c0e7475..69d2bd0d0 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.982.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.983.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.982_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.983_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.982 +Meevax Lisp System, version 0.3.983 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index d752a21ea..c5c68869d 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.982 +0.3.983 diff --git a/basis/overture.ss b/basis/overture.ss index 3cde31eb5..7034b0e8d 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -22,11 +22,9 @@ (meevax pair) (meevax syntax)) - (begin (define (list . xs) xs) - - (define (er-macro-transformer f) + (begin (define (er-macro-transformer f) (lambda (form use-env mac-env) - (define rename:list (list)) + (define renames '()) (define (rename x) (letrec ((assq (lambda (x alist) (if (null? alist) #f @@ -35,11 +33,11 @@ (assq x (cdr alist)))))) (alist-cons (lambda (key x alist) (cons (cons key x) alist)))) - (define key/value (assq x rename:list)) + (define key/value (assq x renames)) (if key/value (cdr key/value) - (begin (set! rename:list (alist-cons x (make-syntactic-closure mac-env '() x) rename:list)) - (cdar rename:list))))) + (begin (set! renames (alist-cons x (make-syntactic-closure mac-env '() x) renames)) + (cdar renames))))) (define (compare x y) (eqv? (if (syntactic-closure? x) x (make-syntactic-closure use-env '() x)) diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index 7d677cd0c..29a5dd708 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -304,13 +304,17 @@ (cons (cadddr elt) d) (cons (car (cddddr elt)) e))))))) -(define (append . lists) - (if (pair? lists) - (let recur ((list1 (car lists)) (lists (cdr lists))) - (if (pair? lists) - (let ((tail (recur (car lists) (cdr lists)))) - (fold-right cons tail list1)) ; Append LIST1 & TAIL. - list1)) +(define (append . xs) + (if (pair? xs) + (letrec ((append (lambda (x xs) + (if (pair? xs) + ((lambda (tail) + (fold-right cons tail x)) + (append (car xs) + (cdr xs))) + x)))) + (append (car xs) + (cdr xs))) '())) (define (append! . lists) @@ -356,19 +360,27 @@ ; Return (map cdr lists). ; However, if any element of LISTS is empty, just abort and return '(). -(define (%cdrs lists) +(define (%cdrs xs) (call-with-current-continuation! (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (let ((lis (car lists))) - (if (null-list? lis) (abort '()) - (cons (cdr lis) (recur (cdr lists))))) - '()))))) + (letrec ((recur (lambda (xs) + (if (pair? xs) + ((lambda (x) + (if (null-list? x) + (abort '()) + (cons (cdr x) + (recur (cdr xs))))) + (car xs)) + '())))) + (recur xs))))) (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (let recur ((lists lists)) - (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) + (letrec ((recur (lambda (lists) + (if (pair? lists) + (cons (caar lists) + (recur (cdr lists))) + (list last-elt))))) + (recur lists))) (define (%cars+cdrs lists) (call-with-current-continuation! @@ -444,16 +456,20 @@ (if (null-list? lis) ans (lp (cdr lis) (kons (car lis) ans)))))) -(define (fold-right kons knil lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) knil - (apply kons (%cars+ lists (recur cdrs)))))) - (let recur ((lis lis1)) - (if (null-list? lis) knil - (let ((head (car lis))) - (kons head (recur (cdr lis)))))))) +(define (fold-right f knil x . xs) + (if (pair? xs) + (letrec ((recur (lambda (lists) + ((lambda (cdrs) + (if (null? cdrs) knil + (apply f (%cars+ lists (recur cdrs))))) + (%cdrs lists))))) + (recur (cons x xs))) + (letrec ((recur (lambda (x) + (if (null-list? x) knil + ((lambda (head) + (f head (recur (cdr x)))) + (car x)))))) + (recur x)))) (define (pair-fold-right f zero lis1 . lists) (if (pair? lists) @@ -824,7 +840,8 @@ (and (not (null-list? lis)) (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) -(define (reverse lis) (fold cons '() lis)) +(define (reverse xs) + (fold cons '() xs)) (define (reverse! lis) (let lp ((lis lis) (ans '())) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 7253d29ef..f4b3af9e0 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -83,8 +83,6 @@ inline namespace kernel auto export_to(environment & destination) { - std::cout << "; importing " << export_specs.size() << " definitions." << std::endl; - for (let const& export_spec : export_specs) { if (export_spec.is() and car(export_spec).is() @@ -94,7 +92,6 @@ inline namespace kernel else { assert(export_spec.is_also()); - std::cout << "; " << export_spec << std::endl; destination.define(export_spec, (*this)[export_spec]); } } @@ -142,7 +139,6 @@ inline namespace kernel template auto define_library(std::string const& name, Ts&&... xs) { - std::cout << "; (define-library " << name << " ...)" << std::endl; return libraries.emplace(name, std::forward(xs)...); } } // namespace kernel diff --git a/include/meevax/kernel/overview.hpp b/include/meevax/kernel/overview.hpp index e6d398b10..b4525c04c 100644 --- a/include/meevax/kernel/overview.hpp +++ b/include/meevax/kernel/overview.hpp @@ -23,7 +23,7 @@ #define NIL /* nothing */ -#define PROFILE_ALLOCATION false +#define PROFILE_ALLOCATION true namespace meevax { From e6c3138525cb8bfc4562f527089f5f9b101f7a7c Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 10 May 2022 04:59:46 +0900 Subject: [PATCH 13/49] Update library `(meevax list)` to provide procedure `append` Signed-off-by: yamacir-kit --- README.md | 6 ++--- VERSION | 2 +- basis/overture.ss | 32 +++++++------------------- basis/srfi-1.ss | 36 ++++++++++++++++-------------- include/meevax/kernel/list.hpp | 2 +- include/meevax/kernel/machine.hpp | 2 +- include/meevax/kernel/overview.hpp | 2 +- src/kernel/library.cpp | 6 +++++ src/kernel/list.cpp | 6 ++--- 9 files changed, 43 insertions(+), 51 deletions(-) diff --git a/README.md b/README.md index 69d2bd0d0..681f49602 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.983.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.984.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.983_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.984_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.983 +Meevax Lisp System, version 0.3.984 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index c5c68869d..be4292c7f 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.983 +0.3.984 diff --git a/basis/overture.ss b/basis/overture.ss index 7034b0e8d..2617728af 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -130,7 +130,7 @@ ; _ ; abs and - ; append + append ; apply ; assoc ; assq @@ -382,27 +382,6 @@ ; ------------------------------------------------------------------------------ -(define (append-2 x y) - (if (null? x) y - (cons (car x) - (append-2 (cdr x) y)))) - -(define (reverse x) - (if (null? x) '() - (append-2 (reverse (cdr x)) - (list (car x))))) - -(define (append . xs) - (letrec ((append-aux (lambda (x xs) - (if (null? x) xs - (append-aux (cdr xs) - (append-2 (car x) xs)))))) - (if (null? xs) '() - ((lambda (xs) - (append-aux (cdr xs) - (car xs))) - (reverse xs))))) - (define-syntax quasiquote (er-macro-transformer (lambda (form rename compare) @@ -460,6 +439,11 @@ `(,(rename 'if) (,(rename 'not) ,(cadr form)) (,(rename 'begin) ,@(cddr form)))))) +(define (reverse x) + (if (null? x) '() + (append (reverse (cdr x)) + (list (car x))))) + (define (map f x . xs) ; map-unorder (define (map-1 f x xs) (if (pair? x) @@ -483,8 +467,8 @@ (apply-1 f x) ((lambda (rxs) (apply-1 f - (append-2 (reverse (cdr rxs)) - (car rxs)))) + (append (reverse (cdr rxs)) + (car rxs)))) (reverse (cons x xs))))) (define (every f x . xs) ; from SRFI-1 for map diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index 29a5dd708..ed5ff669a 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -14,13 +14,15 @@ ; list -(define (xcons x y) (cons y x)) +(define (xcons x y) + (cons y x)) (define (tree-copy x) - (let rec ((x x)) - (if (not (pair? x)) x - (cons (rec (car x)) - (rec (cdr x)))))) + (letrec ((tree-copy (lambda (x) + (if (not (pair? x)) x + (cons (tree-copy (car x)) + (tree-copy (cdr x))))))) + (tree-copy x))) (define (make-list len . maybe-elt) (let ((elt (cond ((null? maybe-elt) #f) ; Default value @@ -304,18 +306,18 @@ (cons (cadddr elt) d) (cons (car (cddddr elt)) e))))))) -(define (append . xs) - (if (pair? xs) - (letrec ((append (lambda (x xs) - (if (pair? xs) - ((lambda (tail) - (fold-right cons tail x)) - (append (car xs) - (cdr xs))) - x)))) - (append (car xs) - (cdr xs))) - '())) +; (define (append . xs) +; (if (pair? xs) +; (letrec ((append (lambda (x xs) +; (if (pair? xs) +; ((lambda (tail) +; (fold-right cons tail x)) +; (append (car xs) +; (cdr xs))) +; x)))) +; (append (car xs) +; (cdr xs))) +; '())) (define (append! . lists) (let lp ((lists lists) (prev '())) ; First, scan through lists looking for a non-empty one. diff --git a/include/meevax/kernel/list.hpp b/include/meevax/kernel/list.hpp index 2c459d937..6829ad9ac 100644 --- a/include/meevax/kernel/list.hpp +++ b/include/meevax/kernel/list.hpp @@ -197,7 +197,7 @@ inline namespace kernel return std::distance(std::cbegin(x), std::cend(x)); }; - auto append(const_reference, const_reference) -> object; + auto append2(const_reference, const_reference) -> object; auto reverse(const_reference) -> object; diff --git a/include/meevax/kernel/machine.hpp b/include/meevax/kernel/machine.hpp index 7a6733e9b..492ab9699 100644 --- a/include/meevax/kernel/machine.hpp +++ b/include/meevax/kernel/machine.hpp @@ -788,7 +788,7 @@ inline namespace kernel current_environment, cons(cons(make("lambda", lambda), unzip1(binding_specs), - append(map(curry(cons)(make("set!", set)), binding_specs), body)), + append2(map(curry(cons)(make("set!", set)), binding_specs), body)), make_list(length(binding_specs), undefined)), current_scope, current_continuation); diff --git a/include/meevax/kernel/overview.hpp b/include/meevax/kernel/overview.hpp index b4525c04c..e6d398b10 100644 --- a/include/meevax/kernel/overview.hpp +++ b/include/meevax/kernel/overview.hpp @@ -23,7 +23,7 @@ #define NIL /* nothing */ -#define PROFILE_ALLOCATION true +#define PROFILE_ALLOCATION false namespace meevax { diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 111e941d7..f43e27a97 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -298,6 +298,11 @@ inline namespace kernel return car(xs).is(); }); + define("append", [](let const& xs) + { + return std::accumulate(std::begin(xs), std::end(xs), unit, append2); + }); + define("list->string", [](let const& xs) { string s; @@ -316,6 +321,7 @@ inline namespace kernel }); export_("null?", + "append", "list->string", "list->vector"); } diff --git a/src/kernel/list.cpp b/src/kernel/list.cpp index fbd6e43ce..156229de5 100644 --- a/src/kernel/list.cpp +++ b/src/kernel/list.cpp @@ -25,14 +25,14 @@ inline namespace kernel return 0 < size ? car(x) | take(cdr(x), --size) : unit; } - auto append(const_reference x, const_reference y) -> object + auto append2(const_reference x, const_reference y) -> object { - return x.is() ? y : cons(car(x), append(cdr(x), y)); + return x.is() ? y : cons(car(x), append2(cdr(x), y)); } auto reverse(const_reference x) -> object { - return x ? append(reverse(cdr(x)), list(car(x))) : unit; + return x ? append2(reverse(cdr(x)), list(car(x))) : unit; } auto zip(const_reference x, const_reference y) -> object From c7c240eb28c1a6b4376797cb9064fe73bb58de8d Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 10 May 2022 22:57:18 +0900 Subject: [PATCH 14/49] Update library `(scheme base)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 1138 ++++++++++++++++++++-------------------- basis/srfi-1.ss | 6 +- src/kernel/library.cpp | 5 +- src/library/meevax.cpp | 5 +- 6 files changed, 584 insertions(+), 578 deletions(-) diff --git a/README.md b/README.md index 681f49602..0ee48117f 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.984.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.985.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.984_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.985_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.984 +Meevax Lisp System, version 0.3.985 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index be4292c7f..901b503e4 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.984 +0.3.985 diff --git a/basis/overture.ss b/basis/overture.ss index 2617728af..5aecb7b3a 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -50,11 +50,14 @@ (define-library (scheme base) (import (srfi 211 explicit-renaming) + (meevax character) (meevax control) (meevax equivalence) (meevax list) (meevax number) (meevax pair) + (meevax string) + (meevax symbol) (meevax syntax) (meevax vector) ) @@ -115,6 +118,481 @@ (cddr form)))) (cadr form))))))) + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + (define (expand x depth) + (cond ((pair? x) + (cond ((compare (rename 'unquote) (car x)) + (if (<= depth 0) + (cadr x) + (list (rename 'list) + (list (rename 'quote) 'unquote) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= depth 0) + (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth)) + (list (rename 'list) + (list (rename 'quote) 'unquote-splicing) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) + (list (rename 'quote) 'quasiquote) + (expand (cadr x) (+ depth 1)))) + ((and (<= depth 0) + (pair? (car x)) + (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) + (cadar x) + (expand (cdr x) depth)))) + (else (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth))))) + ((vector? x) + (list (rename 'list->vector) + (expand (vector->list x) depth))) + ((or (identifier? x) + (null? x)) + (list (rename 'quote) x)) + (else x))) + (expand (cadr form) 0)))) + + (define-syntax when + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) ,(cadr form) + (,(rename 'begin) ,@(cddr form)))))) + + (define (not x) (if x #f #t)) + + (define-syntax unless + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) (,(rename 'not) ,(cadr form)) + (,(rename 'begin) ,@(cddr form)))))) + + (define (reverse xs) + (if (null? xs) '() + (append (reverse (cdr xs)) + (list (car xs))))) + + (define (map f x . xs) + (define (map-1 f x stack) + (if (pair? x) + (map-1 f + (cdr x) + (cons (f (car x)) stack)) + (reverse stack))) + (if (null? xs) + (map-1 f x '()) + (letrec ((map (lambda (f xs stack) + (if (every pair? xs) + (map f + (map-1 cdr xs '()) + (cons (apply f (map-1 car xs '())) stack)) + (reverse stack))))) + (map f (cons x xs) '())))) + + (define (apply f x . xs) + (define (apply-1 f xs) (f . xs)) + (if (null? xs) + (apply-1 f x) + ((lambda (rxs) + (apply-1 f + (append (reverse (cdr rxs)) + (car rxs)))) + (reverse (cons x xs))))) + + (define (every f x . xs) + (define (every-1 f x) + (if (null? (cdr x)) + (f (car x)) + (if (f (car x)) + (every-1 f (cdr x)) + #f))) + (if (null? xs) + (if (pair? x) + (every-1 f x) + #t) + (not (apply any + (lambda xs + (not (apply f xs))) + x xs)))) + + (define (any f x . xs) + (define (any-1 f x) + (if (pair? (cdr x)) + ((lambda (result) + (if result result (any-1 f (cdr x)))) + (f (car x))) + (f (car x)))) + (define (any-2+ f xs) + (if (every pair? xs) + ((lambda (result) + (if result result (any-2+ f (map cdr xs)))) + (apply f (map car xs))) + #f)) + (if (null? xs) + (if (pair? x) + (any-1 f x) + #f) + (any-2+ f (cons x xs)))) + + (define-syntax let + (er-macro-transformer + (lambda (form rename compare) + (if (identifier? (cadr form)) + `(,(rename 'letrec) ((,(cadr form) + (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) + (,(cadr form) ,@(map cadr (caddr form)))) + `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) + ,@(map cadr (cadr form))))))) + + + (define-syntax let* + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cadr form)) + `(,(rename 'let) () ,@(cddr form)) + `(,(rename 'let) (,(caadr form)) + (,(rename 'let*) ,(cdadr form) + ,@(cddr form))))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'let) () + ,@(map (lambda (x) (cons (rename 'define) x)) + (cadr form)) + ,@(cddr form))))) + + (define (member o x . c) ; for case + (let ((compare (if (pair? c) (car c) equal?))) + (let member ((x x)) + (and (pair? x) + (if (compare o (car x)) x + (member (cdr x))))))) + + (define (memq o x) + (member o x eq?)) + + (define (memv o x) + (member o x eqv?)) + + (define-syntax case + (er-macro-transformer + (lambda (form rename compare) + (define (body xs) + (cond ((null? xs) (rename 'result)) + ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) + (else `(,(rename 'begin) ,@xs)))) + (define (each-clause clauses) + (cond ((null? clauses) + (unspecified)) + ((compare (rename 'else) (caar clauses)) + (body (cdar clauses))) + ((and (pair? (caar clauses)) + (null? (cdaar clauses))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) + (,(rename 'quote) ,(caaar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))) + (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) + (,(rename 'quote) ,(caar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))))) + `(,(rename 'let) ((,(rename 'result) ,(cadr form))) + ,(each-clause (cddr form)))))) + + (define-syntax do + (er-macro-transformer + (lambda (form rename compare) + (let ((body `(,(rename 'begin) ,@(cdddr form) + (,(rename 'rec) ,@(map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + (cadr form)))))) + `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) + (list (car x) + (cadr x))) + (cadr form)) + ,(if (null? (cdaddr form)) + `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) + (,(rename 'if) ,(rename 'it) + ,(rename 'it) + ,body)) + `(,(rename 'if) ,(caaddr form) + (,(rename 'begin) ,@(cdaddr form)) + ,body))))))) + + (define (equal? x y) ; structure=? + (if (and (pair? x) + (pair? y)) + (and (equal? (car x) + (car y)) + (equal? (cdr x) + (cdr y))) + (eqv? x y))) + + (define (exact? z) + (define (exact-complex? x) + (and (%complex? x) + (exact? (real-part x)) + (exact? (imag-part x)))) + (or (exact-complex? z) + (ratio? z) + (exact-integer? z))) + + (define (inexact? z) + (define (inexact-complex? x) + (and (%complex? x) + (or (inexact? (real-part x)) + (inexact? (imag-part x))))) + (define (floating-point? z) + (or (single-float? z) + (double-float? z))) + (or (inexact-complex? z) + (floating-point? z))) + + (define (zero? n) + (= n 0)) + + (define (positive? n) + (> n 0)) + + (define (negative? n) + (< n 0)) + + (define (odd? n) + (not (even? n))) + + (define (even? n) + (= (remainder n 2) 0)) + + (define (max x . xs) + (define (max-aux x xs) + (if (null? xs) + (inexact x) + (max-aux (if (< x (car xs)) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (max-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (max-aux x xs)) + (else (rec (if (< x (car xs)) (car xs) x) + (cdr xs))))))) + + (define (min x . xs) + (define (min-aux x xs) + (if (null? xs) + (inexact x) + (min-aux (if (< (car xs) x) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (min-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (min-aux x xs)) + (else (rec (if (< (car xs) x) (car xs) x) + (cdr xs))))))) + + (define (abs n) + (if (< n 0) (- n) n)) + + (define (floor-quotient x y) + (floor (/ x y))) + + (define (floor-remainder x y) + (% (+ y (% x y)) y)) + + (define (floor/ x y) + (values (floor-quotient x y) + (floor-remainder x y))) + + (define (truncate-quotient x y) + (truncate (/ x y))) + + (define truncate-remainder %) + + (define (truncate/ x y) + (values (truncate-quotient x y) + (truncate-remainder x y))) + + (define quotient truncate-quotient) + + (define remainder truncate-remainder) + + (define modulo floor-remainder) + + (define (gcd . xs) ; from Chibi-Scheme lib/init7.scm + (define (gcd-2 a b) + (if (zero? b) + (abs a) + (gcd b (remainder a b)))) + (if (null? xs) 0 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (gcd-2 n (car ns)) (cdr ns)))))) + + (define (lcm . xs) ; from Chibi-Scheme lib/init7.scm + (define (lcm-2 a b) + (abs (quotient (* a b) (gcd a b)))) + (if (null? xs) 1 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (lcm-2 n (car ns)) (cdr ns)))))) + + (define (numerator x) + (cond ((ratio? x) (car x)) + ((exact? x) x) + (else (inexact (numerator (exact x)))))) + + (define (denominator x) + (cond ((exact? x) (if (ratio? x) (cdr x) 1)) + ((integer? x) 1.0) + (else (inexact (denominator (exact x)))))) + + (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) + (define (sr x y return) + (let ((fx (floor x)) + (fy (floor y))) + (cond ((>= fx x) (return fx 1)) + ((= fx fy) (sr (/ (- y fy)) + (/ (- x fx)) + (lambda (n d) + (return (+ d (* fx n)) n)))) + (else (return (+ fx 1) 1))))) + (let ((return (if (negative? x) + (lambda (num den) + (/ (- num) den)) + /)) + (x (abs x)) + (e (abs e))) + (sr (- x e) (+ x e) return))) + + (define (square z) (* z z)) + + (define (boolean? x) + (or (eqv? x #t) + (eqv? x #f))) + + (define boolean=? eqv?) + + (define symbol=? eqv?) + + (define (char-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer x)) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (car xs)))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char=? x . xs) + (char-compare x xs =)) + + (define (char? x . xs) + (char-compare x xs >)) + + (define (char<=? x . xs) + (char-compare x xs <=)) + + (define (char>=? x . xs) + (char-compare x xs >=)) + + (define (string . xs) + (list->string xs)) + + (define substring string-copy) + + (define (string-fill! s c . o) + (let ((start (if (and (pair? o) + (exact-integer? (car o))) + (car o) + 0)) + (end (if (and (pair? o) + (pair? (cdr o)) + (exact-integer? (cadr o))) + (cadr o) + (string-length s)))) + (let rec ((k (- end 1))) + (if (<= start k) + (begin (string-set! s k c) + (rec (- k 1))))))) + + (define (procedure? x) + (or (closure? x) + (continuation? x) + (foreign-function? x))) + + (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html + + (define (dynamic-wind before thunk after) + (before) + (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) + ((lambda (result) ; TODO let-values + (set! %current-dynamic-extents (cdr %current-dynamic-extents)) + (after) + result) ; TODO (apply values result) + (thunk))) + + (define (call-with-current-continuation procedure) + (define (windup! from to) + (set! %current-dynamic-extents from) + (cond ((eq? from to)) + ((null? from) (windup! from (cdr to)) ((caar to))) + ((null? to) ((cdar from)) (windup! (cdr from) to)) + (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) + (set! %current-dynamic-extents to)) + (let ((current-dynamic-extents %current-dynamic-extents)) + (call-with-current-continuation! (lambda (k1) + (procedure (lambda (k2) + (windup! %current-dynamic-extents current-dynamic-extents) + (k1 k2))))))) + + (define call/cc call-with-current-continuation) + + ; (define values + ; (lambda xs + ; (call-with-current-continuation + ; (lambda (cc) + ; (apply cc xs))))) + + (define (list 'values)) ; Magic Token Trick + + (define (values? x) + (if (pair? x) + (eq? (car x) ) + #f)) + + (define (values . xs) + (if (if (null? xs) #f + (null? (cdr xs))) + (car xs) + (cons xs))) + + ; (define (call-with-values producer consumer) + ; (let-values ((xs (producer))) + ; (apply consumer xs))) + + (define (call-with-values producer consumer) + (let ((vs (producer))) + (if (values? vs) + (apply consumer (cdr vs)) + (consumer vs)))) + ) (export * + @@ -128,17 +606,17 @@ > >= ; _ - ; abs + abs and append - ; apply + apply ; assoc ; assq ; assv - ; begin + begin ; binary-port? - ; boolean=? - ; boolean? + boolean=? + boolean? ; bytevector ; bytevector-append ; bytevector-copy @@ -149,24 +627,24 @@ ; bytevector? caar cadr - ; call-with-current-continuation + call-with-current-continuation ; call-with-port - ; call-with-values - ; call/cc + call-with-values + call/cc car - ; case + case cdar cddr cdr ceiling - ; char->integer + char->integer ; char-ready? - ; char<=? - ; char=? - ; char>? - ; char? + char<=? + char=? + char>? + char? ; close-input-port ; close-output-port ; close-port @@ -177,61 +655,61 @@ ; current-error-port ; current-input-port ; current-output-port - ; define + define ; define-record-type - ; define-syntax + define-syntax ; define-values - ; denominator - ; do - ; dynamic-wind + denominator + do + dynamic-wind ; else ; eof-object ; eof-object? eq? - ; equal? + equal? eqv? ; error ; error-object-irritants ; error-object-message ; error-object? - ; even? + even? exact ; exact-integer-sqrt exact-integer? - ; exact? + exact? expt ; features ; file-error? floor - ; floor-quotient - ; floor-remainder - ; floor/ + floor-quotient + floor-remainder + floor/ ; flush-output-port ; for-each - ; gcd + gcd ; get-output-bytevector ; get-output-string ; guard - ; if + if ; include ; include-ci inexact - ; inexact? + inexact? ; input-port-open? ; input-port? integer->char integer? - ; lambda - ; lcm + lambda + lcm ; length - ; let - ; let* + let + let* ; let*-values - ; let-syntax + let-syntax ; let-values - ; letrec - ; letrec* - ; letrec-syntax + letrec + letrec* + letrec-syntax list list->string list->vector @@ -243,23 +721,23 @@ ; make-bytevector ; make-list ; make-parameter - ; make-string - ; make-vector - ; map - ; max - ; member - ; memq - ; memv - ; min - ; modulo - ; negative? + make-string + make-vector + map + max + member + memq + memv + min + modulo + negative? ; newline - ; not + not null? number->string number? - ; numerator - ; odd? + numerator + odd? ; open-input-bytevector ; open-input-string ; open-output-bytevector @@ -272,15 +750,15 @@ ; peek-char ; peek-u8 ; port? - ; positive? - ; procedure? - ; quasiquote - ; quote - ; quotient + positive? + procedure? + quasiquote + quote + quotient ; raise ; raise-continuable rational? - ; rationalize + rationalize ; read-bytevector ; read-bytevector! ; read-char @@ -289,71 +767,71 @@ ; read-string ; read-u8 real? - ; remainder - ; reverse + remainder + reverse round - ; set! + set! set-car! set-cdr! - ; square - ; string - ; string->list - ; string->number - ; string->symbol + square + string + string->list + string->number + string->symbol ; string->utf8 ; string->vector - ; string-append - ; string-copy + string-append + string-copy ; string-copy! - ; string-fill! + string-fill! ; string-for-each - ; string-length + string-length ; string-map - ; string-ref - ; string-set! - ; string<=? - ; string=? - ; string>? - ; string? - ; substring - ; symbol->string + string-ref + string-set! + string<=? + string=? + string>? + string? + substring + symbol->string ; symbol=? - ; symbol? + symbol? ; syntax-error ; syntax-rules ; textual-port? truncate - ; truncate-quotient - ; truncate-remainder - ; truncate/ + truncate-quotient + truncate-remainder + truncate/ ; u8-ready? - ; unless + unless ; unquote ; unquote-splicing ; utf8->string - ; values - ; vector - ; vector->list - ; vector->string + values + vector + vector->list + vector->string ; vector-append ; vector-copy ; vector-copy! - ; vector-fill! + vector-fill! ; vector-for-each - ; vector-length + vector-length ; vector-map - ; vector-ref - ; vector-set! - ; vector? - ; when + vector-ref + vector-set! + vector? + when ; with-exception-handler ; write-bytevector ; write-char ; write-string ; write-u8 - ; zero? + zero? ) ) @@ -382,357 +860,6 @@ ; ------------------------------------------------------------------------------ -(define-syntax quasiquote - (er-macro-transformer - (lambda (form rename compare) - (define (expand x depth) - (cond ((pair? x) - (cond ((compare (rename 'unquote) (car x)) - (if (<= depth 0) - (cadr x) - (list (rename 'list) - (list (rename 'quote) 'unquote) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'unquote-splicing) (car x)) - (if (<= depth 0) - (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth)) - (list (rename 'list) - (list (rename 'quote) 'unquote-splicing) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'quasiquote) (car x)) - (list (rename 'list) - (list (rename 'quote) 'quasiquote) - (expand (cadr x) (+ depth 1)))) - ((and (<= depth 0) - (pair? (car x)) - (compare (rename 'unquote-splicing) (caar x))) - (if (null? (cdr x)) - (cadar x) - (list (rename 'append) - (cadar x) - (expand (cdr x) depth)))) - (else (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth))))) - ((vector? x) - (list (rename 'list->vector) - (expand (vector->list x) depth))) - ((or (identifier? x) - (null? x)) - (list (rename 'quote) x)) - (else x))) - (expand (cadr form) 0)))) - -(define (not x) (if x #f #t)) - -(define-syntax when - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) ,(cadr form) - (,(rename 'begin) ,@(cddr form)))))) - -(define-syntax unless - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) (,(rename 'not) ,(cadr form)) - (,(rename 'begin) ,@(cddr form)))))) - -(define (reverse x) - (if (null? x) '() - (append (reverse (cdr x)) - (list (car x))))) - -(define (map f x . xs) ; map-unorder - (define (map-1 f x xs) - (if (pair? x) - (map-1 f - (cdr x) - (cons (f (car x)) xs)) - (reverse xs))) - (define (map-2+ f xs xss) - (if (every pair? xs) - (map-2+ f - (map-1 cdr xs '()) - (cons (apply f (map-1 car xs '())) xss)) - (reverse xss))) - (if (null? xs) - (map-1 f x '()) - (map-2+ f (cons x xs) '()))) - -(define (apply f x . xs) ; for map - (define (apply-1 f xs) (f . xs)) - (if (null? xs) - (apply-1 f x) - ((lambda (rxs) - (apply-1 f - (append (reverse (cdr rxs)) - (car rxs)))) - (reverse (cons x xs))))) - -(define (every f x . xs) ; from SRFI-1 for map - (define (every-1 f x) - (if (null? (cdr x)) - (f (car x)) - (if (f (car x)) - (every-1 f (cdr x)) - #f))) - (if (null? xs) - (if (pair? x) - (every-1 f x) - #t) - (not (apply any - (lambda xs - (not (apply f xs))) - x xs)))) - -(define (any f x . xs) ; from SRFI-1 for every - (define (any-1 f x) - (if (pair? (cdr x)) - ((lambda (result) - (if result result (any-1 f (cdr x)))) - (f (car x))) - (f (car x)))) - (define (any-2+ f xs) - (if (every pair? xs) - ((lambda (result) - (if result result (any-2+ f (map cdr xs)))) - (apply f (map car xs))) - #f)) - (if (null? xs) - (if (pair? x) - (any-1 f x) - #f) - (any-2+ f (cons x xs)))) - -(define-syntax let - (er-macro-transformer - (lambda (form rename compare) - (if (identifier? (cadr form)) - `(,(rename 'letrec) ((,(cadr form) - (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) - (,(cadr form) ,@(map cadr (caddr form)))) - `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) - ,@(map cadr (cadr form))))))) - - -(define-syntax let* - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cadr form)) - `(,(rename 'let) () ,@(cddr form)) - `(,(rename 'let) (,(caadr form)) - (,(rename 'let*) ,(cdadr form) - ,@(cddr form))))))) - -(define-syntax letrec* - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'let) () - ,@(map (lambda (x) (cons (rename 'define) x)) - (cadr form)) - ,@(cddr form))))) - -(define (member o x . c) ; for case - (let ((compare (if (pair? c) (car c) equal?))) - (let member ((x x)) - (and (pair? x) - (if (compare o (car x)) x - (member (cdr x))))))) - -(define (memq o x) (member o x eq?)) -(define (memv o x) (member o x eqv?)) - -(define-syntax case - (er-macro-transformer - (lambda (form rename compare) - (define (body xs) - (cond ((null? xs) (rename 'result)) - ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) - (else `(,(rename 'begin) ,@xs)))) - (define (each-clause clauses) - (cond ((null? clauses) - (unspecified)) - ((compare (rename 'else) (caar clauses)) - (body (cdar clauses))) - ((and (pair? (caar clauses)) - (null? (cdaar clauses))) - `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) - (,(rename 'quote) ,(caaar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))) - (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) - (,(rename 'quote) ,(caar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))))) - `(,(rename 'let) ((,(rename 'result) ,(cadr form))) - ,(each-clause (cddr form)))))) - -(define-syntax do - (er-macro-transformer - (lambda (form rename compare) - (let ((body `(,(rename 'begin) ,@(cdddr form) - (,(rename 'rec) ,@(map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - (cadr form)))))) - `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) - (list (car x) - (cadr x))) - (cadr form)) - ,(if (null? (cdaddr form)) - `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) - (,(rename 'if) ,(rename 'it) - ,(rename 'it) - ,body)) - `(,(rename 'if) ,(caaddr form) - (,(rename 'begin) ,@(cdaddr form)) - ,body))))))) - -; ---- 6.1. Equivalence predicates --------------------------------------------- - -(define (equal? x y) ; structure=? - (if (and (pair? x) - (pair? y)) - (and (equal? (car x) - (car y)) - (equal? (cdr x) - (cdr y))) - (eqv? x y))) - -; ---- 6.2. Numbers ------------------------------------------------------------ - -(define (exact? z) - (define (exact-complex? x) - (and (%complex? x) - (exact? (real-part x)) - (exact? (imag-part x)))) - (or (exact-complex? z) - (ratio? z) - (exact-integer? z))) - -(define (inexact? z) - (define (inexact-complex? x) - (and (%complex? x) - (or (inexact? (real-part x)) - (inexact? (imag-part x))))) - (define (floating-point? z) - (or (single-float? z) - (double-float? z))) - (or (inexact-complex? z) - (floating-point? z))) - -(define (zero? n) (= n 0)) -(define (positive? n) (> n 0)) -(define (negative? n) (< n 0)) -(define (odd? n) (not (even? n))) -(define (even? n) (= (remainder n 2) 0)) - -(define (max x . xs) - (define (max-aux x xs) - (if (null? xs) - (inexact x) - (max-aux (if (< x (car xs)) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (max-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (max-aux x xs)) - (else (rec (if (< x (car xs)) (car xs) x) - (cdr xs))))))) - -(define (min x . xs) - (define (min-aux x xs) - (if (null? xs) - (inexact x) - (min-aux (if (< (car xs) x) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (min-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (min-aux x xs)) - (else (rec (if (< (car xs) x) (car xs) x) - (cdr xs))))))) - -(define (abs n) - (if (< n 0) (- n) n)) - -(define (floor-quotient x y) (floor (/ x y))) - -(define (floor-remainder x y) (% (+ y (% x y)) y)) - -(define (floor/ x y) - (values (floor-quotient x y) - (floor-remainder x y))) - -(define (truncate-quotient x y) (truncate (/ x y))) - -(define truncate-remainder %) - -(define (truncate/ x y) - (values (truncate-quotient x y) - (truncate-remainder x y))) - -(define quotient truncate-quotient) - -(define remainder truncate-remainder) - -(define modulo floor-remainder) - -(define (gcd . xs) ; from Chibi-Scheme lib/init7.scm - (define (gcd-2 a b) - (if (zero? b) - (abs a) - (gcd b (remainder a b)))) - (if (null? xs) 0 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (gcd-2 n (car ns)) (cdr ns)))))) - -(define (lcm . xs) ; from Chibi-Scheme lib/init7.scm - (define (lcm-2 a b) - (abs (quotient (* a b) (gcd a b)))) - (if (null? xs) 1 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (lcm-2 n (car ns)) (cdr ns)))))) - -(define (numerator x) - (cond ((ratio? x) (car x)) - ((exact? x) x) - (else (inexact (numerator (exact x)))))) - -(define (denominator x) - (cond ((exact? x) (if (ratio? x) (cdr x) 1)) - ((integer? x) 1.0) - (else (inexact (denominator (exact x)))))) - -(define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) - (define (sr x y return) - (let ((fx (floor x)) - (fy (floor y))) - (cond ((>= fx x) (return fx 1)) - ((= fx fy) (sr (/ (- y fy)) - (/ (- x fx)) - (lambda (n d) - (return (+ d (* fx n)) n)))) - (else (return (+ fx 1) 1))))) - (let ((return (if (negative? x) - (lambda (num den) - (/ (- num) den)) - /)) - (x (abs x)) - (e (abs e))) - (sr (- x e) (+ x e) return))) - -(define (square z) (* z z)) - (define (make-rectangular x y) (+ x (* y (sqrt -1)))) (define (make-polar radius phi) @@ -753,37 +880,6 @@ (define inexact->exact exact) (define exact->inexact inexact) -; ---- 6.3. Booleans ----------------------------------------------------------- - -(define (boolean? x) - (or (eqv? x #t) - (eqv? x #f))) - -(define boolean=? eqv?) - -; ---- 6.4. Pairs and lists ---------------------------------------------------- - -; ---- 6.5 Symbols ------------------------------------------------------------- - -(define symbol=? eqv?) - -; ---- 6.6 Characters ---------------------------------------------------------- - -(define (char-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer x)) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (car xs)))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - -(define (char=? x . xs) (char-compare x xs =)) -(define (char? x . xs) (char-compare x xs >)) -(define (char<=? x . xs) (char-compare x xs <=)) -(define (char>=? x . xs) (char-compare x xs >=)) - (define (char-ci-compare x xs compare) (let rec ((compare compare) (lhs (char->integer (char-downcase x))) @@ -833,100 +929,12 @@ (if (char-upper-case? c) c (integer->char (- (char->integer c) 32)))) -; ---- 6.7 Strings ------------------------------------------------------------- - -(define (string . xs) (list->string xs)) - (define (string-ci=? . xs) (apply string=? (map string-foldcase xs))) (define (string-ci? . xs) (apply string>? (map string-foldcase xs))) (define (string-ci<=? . xs) (apply string<=? (map string-foldcase xs))) (define (string-ci>=? . xs) (apply string>=? (map string-foldcase xs))) -(define substring string-copy) - -(define (string-fill! s c . o) - (let ((start (if (and (pair? o) - (exact-integer? (car o))) - (car o) - 0)) - (end (if (and (pair? o) - (pair? (cdr o)) - (exact-integer? (cadr o))) - (cadr o) - (string-length s)))) - (let rec ((k (- end 1))) - (if (<= start k) - (begin (string-set! s k c) - (rec (- k 1))))))) - -; ---- 6.8. Vectors ------------------------------------------------------------ - -; ---- 6.9. Bytevectors -------------------------------------------------------- - -; ---- 6.10. Control features -------------------------------------------------- - -(define (procedure? x) - (or (closure? x) - (continuation? x) - (foreign-function? x))) - -(define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html - -(define (dynamic-wind before thunk after) - (before) - (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) - ((lambda (result) ; TODO let-values - (set! %current-dynamic-extents (cdr %current-dynamic-extents)) - (after) - result) ; TODO (apply values result) - (thunk))) - -(define (call-with-current-continuation procedure) - (define (windup! from to) - (set! %current-dynamic-extents from) - (cond ((eq? from to)) - ((null? from) (windup! from (cdr to)) ((caar to))) - ((null? to) ((cdar from)) (windup! (cdr from) to)) - (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) - (set! %current-dynamic-extents to)) - (let ((current-dynamic-extents %current-dynamic-extents)) - (call-with-current-continuation! (lambda (k1) - (procedure (lambda (k2) - (windup! %current-dynamic-extents current-dynamic-extents) - (k1 k2))))))) - -(define call/cc call-with-current-continuation) - -; (define values -; (lambda xs -; (call-with-current-continuation -; (lambda (cc) -; (apply cc xs))))) - -(define (list 'values)) ; Magic Token Trick - -(define (values? x) - (if (pair? x) - (eq? (car x) ) - #f)) - -(define (values . xs) - (if (if (null? xs) #f - (null? (cdr xs))) - (car xs) - (cons xs))) - -; (define (call-with-values producer consumer) -; (let-values ((xs (producer))) -; (apply consumer xs))) - -(define (call-with-values producer consumer) - (let ((vs (producer))) - (if (values? vs) - (apply consumer (cdr vs)) - (consumer vs)))) - ; ---- 6.11. Exceptions -------------------------------------------------------- (define (error-object? x) diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index ed5ff669a..f0b5b7e1a 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -584,7 +584,7 @@ (x (f (car lis)))) (cons x (recur tail))))))) -(define map map-in-order) +; (define map map-in-order) (define (filter pred lis) (let recur ((lis lis)) @@ -842,8 +842,8 @@ (and (not (null-list? lis)) (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) -(define (reverse xs) - (fold cons '() xs)) +; (define (reverse xs) +; (fold cons '() xs)) (define (reverse! lis) (let lp ((lis lis) (ans '())) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index f43e27a97..0da654178 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -14,6 +14,7 @@ limitations under the License. */ +#include #include namespace meevax @@ -89,8 +90,8 @@ inline namespace kernel #undef DEFINE - define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, [](let const& a, let const& b) { return a + b; }); }); - define("*", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e1, [](let const& a, let const& b) { return a * b; }); }); + define("+", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e0, std::plus()); }); + define("*", [](let const& xs) { return std::accumulate(std::begin(xs), std::end(xs), e1, std::multiplies()); }); #define DEFINE(SYMBOL, FUNCTION, BASIS) \ define(SYMBOL, [](let const& xs) \ diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 2b8ad6b08..2df6349d0 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -33,10 +33,7 @@ namespace meevax import("(meevax number)"); import("(meevax port)"); import("(meevax read)"); - import("(meevax string)"); - import("(meevax symbol)"); - import("(meevax syntax)"); - import("(meevax vector)"); + import("(meevax syntax)"); // quote-syntax import("(meevax write)"); define("features", [](auto&&...) From 07fc3f55c670d837574ac3e54d0af41f5fa53e7c Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 14 May 2022 18:41:27 +0900 Subject: [PATCH 15/49] Support library `(scheme r4rs)` (experimental) Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 797 +++++++++++++++++++++++++++++++++++----------- basis/r7rs.ss | 14 - basis/srfi-1.ss | 44 +-- basis/srfi-45.ss | 81 ++--- 6 files changed, 685 insertions(+), 259 deletions(-) diff --git a/README.md b/README.md index 0ee48117f..b3e175622 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.985.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.986.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.985_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.986_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.985 +Meevax Lisp System, version 0.3.986 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 901b503e4..c5efefde7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.985 +0.3.986 diff --git a/basis/overture.ss b/basis/overture.ss index 5aecb7b3a..49fcbcef9 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -48,19 +48,80 @@ (export er-macro-transformer identifier?)) -(define-library (scheme base) - (import (srfi 211 explicit-renaming) - (meevax character) +(define-library (scheme lazy) + (import + (meevax equivalence) + (meevax pair) + (meevax syntax) + (srfi 211 explicit-renaming) + ) + + (begin (define (list . xs) xs) + + (define (not x) + (if x #f #t))) + + (begin (define (list 'promise)) + + (define (promise done? value) + (cons (cons done? value))) + + (define (promise? x) + (if (pair? x) + (eq? (car x)) + #f)) + + (define promise-done? cadr) + + (define promise-value cddr) + + (define (promise-update! new old) + (set-car! (cdr old) (promise-done? new)) + (set-cdr! (cdr old) (promise-value new)) + (set-car! new (cdr old))) + + (define (force promise) + (if (promise-done? promise) + (promise-value promise) + ((lambda (promise*) + (if (not (promise-done? promise)) + (promise-update! promise* promise)) + (force promise)) + ((promise-value promise))))) + + (define-syntax delay-force + (er-macro-transformer + (lambda (form rename compare) + (list (rename 'promise) #f (list (rename 'lambda) '() (cadr form)))))) + + (define-syntax delay + (er-macro-transformer + (lambda (form rename compare) + (list (rename 'delay-force) (list (rename 'promise) #t (cadr form)))))) + + (define (make-promise x) + (if (promise? x) x + (delay x))) + ) + + (export delay delay-force force make-promise promise?)) + +(define-library (scheme r4rs) + (import (meevax character) (meevax control) (meevax equivalence) + (meevax inexact) (meevax list) (meevax number) (meevax pair) + (meevax port) (meevax string) (meevax symbol) (meevax syntax) (meevax vector) - ) + (meevax write) + (srfi 211 explicit-renaming)) + (begin (define (unspecified) (if #f #f)) (define (list . xs) xs) @@ -161,20 +222,6 @@ (else x))) (expand (cadr form) 0)))) - (define-syntax when - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) ,(cadr form) - (,(rename 'begin) ,@(cddr form)))))) - - (define (not x) (if x #f #t)) - - (define-syntax unless - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) (,(rename 'not) ,(cadr form)) - (,(rename 'begin) ,@(cddr form)))))) - (define (reverse xs) (if (null? xs) '() (append (reverse (cdr xs)) @@ -207,7 +254,7 @@ (car rxs)))) (reverse (cons x xs))))) - (define (every f x . xs) + (define (every f x . xs) ; TODO REMOVE (define (every-1 f x) (if (null? (cdr x)) (f (car x)) @@ -223,7 +270,7 @@ (not (apply f xs))) x xs)))) - (define (any f x . xs) + (define (any f x . xs) ; TODO REMOVE (define (any-1 f x) (if (pair? (cdr x)) ((lambda (result) @@ -252,7 +299,6 @@ `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) ,@(map cadr (cadr form))))))) - (define-syntax let* (er-macro-transformer (lambda (form rename compare) @@ -262,15 +308,76 @@ (,(rename 'let*) ,(cdadr form) ,@(cddr form))))))) - (define-syntax letrec* + (define-syntax do (er-macro-transformer (lambda (form rename compare) - `(,(rename 'let) () - ,@(map (lambda (x) (cons (rename 'define) x)) - (cadr form)) - ,@(cddr form))))) + (let ((body `(,(rename 'begin) ,@(cdddr form) + (,(rename 'rec) ,@(map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + (cadr form)))))) + `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) + (list (car x) + (cadr x))) + (cadr form)) + ,(if (null? (cdaddr form)) + `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) + (,(rename 'if) ,(rename 'it) + ,(rename 'it) + ,body)) + `(,(rename 'if) ,(caaddr form) + (,(rename 'begin) ,@(cdaddr form)) + ,body))))))) + + (define (not x) + (if x #f #t)) + + (define (boolean? x) + (or (eqv? x #t) + (eqv? x #f))) + + (define (equal? x y) + (if (and (pair? x) + (pair? y)) + (and (equal? (car x) + (car y)) + (equal? (cdr x) + (cdr y))) + (eqv? x y))) + + (define (list? x) + (let list? ((x x) + (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) + (list? x lag))) + (null? x))) + (null? x)))) + + (define (length x) + (let length ((x x) + (k 0)) + (if (pair? x) + (length (cdr x) + (+ k 1)) + k))) - (define (member o x . c) ; for case + (define (list-tail x k) + (let list-tail ((x x) + (k k)) + (if (zero? k) x + (list-tail (cdr x) + (- k 1))))) + + (define (list-ref x k) + (car (list-tail x k))) + + (define (member o x . c) (let ((compare (if (pair? c) (car c) equal?))) (let member ((x x)) (and (pair? x) @@ -308,36 +415,21 @@ `(,(rename 'let) ((,(rename 'result) ,(cadr form))) ,(each-clause (cddr form)))))) - (define-syntax do - (er-macro-transformer - (lambda (form rename compare) - (let ((body `(,(rename 'begin) ,@(cdddr form) - (,(rename 'rec) ,@(map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - (cadr form)))))) - `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) - (list (car x) - (cadr x))) - (cadr form)) - ,(if (null? (cdaddr form)) - `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) - (,(rename 'if) ,(rename 'it) - ,(rename 'it) - ,body)) - `(,(rename 'if) ,(caaddr form) - (,(rename 'begin) ,@(cdaddr form)) - ,body))))))) + (define (assoc key alist . compare) + (let ((compare (if (pair? compare) + (car compare) + equal?))) + (let assoc ((alist alist)) + (if (null? alist) #f + (if (compare key (caar alist)) + (car alist) + (assoc (cdr alist))))))) - (define (equal? x y) ; structure=? - (if (and (pair? x) - (pair? y)) - (and (equal? (car x) - (car y)) - (equal? (cdr x) - (cdr y))) - (eqv? x y))) + (define (assq key alist) + (assoc key alist eq?)) + + (define (assv key alist) + (assoc key alist eqv?)) (define (exact? z) (define (exact-complex? x) @@ -405,32 +497,15 @@ (define (abs n) (if (< n 0) (- n) n)) - (define (floor-quotient x y) - (floor (/ x y))) - - (define (floor-remainder x y) - (% (+ y (% x y)) y)) - - (define (floor/ x y) - (values (floor-quotient x y) - (floor-remainder x y))) - - (define (truncate-quotient x y) + (define (quotient x y) (truncate (/ x y))) - (define truncate-remainder %) - - (define (truncate/ x y) - (values (truncate-quotient x y) - (truncate-remainder x y))) + (define remainder %) - (define quotient truncate-quotient) - - (define remainder truncate-remainder) - - (define modulo floor-remainder) + (define (modulo x y) + (% (+ y (% x y)) y)) - (define (gcd . xs) ; from Chibi-Scheme lib/init7.scm + (define (gcd . xs) (define (gcd-2 a b) (if (zero? b) (abs a) @@ -441,7 +516,7 @@ (if (null? ns) n (rec (gcd-2 n (car ns)) (cdr ns)))))) - (define (lcm . xs) ; from Chibi-Scheme lib/init7.scm + (define (lcm . xs) (define (lcm-2 a b) (abs (quotient (* a b) (gcd a b)))) (if (null? xs) 1 @@ -478,15 +553,30 @@ (e (abs e))) (sr (- x e) (+ x e) return))) - (define (square z) (* z z)) + (define (make-rectangular x y) + (+ x (* y (sqrt -1)))) - (define (boolean? x) - (or (eqv? x #t) - (eqv? x #f))) + (define (make-polar radius phi) + (make-rectangular (* radius (cos phi)) + (* radius (sin phi)))) - (define boolean=? eqv?) + (define (real-part z) + (if (%complex? z) (car z) z)) - (define symbol=? eqv?) + (define (imag-part z) + (if (%complex? z) (cdr z) 0)) + + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + + (define (angle z) + (atan (imag-part z) + (real-part z))) + + (define inexact->exact exact) + + (define exact->inexact inexact) (define (char-compare x xs compare) (let rec ((compare compare) @@ -512,9 +602,97 @@ (define (char>=? x . xs) (char-compare x xs >=)) + (define (char-ci-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer (char-downcase x))) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (char-downcase (car xs))))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char-ci=? x . xs) + (char-ci-compare x xs =)) + + (define (char-ci? x . xs) + (char-ci-compare x xs >)) + + (define (char-ci<=? x . xs) + (char-ci-compare x xs <=)) + + (define (char-ci>=? x . xs) + (char-ci-compare x xs >=)) + + (define (char-alphabetic? x) + (<= #,(char->integer #\a) + (char->integer (char-downcase x)) + #,(char->integer #\z))) + + (define (char-numeric? x) + (<= #,(char->integer #\0) + (char->integer x) + #,(char->integer #\9))) + + (define (char-whitespace? x) + (or (eqv? x #\space) + (eqv? x #\tab) + (eqv? x #\newline) + (eqv? x #\return))) + + (define (char-upper-case? x) + (<= #,(char->integer #\A) + (char->integer x) + #,(char->integer #\Z))) + + (define (char-lower-case? x) + (<= #,(char->integer #\a) + (char->integer x) + #,(char->integer #\z))) + + (define (char-downcase c) + (if (char-lower-case? c) c + (integer->char (+ (char->integer c) 32)))) + + (define (char-upcase c) + (if (char-upper-case? c) c + (integer->char (- (char->integer c) 32)))) + (define (string . xs) (list->string xs)) + (define (string-map f x . xs) ; r7rs + (define (string-map-1 x) + (list->string + (map f (string->list x)))) + (define (string-map-n xs) + (map list->string + (map (lambda (c) (map f c)) + (map string->list xs)))) + (if (null? xs) + (string-map-1 x) + (string-map-n (cons x xs)))) + + (define (string-foldcase s) ; r7rs + (string-map char-downcase s)) + + (define (string-ci=? . xs) + (apply string=? (map string-foldcase xs))) + + (define (string-ci? . xs) + (apply string>? (map string-foldcase xs))) + + (define (string-ci<=? . xs) + (apply string<=? (map string-foldcase xs))) + + (define (string-ci>=? . xs) + (apply string>=? (map string-foldcase xs))) + (define substring string-copy) (define (string-fill! s c . o) @@ -537,6 +715,349 @@ (continuation? x) (foreign-function? x))) + (define (for-each f x . xs) + (if (null? xs) + (letrec ((for-each (lambda (f x) + (if (pair? x) + (begin (f (car x)) + (for-each f (cdr x))))))) + (for-each f x)) + (begin (apply map f x xs) + (if #f #f)))) + + (define (call-with-input-file path f) + (define (call-with-input-port port f) + (let ((result (f port))) + (close-input-port port) + result)) + (call-with-input-port (open-input-file path) f)) + + (define (call-with-output-file path f) + (define (call-with-output-port port f) + (let ((result (f port))) + (close-output-port port) + result)) + (call-with-output-port (open-output-file path) f)) + + (define current-input-port standard-input-port) + + (define current-output-port standard-output-port) + + (define (read . port) + (%read (if (pair? port) + (car port) + (current-input-port)))) + + (define (read-char . port) + (%read-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (peek-char . port) + (%peek-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (char-ready? . port) + (%char-ready? (if (pair? port) + (car port) + (current-input-port)))) + + (define (write x . port) + (%write-simple x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-char x . port) + (put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-string string . xs) + (case (length xs) + ((0) (put-string string (current-output-port))) + ((1) (put-string string (car xs))) + (else (put-string (apply string-copy string (cadr xs)) (car xs))))) + + (define (display datum . port) + (cond ((char? datum) (apply write-char datum port)) + ((string? datum) (apply write-string datum port)) + (else (apply write datum port)))) + + (define (newline . port) + (apply write-char #\newline port)) + + ) + + (export quote + lambda + if + set! + cond + case + and + or + let ; named-let inessential + let* ; inessential + letrec + begin + do ; inessential + ; delay ; inessential + quasiquote + define + not + boolean? + eqv? + eq? + equal? + pair? + cons + car + cdr + set-car! + set-cdr! + caar + cadr + cdar + cddr + caaar + caadr + cadar + caddr + cdaar + cdadr + cddar + cdddr + caaaar + caaadr + caadar + caaddr + cadaar + cadadr + caddar + cadddr + cdaaar + cdaadr + cdadar + cdaddr + cddaar + cddadr + cdddar + cddddr + null? + list? + list + length + append + reverse + list-tail ; inessential + list-ref + memq + memv + member + assq + assv + assoc + symbol? + symbol->string + string->symbol + number? + complex? + real? + rational? + integer? + exact? + inexact? + = + < + > + <= + >= + zero? + positive? + negative? + odd? + even? + max + min + + + * + - + / + abs + quotient + remainder + modulo + gcd + lcm + numerator ; inessential + denominator ; inessential + floor + ceiling + truncate + round + rationalize ; inessential + exp ; inessential + log ; inessential + sin ; inessential + cos ; inessential + tan ; inessential + asin ; inessential + acos ; inessential + atan ; inessential + sqrt ; inessential + expt ; inessential + make-rectangular ; inessential + make-polar ; inessential + real-part ; inessential + imag-part ; inessential + magnitude ; inessential + angle ; inessential + exact->inexact ; inessential + inexact->exact ; inessential + number->string + string->number + char? + char=? + char? + char<=? + char>=? + char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char->integer + integer->char + char-upcase + char-downcase + string? + make-string + string + string-length + string-ref + string-set! + string=? + string? + string<=? + string>=? + string-ci=? + string-ci? + string-ci<=? + string-ci>=? + substring + string-append + string->list + list->string + string-copy ; inessential + string-fill! ; inessential + vector? + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector + vector-fill! ; inessential + procedure? + apply + map + for-each + ; force ; inessential + call-with-current-continuation! ; A version that does not consider dynamic-wind. + call-with-input-file ; r7rs incompatible (values unsupported) + call-with-output-file ; r7rs incompatible (values unsupported) + input-port? + output-port? + current-input-port ; r7rs incompatible (current-input-port is standard input) + current-output-port ; r7rs incompatible (current-output-port is standard output) + ; with-input-from-file ; inessential + ; with-output-to-file ; inessential + open-input-file + open-output-file + close-input-port + close-output-port + read + read-char + peek-char + eof-object? + char-ready? ; inessential + write + display + newline + write-char + ; load + ) + ) + +(define-library (scheme base) + (import (meevax character) ; for digit-value + (meevax number) ; for exact-integer? + (meevax syntax) ; for quote-syntax + (scheme r4rs) + (srfi 211 explicit-renaming) + ) + (begin (define (unspecified) (if #f #f)) + + (define-syntax when + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) ,(cadr form) + (,(rename 'begin) ,@(cddr form)))))) + + (define-syntax unless + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) (,(rename 'not) ,(cadr form)) + (,(rename 'begin) ,@(cddr form)))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'let) () + ,@(map (lambda (x) (cons (rename 'define) x)) + (cadr form)) + ,@(cddr form))))) + + (define (floor-quotient x y) + (floor (/ x y))) + + (define floor-remainder modulo) + + (define (floor/ x y) + (values (floor-quotient x y) + (floor-remainder x y))) + + (define truncate-quotient quotient) + + (define truncate-remainder remainder) + + (define (truncate/ x y) + (values (truncate-quotient x y) + (truncate-remainder x y))) + + (define (square z) (* z z)) + + (define inexact exact->inexact) + + (define exact inexact->exact) + + (define boolean=? eqv?) + + (define (list-set! x k object) + (set-car! (list-tail x k) object)) + + (define symbol=? eqv?) + (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html (define (dynamic-wind before thunk after) @@ -610,9 +1131,9 @@ and append apply - ; assoc - ; assq - ; assv + assoc + assq + assv begin ; binary-port? boolean=? @@ -685,7 +1206,7 @@ floor-remainder floor/ ; flush-output-port - ; for-each + for-each gcd ; get-output-bytevector ; get-output-string @@ -701,7 +1222,7 @@ integer? lambda lcm - ; length + length let let* ; let*-values @@ -714,10 +1235,10 @@ list->string list->vector ; list-copy - ; list-ref - ; list-set! - ; list-tail - ; list? + list-ref + list-set! + list-tail + list? ; make-bytevector ; make-list ; make-parameter @@ -844,7 +1365,8 @@ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) -(import (scheme base) +(import (scheme r4rs) + (scheme base) (scheme cxr) (srfi 211 explicit-renaming) (srfi 211 syntactic-closures) @@ -852,89 +1374,10 @@ (define (unspecified) (if #f #f)) -; ------------------------------------------------------------------------------ - (define (traditional-macro-transformer f) (lambda (form use-env mac-env) (apply f (cdr form)))) -; ------------------------------------------------------------------------------ - -(define (make-rectangular x y) (+ x (* y (sqrt -1)))) - -(define (make-polar radius phi) - (make-rectangular (* radius (cos phi)) - (* radius (sin phi)))) - -(define (real-part z) (if (%complex? z) (car z) z)) -(define (imag-part z) (if (%complex? z) (cdr z) 0)) - -(define (magnitude z) - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) - -(define (angle z) - (atan (imag-part z) - (real-part z))) - -(define inexact->exact exact) -(define exact->inexact inexact) - -(define (char-ci-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer (char-downcase x))) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (char-downcase (car xs))))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - -(define (char-ci=? x . xs) (char-ci-compare x xs =)) -(define (char-ci? x . xs) (char-ci-compare x xs >)) -(define (char-ci<=? x . xs) (char-ci-compare x xs <=)) -(define (char-ci>=? x . xs) (char-ci-compare x xs >=)) - -(define (char-alphabetic? x) - (<= #,(char->integer #\a) - (char->integer (char-downcase x)) - #,(char->integer #\z))) - -(define (char-numeric? x) - (<= #,(char->integer #\0) - (char->integer x) - #,(char->integer #\9))) - -(define (char-whitespace? x) - (or (eqv? x #\space) - (eqv? x #\tab) - (eqv? x #\newline) - (eqv? x #\return))) - -(define (char-upper-case? x) - (<= #,(char->integer #\A) - (char->integer x) - #,(char->integer #\Z))) - -(define (char-lower-case? x) - (<= #,(char->integer #\a) - (char->integer x) - #,(char->integer #\z))) - -(define (char-downcase c) - (if (char-lower-case? c) c - (integer->char (+ (char->integer c) 32)))) - -(define (char-upcase c) - (if (char-upper-case? c) c - (integer->char (- (char->integer c) 32)))) - -(define (string-ci=? . xs) (apply string=? (map string-foldcase xs))) -(define (string-ci? . xs) (apply string>? (map string-foldcase xs))) -(define (string-ci<=? . xs) (apply string<=? (map string-foldcase xs))) -(define (string-ci>=? . xs) (apply string>=? (map string-foldcase xs))) - ; ---- 6.11. Exceptions -------------------------------------------------------- (define (error-object? x) @@ -961,12 +1404,6 @@ (close-port port) result)) -(define (call-with-input-file path procedure) - (call-with-port (open-input-file path) procedure)) - -(define (call-with-output-file path procedure) - (call-with-port (open-output-file path) procedure)) - (define (close-port x) (cond ((input-port? x) (close-input-port x)) ((output-port? x) (close-output-port x)) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index b3608cc2b..f50739bef 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -185,16 +185,6 @@ ; ---- 4.2.5. Delayed evaluation ----------------------------------------------- -delay ; is defined in srfi-45.ss - -(define delay-force lazy) ; lazy is defined in srfi-45.ss - -force ; is defined in srfi-45.ss - -promise? ; is defined in srfi-45.ss - -make-promise ; is defined in srfi-45.ss - ; ---- 4.2.6. Dynamic bindings ------------------------------------------------- make-parameter ; is defined in srfi-39.ss @@ -275,10 +265,6 @@ parameterize ; is defined in srfi-39.ss ; ---- 6.4. Pairs and lists ---------------------------------------------------- -(define list-tail drop) ; from SRFI-1 - -(define (list-set! x k object) (set-car! (list-tail x k) object)) - ; ---- 6.5 Symbols ------------------------------------------------------------- ; ---- 6.6 Characters ---------------------------------------------------------- diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index f0b5b7e1a..cdc2dec7d 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -77,7 +77,7 @@ (null? x))) (null? x)))) -(define list? proper-list?) +; (define list? proper-list?) (define (dotted-list? x) (let rec ((x x) (lag x)) @@ -126,11 +126,11 @@ (lp2 (cdr pair-a) (cdr pair-b))))))))))) -(define (length x) - (let rec ((x x) (len 0)) - (if (pair? x) - (rec (cdr x) (+ len 1)) - len))) +; (define (length x) +; (let rec ((x x) (len 0)) +; (if (pair? x) +; (rec (cdr x) (+ len 1)) +; len))) (define (length+ x) ; Returns #f if X is circular. (let rec ((x x) (lag x) (len 0)) @@ -243,7 +243,7 @@ (begin (set-cdr! lag '()) x))) '()))) -(define (list-ref x k) (car (drop x k))) +; (define (list-ref x k) (car (drop x k))) (define (split-at x k) (let recur ((lis x) (k k)) @@ -523,15 +523,15 @@ (if (null-list? rest) vals (appender vals (recur (car rest) (cdr rest))))))))) -(define (for-each f x . xs) - (define (for-each f x) - (if (pair? x) - (begin (f (car x)) - (for-each f (cdr x))))) - (if (null? xs) - (for-each f x) - (begin (apply map f x xs) - (if #f #f)))) +; (define (for-each f x . xs) +; (define (for-each f x) +; (if (pair? x) +; (begin (f (car x)) +; (for-each f (cdr x))))) +; (if (null? xs) +; (for-each f x) +; (begin (apply map f x xs) +; (if #f #f)))) (define (pair-for-each proc lis1 . lists) (if (pair? lists) @@ -721,12 +721,12 @@ (new-tail (recur (delete! x tail elt=)))) (if (eq? tail new-tail) lis (cons x new-tail))))))) -(define (assoc x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (find (lambda (entry) (= x (car entry))) lis))) - -(define (assq key alist) (assoc key alist eq?)) -(define (assv key alist) (assoc key alist eqv?)) +; (define (assoc x lis . maybe-=) +; (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) +; (find (lambda (entry) (= x (car entry))) lis))) +; +; (define (assq key alist) (assoc key alist eq?)) +; (define (assv key alist) (assoc key alist eqv?)) (define (alist-cons key datum alist) (cons (cons key datum) alist)) diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index 2e8416d5d..6b66aaad3 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -1,39 +1,42 @@ -(define promise-tag (list 'promise)) - -(define (promise done? value-or-generator) - (cons (cons done? value-or-generator) promise-tag)) - -(define (promise? x) - (and (pair? x) - (eq? promise-tag (cdr x)))) - -(define promise-done? caar) -(define promise-value cdar) -(define promise-generator cdar) - -(define (promise-merge! new old) - (set-car! (car old) (promise-done? new)) - (set-cdr! (car old) (promise-value new)) - (set-car! new (car old))) - -(define (force promise) - (if (promise-done? promise) - (promise-value promise) - (let ((new ((promise-generator promise)))) - (unless (promise-done? promise) - (promise-merge! new promise)) - (force promise)))) - -(define-syntax lazy - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'promise) #f (,(rename 'lambda) () ,(cadr form)))))) - -(define-syntax delay - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'lazy) (,(rename 'promise) #t ,(cadr form)))))) - -(define (make-promise x) - (if (promise? x) x - (delay x))) +; (define (list 'promise)) +; +; (define (promise done? value) +; (cons (cons done? value))) +; +; (define (promise? x) +; (and (pair? x) +; (eq? (car x)))) +; +; (define promise-done? cadr) +; +; (define promise-value cddr) +; +; (define (promise-update! new old) +; (set-car! (cdr old) (promise-done? new)) +; (set-cdr! (cdr old) (promise-value new)) +; (set-car! new (cdr old))) +; +; (define (force promise) +; (if (promise-done? promise) +; (promise-value promise) +; ((lambda (promise*) +; (if (not (promise-done? promise)) +; (promise-update! promise* promise)) +; (force promise)) +; ((promise-value promise))))) +; +; (define-syntax lazy +; (er-macro-transformer +; (lambda (form rename compare) +; (list (rename 'promise) #f (list (rename 'lambda) '() (cadr form)))))) +; +; (define-syntax delay +; (er-macro-transformer +; (lambda (form rename compare) +; (list (rename 'lazy) (list (rename 'promise) #t (cadr form)))))) +; +; (define (make-promise x) +; (if (promise? x) x +; (delay x))) + +(import (scheme lazy)) From f78b2f4664642294da67847ce673c532d13fe41f Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 14 May 2022 19:12:31 +0900 Subject: [PATCH 16/49] Move library `(srfi 211 ...)` into `basis/srfi-211.ss` Signed-off-by: yamacir-kit --- README.md | 6 ++-- VERSION | 2 +- basis/overture.ss | 50 --------------------------------- basis/srfi-211.ss | 45 +++++++++++++++++++++++++++++ include/meevax/kernel/basis.hpp | 1 + src/kernel/basis.cpp | 1 + src/library/meevax.cpp | 1 + 7 files changed, 52 insertions(+), 54 deletions(-) create mode 100644 basis/srfi-211.ss diff --git a/README.md b/README.md index b3e175622..5aec43ccf 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.986.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.987.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.986_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.987_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.986 +Meevax Lisp System, version 0.3.987 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index c5efefde7..f8d48ae8a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.986 +0.3.987 diff --git a/basis/overture.ss b/basis/overture.ss index 49fcbcef9..f439a6eed 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,53 +1,3 @@ -(define-library (srfi 211 syntactic-closures) - (import (meevax macro) - (meevax syntax)) - - (begin (define (sc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure mac-env '() (f form use-env)))) - - (define (rsc-macro-transformer f) - (lambda (form use-env mac-env) - (make-syntactic-closure use-env '() (f form mac-env))))) - - (export sc-macro-transformer - rsc-macro-transformer - make-syntactic-closure - identifier?)) - -(define-library (srfi 211 explicit-renaming) - (import (meevax equivalence) - (meevax list) - (meevax macro) - (meevax pair) - (meevax syntax)) - - (begin (define (er-macro-transformer f) - (lambda (form use-env mac-env) - (define renames '()) - (define (rename x) - (letrec ((assq (lambda (x alist) - (if (null? alist) #f - (if (eq? x (caar alist)) - (car alist) - (assq x (cdr alist)))))) - (alist-cons (lambda (key x alist) - (cons (cons key x) alist)))) - (define key/value (assq x renames)) - (if key/value - (cdr key/value) - (begin (set! renames (alist-cons x (make-syntactic-closure mac-env '() x) renames)) - (cdar renames))))) - (define (compare x y) - (eqv? (if (syntactic-closure? x) x - (make-syntactic-closure use-env '() x)) - (if (syntactic-closure? y) y - (make-syntactic-closure use-env '() y)))) - (f form rename compare)))) - - (export er-macro-transformer - identifier?)) - (define-library (scheme lazy) (import (meevax equivalence) diff --git a/basis/srfi-211.ss b/basis/srfi-211.ss new file mode 100644 index 000000000..0e00fe979 --- /dev/null +++ b/basis/srfi-211.ss @@ -0,0 +1,45 @@ +(define-library (srfi 211 syntactic-closures) + (import (meevax macro) + (meevax syntax)) + + (begin (define (sc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure mac-env '() (f form use-env)))) + + (define (rsc-macro-transformer f) + (lambda (form use-env mac-env) + (make-syntactic-closure use-env '() (f form mac-env))))) + + (export sc-macro-transformer rsc-macro-transformer make-syntactic-closure identifier?)) + +(define-library (srfi 211 explicit-renaming) + (import (meevax equivalence) + (meevax list) + (meevax macro) + (meevax pair) + (meevax syntax)) + + (begin (define (er-macro-transformer f) + (lambda (form use-env mac-env) + (define renames '()) + (define (rename x) + (letrec ((assq (lambda (x alist) + (if (null? alist) #f + (if (eq? x (caar alist)) + (car alist) + (assq x (cdr alist)))))) + (alist-cons (lambda (key x alist) + (cons (cons key x) alist)))) + (define key/value (assq x renames)) + (if key/value + (cdr key/value) + (begin (set! renames (alist-cons x (make-syntactic-closure mac-env '() x) renames)) + (cdar renames))))) + (define (compare x y) + (eqv? (if (syntactic-closure? x) x + (make-syntactic-closure use-env '() x)) + (if (syntactic-closure? y) y + (make-syntactic-closure use-env '() y)))) + (f form rename compare)))) + + (export er-macro-transformer identifier?)) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index 441de6cc7..25dbb8b74 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -39,6 +39,7 @@ inline namespace kernel extern string_view const srfi_45; extern string_view const srfi_78; extern string_view const srfi_149; + extern string_view const srfi_211; } // namespace kernel } // namespace meevax diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index d63f4a7dc..df350cdbf 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -52,3 +52,4 @@ DEFINE_BINARY(srfi_39); DEFINE_BINARY(srfi_45); DEFINE_BINARY(srfi_78); DEFINE_BINARY(srfi_149); +DEFINE_BINARY(srfi_211); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 2df6349d0..0a509b336 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -47,6 +47,7 @@ namespace meevax }); std::vector const codes { + srfi_211, overture, srfi_8, srfi_1, From a74f22f807c1629a996d11b2bd75d9dda98d15a0 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 14 May 2022 19:27:23 +0900 Subject: [PATCH 17/49] Move library `(scheme r4rs)` into `basis/r4rs.ss` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 893 -------------------------------- basis/r4rs.ss | 892 +++++++++++++++++++++++++++++++ include/meevax/kernel/basis.hpp | 1 + src/kernel/basis.cpp | 1 + src/library/meevax.cpp | 1 + 7 files changed, 899 insertions(+), 897 deletions(-) create mode 100644 basis/r4rs.ss diff --git a/README.md b/README.md index 5aec43ccf..0c8015cd1 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.987.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.988.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.987_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.988_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.987 +Meevax Lisp System, version 0.3.988 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index f8d48ae8a..168453c9f 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.987 +0.3.988 diff --git a/basis/overture.ss b/basis/overture.ss index f439a6eed..dd9ca3bfa 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -56,899 +56,6 @@ (export delay delay-force force make-promise promise?)) -(define-library (scheme r4rs) - (import (meevax character) - (meevax control) - (meevax equivalence) - (meevax inexact) - (meevax list) - (meevax number) - (meevax pair) - (meevax port) - (meevax string) - (meevax symbol) - (meevax syntax) - (meevax vector) - (meevax write) - (srfi 211 explicit-renaming)) - - (begin (define (unspecified) (if #f #f)) - - (define (list . xs) xs) - - (define-syntax cond - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cdr form)) - (unspecified) - ((lambda (clause) - (if (compare (rename 'else) (car clause)) - (cons (rename 'begin) (cdr clause)) - (if (if (null? (cdr clause)) #t - (compare (rename '=>) (cadr clause))) - (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (if (null? (cdr clause)) - (rename 'result) - (list (caddr clause) - (rename 'result))) - (cons (rename 'cond) (cddr form)))) - (car clause)) - (list (rename 'if) - (car clause) - (cons (rename 'begin) (cdr clause)) - (cons (rename 'cond) (cddr form)))))) - (cadr form)))))) - - (define-syntax and - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form))) - ((null? (cddr form)) - (cadr form)) - (else (list (rename 'if) - (cadr form) - (cons (rename 'and) - (cddr form)) - #f)))))) - - (define-syntax or - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form)) #f) - ((null? (cddr form)) - (cadr form)) - (else (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (rename 'result) - (cons (rename 'or) - (cddr form)))) - (cadr form))))))) - - (define-syntax quasiquote - (er-macro-transformer - (lambda (form rename compare) - (define (expand x depth) - (cond ((pair? x) - (cond ((compare (rename 'unquote) (car x)) - (if (<= depth 0) - (cadr x) - (list (rename 'list) - (list (rename 'quote) 'unquote) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'unquote-splicing) (car x)) - (if (<= depth 0) - (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth)) - (list (rename 'list) - (list (rename 'quote) 'unquote-splicing) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'quasiquote) (car x)) - (list (rename 'list) - (list (rename 'quote) 'quasiquote) - (expand (cadr x) (+ depth 1)))) - ((and (<= depth 0) - (pair? (car x)) - (compare (rename 'unquote-splicing) (caar x))) - (if (null? (cdr x)) - (cadar x) - (list (rename 'append) - (cadar x) - (expand (cdr x) depth)))) - (else (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth))))) - ((vector? x) - (list (rename 'list->vector) - (expand (vector->list x) depth))) - ((or (identifier? x) - (null? x)) - (list (rename 'quote) x)) - (else x))) - (expand (cadr form) 0)))) - - (define (reverse xs) - (if (null? xs) '() - (append (reverse (cdr xs)) - (list (car xs))))) - - (define (map f x . xs) - (define (map-1 f x stack) - (if (pair? x) - (map-1 f - (cdr x) - (cons (f (car x)) stack)) - (reverse stack))) - (if (null? xs) - (map-1 f x '()) - (letrec ((map (lambda (f xs stack) - (if (every pair? xs) - (map f - (map-1 cdr xs '()) - (cons (apply f (map-1 car xs '())) stack)) - (reverse stack))))) - (map f (cons x xs) '())))) - - (define (apply f x . xs) - (define (apply-1 f xs) (f . xs)) - (if (null? xs) - (apply-1 f x) - ((lambda (rxs) - (apply-1 f - (append (reverse (cdr rxs)) - (car rxs)))) - (reverse (cons x xs))))) - - (define (every f x . xs) ; TODO REMOVE - (define (every-1 f x) - (if (null? (cdr x)) - (f (car x)) - (if (f (car x)) - (every-1 f (cdr x)) - #f))) - (if (null? xs) - (if (pair? x) - (every-1 f x) - #t) - (not (apply any - (lambda xs - (not (apply f xs))) - x xs)))) - - (define (any f x . xs) ; TODO REMOVE - (define (any-1 f x) - (if (pair? (cdr x)) - ((lambda (result) - (if result result (any-1 f (cdr x)))) - (f (car x))) - (f (car x)))) - (define (any-2+ f xs) - (if (every pair? xs) - ((lambda (result) - (if result result (any-2+ f (map cdr xs)))) - (apply f (map car xs))) - #f)) - (if (null? xs) - (if (pair? x) - (any-1 f x) - #f) - (any-2+ f (cons x xs)))) - - (define-syntax let - (er-macro-transformer - (lambda (form rename compare) - (if (identifier? (cadr form)) - `(,(rename 'letrec) ((,(cadr form) - (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) - (,(cadr form) ,@(map cadr (caddr form)))) - `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) - ,@(map cadr (cadr form))))))) - - (define-syntax let* - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cadr form)) - `(,(rename 'let) () ,@(cddr form)) - `(,(rename 'let) (,(caadr form)) - (,(rename 'let*) ,(cdadr form) - ,@(cddr form))))))) - - (define-syntax do - (er-macro-transformer - (lambda (form rename compare) - (let ((body `(,(rename 'begin) ,@(cdddr form) - (,(rename 'rec) ,@(map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - (cadr form)))))) - `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) - (list (car x) - (cadr x))) - (cadr form)) - ,(if (null? (cdaddr form)) - `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) - (,(rename 'if) ,(rename 'it) - ,(rename 'it) - ,body)) - `(,(rename 'if) ,(caaddr form) - (,(rename 'begin) ,@(cdaddr form)) - ,body))))))) - - (define (not x) - (if x #f #t)) - - (define (boolean? x) - (or (eqv? x #t) - (eqv? x #f))) - - (define (equal? x y) - (if (and (pair? x) - (pair? y)) - (and (equal? (car x) - (car y)) - (equal? (cdr x) - (cdr y))) - (eqv? x y))) - - (define (list? x) - (let list? ((x x) - (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) - (list? x lag))) - (null? x))) - (null? x)))) - - (define (length x) - (let length ((x x) - (k 0)) - (if (pair? x) - (length (cdr x) - (+ k 1)) - k))) - - (define (list-tail x k) - (let list-tail ((x x) - (k k)) - (if (zero? k) x - (list-tail (cdr x) - (- k 1))))) - - (define (list-ref x k) - (car (list-tail x k))) - - (define (member o x . c) - (let ((compare (if (pair? c) (car c) equal?))) - (let member ((x x)) - (and (pair? x) - (if (compare o (car x)) x - (member (cdr x))))))) - - (define (memq o x) - (member o x eq?)) - - (define (memv o x) - (member o x eqv?)) - - (define-syntax case - (er-macro-transformer - (lambda (form rename compare) - (define (body xs) - (cond ((null? xs) (rename 'result)) - ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) - (else `(,(rename 'begin) ,@xs)))) - (define (each-clause clauses) - (cond ((null? clauses) - (unspecified)) - ((compare (rename 'else) (caar clauses)) - (body (cdar clauses))) - ((and (pair? (caar clauses)) - (null? (cdaar clauses))) - `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) - (,(rename 'quote) ,(caaar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))) - (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) - (,(rename 'quote) ,(caar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))))) - `(,(rename 'let) ((,(rename 'result) ,(cadr form))) - ,(each-clause (cddr form)))))) - - (define (assoc key alist . compare) - (let ((compare (if (pair? compare) - (car compare) - equal?))) - (let assoc ((alist alist)) - (if (null? alist) #f - (if (compare key (caar alist)) - (car alist) - (assoc (cdr alist))))))) - - (define (assq key alist) - (assoc key alist eq?)) - - (define (assv key alist) - (assoc key alist eqv?)) - - (define (exact? z) - (define (exact-complex? x) - (and (%complex? x) - (exact? (real-part x)) - (exact? (imag-part x)))) - (or (exact-complex? z) - (ratio? z) - (exact-integer? z))) - - (define (inexact? z) - (define (inexact-complex? x) - (and (%complex? x) - (or (inexact? (real-part x)) - (inexact? (imag-part x))))) - (define (floating-point? z) - (or (single-float? z) - (double-float? z))) - (or (inexact-complex? z) - (floating-point? z))) - - (define (zero? n) - (= n 0)) - - (define (positive? n) - (> n 0)) - - (define (negative? n) - (< n 0)) - - (define (odd? n) - (not (even? n))) - - (define (even? n) - (= (remainder n 2) 0)) - - (define (max x . xs) - (define (max-aux x xs) - (if (null? xs) - (inexact x) - (max-aux (if (< x (car xs)) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (max-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (max-aux x xs)) - (else (rec (if (< x (car xs)) (car xs) x) - (cdr xs))))))) - - (define (min x . xs) - (define (min-aux x xs) - (if (null? xs) - (inexact x) - (min-aux (if (< (car xs) x) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (min-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (min-aux x xs)) - (else (rec (if (< (car xs) x) (car xs) x) - (cdr xs))))))) - - (define (abs n) - (if (< n 0) (- n) n)) - - (define (quotient x y) - (truncate (/ x y))) - - (define remainder %) - - (define (modulo x y) - (% (+ y (% x y)) y)) - - (define (gcd . xs) - (define (gcd-2 a b) - (if (zero? b) - (abs a) - (gcd b (remainder a b)))) - (if (null? xs) 0 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (gcd-2 n (car ns)) (cdr ns)))))) - - (define (lcm . xs) - (define (lcm-2 a b) - (abs (quotient (* a b) (gcd a b)))) - (if (null? xs) 1 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (lcm-2 n (car ns)) (cdr ns)))))) - - (define (numerator x) - (cond ((ratio? x) (car x)) - ((exact? x) x) - (else (inexact (numerator (exact x)))))) - - (define (denominator x) - (cond ((exact? x) (if (ratio? x) (cdr x) 1)) - ((integer? x) 1.0) - (else (inexact (denominator (exact x)))))) - - (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) - (define (sr x y return) - (let ((fx (floor x)) - (fy (floor y))) - (cond ((>= fx x) (return fx 1)) - ((= fx fy) (sr (/ (- y fy)) - (/ (- x fx)) - (lambda (n d) - (return (+ d (* fx n)) n)))) - (else (return (+ fx 1) 1))))) - (let ((return (if (negative? x) - (lambda (num den) - (/ (- num) den)) - /)) - (x (abs x)) - (e (abs e))) - (sr (- x e) (+ x e) return))) - - (define (make-rectangular x y) - (+ x (* y (sqrt -1)))) - - (define (make-polar radius phi) - (make-rectangular (* radius (cos phi)) - (* radius (sin phi)))) - - (define (real-part z) - (if (%complex? z) (car z) z)) - - (define (imag-part z) - (if (%complex? z) (cdr z) 0)) - - (define (magnitude z) - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) - - (define (angle z) - (atan (imag-part z) - (real-part z))) - - (define inexact->exact exact) - - (define exact->inexact inexact) - - (define (char-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer x)) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (car xs)))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char=? x . xs) - (char-compare x xs =)) - - (define (char? x . xs) - (char-compare x xs >)) - - (define (char<=? x . xs) - (char-compare x xs <=)) - - (define (char>=? x . xs) - (char-compare x xs >=)) - - (define (char-ci-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer (char-downcase x))) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (char-downcase (car xs))))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char-ci=? x . xs) - (char-ci-compare x xs =)) - - (define (char-ci? x . xs) - (char-ci-compare x xs >)) - - (define (char-ci<=? x . xs) - (char-ci-compare x xs <=)) - - (define (char-ci>=? x . xs) - (char-ci-compare x xs >=)) - - (define (char-alphabetic? x) - (<= #,(char->integer #\a) - (char->integer (char-downcase x)) - #,(char->integer #\z))) - - (define (char-numeric? x) - (<= #,(char->integer #\0) - (char->integer x) - #,(char->integer #\9))) - - (define (char-whitespace? x) - (or (eqv? x #\space) - (eqv? x #\tab) - (eqv? x #\newline) - (eqv? x #\return))) - - (define (char-upper-case? x) - (<= #,(char->integer #\A) - (char->integer x) - #,(char->integer #\Z))) - - (define (char-lower-case? x) - (<= #,(char->integer #\a) - (char->integer x) - #,(char->integer #\z))) - - (define (char-downcase c) - (if (char-lower-case? c) c - (integer->char (+ (char->integer c) 32)))) - - (define (char-upcase c) - (if (char-upper-case? c) c - (integer->char (- (char->integer c) 32)))) - - (define (string . xs) - (list->string xs)) - - (define (string-map f x . xs) ; r7rs - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) - (if (null? xs) - (string-map-1 x) - (string-map-n (cons x xs)))) - - (define (string-foldcase s) ; r7rs - (string-map char-downcase s)) - - (define (string-ci=? . xs) - (apply string=? (map string-foldcase xs))) - - (define (string-ci? . xs) - (apply string>? (map string-foldcase xs))) - - (define (string-ci<=? . xs) - (apply string<=? (map string-foldcase xs))) - - (define (string-ci>=? . xs) - (apply string>=? (map string-foldcase xs))) - - (define substring string-copy) - - (define (string-fill! s c . o) - (let ((start (if (and (pair? o) - (exact-integer? (car o))) - (car o) - 0)) - (end (if (and (pair? o) - (pair? (cdr o)) - (exact-integer? (cadr o))) - (cadr o) - (string-length s)))) - (let rec ((k (- end 1))) - (if (<= start k) - (begin (string-set! s k c) - (rec (- k 1))))))) - - (define (procedure? x) - (or (closure? x) - (continuation? x) - (foreign-function? x))) - - (define (for-each f x . xs) - (if (null? xs) - (letrec ((for-each (lambda (f x) - (if (pair? x) - (begin (f (car x)) - (for-each f (cdr x))))))) - (for-each f x)) - (begin (apply map f x xs) - (if #f #f)))) - - (define (call-with-input-file path f) - (define (call-with-input-port port f) - (let ((result (f port))) - (close-input-port port) - result)) - (call-with-input-port (open-input-file path) f)) - - (define (call-with-output-file path f) - (define (call-with-output-port port f) - (let ((result (f port))) - (close-output-port port) - result)) - (call-with-output-port (open-output-file path) f)) - - (define current-input-port standard-input-port) - - (define current-output-port standard-output-port) - - (define (read . port) - (%read (if (pair? port) - (car port) - (current-input-port)))) - - (define (read-char . port) - (%read-char (if (pair? port) - (car port) - (current-input-port)))) - - (define (peek-char . port) - (%peek-char (if (pair? port) - (car port) - (current-input-port)))) - - (define (char-ready? . port) - (%char-ready? (if (pair? port) - (car port) - (current-input-port)))) - - (define (write x . port) - (%write-simple x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-char x . port) - (put-char x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-string string . xs) - (case (length xs) - ((0) (put-string string (current-output-port))) - ((1) (put-string string (car xs))) - (else (put-string (apply string-copy string (cadr xs)) (car xs))))) - - (define (display datum . port) - (cond ((char? datum) (apply write-char datum port)) - ((string? datum) (apply write-string datum port)) - (else (apply write datum port)))) - - (define (newline . port) - (apply write-char #\newline port)) - - ) - - (export quote - lambda - if - set! - cond - case - and - or - let ; named-let inessential - let* ; inessential - letrec - begin - do ; inessential - ; delay ; inessential - quasiquote - define - not - boolean? - eqv? - eq? - equal? - pair? - cons - car - cdr - set-car! - set-cdr! - caar - cadr - cdar - cddr - caaar - caadr - cadar - caddr - cdaar - cdadr - cddar - cdddr - caaaar - caaadr - caadar - caaddr - cadaar - cadadr - caddar - cadddr - cdaaar - cdaadr - cdadar - cdaddr - cddaar - cddadr - cdddar - cddddr - null? - list? - list - length - append - reverse - list-tail ; inessential - list-ref - memq - memv - member - assq - assv - assoc - symbol? - symbol->string - string->symbol - number? - complex? - real? - rational? - integer? - exact? - inexact? - = - < - > - <= - >= - zero? - positive? - negative? - odd? - even? - max - min - + - * - - - / - abs - quotient - remainder - modulo - gcd - lcm - numerator ; inessential - denominator ; inessential - floor - ceiling - truncate - round - rationalize ; inessential - exp ; inessential - log ; inessential - sin ; inessential - cos ; inessential - tan ; inessential - asin ; inessential - acos ; inessential - atan ; inessential - sqrt ; inessential - expt ; inessential - make-rectangular ; inessential - make-polar ; inessential - real-part ; inessential - imag-part ; inessential - magnitude ; inessential - angle ; inessential - exact->inexact ; inessential - inexact->exact ; inessential - number->string - string->number - char? - char=? - char? - char<=? - char>=? - char-ci=? - char-ci? - char-ci<=? - char-ci>=? - char-alphabetic? - char-numeric? - char-whitespace? - char-upper-case? - char-lower-case? - char->integer - integer->char - char-upcase - char-downcase - string? - make-string - string - string-length - string-ref - string-set! - string=? - string? - string<=? - string>=? - string-ci=? - string-ci? - string-ci<=? - string-ci>=? - substring - string-append - string->list - list->string - string-copy ; inessential - string-fill! ; inessential - vector? - make-vector - vector - vector-length - vector-ref - vector-set! - vector->list - list->vector - vector-fill! ; inessential - procedure? - apply - map - for-each - ; force ; inessential - call-with-current-continuation! ; A version that does not consider dynamic-wind. - call-with-input-file ; r7rs incompatible (values unsupported) - call-with-output-file ; r7rs incompatible (values unsupported) - input-port? - output-port? - current-input-port ; r7rs incompatible (current-input-port is standard input) - current-output-port ; r7rs incompatible (current-output-port is standard output) - ; with-input-from-file ; inessential - ; with-output-to-file ; inessential - open-input-file - open-output-file - close-input-port - close-output-port - read - read-char - peek-char - eof-object? - char-ready? ; inessential - write - display - newline - write-char - ; load - ) - ) - (define-library (scheme base) (import (meevax character) ; for digit-value (meevax number) ; for exact-integer? diff --git a/basis/r4rs.ss b/basis/r4rs.ss new file mode 100644 index 000000000..e7b8545c5 --- /dev/null +++ b/basis/r4rs.ss @@ -0,0 +1,892 @@ +(define-library (scheme r4rs) + (import (meevax character) + (meevax control) + (meevax equivalence) + (meevax inexact) + (meevax list) + (meevax number) + (meevax pair) + (meevax port) + (meevax string) + (meevax symbol) + (meevax syntax) + (meevax vector) + (meevax write) + (srfi 211 explicit-renaming)) + + (begin (define (unspecified) (if #f #f)) + + (define (list . xs) xs) + + (define-syntax cond + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cdr form)) + (unspecified) + ((lambda (clause) + (if (compare (rename 'else) (car clause)) + (cons (rename 'begin) (cdr clause)) + (if (if (null? (cdr clause)) #t + (compare (rename '=>) (cadr clause))) + (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (if (null? (cdr clause)) + (rename 'result) + (list (caddr clause) + (rename 'result))) + (cons (rename 'cond) (cddr form)))) + (car clause)) + (list (rename 'if) + (car clause) + (cons (rename 'begin) (cdr clause)) + (cons (rename 'cond) (cddr form)))))) + (cadr form)))))) + + (define-syntax and + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form))) + ((null? (cddr form)) + (cadr form)) + (else (list (rename 'if) + (cadr form) + (cons (rename 'and) + (cddr form)) + #f)))))) + + (define-syntax or + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form)) #f) + ((null? (cddr form)) + (cadr form)) + (else (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (rename 'result) + (cons (rename 'or) + (cddr form)))) + (cadr form))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + (define (expand x depth) + (cond ((pair? x) + (cond ((compare (rename 'unquote) (car x)) + (if (<= depth 0) + (cadr x) + (list (rename 'list) + (list (rename 'quote) 'unquote) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= depth 0) + (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth)) + (list (rename 'list) + (list (rename 'quote) 'unquote-splicing) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) + (list (rename 'quote) 'quasiquote) + (expand (cadr x) (+ depth 1)))) + ((and (<= depth 0) + (pair? (car x)) + (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) + (cadar x) + (expand (cdr x) depth)))) + (else (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth))))) + ((vector? x) + (list (rename 'list->vector) + (expand (vector->list x) depth))) + ((or (identifier? x) + (null? x)) + (list (rename 'quote) x)) + (else x))) + (expand (cadr form) 0)))) + + (define (reverse xs) + (if (null? xs) '() + (append (reverse (cdr xs)) + (list (car xs))))) + + (define (map f x . xs) + (define (map-1 f x stack) + (if (pair? x) + (map-1 f + (cdr x) + (cons (f (car x)) stack)) + (reverse stack))) + (if (null? xs) + (map-1 f x '()) + (letrec ((map (lambda (f xs stack) + (if (every pair? xs) + (map f + (map-1 cdr xs '()) + (cons (apply f (map-1 car xs '())) stack)) + (reverse stack))))) + (map f (cons x xs) '())))) + + (define (apply f x . xs) + (define (apply-1 f xs) (f . xs)) + (if (null? xs) + (apply-1 f x) + ((lambda (rxs) + (apply-1 f + (append (reverse (cdr rxs)) + (car rxs)))) + (reverse (cons x xs))))) + + (define (every f x . xs) ; TODO REMOVE + (define (every-1 f x) + (if (null? (cdr x)) + (f (car x)) + (if (f (car x)) + (every-1 f (cdr x)) + #f))) + (if (null? xs) + (if (pair? x) + (every-1 f x) + #t) + (not (apply any + (lambda xs + (not (apply f xs))) + x xs)))) + + (define (any f x . xs) ; TODO REMOVE + (define (any-1 f x) + (if (pair? (cdr x)) + ((lambda (result) + (if result result (any-1 f (cdr x)))) + (f (car x))) + (f (car x)))) + (define (any-2+ f xs) + (if (every pair? xs) + ((lambda (result) + (if result result (any-2+ f (map cdr xs)))) + (apply f (map car xs))) + #f)) + (if (null? xs) + (if (pair? x) + (any-1 f x) + #f) + (any-2+ f (cons x xs)))) + + (define-syntax let + (er-macro-transformer + (lambda (form rename compare) + (if (identifier? (cadr form)) + `(,(rename 'letrec) ((,(cadr form) + (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) + (,(cadr form) ,@(map cadr (caddr form)))) + `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) + ,@(map cadr (cadr form))))))) + + (define-syntax let* + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cadr form)) + `(,(rename 'let) () ,@(cddr form)) + `(,(rename 'let) (,(caadr form)) + (,(rename 'let*) ,(cdadr form) + ,@(cddr form))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form rename compare) + (let ((body `(,(rename 'begin) ,@(cdddr form) + (,(rename 'rec) ,@(map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + (cadr form)))))) + `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) + (list (car x) + (cadr x))) + (cadr form)) + ,(if (null? (cdaddr form)) + `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) + (,(rename 'if) ,(rename 'it) + ,(rename 'it) + ,body)) + `(,(rename 'if) ,(caaddr form) + (,(rename 'begin) ,@(cdaddr form)) + ,body))))))) + + (define (not x) + (if x #f #t)) + + (define (boolean? x) + (or (eqv? x #t) + (eqv? x #f))) + + (define (equal? x y) + (if (and (pair? x) + (pair? y)) + (and (equal? (car x) + (car y)) + (equal? (cdr x) + (cdr y))) + (eqv? x y))) + + (define (list? x) + (let list? ((x x) + (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) + (list? x lag))) + (null? x))) + (null? x)))) + + (define (length x) + (let length ((x x) + (k 0)) + (if (pair? x) + (length (cdr x) + (+ k 1)) + k))) + + (define (list-tail x k) + (let list-tail ((x x) + (k k)) + (if (zero? k) x + (list-tail (cdr x) + (- k 1))))) + + (define (list-ref x k) + (car (list-tail x k))) + + (define (member o x . c) + (let ((compare (if (pair? c) (car c) equal?))) + (let member ((x x)) + (and (pair? x) + (if (compare o (car x)) x + (member (cdr x))))))) + + (define (memq o x) + (member o x eq?)) + + (define (memv o x) + (member o x eqv?)) + + (define-syntax case + (er-macro-transformer + (lambda (form rename compare) + (define (body xs) + (cond ((null? xs) (rename 'result)) + ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) + (else `(,(rename 'begin) ,@xs)))) + (define (each-clause clauses) + (cond ((null? clauses) + (unspecified)) + ((compare (rename 'else) (caar clauses)) + (body (cdar clauses))) + ((and (pair? (caar clauses)) + (null? (cdaar clauses))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) + (,(rename 'quote) ,(caaar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))) + (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) + (,(rename 'quote) ,(caar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))))) + `(,(rename 'let) ((,(rename 'result) ,(cadr form))) + ,(each-clause (cddr form)))))) + + (define (assoc key alist . compare) + (let ((compare (if (pair? compare) + (car compare) + equal?))) + (let assoc ((alist alist)) + (if (null? alist) #f + (if (compare key (caar alist)) + (car alist) + (assoc (cdr alist))))))) + + (define (assq key alist) + (assoc key alist eq?)) + + (define (assv key alist) + (assoc key alist eqv?)) + + (define (exact? z) + (define (exact-complex? x) + (and (%complex? x) + (exact? (real-part x)) + (exact? (imag-part x)))) + (or (exact-complex? z) + (ratio? z) + (exact-integer? z))) + + (define (inexact? z) + (define (inexact-complex? x) + (and (%complex? x) + (or (inexact? (real-part x)) + (inexact? (imag-part x))))) + (define (floating-point? z) + (or (single-float? z) + (double-float? z))) + (or (inexact-complex? z) + (floating-point? z))) + + (define (zero? n) + (= n 0)) + + (define (positive? n) + (> n 0)) + + (define (negative? n) + (< n 0)) + + (define (odd? n) + (not (even? n))) + + (define (even? n) + (= (remainder n 2) 0)) + + (define (max x . xs) + (define (max-aux x xs) + (if (null? xs) + (inexact x) + (max-aux (if (< x (car xs)) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (max-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (max-aux x xs)) + (else (rec (if (< x (car xs)) (car xs) x) + (cdr xs))))))) + + (define (min x . xs) + (define (min-aux x xs) + (if (null? xs) + (inexact x) + (min-aux (if (< (car xs) x) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (min-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (min-aux x xs)) + (else (rec (if (< (car xs) x) (car xs) x) + (cdr xs))))))) + + (define (abs n) + (if (< n 0) (- n) n)) + + (define (quotient x y) + (truncate (/ x y))) + + (define remainder %) + + (define (modulo x y) + (% (+ y (% x y)) y)) + + (define (gcd . xs) + (define (gcd-2 a b) + (if (zero? b) + (abs a) + (gcd b (remainder a b)))) + (if (null? xs) 0 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (gcd-2 n (car ns)) (cdr ns)))))) + + (define (lcm . xs) + (define (lcm-2 a b) + (abs (quotient (* a b) (gcd a b)))) + (if (null? xs) 1 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (lcm-2 n (car ns)) (cdr ns)))))) + + (define (numerator x) + (cond ((ratio? x) (car x)) + ((exact? x) x) + (else (inexact (numerator (exact x)))))) + + (define (denominator x) + (cond ((exact? x) (if (ratio? x) (cdr x) 1)) + ((integer? x) 1.0) + (else (inexact (denominator (exact x)))))) + + (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) + (define (sr x y return) + (let ((fx (floor x)) + (fy (floor y))) + (cond ((>= fx x) (return fx 1)) + ((= fx fy) (sr (/ (- y fy)) + (/ (- x fx)) + (lambda (n d) + (return (+ d (* fx n)) n)))) + (else (return (+ fx 1) 1))))) + (let ((return (if (negative? x) + (lambda (num den) + (/ (- num) den)) + /)) + (x (abs x)) + (e (abs e))) + (sr (- x e) (+ x e) return))) + + (define (make-rectangular x y) + (+ x (* y (sqrt -1)))) + + (define (make-polar radius phi) + (make-rectangular (* radius (cos phi)) + (* radius (sin phi)))) + + (define (real-part z) + (if (%complex? z) (car z) z)) + + (define (imag-part z) + (if (%complex? z) (cdr z) 0)) + + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + + (define (angle z) + (atan (imag-part z) + (real-part z))) + + (define inexact->exact exact) + + (define exact->inexact inexact) + + (define (char-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer x)) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (car xs)))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char=? x . xs) + (char-compare x xs =)) + + (define (char? x . xs) + (char-compare x xs >)) + + (define (char<=? x . xs) + (char-compare x xs <=)) + + (define (char>=? x . xs) + (char-compare x xs >=)) + + (define (char-ci-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer (char-downcase x))) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (char-downcase (car xs))))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char-ci=? x . xs) + (char-ci-compare x xs =)) + + (define (char-ci? x . xs) + (char-ci-compare x xs >)) + + (define (char-ci<=? x . xs) + (char-ci-compare x xs <=)) + + (define (char-ci>=? x . xs) + (char-ci-compare x xs >=)) + + (define (char-alphabetic? x) + (<= #,(char->integer #\a) + (char->integer (char-downcase x)) + #,(char->integer #\z))) + + (define (char-numeric? x) + (<= #,(char->integer #\0) + (char->integer x) + #,(char->integer #\9))) + + (define (char-whitespace? x) + (or (eqv? x #\space) + (eqv? x #\tab) + (eqv? x #\newline) + (eqv? x #\return))) + + (define (char-upper-case? x) + (<= #,(char->integer #\A) + (char->integer x) + #,(char->integer #\Z))) + + (define (char-lower-case? x) + (<= #,(char->integer #\a) + (char->integer x) + #,(char->integer #\z))) + + (define (char-downcase c) + (if (char-lower-case? c) c + (integer->char (+ (char->integer c) 32)))) + + (define (char-upcase c) + (if (char-upper-case? c) c + (integer->char (- (char->integer c) 32)))) + + (define (string . xs) + (list->string xs)) + + (define (string-map f x . xs) ; r7rs + (define (string-map-1 x) + (list->string + (map f (string->list x)))) + (define (string-map-n xs) + (map list->string + (map (lambda (c) (map f c)) + (map string->list xs)))) + (if (null? xs) + (string-map-1 x) + (string-map-n (cons x xs)))) + + (define (string-foldcase s) ; r7rs + (string-map char-downcase s)) + + (define (string-ci=? . xs) + (apply string=? (map string-foldcase xs))) + + (define (string-ci? . xs) + (apply string>? (map string-foldcase xs))) + + (define (string-ci<=? . xs) + (apply string<=? (map string-foldcase xs))) + + (define (string-ci>=? . xs) + (apply string>=? (map string-foldcase xs))) + + (define substring string-copy) + + (define (string-fill! s c . o) + (let ((start (if (and (pair? o) + (exact-integer? (car o))) + (car o) + 0)) + (end (if (and (pair? o) + (pair? (cdr o)) + (exact-integer? (cadr o))) + (cadr o) + (string-length s)))) + (let rec ((k (- end 1))) + (if (<= start k) + (begin (string-set! s k c) + (rec (- k 1))))))) + + (define (procedure? x) + (or (closure? x) + (continuation? x) + (foreign-function? x))) + + (define (for-each f x . xs) + (if (null? xs) + (letrec ((for-each (lambda (f x) + (if (pair? x) + (begin (f (car x)) + (for-each f (cdr x))))))) + (for-each f x)) + (begin (apply map f x xs) + (if #f #f)))) + + (define (call-with-input-file path f) + (define (call-with-input-port port f) + (let ((result (f port))) + (close-input-port port) + result)) + (call-with-input-port (open-input-file path) f)) + + (define (call-with-output-file path f) + (define (call-with-output-port port f) + (let ((result (f port))) + (close-output-port port) + result)) + (call-with-output-port (open-output-file path) f)) + + (define current-input-port standard-input-port) + + (define current-output-port standard-output-port) + + (define (read . port) + (%read (if (pair? port) + (car port) + (current-input-port)))) + + (define (read-char . port) + (%read-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (peek-char . port) + (%peek-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (char-ready? . port) + (%char-ready? (if (pair? port) + (car port) + (current-input-port)))) + + (define (write x . port) + (%write-simple x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-char x . port) + (put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-string string . xs) + (case (length xs) + ((0) (put-string string (current-output-port))) + ((1) (put-string string (car xs))) + (else (put-string (apply string-copy string (cadr xs)) (car xs))))) + + (define (display datum . port) + (cond ((char? datum) (apply write-char datum port)) + ((string? datum) (apply write-string datum port)) + (else (apply write datum port)))) + + (define (newline . port) + (apply write-char #\newline port)) + + ) + + (export quote + lambda + if + set! + cond + case + and + or + let ; named-let inessential + let* ; inessential + letrec + begin + do ; inessential + ; delay ; inessential + quasiquote + define + not + boolean? + eqv? + eq? + equal? + pair? + cons + car + cdr + set-car! + set-cdr! + caar + cadr + cdar + cddr + caaar + caadr + cadar + caddr + cdaar + cdadr + cddar + cdddr + caaaar + caaadr + caadar + caaddr + cadaar + cadadr + caddar + cadddr + cdaaar + cdaadr + cdadar + cdaddr + cddaar + cddadr + cdddar + cddddr + null? + list? + list + length + append + reverse + list-tail ; inessential + list-ref + memq + memv + member + assq + assv + assoc + symbol? + symbol->string + string->symbol + number? + complex? + real? + rational? + integer? + exact? + inexact? + = + < + > + <= + >= + zero? + positive? + negative? + odd? + even? + max + min + + + * + - + / + abs + quotient + remainder + modulo + gcd + lcm + numerator ; inessential + denominator ; inessential + floor + ceiling + truncate + round + rationalize ; inessential + exp ; inessential + log ; inessential + sin ; inessential + cos ; inessential + tan ; inessential + asin ; inessential + acos ; inessential + atan ; inessential + sqrt ; inessential + expt ; inessential + make-rectangular ; inessential + make-polar ; inessential + real-part ; inessential + imag-part ; inessential + magnitude ; inessential + angle ; inessential + exact->inexact ; inessential + inexact->exact ; inessential + number->string + string->number + char? + char=? + char? + char<=? + char>=? + char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char->integer + integer->char + char-upcase + char-downcase + string? + make-string + string + string-length + string-ref + string-set! + string=? + string? + string<=? + string>=? + string-ci=? + string-ci? + string-ci<=? + string-ci>=? + substring + string-append + string->list + list->string + string-copy ; inessential + string-fill! ; inessential + vector? + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector + vector-fill! ; inessential + procedure? + apply + map + for-each + ; force ; inessential + call-with-current-continuation! ; A version that does not consider dynamic-wind. + call-with-input-file ; r7rs incompatible (values unsupported) + call-with-output-file ; r7rs incompatible (values unsupported) + input-port? + output-port? + current-input-port ; r7rs incompatible (current-input-port is standard input) + current-output-port ; r7rs incompatible (current-output-port is standard output) + ; with-input-from-file ; inessential + ; with-output-to-file ; inessential + open-input-file + open-output-file + close-input-port + close-output-port + read + read-char + peek-char + eof-object? + char-ready? ; inessential + write + display + newline + write-char + ; load + ) + ) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index 25dbb8b74..c6a32c510 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -30,6 +30,7 @@ inline namespace kernel #endif extern string_view const overture; + extern string_view const r4rs; extern string_view const r7rs; extern string_view const srfi_1; extern string_view const srfi_8; diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index df350cdbf..d26c923dc 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -43,6 +43,7 @@ inline namespace kernel \ } static_assert(true) DEFINE_BINARY(overture); +DEFINE_BINARY(r4rs); DEFINE_BINARY(r7rs); DEFINE_BINARY(srfi_1); DEFINE_BINARY(srfi_8); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 0a509b336..178646543 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -48,6 +48,7 @@ namespace meevax std::vector const codes { srfi_211, + r4rs, overture, srfi_8, srfi_1, From e4ab1292dba99b3d03d6d0e50e7c8e9b28668972 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 14 May 2022 21:13:34 +0900 Subject: [PATCH 18/49] Support library `(srfi 45)` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- basis/overture.ss | 58 -------------------- basis/r4rs.ss | 2 +- basis/r7rs.ss | 9 ++++ basis/srfi-45.ss | 89 ++++++++++++++++--------------- include/meevax/kernel/machine.hpp | 4 ++ 7 files changed, 65 insertions(+), 105 deletions(-) diff --git a/README.md b/README.md index 0c8015cd1..d2624c33a 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.988.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.989.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.988_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.989_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.988 +Meevax Lisp System, version 0.3.989 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 168453c9f..76152197a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.988 +0.3.989 diff --git a/basis/overture.ss b/basis/overture.ss index dd9ca3bfa..a80c7978f 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,61 +1,3 @@ -(define-library (scheme lazy) - (import - (meevax equivalence) - (meevax pair) - (meevax syntax) - (srfi 211 explicit-renaming) - ) - - (begin (define (list . xs) xs) - - (define (not x) - (if x #f #t))) - - (begin (define (list 'promise)) - - (define (promise done? value) - (cons (cons done? value))) - - (define (promise? x) - (if (pair? x) - (eq? (car x)) - #f)) - - (define promise-done? cadr) - - (define promise-value cddr) - - (define (promise-update! new old) - (set-car! (cdr old) (promise-done? new)) - (set-cdr! (cdr old) (promise-value new)) - (set-car! new (cdr old))) - - (define (force promise) - (if (promise-done? promise) - (promise-value promise) - ((lambda (promise*) - (if (not (promise-done? promise)) - (promise-update! promise* promise)) - (force promise)) - ((promise-value promise))))) - - (define-syntax delay-force - (er-macro-transformer - (lambda (form rename compare) - (list (rename 'promise) #f (list (rename 'lambda) '() (cadr form)))))) - - (define-syntax delay - (er-macro-transformer - (lambda (form rename compare) - (list (rename 'delay-force) (list (rename 'promise) #t (cadr form)))))) - - (define (make-promise x) - (if (promise? x) x - (delay x))) - ) - - (export delay delay-force force make-promise promise?)) - (define-library (scheme base) (import (meevax character) ; for digit-value (meevax number) ; for exact-integer? diff --git a/basis/r4rs.ss b/basis/r4rs.ss index e7b8545c5..8f5e26642 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -865,7 +865,7 @@ map for-each ; force ; inessential - call-with-current-continuation! ; A version that does not consider dynamic-wind. + call-with-current-continuation! ; call/cc! does not consider dynamic-wind. call-with-input-file ; r7rs incompatible (values unsupported) call-with-output-file ; r7rs incompatible (values unsupported) input-port? diff --git a/basis/r7rs.ss b/basis/r7rs.ss index f50739bef..a864b4dfc 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -185,6 +185,15 @@ ; ---- 4.2.5. Delayed evaluation ----------------------------------------------- +(define-library (scheme lazy) ; TEMPORARY + (import (scheme r4rs) + (srfi 45)) + (export delay delay-force force make-promise promise?) + (begin (define make-promise eager) + (define delay-force lazy))) + +(import (scheme lazy)) + ; ---- 4.2.6. Dynamic bindings ------------------------------------------------- make-parameter ; is defined in srfi-39.ss diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index 6b66aaad3..d67a52f8b 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -1,42 +1,47 @@ -; (define (list 'promise)) -; -; (define (promise done? value) -; (cons (cons done? value))) -; -; (define (promise? x) -; (and (pair? x) -; (eq? (car x)))) -; -; (define promise-done? cadr) -; -; (define promise-value cddr) -; -; (define (promise-update! new old) -; (set-car! (cdr old) (promise-done? new)) -; (set-cdr! (cdr old) (promise-value new)) -; (set-car! new (cdr old))) -; -; (define (force promise) -; (if (promise-done? promise) -; (promise-value promise) -; ((lambda (promise*) -; (if (not (promise-done? promise)) -; (promise-update! promise* promise)) -; (force promise)) -; ((promise-value promise))))) -; -; (define-syntax lazy -; (er-macro-transformer -; (lambda (form rename compare) -; (list (rename 'promise) #f (list (rename 'lambda) '() (cadr form)))))) -; -; (define-syntax delay -; (er-macro-transformer -; (lambda (form rename compare) -; (list (rename 'lazy) (list (rename 'promise) #t (cadr form)))))) -; -; (define (make-promise x) -; (if (promise? x) x -; (delay x))) - -(import (scheme lazy)) +(define-library (srfi 45) ; Based on r7rs reference implementation. + (import (scheme r4rs) + (meevax syntax) ; for define-syntax + (srfi 211 explicit-renaming)) + + (export delay eager force lazy promise?) + + (begin (define (list 'promise)) + + (define (promise done? value) + (cons (cons done? value))) + + (define (promise? x) + (and (pair? x) + (eq? (car x)))) + + (define promise-done? cadr) + + (define promise-value cddr) + + (define (promise-update! new old) + (set-car! (cdr old) (promise-done? new)) + (set-cdr! (cdr old) (promise-value new)) + (set-car! new (cdr old))) + + (define (force promise) + (if (promise-done? promise) + (promise-value promise) + ((lambda (promise*) + (if (not (promise-done? promise)) + (promise-update! promise* promise)) + (force promise)) + ((promise-value promise))))) + + (define-syntax lazy + (er-macro-transformer + (lambda (form rename compare) + (list (rename 'promise) #f (list (rename 'lambda) '() (cadr form)))))) + + (define-syntax delay + (er-macro-transformer + (lambda (form rename compare) + (list (rename 'lazy) (list (rename 'promise) #t (cadr form)))))) + + (define (eager x) + (if (promise? x) x + (delay x))))) diff --git a/include/meevax/kernel/machine.hpp b/include/meevax/kernel/machine.hpp index 492ab9699..0d3d94120 100644 --- a/include/meevax/kernel/machine.hpp +++ b/include/meevax/kernel/machine.hpp @@ -333,6 +333,10 @@ inline namespace kernel * * ------------------------------------------------------------------- */ s = cons(cadr(c).template as().load(e), s); + if (car(s).is()) + { + std::cout << "warning: " << cadr(c) << " is unbound." << std::endl; + } c = cddr(c); goto decode; From 4fe54cb281cb597a36c637ddf4f78a6599b71b3f Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sat, 14 May 2022 23:34:21 +0900 Subject: [PATCH 19/49] Add experimental library `(scheme r5rs)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 67 +--------- basis/r4rs.ss | 187 ++++++--------------------- basis/r5rs.ss | 205 ++++++++++++++++++++++++++++++ basis/r7rs.ss | 2 +- include/meevax/kernel/basis.hpp | 1 + include/meevax/kernel/library.hpp | 7 +- include/meevax/kernel/machine.hpp | 4 +- src/kernel/basis.cpp | 1 + src/kernel/library.cpp | 4 +- src/library/meevax.cpp | 3 +- 12 files changed, 271 insertions(+), 218 deletions(-) create mode 100644 basis/r5rs.ss diff --git a/README.md b/README.md index d2624c33a..ade437844 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.989.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.990.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.989_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.990_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.989 +Meevax Lisp System, version 0.3.990 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 76152197a..c72e7a0b7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.989 +0.3.990 diff --git a/basis/overture.ss b/basis/overture.ss index a80c7978f..cc3d526ab 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -2,7 +2,8 @@ (import (meevax character) ; for digit-value (meevax number) ; for exact-integer? (meevax syntax) ; for quote-syntax - (scheme r4rs) + (meevax vector) ; for vector->string + (scheme r5rs) (srfi 211 explicit-renaming) ) (begin (define (unspecified) (if #f #f)) @@ -57,62 +58,8 @@ (define symbol=? eqv?) - (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html - - (define (dynamic-wind before thunk after) - (before) - (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) - ((lambda (result) ; TODO let-values - (set! %current-dynamic-extents (cdr %current-dynamic-extents)) - (after) - result) ; TODO (apply values result) - (thunk))) - - (define (call-with-current-continuation procedure) - (define (windup! from to) - (set! %current-dynamic-extents from) - (cond ((eq? from to)) - ((null? from) (windup! from (cdr to)) ((caar to))) - ((null? to) ((cdar from)) (windup! (cdr from) to)) - (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) - (set! %current-dynamic-extents to)) - (let ((current-dynamic-extents %current-dynamic-extents)) - (call-with-current-continuation! (lambda (k1) - (procedure (lambda (k2) - (windup! %current-dynamic-extents current-dynamic-extents) - (k1 k2))))))) - (define call/cc call-with-current-continuation) - ; (define values - ; (lambda xs - ; (call-with-current-continuation - ; (lambda (cc) - ; (apply cc xs))))) - - (define (list 'values)) ; Magic Token Trick - - (define (values? x) - (if (pair? x) - (eq? (car x) ) - #f)) - - (define (values . xs) - (if (if (null? xs) #f - (null? (cdr xs))) - (car xs) - (cons xs))) - - ; (define (call-with-values producer consumer) - ; (let-values ((xs (producer))) - ; (apply consumer xs))) - - (define (call-with-values producer consumer) - (let ((vs (producer))) - (if (values? vs) - (apply consumer (cdr vs)) - (consumer vs)))) - ) (export * + @@ -364,7 +311,7 @@ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) -(import (scheme r4rs) +(import (scheme r5rs) (scheme base) (scheme cxr) (srfi 211 explicit-renaming) @@ -408,10 +355,10 @@ ((output-port? x) (close-output-port x)) (else (unspecified)))) -(define (read . x) (%read (if (pair? x) (car x) (current-input-port)))) -(define (read-char . x) (%read-char (if (pair? x) (car x) (current-input-port)))) -(define (peek-char . x) (%peek-char (if (pair? x) (car x) (current-input-port)))) -(define (char-ready? . x) (%char-ready? (if (pair? x) (car x) (current-input-port)))) +(define (read . x) (%read (if (pair? x) (car x) (current-input-port)))) +(define (read-char . x) (%read-char (if (pair? x) (car x) (current-input-port)))) +(define (peek-char . x) (%peek-char (if (pair? x) (car x) (current-input-port)))) +(define (char-ready? . x) (read-ready? (if (pair? x) (car x) (current-input-port)))) (define (write-simple x . port) (%write-simple x (if (pair? port) (car port) (current-output-port)))) (define (write-char x . port) (put-char x (if (pair? port) (car port) (current-output-port)))) diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 8f5e26642..39bc78ada 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -2,7 +2,6 @@ (import (meevax character) (meevax control) (meevax equivalence) - (meevax inexact) (meevax list) (meevax number) (meevax pair) @@ -181,7 +180,7 @@ #f) (any-2+ f (cons x xs)))) - (define-syntax let + (define-syntax let ; named-let inessential (er-macro-transformer (lambda (form rename compare) (if (identifier? (cadr form)) @@ -191,37 +190,6 @@ `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) ,@(map cadr (cadr form))))))) - (define-syntax let* - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cadr form)) - `(,(rename 'let) () ,@(cddr form)) - `(,(rename 'let) (,(caadr form)) - (,(rename 'let*) ,(cdadr form) - ,@(cddr form))))))) - - (define-syntax do - (er-macro-transformer - (lambda (form rename compare) - (let ((body `(,(rename 'begin) ,@(cdddr form) - (,(rename 'rec) ,@(map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - (cadr form)))))) - `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) - (list (car x) - (cadr x))) - (cadr form)) - ,(if (null? (cdaddr form)) - `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) - (,(rename 'if) ,(rename 'it) - ,(rename 'it) - ,body)) - `(,(rename 'if) ,(caaddr form) - (,(rename 'begin) ,@(cdaddr form)) - ,body))))))) - (define (not x) (if x #f #t)) @@ -259,7 +227,7 @@ (+ k 1)) k))) - (define (list-tail x k) + (define (list-tail x k) ; inessential (let list-tail ((x x) (k k)) (if (zero? k) x @@ -417,59 +385,6 @@ (if (null? ns) n (rec (lcm-2 n (car ns)) (cdr ns)))))) - (define (numerator x) - (cond ((ratio? x) (car x)) - ((exact? x) x) - (else (inexact (numerator (exact x)))))) - - (define (denominator x) - (cond ((exact? x) (if (ratio? x) (cdr x) 1)) - ((integer? x) 1.0) - (else (inexact (denominator (exact x)))))) - - (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) - (define (sr x y return) - (let ((fx (floor x)) - (fy (floor y))) - (cond ((>= fx x) (return fx 1)) - ((= fx fy) (sr (/ (- y fy)) - (/ (- x fx)) - (lambda (n d) - (return (+ d (* fx n)) n)))) - (else (return (+ fx 1) 1))))) - (let ((return (if (negative? x) - (lambda (num den) - (/ (- num) den)) - /)) - (x (abs x)) - (e (abs e))) - (sr (- x e) (+ x e) return))) - - (define (make-rectangular x y) - (+ x (* y (sqrt -1)))) - - (define (make-polar radius phi) - (make-rectangular (* radius (cos phi)) - (* radius (sin phi)))) - - (define (real-part z) - (if (%complex? z) (car z) z)) - - (define (imag-part z) - (if (%complex? z) (cdr z) 0)) - - (define (magnitude z) - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) - - (define (angle z) - (atan (imag-part z) - (real-part z))) - - (define inexact->exact exact) - - (define exact->inexact inexact) - (define (char-compare x xs compare) (let rec ((compare compare) (lhs (char->integer x)) @@ -587,21 +502,6 @@ (define substring string-copy) - (define (string-fill! s c . o) - (let ((start (if (and (pair? o) - (exact-integer? (car o))) - (car o) - 0)) - (end (if (and (pair? o) - (pair? (cdr o)) - (exact-integer? (cadr o))) - (cadr o) - (string-length s)))) - (let rec ((k (- end 1))) - (if (<= start k) - (begin (string-set! s k c) - (rec (- k 1))))))) - (define (procedure? x) (or (closure? x) (continuation? x) @@ -617,23 +517,23 @@ (begin (apply map f x xs) (if #f #f)))) - (define (call-with-input-file path f) + (define (call-with-input-file path f) ; r7rs incompatible (values unsupported) (define (call-with-input-port port f) (let ((result (f port))) (close-input-port port) result)) (call-with-input-port (open-input-file path) f)) - (define (call-with-output-file path f) + (define (call-with-output-file path f) ; r7rs incompatible (values unsupported) (define (call-with-output-port port f) (let ((result (f port))) (close-output-port port) result)) (call-with-output-port (open-output-file path) f)) - (define current-input-port standard-input-port) + (define current-input-port standard-input-port) ; r7rs incompatible (current-input-port is standard input) - (define current-output-port standard-output-port) + (define current-output-port standard-output-port) ; r7rs incompatible (current-output-port is standard output) (define (read . port) (%read (if (pair? port) @@ -650,11 +550,6 @@ (car port) (current-input-port)))) - (define (char-ready? . port) - (%char-ready? (if (pair? port) - (car port) - (current-input-port)))) - (define (write x . port) (%write-simple x (if (pair? port) (car port) @@ -665,7 +560,7 @@ (car port) (current-output-port)))) - (define (write-string string . xs) + (define (write-string string . xs) ; TODO REMOVE! (case (length xs) ((0) (put-string string (current-output-port))) ((1) (put-string string (car xs))) @@ -689,11 +584,11 @@ case and or - let ; named-let inessential - let* ; inessential + let + ; let* ; inessential letrec begin - do ; inessential + ; do ; inessential ; delay ; inessential quasiquote define @@ -782,31 +677,31 @@ modulo gcd lcm - numerator ; inessential - denominator ; inessential + ; numerator ; inessential + ; denominator ; inessential floor ceiling truncate round - rationalize ; inessential - exp ; inessential - log ; inessential - sin ; inessential - cos ; inessential - tan ; inessential - asin ; inessential - acos ; inessential - atan ; inessential - sqrt ; inessential - expt ; inessential - make-rectangular ; inessential - make-polar ; inessential - real-part ; inessential - imag-part ; inessential - magnitude ; inessential - angle ; inessential - exact->inexact ; inessential - inexact->exact ; inessential + ; rationalize ; inessential + ; exp ; inessential + ; log ; inessential + ; sin ; inessential + ; cos ; inessential + ; tan ; inessential + ; asin ; inessential + ; acos ; inessential + ; atan ; inessential + ; sqrt ; inessential + ; expt ; inessential + ; make-rectangular ; inessential + ; make-polar ; inessential + ; real-part ; inessential + ; imag-part ; inessential + ; magnitude ; inessential + ; angle ; inessential + ; exact->inexact ; inessential + ; inexact->exact ; inessential number->string string->number char? @@ -849,8 +744,8 @@ string-append string->list list->string - string-copy ; inessential - string-fill! ; inessential + ; string-copy ; inessential + ; string-fill! ; inessential vector? make-vector vector @@ -859,19 +754,19 @@ vector-set! vector->list list->vector - vector-fill! ; inessential + ; vector-fill! ; inessential procedure? apply map for-each ; force ; inessential - call-with-current-continuation! ; call/cc! does not consider dynamic-wind. - call-with-input-file ; r7rs incompatible (values unsupported) - call-with-output-file ; r7rs incompatible (values unsupported) + call-with-current-continuation! + call-with-input-file + call-with-output-file input-port? output-port? - current-input-port ; r7rs incompatible (current-input-port is standard input) - current-output-port ; r7rs incompatible (current-output-port is standard output) + current-input-port + current-output-port ; with-input-from-file ; inessential ; with-output-to-file ; inessential open-input-file @@ -882,11 +777,11 @@ read-char peek-char eof-object? - char-ready? ; inessential + ; char-ready? ; inessential write display newline write-char - ; load + load ) ) diff --git a/basis/r5rs.ss b/basis/r5rs.ss new file mode 100644 index 000000000..d4e5e11d4 --- /dev/null +++ b/basis/r5rs.ss @@ -0,0 +1,205 @@ +(define-library (scheme r5rs) + (import + (meevax inexact) + (meevax number) ; for exact-integer? + (meevax port) ; for read-ready? + (meevax string) ; for string-copy + (meevax syntax) ; for let-syntax letrec-syntax + (meevax vector) ; for vector-fill! + (scheme r4rs) + (srfi 45) + (srfi 211 explicit-renaming) + ) + + (export quote lambda if set! cond case and or let let* letrec begin do delay + quasiquote let-syntax letrec-syntax syntax-rules define define-syntax + eqv? eq? equal? number? complex? real? rational? integer? exact? + inexact? = < > <= >= zero? positive? negative? odd? even? max min + * + - / abs quotient remainder modulo gcd lcm numerator denominator floor + ceiling truncate round rationalize exp log sin cos tan asin acos atan + sqrt expt make-rectangular make-polar real-part imag-part magnitude + angle exact->inexact inexact->exact number->string string->number not + boolean? pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar + caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar + cddadr cdddar cddddr null? list? list length append reverse list-tail + list-ref memq memv member assq assv assoc symbol? symbol->string + string->symbol char? char=? char? char<=? char>=? char-ci=? + char-ci? char-ci<=? char-ci>=? char-alphabetic? + char-numeric? char-whitespace? char-upper-case? char-lower-case? + char->integer integer->char char-upcase char-downcase string? + make-string string string-length string-ref string-set! string=? + string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? substring string-append + string->list list->string string-copy string-fill! vector? make-vector + vector vector-length vector-ref vector-set! vector->list list->vector + vector-fill! procedure? apply map for-each force + call-with-current-continuation values call-with-values dynamic-wind + eval scheme-report-environment null-environment + interaction-environment call-with-input-file call-with-output-file + input-port? output-port? current-input-port current-output-port + with-input-from-file with-output-to-file open-input-file + open-output-file close-input-port close-output-port read read-char + peek-char eof-object? char-ready? write display newline write-char + load) + + (begin (define-syntax let* + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cadr form)) + `(,(rename 'let) () ,@(cddr form)) + `(,(rename 'let) (,(caadr form)) + (,(rename 'let*) ,(cdadr form) + ,@(cddr form))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form rename compare) + (let ((body `(,(rename 'begin) ,@(cdddr form) + (,(rename 'rec) ,@(map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + (cadr form)))))) + `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) + (list (car x) + (cadr x))) + (cadr form)) + ,(if (null? (cdaddr form)) + `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) + (,(rename 'if) ,(rename 'it) + ,(rename 'it) + ,body)) + `(,(rename 'if) ,(caaddr form) + (,(rename 'begin) ,@(cdaddr form)) + ,body))))))) + + (define (numerator x) + (cond ((ratio? x) (car x)) + ((exact? x) x) + (else (inexact (numerator (exact x)))))) + + (define (denominator x) + (cond ((exact? x) (if (ratio? x) (cdr x) 1)) + ((integer? x) 1.0) + (else (inexact (denominator (exact x)))))) + + (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) + (define (sr x y return) + (let ((fx (floor x)) + (fy (floor y))) + (cond ((>= fx x) (return fx 1)) + ((= fx fy) (sr (/ (- y fy)) + (/ (- x fx)) + (lambda (n d) + (return (+ d (* fx n)) n)))) + (else (return (+ fx 1) 1))))) + (let ((return (if (negative? x) + (lambda (num den) + (/ (- num) den)) + /)) + (x (abs x)) + (e (abs e))) + (sr (- x e) (+ x e) return))) + + (define (make-rectangular x y) + (+ x (* y (sqrt -1)))) + + (define (make-polar radius phi) + (make-rectangular (* radius (cos phi)) + (* radius (sin phi)))) + + (define (real-part z) + (if (%complex? z) (car z) z)) + + (define (imag-part z) + (if (%complex? z) (cdr z) 0)) + + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + + (define (angle z) + (atan (imag-part z) + (real-part z))) + + (define exact->inexact inexact) + + (define inexact->exact exact) + + (define (string-fill! s c . o) + (let ((start (if (and (pair? o) + (exact-integer? (car o))) + (car o) + 0)) + (end (if (and (pair? o) + (pair? (cdr o)) + (exact-integer? (cadr o))) + (cadr o) + (string-length s)))) + (let rec ((k (- end 1))) + (if (<= start k) + (begin (string-set! s k c) + (rec (- k 1))))))) + + ; (define values + ; (lambda xs + ; (call-with-current-continuation + ; (lambda (cc) + ; (apply cc xs))))) + + (define (list 'values)) + + (define (values? x) + (if (pair? x) + (eq? (car x)) + #f)) + + (define (values . xs) + (if (if (null? xs) #f + (null? (cdr xs))) + (car xs) + (cons xs))) + + ; (define (call-with-values producer consumer) + ; (let-values ((xs (producer))) + ; (apply consumer xs))) + + (define (call-with-values producer consumer) + (let ((vs (producer))) + (if (values? vs) + (apply consumer (cdr vs)) + (consumer vs)))) + + (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html + + (define (dynamic-wind before thunk after) + (before) + (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) + ((lambda (result) ; TODO let-values + (set! %current-dynamic-extents (cdr %current-dynamic-extents)) + (after) + result) ; TODO (apply values result) + (thunk))) + + (define (call-with-current-continuation procedure) + (define (windup! from to) + (set! %current-dynamic-extents from) + (cond ((eq? from to)) + ((null? from) (windup! from (cdr to)) ((caar to))) + ((null? to) ((cdar from)) (windup! (cdr from) to)) + (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) + (set! %current-dynamic-extents to)) + (let ((current-dynamic-extents %current-dynamic-extents)) + (call-with-current-continuation! (lambda (k1) + (procedure (lambda (k2) + (windup! %current-dynamic-extents current-dynamic-extents) + (k1 k2))))))) + + (define (char-ready? . port) + (read-ready? (if (pair? port) + (car port) + (current-input-port)))) + + ) + ) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index a864b4dfc..c549e0119 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -185,7 +185,7 @@ ; ---- 4.2.5. Delayed evaluation ----------------------------------------------- -(define-library (scheme lazy) ; TEMPORARY +(define-library (scheme lazy) (import (scheme r4rs) (srfi 45)) (export delay delay-force force make-promise promise?) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index c6a32c510..b7922d092 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -31,6 +31,7 @@ inline namespace kernel extern string_view const overture; extern string_view const r4rs; + extern string_view const r5rs; extern string_view const r7rs; extern string_view const srfi_1; extern string_view const srfi_8; diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index f4b3af9e0..fedd88ca5 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -89,10 +89,13 @@ inline namespace kernel and car(export_spec).as().value == "rename") { } + else if (let const& binding = (*this)[export_spec]; binding.is()) + { + std::cout << "; warning: " << export_spec << " is exported but undefined." << std::endl; + } else { - assert(export_spec.is_also()); - destination.define(export_spec, (*this)[export_spec]); + destination.define(export_spec, binding); } } } diff --git a/include/meevax/kernel/machine.hpp b/include/meevax/kernel/machine.hpp index 0d3d94120..09c6a4cbd 100644 --- a/include/meevax/kernel/machine.hpp +++ b/include/meevax/kernel/machine.hpp @@ -333,9 +333,9 @@ inline namespace kernel * * ------------------------------------------------------------------- */ s = cons(cadr(c).template as().load(e), s); - if (car(s).is()) + if (car(s).template is()) { - std::cout << "warning: " << cadr(c) << " is unbound." << std::endl; + std::cout << "; warning: " << cadr(c) << " is unbound." << std::endl; } c = cddr(c); goto decode; diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index d26c923dc..edb51d44c 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -44,6 +44,7 @@ inline namespace kernel \ DEFINE_BINARY(overture); DEFINE_BINARY(r4rs); +DEFINE_BINARY(r5rs); DEFINE_BINARY(r7rs); DEFINE_BINARY(srfi_1); DEFINE_BINARY(srfi_8); diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 0da654178..6e7eb2479 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -810,7 +810,7 @@ inline namespace kernel return eof_object; }); - define("%char-ready?", [](let const& xs) + define("read-ready?", [](let const& xs) { return static_cast(car(xs).as()); }); @@ -878,7 +878,7 @@ inline namespace kernel "%peek-char", "eof-object?", "eof-object", - "%char-ready?", + "read-ready?", "%read-string", "put-char", "put-string", diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 178646543..b3862ae06 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -49,13 +49,14 @@ namespace meevax std::vector const codes { srfi_211, r4rs, + srfi_45, + r5rs, overture, srfi_8, srfi_1, srfi_23, srfi_34, srfi_39, - srfi_45, srfi_78, srfi_149, r7rs, From 2d4f1cc1f0f34c092b78832b180c2d8f9988de0e Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 00:06:02 +0900 Subject: [PATCH 20/49] Rename library `(scheme r4rs)` to `(scheme r4rs essential)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r4rs.ss | 249 ++++++----------------------------------------- basis/r5rs.ss | 9 +- basis/r7rs.ss | 2 +- basis/srfi-45.ss | 2 +- 6 files changed, 45 insertions(+), 225 deletions(-) diff --git a/README.md b/README.md index ade437844..8431bee20 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.990.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.991.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.990_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.991_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.990 +Meevax Lisp System, version 0.3.991 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index c72e7a0b7..8228d4adc 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.990 +0.3.991 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 39bc78ada..47bebd6ed 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -1,4 +1,4 @@ -(define-library (scheme r4rs) +(define-library (scheme r4rs essential) (import (meevax character) (meevax control) (meevax equivalence) @@ -13,6 +13,30 @@ (meevax write) (srfi 211 explicit-renaming)) + (export quote lambda if set! cond case and or let letrec begin quasiquote + define not boolean? eqv? eq? equal? pair? cons car cdr set-car! + set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar + cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar + cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list + length append reverse list-ref memq memv member assq assv assoc + symbol? symbol->string string->symbol number? complex? real? rational? + integer? exact? inexact? = < > <= >= zero? positive? negative? odd? + even? max min + * - / abs quotient remainder modulo gcd lcm floor + ceiling truncate round number->string string->number char? char=? + char? char<=? char>=? char-ci=? char-ci? char-ci<=? + char-ci>=? char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char->integer integer->char + char-upcase char-downcase string? make-string string string-length + string-ref string-set! string=? string? string<=? string>=? + string-ci=? string-ci? string-ci<=? string-ci>=? + substring string-append string->list list->string vector? make-vector + vector vector-length vector-ref vector-set! vector->list list->vector + procedure? apply map for-each call-with-current-continuation! + call-with-input-file call-with-output-file input-port? output-port? + current-input-port current-output-port open-input-file + open-output-file close-input-port close-output-port read read-char + peek-char eof-object? write display newline write-char load) + (begin (define (unspecified) (if #f #f)) (define (list . xs) xs) @@ -227,15 +251,13 @@ (+ k 1)) k))) - (define (list-tail x k) ; inessential - (let list-tail ((x x) - (k k)) - (if (zero? k) x - (list-tail (cdr x) - (- k 1))))) - (define (list-ref x k) - (car (list-tail x k))) + (let list-ref ((x x) + (k k)) + (if (zero? k) + (car x) + (list-ref (cdr x) + (- k 1))))) (define (member o x . c) (let ((compare (if (pair? c) (car c) equal?))) @@ -575,213 +597,4 @@ (apply write-char #\newline port)) ) - - (export quote - lambda - if - set! - cond - case - and - or - let - ; let* ; inessential - letrec - begin - ; do ; inessential - ; delay ; inessential - quasiquote - define - not - boolean? - eqv? - eq? - equal? - pair? - cons - car - cdr - set-car! - set-cdr! - caar - cadr - cdar - cddr - caaar - caadr - cadar - caddr - cdaar - cdadr - cddar - cdddr - caaaar - caaadr - caadar - caaddr - cadaar - cadadr - caddar - cadddr - cdaaar - cdaadr - cdadar - cdaddr - cddaar - cddadr - cdddar - cddddr - null? - list? - list - length - append - reverse - list-tail ; inessential - list-ref - memq - memv - member - assq - assv - assoc - symbol? - symbol->string - string->symbol - number? - complex? - real? - rational? - integer? - exact? - inexact? - = - < - > - <= - >= - zero? - positive? - negative? - odd? - even? - max - min - + - * - - - / - abs - quotient - remainder - modulo - gcd - lcm - ; numerator ; inessential - ; denominator ; inessential - floor - ceiling - truncate - round - ; rationalize ; inessential - ; exp ; inessential - ; log ; inessential - ; sin ; inessential - ; cos ; inessential - ; tan ; inessential - ; asin ; inessential - ; acos ; inessential - ; atan ; inessential - ; sqrt ; inessential - ; expt ; inessential - ; make-rectangular ; inessential - ; make-polar ; inessential - ; real-part ; inessential - ; imag-part ; inessential - ; magnitude ; inessential - ; angle ; inessential - ; exact->inexact ; inessential - ; inexact->exact ; inessential - number->string - string->number - char? - char=? - char? - char<=? - char>=? - char-ci=? - char-ci? - char-ci<=? - char-ci>=? - char-alphabetic? - char-numeric? - char-whitespace? - char-upper-case? - char-lower-case? - char->integer - integer->char - char-upcase - char-downcase - string? - make-string - string - string-length - string-ref - string-set! - string=? - string? - string<=? - string>=? - string-ci=? - string-ci? - string-ci<=? - string-ci>=? - substring - string-append - string->list - list->string - ; string-copy ; inessential - ; string-fill! ; inessential - vector? - make-vector - vector - vector-length - vector-ref - vector-set! - vector->list - list->vector - ; vector-fill! ; inessential - procedure? - apply - map - for-each - ; force ; inessential - call-with-current-continuation! - call-with-input-file - call-with-output-file - input-port? - output-port? - current-input-port - current-output-port - ; with-input-from-file ; inessential - ; with-output-to-file ; inessential - open-input-file - open-output-file - close-input-port - close-output-port - read - read-char - peek-char - eof-object? - ; char-ready? ; inessential - write - display - newline - write-char - load - ) ) diff --git a/basis/r5rs.ss b/basis/r5rs.ss index d4e5e11d4..edb36f2a5 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -6,7 +6,7 @@ (meevax string) ; for string-copy (meevax syntax) ; for let-syntax letrec-syntax (meevax vector) ; for vector-fill! - (scheme r4rs) + (scheme r4rs essential) (srfi 45) (srfi 211 explicit-renaming) ) @@ -127,6 +127,13 @@ (define inexact->exact exact) + (define (list-tail x k) + (let list-tail ((x x) + (k k)) + (if (zero? k) x + (list-tail (cdr x) + (- k 1))))) + (define (string-fill! s c . o) (let ((start (if (and (pair? o) (exact-integer? (car o))) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index c549e0119..40953e4b5 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -186,7 +186,7 @@ ; ---- 4.2.5. Delayed evaluation ----------------------------------------------- (define-library (scheme lazy) - (import (scheme r4rs) + (import (scheme r4rs essential) (srfi 45)) (export delay delay-force force make-promise promise?) (begin (define make-promise eager) diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index d67a52f8b..82be43528 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -1,5 +1,5 @@ (define-library (srfi 45) ; Based on r7rs reference implementation. - (import (scheme r4rs) + (import (scheme r4rs essential) (meevax syntax) ; for define-syntax (srfi 211 explicit-renaming)) From 10fd9a29231d93f3db508465f112fcefc996edb3 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 01:28:06 +0900 Subject: [PATCH 21/49] Update SRFI 39 to be R7RS style library `(srfi 39)` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- basis/r5rs.ss | 2 +- basis/srfi-39.ss | 100 ++++++++++++++++++++++------------------- src/library/meevax.cpp | 6 +-- 5 files changed, 62 insertions(+), 54 deletions(-) diff --git a/README.md b/README.md index 8431bee20..ddd4c7390 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.991.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.992.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.991_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.992_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.991 +Meevax Lisp System, version 0.3.992 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 8228d4adc..f5610fd18 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.991 +0.3.992 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index edb36f2a5..b545f2e26 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,5 +1,5 @@ (define-library (scheme r5rs) - (import + (import (meevax evaluate) (meevax inexact) (meevax number) ; for exact-integer? (meevax port) ; for read-ready? diff --git a/basis/srfi-39.ss b/basis/srfi-39.ss index 53b5c756c..ca2c097b6 100644 --- a/basis/srfi-39.ss +++ b/basis/srfi-39.ss @@ -18,56 +18,64 @@ ; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ; SOFTWARE. -(define make-parameter - (lambda (init . conv) - (let ((converter - (if (null? conv) (lambda (x) x) (car conv)))) - (let ((global-cell - (cons #f (converter init)))) - (letrec ((parameter - (lambda new-val - (let ((cell (dynamic-lookup parameter global-cell))) - (cond ((null? new-val) - (cdr cell)) - ((null? (cdr new-val)) - (set-cdr! cell (converter (car new-val)))) - (else ; this case is needed for parameterize - (converter (car new-val)))))))) - (set-car! global-cell parameter) - parameter))))) +(define-library (srfi 39) + (import (scheme r5rs) + (srfi 211 explicit-renaming)) -(define dynamic-bind - (lambda (parameters values body) - (let* ((old-local - (dynamic-env-local-get)) - (new-cells - (map (lambda (parameter value) - (cons parameter (parameter value #f))) - parameters - values)) - (new-local - (append new-cells old-local))) - (dynamic-wind - (lambda () (dynamic-env-local-set! new-local)) - body - (lambda () (dynamic-env-local-set! old-local)))))) + (export make-parameter parameterize) -(define dynamic-lookup - (lambda (parameter global-cell) - (or (assq parameter (dynamic-env-local-get)) - global-cell))) + (begin (define make-parameter + (lambda (init . conv) + (let ((converter (if (null? conv) + (lambda (x) x) + (car conv)))) + (let ((global-cell + (cons #f (converter init)))) + (letrec ((parameter + (lambda new-val + (let ((cell (dynamic-lookup parameter global-cell))) + (cond ((null? new-val) + (cdr cell)) + ((null? (cdr new-val)) + (set-cdr! cell (converter (car new-val)))) + (else ; this case is needed for parameterize + (converter (car new-val)))))))) + (set-car! global-cell parameter) + parameter))))) -(define dynamic-env-local '()) + (define dynamic-bind + (lambda (parameters values body) + (let* ((old-local + (dynamic-env-local-get)) + (new-cells + (map (lambda (parameter value) + (cons parameter (parameter value #f))) + parameters + values)) + (new-local + (append new-cells old-local))) + (dynamic-wind + (lambda () (dynamic-env-local-set! new-local)) + body + (lambda () (dynamic-env-local-set! old-local)))))) -(define (dynamic-env-local-get) dynamic-env-local) + (define dynamic-lookup + (lambda (parameter global-cell) + (or (assq parameter (dynamic-env-local-get)) + global-cell))) -(define (dynamic-env-local-set! new-env) - (set! dynamic-env-local new-env)) + (define dynamic-env-local '()) -(define-syntax parameterize - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form))) - (,(rename 'list) ,@(map cadr (cadr form))) - (,(rename 'lambda) () ,@(cddr form)))))) + (define (dynamic-env-local-get) dynamic-env-local) + (define (dynamic-env-local-set! new-env) + (set! dynamic-env-local new-env)) + + (define-syntax parameterize + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form))) + (,(rename 'list) ,@(map cadr (cadr form))) + (,(rename 'lambda) () ,@(cddr form)))))))) + +(import (srfi 39)) ; TEMPORARY diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index b3862ae06..227be6970 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -48,9 +48,9 @@ namespace meevax std::vector const codes { srfi_211, - r4rs, + r4rs, // ----------------------------------------------------------------- srfi_45, - r5rs, + r5rs, // ----------------------------------------------------------------- overture, srfi_8, srfi_1, @@ -59,7 +59,7 @@ namespace meevax srfi_39, srfi_78, srfi_149, - r7rs, + r7rs, // ----------------------------------------------------------------- }; for (auto const& code : codes) From 935121f23450388ef3d1a03d529191baade757af Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 02:14:38 +0900 Subject: [PATCH 22/49] Support library `(scheme r4rs)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r4rs-essential.ss | 597 ++++++++++++++++++++++++++ basis/r4rs.ss | 722 ++++++-------------------------- basis/r5rs.ss | 121 +----- include/meevax/kernel/basis.hpp | 1 + src/kernel/basis.cpp | 1 + src/library/meevax.cpp | 9 +- 8 files changed, 746 insertions(+), 713 deletions(-) create mode 100644 basis/r4rs-essential.ss diff --git a/README.md b/README.md index ddd4c7390..1950c5792 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.992.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.993.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.992_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.993_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.992 +Meevax Lisp System, version 0.3.993 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index f5610fd18..6bd3dee58 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.992 +0.3.993 diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss new file mode 100644 index 000000000..f4862815c --- /dev/null +++ b/basis/r4rs-essential.ss @@ -0,0 +1,597 @@ +(define-library (scheme r4rs essential) + (import (meevax character) + (meevax control) + (meevax equivalence) + (meevax list) + (meevax number) + (meevax pair) + (meevax port) + (meevax string) + (meevax symbol) + (meevax syntax) + (meevax vector) + (meevax write) + (srfi 211 explicit-renaming)) + + (export quote lambda if set! cond case and or let letrec begin quasiquote + define not boolean? eqv? eq? equal? pair? cons car cdr set-car! + set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar + cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar + cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list + length append reverse list-ref memq memv member assq assv assoc + symbol? symbol->string string->symbol number? complex? real? rational? + integer? exact? inexact? = < > <= >= zero? positive? negative? odd? + even? max min + * - / abs quotient remainder modulo gcd lcm floor + ceiling truncate round number->string string->number char? char=? + char? char<=? char>=? char-ci=? char-ci? char-ci<=? + char-ci>=? char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char->integer integer->char + char-upcase char-downcase string? make-string string string-length + string-ref string-set! string=? string? string<=? string>=? + string-ci=? string-ci? string-ci<=? string-ci>=? + substring string-append string->list list->string vector? make-vector + vector vector-length vector-ref vector-set! vector->list list->vector + procedure? apply map for-each call-with-current-continuation! + call-with-input-file call-with-output-file input-port? output-port? + current-input-port current-output-port open-input-file + open-output-file close-input-port close-output-port read read-char + peek-char eof-object? write display newline write-char load) + + (begin (define (unspecified) (if #f #f)) + + (define (list . xs) xs) + + (define-syntax cond + (er-macro-transformer + (lambda (form rename compare) + (if (null? (cdr form)) + (unspecified) + ((lambda (clause) + (if (compare (rename 'else) (car clause)) + (cons (rename 'begin) (cdr clause)) + (if (if (null? (cdr clause)) #t + (compare (rename '=>) (cadr clause))) + (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (if (null? (cdr clause)) + (rename 'result) + (list (caddr clause) + (rename 'result))) + (cons (rename 'cond) (cddr form)))) + (car clause)) + (list (rename 'if) + (car clause) + (cons (rename 'begin) (cdr clause)) + (cons (rename 'cond) (cddr form)))))) + (cadr form)))))) + + (define-syntax and + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form))) + ((null? (cddr form)) + (cadr form)) + (else (list (rename 'if) + (cadr form) + (cons (rename 'and) + (cddr form)) + #f)))))) + + (define-syntax or + (er-macro-transformer + (lambda (form rename compare) + (cond ((null? (cdr form)) #f) + ((null? (cddr form)) + (cadr form)) + (else (list (list (rename 'lambda) + (list (rename 'result)) + (list (rename 'if) + (rename 'result) + (rename 'result) + (cons (rename 'or) + (cddr form)))) + (cadr form))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + (define (expand x depth) + (cond ((pair? x) + (cond ((compare (rename 'unquote) (car x)) + (if (<= depth 0) + (cadr x) + (list (rename 'list) + (list (rename 'quote) 'unquote) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'unquote-splicing) (car x)) + (if (<= depth 0) + (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth)) + (list (rename 'list) + (list (rename 'quote) 'unquote-splicing) + (expand (cadr x) (- depth 1))))) + ((compare (rename 'quasiquote) (car x)) + (list (rename 'list) + (list (rename 'quote) 'quasiquote) + (expand (cadr x) (+ depth 1)))) + ((and (<= depth 0) + (pair? (car x)) + (compare (rename 'unquote-splicing) (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) + (cadar x) + (expand (cdr x) depth)))) + (else (list (rename 'cons) + (expand (car x) depth) + (expand (cdr x) depth))))) + ((vector? x) + (list (rename 'list->vector) + (expand (vector->list x) depth))) + ((or (identifier? x) + (null? x)) + (list (rename 'quote) x)) + (else x))) + (expand (cadr form) 0)))) + + (define (reverse xs) + (if (null? xs) '() + (append (reverse (cdr xs)) + (list (car xs))))) + + (define (map f x . xs) + (define (map-1 f x stack) + (if (pair? x) + (map-1 f + (cdr x) + (cons (f (car x)) stack)) + (reverse stack))) + (if (null? xs) + (map-1 f x '()) + (letrec ((map (lambda (f xs stack) + (if (every pair? xs) + (map f + (map-1 cdr xs '()) + (cons (apply f (map-1 car xs '())) stack)) + (reverse stack))))) + (map f (cons x xs) '())))) + + (define (apply f x . xs) + (define (apply-1 f xs) (f . xs)) + (if (null? xs) + (apply-1 f x) + ((lambda (rxs) + (apply-1 f + (append (reverse (cdr rxs)) + (car rxs)))) + (reverse (cons x xs))))) + + (define (every f x . xs) ; TODO REMOVE + (define (every-1 f x) + (if (null? (cdr x)) + (f (car x)) + (if (f (car x)) + (every-1 f (cdr x)) + #f))) + (if (null? xs) + (if (pair? x) + (every-1 f x) + #t) + (not (apply any + (lambda xs + (not (apply f xs))) + x xs)))) + + (define (any f x . xs) ; TODO REMOVE + (define (any-1 f x) + (if (pair? (cdr x)) + ((lambda (result) + (if result result (any-1 f (cdr x)))) + (f (car x))) + (f (car x)))) + (define (any-2+ f xs) + (if (every pair? xs) + ((lambda (result) + (if result result (any-2+ f (map cdr xs)))) + (apply f (map car xs))) + #f)) + (if (null? xs) + (if (pair? x) + (any-1 f x) + #f) + (any-2+ f (cons x xs)))) + + (define-syntax let ; named-let inessential + (er-macro-transformer + (lambda (form rename compare) + (if (identifier? (cadr form)) + `(,(rename 'letrec) ((,(cadr form) + (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) + (,(cadr form) ,@(map cadr (caddr form)))) + `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) + ,@(map cadr (cadr form))))))) + + (define (not x) + (if x #f #t)) + + (define (boolean? x) + (or (eqv? x #t) + (eqv? x #f))) + + (define (equal? x y) + (if (and (pair? x) + (pair? y)) + (and (equal? (car x) + (car y)) + (equal? (cdr x) + (cdr y))) + (eqv? x y))) + + (define (list? x) + (let list? ((x x) + (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) + (list? x lag))) + (null? x))) + (null? x)))) + + (define (length x) + (let length ((x x) + (k 0)) + (if (pair? x) + (length (cdr x) + (+ k 1)) + k))) + + (define (list-ref x k) + (let list-ref ((x x) + (k k)) + (if (zero? k) + (car x) + (list-ref (cdr x) + (- k 1))))) + + (define (member o x . c) + (let ((compare (if (pair? c) (car c) equal?))) + (let member ((x x)) + (and (pair? x) + (if (compare o (car x)) x + (member (cdr x))))))) + + (define (memq o x) + (member o x eq?)) + + (define (memv o x) + (member o x eqv?)) + + (define-syntax case + (er-macro-transformer + (lambda (form rename compare) + (define (body xs) + (cond ((null? xs) (rename 'result)) + ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) + (else `(,(rename 'begin) ,@xs)))) + (define (each-clause clauses) + (cond ((null? clauses) + (unspecified)) + ((compare (rename 'else) (caar clauses)) + (body (cdar clauses))) + ((and (pair? (caar clauses)) + (null? (cdaar clauses))) + `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) + (,(rename 'quote) ,(caaar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))) + (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) + (,(rename 'quote) ,(caar clauses))) + ,(body (cdar clauses)) + ,(each-clause (cdr clauses)))))) + `(,(rename 'let) ((,(rename 'result) ,(cadr form))) + ,(each-clause (cddr form)))))) + + (define (assoc key alist . compare) + (let ((compare (if (pair? compare) + (car compare) + equal?))) + (let assoc ((alist alist)) + (if (null? alist) #f + (if (compare key (caar alist)) + (car alist) + (assoc (cdr alist))))))) + + (define (assq key alist) + (assoc key alist eq?)) + + (define (assv key alist) + (assoc key alist eqv?)) + + (define (exact? z) + (define (exact-complex? x) + (and (%complex? x) + (exact? (real-part x)) + (exact? (imag-part x)))) + (or (exact-complex? z) + (ratio? z) + (exact-integer? z))) + + (define (inexact? z) + (define (inexact-complex? x) + (and (%complex? x) + (or (inexact? (real-part x)) + (inexact? (imag-part x))))) + (define (floating-point? z) + (or (single-float? z) + (double-float? z))) + (or (inexact-complex? z) + (floating-point? z))) + + (define (zero? n) + (= n 0)) + + (define (positive? n) + (> n 0)) + + (define (negative? n) + (< n 0)) + + (define (odd? n) + (not (even? n))) + + (define (even? n) + (= (remainder n 2) 0)) + + (define (max x . xs) + (define (max-aux x xs) + (if (null? xs) + (inexact x) + (max-aux (if (< x (car xs)) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (max-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (max-aux x xs)) + (else (rec (if (< x (car xs)) (car xs) x) + (cdr xs))))))) + + (define (min x . xs) + (define (min-aux x xs) + (if (null? xs) + (inexact x) + (min-aux (if (< (car xs) x) (car xs) x) + (cdr xs)))) + (if (inexact? x) + (min-aux x xs) + (let rec ((x x) (xs xs)) + (cond ((null? xs) x) + ((inexact? (car xs)) (min-aux x xs)) + (else (rec (if (< (car xs) x) (car xs) x) + (cdr xs))))))) + + (define (abs n) + (if (< n 0) (- n) n)) + + (define (quotient x y) + (truncate (/ x y))) + + (define remainder %) + + (define (modulo x y) + (% (+ y (% x y)) y)) + + (define (gcd . xs) + (define (gcd-2 a b) + (if (zero? b) + (abs a) + (gcd b (remainder a b)))) + (if (null? xs) 0 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (gcd-2 n (car ns)) (cdr ns)))))) + + (define (lcm . xs) + (define (lcm-2 a b) + (abs (quotient (* a b) (gcd a b)))) + (if (null? xs) 1 + (let rec ((n (car xs)) + (ns (cdr xs))) + (if (null? ns) n + (rec (lcm-2 n (car ns)) (cdr ns)))))) + + (define (char-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer x)) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (car xs)))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char=? x . xs) + (char-compare x xs =)) + + (define (char? x . xs) + (char-compare x xs >)) + + (define (char<=? x . xs) + (char-compare x xs <=)) + + (define (char>=? x . xs) + (char-compare x xs >=)) + + (define (char-ci-compare x xs compare) + (let rec ((compare compare) + (lhs (char->integer (char-downcase x))) + (xs xs)) + (if (null? xs) #t + (let ((rhs (char->integer (char-downcase (car xs))))) + (and (compare lhs rhs) + (rec compare rhs (cdr xs))))))) + + (define (char-ci=? x . xs) + (char-ci-compare x xs =)) + + (define (char-ci? x . xs) + (char-ci-compare x xs >)) + + (define (char-ci<=? x . xs) + (char-ci-compare x xs <=)) + + (define (char-ci>=? x . xs) + (char-ci-compare x xs >=)) + + (define (char-alphabetic? x) + (<= #,(char->integer #\a) + (char->integer (char-downcase x)) + #,(char->integer #\z))) + + (define (char-numeric? x) + (<= #,(char->integer #\0) + (char->integer x) + #,(char->integer #\9))) + + (define (char-whitespace? x) + (or (eqv? x #\space) + (eqv? x #\tab) + (eqv? x #\newline) + (eqv? x #\return))) + + (define (char-upper-case? x) + (<= #,(char->integer #\A) + (char->integer x) + #,(char->integer #\Z))) + + (define (char-lower-case? x) + (<= #,(char->integer #\a) + (char->integer x) + #,(char->integer #\z))) + + (define (char-downcase c) + (if (char-lower-case? c) c + (integer->char (+ (char->integer c) 32)))) + + (define (char-upcase c) + (if (char-upper-case? c) c + (integer->char (- (char->integer c) 32)))) + + (define (string . xs) + (list->string xs)) + + (define (string-map f x . xs) ; r7rs + (define (string-map-1 x) + (list->string + (map f (string->list x)))) + (define (string-map-n xs) + (map list->string + (map (lambda (c) (map f c)) + (map string->list xs)))) + (if (null? xs) + (string-map-1 x) + (string-map-n (cons x xs)))) + + (define (string-foldcase s) ; r7rs + (string-map char-downcase s)) + + (define (string-ci=? . xs) + (apply string=? (map string-foldcase xs))) + + (define (string-ci? . xs) + (apply string>? (map string-foldcase xs))) + + (define (string-ci<=? . xs) + (apply string<=? (map string-foldcase xs))) + + (define (string-ci>=? . xs) + (apply string>=? (map string-foldcase xs))) + + (define substring string-copy) + + (define (procedure? x) + (or (closure? x) + (continuation? x) + (foreign-function? x))) + + (define (for-each f x . xs) + (if (null? xs) + (letrec ((for-each (lambda (f x) + (if (pair? x) + (begin (f (car x)) + (for-each f (cdr x))))))) + (for-each f x)) + (begin (apply map f x xs) + (if #f #f)))) + + (define (call-with-input-file path f) ; r7rs incompatible (values unsupported) + (define (call-with-input-port port f) + (let ((result (f port))) + (close-input-port port) + result)) + (call-with-input-port (open-input-file path) f)) + + (define (call-with-output-file path f) ; r7rs incompatible (values unsupported) + (define (call-with-output-port port f) + (let ((result (f port))) + (close-output-port port) + result)) + (call-with-output-port (open-output-file path) f)) + + (define current-input-port standard-input-port) ; r7rs incompatible (current-input-port is standard input) + + (define current-output-port standard-output-port) ; r7rs incompatible (current-output-port is standard output) + + (define (read . port) + (%read (if (pair? port) + (car port) + (current-input-port)))) + + (define (read-char . port) + (%read-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (peek-char . port) + (%peek-char (if (pair? port) + (car port) + (current-input-port)))) + + (define (write x . port) + (%write-simple x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-char x . port) + (put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-string string . xs) ; TODO REMOVE! + (case (length xs) + ((0) (put-string string (current-output-port))) + ((1) (put-string string (car xs))) + (else (put-string (apply string-copy string (cadr xs)) (car xs))))) + + (define (display datum . port) + (cond ((char? datum) (apply write-char datum port)) + ((string? datum) (apply write-string datum port)) + (else (apply write datum port)))) + + (define (newline . port) + (apply write-char #\newline port)))) diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 47bebd6ed..52feea537 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -1,600 +1,150 @@ -(define-library (scheme r4rs essential) - (import (meevax character) - (meevax control) - (meevax equivalence) - (meevax list) - (meevax number) - (meevax pair) - (meevax port) - (meevax string) - (meevax symbol) - (meevax syntax) - (meevax vector) - (meevax write) +(define-library (scheme r4rs) + (import (meevax inexact) + (meevax number) ; for exact-integer? + (meevax port) ; for read-ready? + (meevax string) ; for string-copy + (meevax syntax) ; for define-syntax + (meevax vector) ; for vector-fill! + (scheme r4rs essential) + (srfi 45) (srfi 211 explicit-renaming)) - (export quote lambda if set! cond case and or let letrec begin quasiquote - define not boolean? eqv? eq? equal? pair? cons car cdr set-car! - set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar - cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar - cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? list? list - length append reverse list-ref memq memv member assq assv assoc - symbol? symbol->string string->symbol number? complex? real? rational? - integer? exact? inexact? = < > <= >= zero? positive? negative? odd? - even? max min + * - / abs quotient remainder modulo gcd lcm floor - ceiling truncate round number->string string->number char? char=? - char? char<=? char>=? char-ci=? char-ci? char-ci<=? + (export quote lambda if set! cond case and or let let* letrec begin do delay + quasiquote define not boolean? eqv? eq? equal? pair? cons car cdr + set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr cdaar + cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar + cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr null? + list? list length append reverse list-tail list-ref memq memv member + assq assv assoc symbol? symbol->string string->symbol number? complex? + real? rational? integer? exact? inexact? = < > <= >= zero? positive? + negative? odd? even? max min + * - / abs quotient remainder modulo + gcd lcm numerator denominator floor ceiling truncate round rationalize + exp log sin cos tan asin acos atan sqrt expt make-rectangular + make-polar real-part imag-part magnitude angle exact->inexact + inexact->exact number->string string->number char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace? char-upper-case? char-lower-case? char->integer integer->char char-upcase char-downcase string? make-string string string-length string-ref string-set! string=? string? string<=? string>=? string-ci=? string-ci? string-ci<=? string-ci>=? - substring string-append string->list list->string vector? make-vector - vector vector-length vector-ref vector-set! vector->list list->vector - procedure? apply map for-each call-with-current-continuation! + substring string-append string->list list->string string-copy + string-fill! vector? make-vector vector vector-length vector-ref + vector-set! vector->list list->vector vector-fill! procedure? apply + map for-each force call-with-current-continuation! call-with-input-file call-with-output-file input-port? output-port? - current-input-port current-output-port open-input-file - open-output-file close-input-port close-output-port read read-char - peek-char eof-object? write display newline write-char load) + current-input-port current-output-port with-input-from-file + with-output-to-file open-input-file open-output-file close-input-port + close-output-port read read-char peek-char eof-object? char-ready? + write display newline write-char load) - (begin (define (unspecified) (if #f #f)) - - (define (list . xs) xs) - - (define-syntax cond - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cdr form)) - (unspecified) - ((lambda (clause) - (if (compare (rename 'else) (car clause)) - (cons (rename 'begin) (cdr clause)) - (if (if (null? (cdr clause)) #t - (compare (rename '=>) (cadr clause))) - (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (if (null? (cdr clause)) - (rename 'result) - (list (caddr clause) - (rename 'result))) - (cons (rename 'cond) (cddr form)))) - (car clause)) - (list (rename 'if) - (car clause) - (cons (rename 'begin) (cdr clause)) - (cons (rename 'cond) (cddr form)))))) - (cadr form)))))) - - (define-syntax and - (er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form))) - ((null? (cddr form)) - (cadr form)) - (else (list (rename 'if) - (cadr form) - (cons (rename 'and) - (cddr form)) - #f)))))) - - (define-syntax or + (begin (define-syntax let* (er-macro-transformer (lambda (form rename compare) - (cond ((null? (cdr form)) #f) - ((null? (cddr form)) - (cadr form)) - (else (list (list (rename 'lambda) - (list (rename 'result)) - (list (rename 'if) - (rename 'result) - (rename 'result) - (cons (rename 'or) - (cddr form)))) - (cadr form))))))) + (if (null? (cadr form)) + `(,(rename 'let) () ,@(cddr form)) + `(,(rename 'let) (,(caadr form)) + (,(rename 'let*) ,(cdadr form) + ,@(cddr form))))))) - (define-syntax quasiquote + (define-syntax do (er-macro-transformer (lambda (form rename compare) - (define (expand x depth) - (cond ((pair? x) - (cond ((compare (rename 'unquote) (car x)) - (if (<= depth 0) - (cadr x) - (list (rename 'list) - (list (rename 'quote) 'unquote) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'unquote-splicing) (car x)) - (if (<= depth 0) - (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth)) - (list (rename 'list) - (list (rename 'quote) 'unquote-splicing) - (expand (cadr x) (- depth 1))))) - ((compare (rename 'quasiquote) (car x)) - (list (rename 'list) - (list (rename 'quote) 'quasiquote) - (expand (cadr x) (+ depth 1)))) - ((and (<= depth 0) - (pair? (car x)) - (compare (rename 'unquote-splicing) (caar x))) - (if (null? (cdr x)) - (cadar x) - (list (rename 'append) - (cadar x) - (expand (cdr x) depth)))) - (else (list (rename 'cons) - (expand (car x) depth) - (expand (cdr x) depth))))) - ((vector? x) - (list (rename 'list->vector) - (expand (vector->list x) depth))) - ((or (identifier? x) - (null? x)) - (list (rename 'quote) x)) - (else x))) - (expand (cadr form) 0)))) - - (define (reverse xs) - (if (null? xs) '() - (append (reverse (cdr xs)) - (list (car xs))))) - - (define (map f x . xs) - (define (map-1 f x stack) - (if (pair? x) - (map-1 f - (cdr x) - (cons (f (car x)) stack)) - (reverse stack))) - (if (null? xs) - (map-1 f x '()) - (letrec ((map (lambda (f xs stack) - (if (every pair? xs) - (map f - (map-1 cdr xs '()) - (cons (apply f (map-1 car xs '())) stack)) - (reverse stack))))) - (map f (cons x xs) '())))) - - (define (apply f x . xs) - (define (apply-1 f xs) (f . xs)) - (if (null? xs) - (apply-1 f x) - ((lambda (rxs) - (apply-1 f - (append (reverse (cdr rxs)) - (car rxs)))) - (reverse (cons x xs))))) - - (define (every f x . xs) ; TODO REMOVE - (define (every-1 f x) - (if (null? (cdr x)) - (f (car x)) - (if (f (car x)) - (every-1 f (cdr x)) - #f))) - (if (null? xs) - (if (pair? x) - (every-1 f x) - #t) - (not (apply any - (lambda xs - (not (apply f xs))) - x xs)))) - - (define (any f x . xs) ; TODO REMOVE - (define (any-1 f x) - (if (pair? (cdr x)) - ((lambda (result) - (if result result (any-1 f (cdr x)))) - (f (car x))) - (f (car x)))) - (define (any-2+ f xs) - (if (every pair? xs) - ((lambda (result) - (if result result (any-2+ f (map cdr xs)))) - (apply f (map car xs))) - #f)) - (if (null? xs) - (if (pair? x) - (any-1 f x) - #f) - (any-2+ f (cons x xs)))) - - (define-syntax let ; named-let inessential - (er-macro-transformer - (lambda (form rename compare) - (if (identifier? (cadr form)) - `(,(rename 'letrec) ((,(cadr form) - (,(rename 'lambda) ,(map car (caddr form)) ,@(cdddr form)))) - (,(cadr form) ,@(map cadr (caddr form)))) - `((,(rename 'lambda) ,(map car (cadr form)) ,@(cddr form)) - ,@(map cadr (cadr form))))))) - - (define (not x) - (if x #f #t)) - - (define (boolean? x) - (or (eqv? x #t) - (eqv? x #f))) - - (define (equal? x y) - (if (and (pair? x) - (pair? y)) - (and (equal? (car x) - (car y)) - (equal? (cdr x) - (cdr y))) - (eqv? x y))) - - (define (list? x) - (let list? ((x x) - (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) - (list? x lag))) - (null? x))) - (null? x)))) - - (define (length x) - (let length ((x x) - (k 0)) - (if (pair? x) - (length (cdr x) - (+ k 1)) - k))) - - (define (list-ref x k) - (let list-ref ((x x) - (k k)) - (if (zero? k) - (car x) - (list-ref (cdr x) - (- k 1))))) - - (define (member o x . c) - (let ((compare (if (pair? c) (car c) equal?))) - (let member ((x x)) - (and (pair? x) - (if (compare o (car x)) x - (member (cdr x))))))) - - (define (memq o x) - (member o x eq?)) - - (define (memv o x) - (member o x eqv?)) - - (define-syntax case - (er-macro-transformer - (lambda (form rename compare) - (define (body xs) - (cond ((null? xs) (rename 'result)) - ((compare (rename '=>) (car xs)) `(,(cadr xs) ,(rename 'result))) - (else `(,(rename 'begin) ,@xs)))) - (define (each-clause clauses) - (cond ((null? clauses) - (unspecified)) - ((compare (rename 'else) (caar clauses)) - (body (cdar clauses))) - ((and (pair? (caar clauses)) - (null? (cdaar clauses))) - `(,(rename 'if) (,(rename 'eqv?) ,(rename 'result) - (,(rename 'quote) ,(caaar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))) - (else `(,(rename 'if) (,(rename 'memv) ,(rename 'result) - (,(rename 'quote) ,(caar clauses))) - ,(body (cdar clauses)) - ,(each-clause (cdr clauses)))))) - `(,(rename 'let) ((,(rename 'result) ,(cadr form))) - ,(each-clause (cddr form)))))) - - (define (assoc key alist . compare) - (let ((compare (if (pair? compare) - (car compare) - equal?))) - (let assoc ((alist alist)) - (if (null? alist) #f - (if (compare key (caar alist)) - (car alist) - (assoc (cdr alist))))))) - - (define (assq key alist) - (assoc key alist eq?)) - - (define (assv key alist) - (assoc key alist eqv?)) - - (define (exact? z) - (define (exact-complex? x) - (and (%complex? x) - (exact? (real-part x)) - (exact? (imag-part x)))) - (or (exact-complex? z) - (ratio? z) - (exact-integer? z))) - - (define (inexact? z) - (define (inexact-complex? x) - (and (%complex? x) - (or (inexact? (real-part x)) - (inexact? (imag-part x))))) - (define (floating-point? z) - (or (single-float? z) - (double-float? z))) - (or (inexact-complex? z) - (floating-point? z))) - - (define (zero? n) - (= n 0)) - - (define (positive? n) - (> n 0)) - - (define (negative? n) - (< n 0)) - - (define (odd? n) - (not (even? n))) - - (define (even? n) - (= (remainder n 2) 0)) - - (define (max x . xs) - (define (max-aux x xs) - (if (null? xs) - (inexact x) - (max-aux (if (< x (car xs)) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (max-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (max-aux x xs)) - (else (rec (if (< x (car xs)) (car xs) x) - (cdr xs))))))) - - (define (min x . xs) - (define (min-aux x xs) - (if (null? xs) - (inexact x) - (min-aux (if (< (car xs) x) (car xs) x) - (cdr xs)))) - (if (inexact? x) - (min-aux x xs) - (let rec ((x x) (xs xs)) - (cond ((null? xs) x) - ((inexact? (car xs)) (min-aux x xs)) - (else (rec (if (< (car xs) x) (car xs) x) - (cdr xs))))))) - - (define (abs n) - (if (< n 0) (- n) n)) - - (define (quotient x y) - (truncate (/ x y))) - - (define remainder %) - - (define (modulo x y) - (% (+ y (% x y)) y)) - - (define (gcd . xs) - (define (gcd-2 a b) - (if (zero? b) - (abs a) - (gcd b (remainder a b)))) - (if (null? xs) 0 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (gcd-2 n (car ns)) (cdr ns)))))) - - (define (lcm . xs) - (define (lcm-2 a b) - (abs (quotient (* a b) (gcd a b)))) - (if (null? xs) 1 - (let rec ((n (car xs)) - (ns (cdr xs))) - (if (null? ns) n - (rec (lcm-2 n (car ns)) (cdr ns)))))) - - (define (char-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer x)) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (car xs)))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char=? x . xs) - (char-compare x xs =)) - - (define (char? x . xs) - (char-compare x xs >)) - - (define (char<=? x . xs) - (char-compare x xs <=)) - - (define (char>=? x . xs) - (char-compare x xs >=)) - - (define (char-ci-compare x xs compare) - (let rec ((compare compare) - (lhs (char->integer (char-downcase x))) - (xs xs)) - (if (null? xs) #t - (let ((rhs (char->integer (char-downcase (car xs))))) - (and (compare lhs rhs) - (rec compare rhs (cdr xs))))))) - - (define (char-ci=? x . xs) - (char-ci-compare x xs =)) - - (define (char-ci? x . xs) - (char-ci-compare x xs >)) - - (define (char-ci<=? x . xs) - (char-ci-compare x xs <=)) - - (define (char-ci>=? x . xs) - (char-ci-compare x xs >=)) - - (define (char-alphabetic? x) - (<= #,(char->integer #\a) - (char->integer (char-downcase x)) - #,(char->integer #\z))) - - (define (char-numeric? x) - (<= #,(char->integer #\0) - (char->integer x) - #,(char->integer #\9))) - - (define (char-whitespace? x) - (or (eqv? x #\space) - (eqv? x #\tab) - (eqv? x #\newline) - (eqv? x #\return))) - - (define (char-upper-case? x) - (<= #,(char->integer #\A) - (char->integer x) - #,(char->integer #\Z))) - - (define (char-lower-case? x) - (<= #,(char->integer #\a) - (char->integer x) - #,(char->integer #\z))) - - (define (char-downcase c) - (if (char-lower-case? c) c - (integer->char (+ (char->integer c) 32)))) - - (define (char-upcase c) - (if (char-upper-case? c) c - (integer->char (- (char->integer c) 32)))) - - (define (string . xs) - (list->string xs)) - - (define (string-map f x . xs) ; r7rs - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) - (if (null? xs) - (string-map-1 x) - (string-map-n (cons x xs)))) - - (define (string-foldcase s) ; r7rs - (string-map char-downcase s)) - - (define (string-ci=? . xs) - (apply string=? (map string-foldcase xs))) - - (define (string-ci? . xs) - (apply string>? (map string-foldcase xs))) - - (define (string-ci<=? . xs) - (apply string<=? (map string-foldcase xs))) - - (define (string-ci>=? . xs) - (apply string>=? (map string-foldcase xs))) - - (define substring string-copy) - - (define (procedure? x) - (or (closure? x) - (continuation? x) - (foreign-function? x))) - - (define (for-each f x . xs) - (if (null? xs) - (letrec ((for-each (lambda (f x) - (if (pair? x) - (begin (f (car x)) - (for-each f (cdr x))))))) - (for-each f x)) - (begin (apply map f x xs) - (if #f #f)))) - - (define (call-with-input-file path f) ; r7rs incompatible (values unsupported) - (define (call-with-input-port port f) - (let ((result (f port))) - (close-input-port port) - result)) - (call-with-input-port (open-input-file path) f)) - - (define (call-with-output-file path f) ; r7rs incompatible (values unsupported) - (define (call-with-output-port port f) - (let ((result (f port))) - (close-output-port port) - result)) - (call-with-output-port (open-output-file path) f)) - - (define current-input-port standard-input-port) ; r7rs incompatible (current-input-port is standard input) - - (define current-output-port standard-output-port) ; r7rs incompatible (current-output-port is standard output) - - (define (read . port) - (%read (if (pair? port) - (car port) - (current-input-port)))) - - (define (read-char . port) - (%read-char (if (pair? port) - (car port) - (current-input-port)))) - - (define (peek-char . port) - (%peek-char (if (pair? port) - (car port) - (current-input-port)))) - - (define (write x . port) - (%write-simple x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-char x . port) - (put-char x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-string string . xs) ; TODO REMOVE! - (case (length xs) - ((0) (put-string string (current-output-port))) - ((1) (put-string string (car xs))) - (else (put-string (apply string-copy string (cadr xs)) (car xs))))) - - (define (display datum . port) - (cond ((char? datum) (apply write-char datum port)) - ((string? datum) (apply write-string datum port)) - (else (apply write datum port)))) - - (define (newline . port) - (apply write-char #\newline port)) - - ) - ) + (let ((body `(,(rename 'begin) ,@(cdddr form) + (,(rename 'rec) ,@(map (lambda (x) + (if (pair? (cddr x)) + (caddr x) + (car x))) + (cadr form)))))) + `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) + (list (car x) + (cadr x))) + (cadr form)) + ,(if (null? (cdaddr form)) + `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) + (,(rename 'if) ,(rename 'it) + ,(rename 'it) + ,body)) + `(,(rename 'if) ,(caaddr form) + (,(rename 'begin) ,@(cdaddr form)) + ,body))))))) + + (define (numerator x) + (cond ((ratio? x) (car x)) + ((exact? x) x) + (else (inexact (numerator (exact x)))))) + + (define (denominator x) + (cond ((exact? x) (if (ratio? x) (cdr x) 1)) + ((integer? x) 1.0) + (else (inexact (denominator (exact x)))))) + + (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) + (define (sr x y return) + (let ((fx (floor x)) + (fy (floor y))) + (cond ((>= fx x) (return fx 1)) + ((= fx fy) (sr (/ (- y fy)) + (/ (- x fx)) + (lambda (n d) + (return (+ d (* fx n)) n)))) + (else (return (+ fx 1) 1))))) + (let ((return (if (negative? x) + (lambda (num den) + (/ (- num) den)) + /)) + (x (abs x)) + (e (abs e))) + (sr (- x e) (+ x e) return))) + + (define (make-rectangular x y) + (+ x (* y (sqrt -1)))) + + (define (make-polar radius phi) + (make-rectangular (* radius (cos phi)) + (* radius (sin phi)))) + + (define (real-part z) + (if (%complex? z) (car z) z)) + + (define (imag-part z) + (if (%complex? z) (cdr z) 0)) + + (define (magnitude z) + (sqrt (+ (square (real-part z)) + (square (imag-part z))))) + + (define (angle z) + (atan (imag-part z) + (real-part z))) + + (define exact->inexact inexact) + + (define inexact->exact exact) + + (define (list-tail x k) + (let list-tail ((x x) + (k k)) + (if (zero? k) x + (list-tail (cdr x) + (- k 1))))) + + (define (string-fill! s c . o) + (let ((start (if (and (pair? o) + (exact-integer? (car o))) + (car o) + 0)) + (end (if (and (pair? o) + (pair? (cdr o)) + (exact-integer? (cadr o))) + (cadr o) + (string-length s)))) + (let rec ((k (- end 1))) + (if (<= start k) + (begin (string-set! s k c) + (rec (- k 1))))))) + + (define (char-ready? . port) + (read-ready? (if (pair? port) + (car port) + (current-input-port)))))) diff --git a/basis/r5rs.ss b/basis/r5rs.ss index b545f2e26..c89b28b44 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,14 +1,7 @@ (define-library (scheme r5rs) (import (meevax evaluate) - (meevax inexact) - (meevax number) ; for exact-integer? - (meevax port) ; for read-ready? - (meevax string) ; for string-copy (meevax syntax) ; for let-syntax letrec-syntax - (meevax vector) ; for vector-fill! - (scheme r4rs essential) - (srfi 45) - (srfi 211 explicit-renaming) + (scheme r4rs) ) (export quote lambda if set! cond case and or let let* letrec begin do delay @@ -43,112 +36,7 @@ peek-char eof-object? char-ready? write display newline write-char load) - (begin (define-syntax let* - (er-macro-transformer - (lambda (form rename compare) - (if (null? (cadr form)) - `(,(rename 'let) () ,@(cddr form)) - `(,(rename 'let) (,(caadr form)) - (,(rename 'let*) ,(cdadr form) - ,@(cddr form))))))) - - (define-syntax do - (er-macro-transformer - (lambda (form rename compare) - (let ((body `(,(rename 'begin) ,@(cdddr form) - (,(rename 'rec) ,@(map (lambda (x) - (if (pair? (cddr x)) - (caddr x) - (car x))) - (cadr form)))))) - `(,(rename 'let) ,(rename 'rec) ,(map (lambda (x) - (list (car x) - (cadr x))) - (cadr form)) - ,(if (null? (cdaddr form)) - `(,(rename 'let) ((,(rename 'it) ,(caaddr form))) - (,(rename 'if) ,(rename 'it) - ,(rename 'it) - ,body)) - `(,(rename 'if) ,(caaddr form) - (,(rename 'begin) ,@(cdaddr form)) - ,body))))))) - - (define (numerator x) - (cond ((ratio? x) (car x)) - ((exact? x) x) - (else (inexact (numerator (exact x)))))) - - (define (denominator x) - (cond ((exact? x) (if (ratio? x) (cdr x) 1)) - ((integer? x) 1.0) - (else (inexact (denominator (exact x)))))) - - (define (rationalize x e) ; from Chibi-Scheme lib/scheme/extras.scm (https://ml.cddddr.org/scheme/msg01498.html) - (define (sr x y return) - (let ((fx (floor x)) - (fy (floor y))) - (cond ((>= fx x) (return fx 1)) - ((= fx fy) (sr (/ (- y fy)) - (/ (- x fx)) - (lambda (n d) - (return (+ d (* fx n)) n)))) - (else (return (+ fx 1) 1))))) - (let ((return (if (negative? x) - (lambda (num den) - (/ (- num) den)) - /)) - (x (abs x)) - (e (abs e))) - (sr (- x e) (+ x e) return))) - - (define (make-rectangular x y) - (+ x (* y (sqrt -1)))) - - (define (make-polar radius phi) - (make-rectangular (* radius (cos phi)) - (* radius (sin phi)))) - - (define (real-part z) - (if (%complex? z) (car z) z)) - - (define (imag-part z) - (if (%complex? z) (cdr z) 0)) - - (define (magnitude z) - (sqrt (+ (square (real-part z)) - (square (imag-part z))))) - - (define (angle z) - (atan (imag-part z) - (real-part z))) - - (define exact->inexact inexact) - - (define inexact->exact exact) - - (define (list-tail x k) - (let list-tail ((x x) - (k k)) - (if (zero? k) x - (list-tail (cdr x) - (- k 1))))) - - (define (string-fill! s c . o) - (let ((start (if (and (pair? o) - (exact-integer? (car o))) - (car o) - 0)) - (end (if (and (pair? o) - (pair? (cdr o)) - (exact-integer? (cadr o))) - (cadr o) - (string-length s)))) - (let rec ((k (- end 1))) - (if (<= start k) - (begin (string-set! s k c) - (rec (- k 1))))))) - + (begin ; (define values ; (lambda xs ; (call-with-current-continuation @@ -203,10 +91,5 @@ (windup! %current-dynamic-extents current-dynamic-extents) (k1 k2))))))) - (define (char-ready? . port) - (read-ready? (if (pair? port) - (car port) - (current-input-port)))) - ) ) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index b7922d092..7cb1e9834 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -31,6 +31,7 @@ inline namespace kernel extern string_view const overture; extern string_view const r4rs; + extern string_view const r4rs_essential; extern string_view const r5rs; extern string_view const r7rs; extern string_view const srfi_1; diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index edb51d44c..18484f5d1 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -44,6 +44,7 @@ inline namespace kernel \ DEFINE_BINARY(overture); DEFINE_BINARY(r4rs); +DEFINE_BINARY(r4rs_essential); DEFINE_BINARY(r5rs); DEFINE_BINARY(r7rs); DEFINE_BINARY(srfi_1); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 227be6970..c41d7baf7 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -48,9 +48,10 @@ namespace meevax std::vector const codes { srfi_211, - r4rs, // ----------------------------------------------------------------- - srfi_45, - r5rs, // ----------------------------------------------------------------- + r4rs_essential, + srfi_45, // (scheme lazy) + r4rs, + r5rs, overture, srfi_8, srfi_1, @@ -59,7 +60,7 @@ namespace meevax srfi_39, srfi_78, srfi_149, - r7rs, // ----------------------------------------------------------------- + r7rs, }; for (auto const& code : codes) From 0b3f519d2b6d5ff1c10be21a63955031a31abeda Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 02:26:59 +0900 Subject: [PATCH 23/49] Update library `(scheme r4rs)` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs.ss | 20 ++++++++++++++++++++ 3 files changed, 24 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 1950c5792..a13252306 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.993.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.994.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.993_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.994_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.993 +Meevax Lisp System, version 0.3.994 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 6bd3dee58..2436fbf14 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.993 +0.3.994 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 52feea537..5992654c3 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -144,6 +144,26 @@ (begin (string-set! s k c) (rec (- k 1))))))) + (define %current-input-port standard-input-port) + + (define (current-input-port) %current-input-port) + + (define %current-output-port standard-output-port) + + (define (current-output-port) %current-output-port) + + (define (with-input-from-file path thunk) + (let ((previous-input-port (current-input-port))) + (set! %current-input-port (open-input-file path)) + (thunk) + (set! %current-input-port previous-input-port))) + + (define (with-output-to-file path thunk) + (let ((previous-output-port (current-output-port))) + (set! %current-output-port (open-output-file path)) + (thunk) + (set! %current-output-port previous-output-port))) + (define (char-ready? . port) (read-ready? (if (pair? port) (car port) From 109ed9ab53fa31b9b8a9756ad6da227fc0f2dcfd Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 02:41:54 +0900 Subject: [PATCH 24/49] Update SRFI 149 to be R7RS style library `(srfi 149)` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/srfi-149.ss | 524 ++++++++++++++++++++++------------------- src/library/meevax.cpp | 2 +- 4 files changed, 288 insertions(+), 246 deletions(-) diff --git a/README.md b/README.md index a13252306..f820c34f7 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.994.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.995.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.994_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.995_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.994 +Meevax Lisp System, version 0.3.995 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 2436fbf14..fa87479fb 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.994 +0.3.995 diff --git a/basis/srfi-149.ss b/basis/srfi-149.ss index c8f0b3c16..f6a835e6a 100644 --- a/basis/srfi-149.ss +++ b/basis/srfi-149.ss @@ -23,251 +23,293 @@ ; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -(define %number->string number->string) +(define-library (srfi 149) + (import + (meevax macro) + (meevax syntax) ; for define-syntax + (scheme r4rs) + (srfi 211 explicit-renaming) + ) -(define (length* ls) - (let ((r (length ls))) - (cond ((positive? r) r) ; no worry - ((= r -2) #f) ; -2 is circular list so return #f - (else (let loop ((i 0) (ls ls)) - (if (not (pair? ls)) i - (loop (+ i 1) (cdr ls)))))))) + (export syntax-rules) -(define (cons-source kar kdr source) - (cons kar kdr)) + (begin (define %number->string number->string) -(define syntax-quote quote-syntax) + (define (length* ls) + (let ((r (length ls))) + (cond ((positive? r) r) ; no worry + ((= r -2) #f) ; -2 is circular list so return #f + (else (let loop ((i 0) (ls ls)) + (if (not (pair? ls)) i + (loop (+ i 1) (cdr ls)))))))) -(define strip-syntactic-closures identity) + (define (cons-source kar kdr source) + (cons kar kdr)) -(define (syntax-rules-transformer expr rename compare) - (let ((ellipsis-specified? (identifier? (cadr expr))) - (count 0) - (_er-macro-transformer (rename 'er-macro-transformer)) - (_lambda (rename 'lambda)) (_let (rename 'let)) - (_begin (rename 'begin)) (_if (rename 'if)) - (_and (rename 'and)) (_or (rename 'or)) - (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) - (_car (rename 'car)) (_cdr (rename 'cdr)) - (_cons (rename 'cons)) (_pair? (rename 'pair?)) - (_null? (rename 'null?)) (_expr (rename 'expr)) - (_rename (rename 'rename)) (_compare (rename 'compare)) - (_quote (rename 'syntax-quote)) (_apply (rename 'apply)) - (_append (rename 'append)) (_map (rename 'map)) - (_vector? (rename 'vector?)) (_list? (rename 'list?)) - (_len (rename'len)) (_length (rename 'length*)) - (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) - (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) - (_reverse (rename 'reverse)) - (_vector->list (rename 'vector->list)) - (_list->vector (rename 'list->vector)) - (_cons3 (rename 'cons-source)) - (_underscore (rename '_))) - (define ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) - (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) - (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) - (define (next-symbol s) - (set! count (+ count 1)) - (rename (string->symbol (string-append s (%number->string count))))) - (define (expand-pattern pat tmpl) - (let lp ((p (cdr pat)) - (x (list _cdr _expr)) - (dim 0) - (vars '()) - (k (lambda (vars) - (list _cons (expand-template tmpl vars) #f)))) - (let ((v (next-symbol "v."))) - (list - _let (list (list v x)) - (cond - ((identifier? p) - (if (any (lambda (l) (compare p l)) lits) - (list _and - (list _compare v (list _rename (list _quote p))) - (k vars)) - (if (compare p _underscore) - (k vars) - (list _let (list (list p v)) (k (cons (cons p dim) vars)))))) - ((ellipsis? p) - (cond - ((not (null? (cdr (cdr p)))) - (cond - ((any (lambda (x) (and (identifier? x) (compare x ellipsis))) - (cddr p)) - (error "multiple ellipses" p)) - (else - (let ((len (length* (cdr (cdr p)))) - (_lp (next-symbol "lp."))) - `(,_let ((,_len (,_length ,v))) - (,_and (,_>= ,_len ,len) - (,_let ,_lp ((,_ls ,v) - (,_i (,_- ,_len ,len)) - (,_res (,_quote ()))) - (,_if (,_>= 0 ,_i) - ,(lp `(,(cddr p) - (,(car p) ,(car (cdr p)))) - `(,_cons ,_ls - (,_cons (,_reverse ,_res) - (,_quote ()))) - dim - vars - k) - (,_lp (,_cdr ,_ls) - (,_- ,_i 1) - (,_cons3 (,_car ,_ls) - ,_res - ,_ls)))))))))) - ((identifier? (car p)) - (list _and (list _list? v) - (list _let (list (list (car p) v)) - (k (cons (cons (car p) (+ 1 dim)) vars))))) - (else - (let* ((w (next-symbol "w.")) - (_lp (next-symbol "lp.")) - (new-vars (all-vars (car p) (+ dim 1))) - (ls-vars (map (lambda (x) - (next-symbol - (string-append - (symbol->string - (identifier->symbol (car x))) - "-ls"))) - new-vars)) - (once - (lp (car p) (list _car w) (+ dim 1) '() - (lambda (_) - (cons - _lp - (cons - (list _cdr w) - (map (lambda (x l) - (list _cons (car x) l)) - new-vars - ls-vars))))))) + (define syntax-quote quote-syntax) + + (define (strip-syntactic-closures x) x) + + (define (any f x . xs) ; TODO REMOVE + (define (any-1 f x) + (if (pair? (cdr x)) + ((lambda (result) + (if result result (any-1 f (cdr x)))) + (f (car x))) + (f (car x)))) + (define (any-2+ f xs) + (if (every pair? xs) + ((lambda (result) + (if result result (any-2+ f (map cdr xs)))) + (apply f (map car xs))) + #f)) + (if (null? xs) + (if (pair? x) + (any-1 f x) + #f) + (any-2+ f (cons x xs)))) + + (define (find pred list) + (cond ((find-tail pred list) => car) + (else #f))) + + (define (find-tail pred list) + (let lp ((list list)) + (and (not (null? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + ) + + (begin (define (syntax-rules-transformer expr rename compare) + (let ((ellipsis-specified? (identifier? (cadr expr))) + (count 0) + (_er-macro-transformer (rename 'er-macro-transformer)) + (_lambda (rename 'lambda)) (_let (rename 'let)) + (_begin (rename 'begin)) (_if (rename 'if)) + (_and (rename 'and)) (_or (rename 'or)) + (_eq? (rename 'eq?)) (_equal? (rename 'equal?)) + (_car (rename 'car)) (_cdr (rename 'cdr)) + (_cons (rename 'cons)) (_pair? (rename 'pair?)) + (_null? (rename 'null?)) (_expr (rename 'expr)) + (_rename (rename 'rename)) (_compare (rename 'compare)) + (_quote (rename 'syntax-quote)) (_apply (rename 'apply)) + (_append (rename 'append)) (_map (rename 'map)) + (_vector? (rename 'vector?)) (_list? (rename 'list?)) + (_len (rename'len)) (_length (rename 'length*)) + (_- (rename '-)) (_>= (rename '>=)) (_error (rename 'error)) + (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i)) + (_reverse (rename 'reverse)) + (_vector->list (rename 'vector->list)) + (_list->vector (rename 'list->vector)) + (_cons3 (rename 'cons-source)) + (_underscore (rename '_))) + (define ellipsis (if ellipsis-specified? (cadr expr) (rename '...))) + (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr))) + (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr))) + (define (next-symbol s) + (set! count (+ count 1)) + (rename (string->symbol (string-append s (%number->string count))))) + (define (expand-pattern pat tmpl) + (let lp ((p (cdr pat)) + (x (list _cdr _expr)) + (dim 0) + (vars '()) + (k (lambda (vars) + (list _cons (expand-template tmpl vars) #f)))) + (let ((v (next-symbol "v."))) + (list + _let (list (list v x)) + (cond + ((identifier? p) + (if (any (lambda (l) (compare p l)) lits) + (list _and + (list _compare v (list _rename (list _quote p))) + (k vars)) + (if (compare p _underscore) + (k vars) + (list _let (list (list p v)) (k (cons (cons p dim) vars)))))) + ((ellipsis? p) + (cond + ((not (null? (cdr (cdr p)))) + (cond + ((any (lambda (x) (and (identifier? x) (compare x ellipsis))) + (cddr p)) + (error "multiple ellipses" p)) + (else + (let ((len (length* (cdr (cdr p)))) + (_lp (next-symbol "lp."))) + `(,_let ((,_len (,_length ,v))) + (,_and (,_>= ,_len ,len) + (,_let ,_lp ((,_ls ,v) + (,_i (,_- ,_len ,len)) + (,_res (,_quote ()))) + (,_if (,_>= 0 ,_i) + ,(lp `(,(cddr p) + (,(car p) ,(car (cdr p)))) + `(,_cons ,_ls + (,_cons (,_reverse ,_res) + (,_quote ()))) + dim + vars + k) + (,_lp (,_cdr ,_ls) + (,_- ,_i 1) + (,_cons3 (,_car ,_ls) + ,_res + ,_ls)))))))))) + ((identifier? (car p)) + (list _and (list _list? v) + (list _let (list (list (car p) v)) + (k (cons (cons (car p) (+ 1 dim)) vars))))) + (else + (let* ((w (next-symbol "w.")) + (_lp (next-symbol "lp.")) + (new-vars (all-vars (car p) (+ dim 1))) + (ls-vars (map (lambda (x) + (next-symbol + (string-append + (symbol->string + (identifier->symbol (car x))) + "-ls"))) + new-vars)) + (once + (lp (car p) (list _car w) (+ dim 1) '() + (lambda (_) + (cons + _lp + (cons + (list _cdr w) + (map (lambda (x l) + (list _cons (car x) l)) + new-vars + ls-vars))))))) + (list + _let + _lp (cons (list w v) + (map (lambda (x) (list x (list _quote '()))) ls-vars)) + (list _if (list _null? w) + (list _let (map (lambda (x l) + (list (car x) (list _reverse l))) + new-vars + ls-vars) + (k (append new-vars vars))) + (list _and (list _pair? w) once))))))) + ((pair? p) + (list _and (list _pair? v) + (lp (car p) + (list _car v) + dim + vars + (lambda (vars) + (lp (cdr p) (list _cdr v) dim vars k))))) + ((vector? p) + (list _and + (list _vector? v) + (lp (vector->list p) (list _vector->list v) dim vars k))) + ((null? p) (list _and (list _null? v) (k vars))) + (else (list _and (list _equal? v p) (k vars)))))))) + (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x)))) + (define (ellipsis? x) + (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x)))) + (define (ellipsis-depth x) + (if (ellipsis? x) + (+ 1 (ellipsis-depth (cdr x))) + 0)) + (define (ellipsis-tail x) + (if (ellipsis? x) + (ellipsis-tail (cdr x)) + (cdr x))) + (define (all-vars x dim) + (let lp ((x x) (dim dim) (vars '())) + (cond ((identifier? x) + (if (any (lambda (lit) (compare x lit)) lits) + vars + (cons (cons x dim) vars))) + ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars))) + ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) + ((vector? x) (lp (vector->list x) dim vars)) + (else vars)))) + (define (free-vars x vars dim) + (let lp ((x x) (free '())) + (cond + ((identifier? x) + (if (and (not (memq x free)) + (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) + (else #f))) + (cons x free) + free)) + ((pair? x) (lp (car x) (lp (cdr x) free))) + ((vector? x) (lp (vector->list x) free)) + (else free)))) + (define (expand-template tmpl vars) + (let lp ((t tmpl) (dim 0)) + (cond + ((identifier? t) + (cond + ((find (lambda (v) (eq? t (car v))) vars) + => (lambda (cell) + (if (<= (cdr cell) dim) + t + (error "too few ...'s")))) + (else + (list _rename (list _quote t))))) + ((pair? t) + (cond + ((ellipsis-escape? t) + (list _quote + (if (pair? (cdr t)) + (if (pair? (cddr t)) (cddr t) (cadr t)) + (cdr t)))) + ((ellipsis? t) + (let* ((depth (ellipsis-depth t)) + (ell-dim (+ dim depth)) + (ell-vars (free-vars (car t) vars ell-dim))) + (cond + ((null? ell-vars) + (error "too many ...'s")) + ((and (null? (cdr (cdr t))) (identifier? (car t))) + ;; shortcut for (var ...) + (lp (car t) ell-dim)) + (else + (let* ((once (lp (car t) ell-dim)) + (nest (if (and (null? (cdr ell-vars)) + (identifier? once) + (eq? once (car vars))) + once ;; shortcut + (cons _map + (cons (list _lambda ell-vars once) + ell-vars)))) + (many (do ((d depth (- d 1)) + (many nest + (list _apply _append many))) + ((= d 1) many)))) + (if (null? (ellipsis-tail t)) + many ;; shortcut + (list _append many (lp (ellipsis-tail t) dim)))))))) + (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t))))) + ((vector? t) (list _list->vector (lp (vector->list t) dim))) + ((null? t) (list _quote '())) + (else t)))) + (list + _er-macro-transformer + (list _lambda (list _expr _rename _compare) (list - _let - _lp (cons (list w v) - (map (lambda (x) (list x (list _quote '()))) ls-vars)) - (list _if (list _null? w) - (list _let (map (lambda (x l) - (list (car x) (list _reverse l))) - new-vars - ls-vars) - (k (append new-vars vars))) - (list _and (list _pair? w) once))))))) - ((pair? p) - (list _and (list _pair? v) - (lp (car p) - (list _car v) - dim - vars - (lambda (vars) - (lp (cdr p) (list _cdr v) dim vars k))))) - ((vector? p) - (list _and - (list _vector? v) - (lp (vector->list p) (list _vector->list v) dim vars k))) - ((null? p) (list _and (list _null? v) (k vars))) - (else (list _and (list _equal? v p) (k vars)))))))) - (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x)))) - (define (ellipsis? x) - (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x)))) - (define (ellipsis-depth x) - (if (ellipsis? x) - (+ 1 (ellipsis-depth (cdr x))) - 0)) - (define (ellipsis-tail x) - (if (ellipsis? x) - (ellipsis-tail (cdr x)) - (cdr x))) - (define (all-vars x dim) - (let lp ((x x) (dim dim) (vars '())) - (cond ((identifier? x) - (if (any (lambda (lit) (compare x lit)) lits) - vars - (cons (cons x dim) vars))) - ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars))) - ((pair? x) (lp (car x) dim (lp (cdr x) dim vars))) - ((vector? x) (lp (vector->list x) dim vars)) - (else vars)))) - (define (free-vars x vars dim) - (let lp ((x x) (free '())) - (cond - ((identifier? x) - (if (and (not (memq x free)) - (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim))) - (else #f))) - (cons x free) - free)) - ((pair? x) (lp (car x) (lp (cdr x) free))) - ((vector? x) (lp (vector->list x) free)) - (else free)))) - (define (expand-template tmpl vars) - (let lp ((t tmpl) (dim 0)) - (cond - ((identifier? t) - (cond - ((find (lambda (v) (eq? t (car v))) vars) - => (lambda (cell) - (if (<= (cdr cell) dim) - t - (error "too few ...'s")))) - (else - (list _rename (list _quote t))))) - ((pair? t) - (cond - ((ellipsis-escape? t) - (list _quote - (if (pair? (cdr t)) - (if (pair? (cddr t)) (cddr t) (cadr t)) - (cdr t)))) - ((ellipsis? t) - (let* ((depth (ellipsis-depth t)) - (ell-dim (+ dim depth)) - (ell-vars (free-vars (car t) vars ell-dim))) - (cond - ((null? ell-vars) - (error "too many ...'s")) - ((and (null? (cdr (cdr t))) (identifier? (car t))) - ;; shortcut for (var ...) - (lp (car t) ell-dim)) - (else - (let* ((once (lp (car t) ell-dim)) - (nest (if (and (null? (cdr ell-vars)) - (identifier? once) - (eq? once (car vars))) - once ;; shortcut - (cons _map - (cons (list _lambda ell-vars once) - ell-vars)))) - (many (do ((d depth (- d 1)) - (many nest - (list _apply _append many))) - ((= d 1) many)))) - (if (null? (ellipsis-tail t)) - many ;; shortcut - (list _append many (lp (ellipsis-tail t) dim)))))))) - (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t))))) - ((vector? t) (list _list->vector (lp (vector->list t) dim))) - ((null? t) (list _quote '())) - (else t)))) - (list - _er-macro-transformer - (list _lambda (list _expr _rename _compare) - (list - _car - (cons - _or - (append - (map - (lambda (clause) (expand-pattern (car clause) (cadr clause))) - forms) - (list - (list _cons - (list _error "no expansion for" - (list (rename 'strip-syntactic-closures) _expr)) - #f))))))))) + _car + (cons + _or + (append + (map + (lambda (clause) (expand-pattern (car clause) (cadr clause))) + forms) + (list + (list _cons + (list _error "no expansion for" + (list (rename 'strip-syntactic-closures) _expr)) + #f))))))))) + + (define-syntax syntax-rules + (er-macro-transformer + (lambda (form rename compare) + (syntax-rules-transformer form rename compare)))))) -(define-syntax syntax-rules - (er-macro-transformer - (lambda (form rename compare) - (syntax-rules-transformer form rename compare)))) +(import (srfi 149)) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index c41d7baf7..7348e5c81 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -51,6 +51,7 @@ namespace meevax r4rs_essential, srfi_45, // (scheme lazy) r4rs, + srfi_149, r5rs, overture, srfi_8, @@ -59,7 +60,6 @@ namespace meevax srfi_34, srfi_39, srfi_78, - srfi_149, r7rs, }; From 4069791308f88ff74787acf1acb9ef5e6fd6d6ab Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 02:46:11 +0900 Subject: [PATCH 25/49] Update library `(scheme r5rs)` to import `(srfi 149)` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r5rs.ss | 1 + basis/srfi-149.ss | 5 +---- 4 files changed, 6 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index f820c34f7..d6669c738 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.995.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.996.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.995_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.996_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.995 +Meevax Lisp System, version 0.3.996 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index fa87479fb..727af32ed 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.995 +0.3.996 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index c89b28b44..7ed6cd8a9 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -2,6 +2,7 @@ (import (meevax evaluate) (meevax syntax) ; for let-syntax letrec-syntax (scheme r4rs) + (srfi 149) ) (export quote lambda if set! cond case and or let let* letrec begin do delay diff --git a/basis/srfi-149.ss b/basis/srfi-149.ss index f6a835e6a..b298c3eb5 100644 --- a/basis/srfi-149.ss +++ b/basis/srfi-149.ss @@ -24,8 +24,7 @@ ; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define-library (srfi 149) - (import - (meevax macro) + (import (meevax macro) (meevax syntax) ; for define-syntax (scheme r4rs) (srfi 211 explicit-renaming) @@ -311,5 +310,3 @@ (er-macro-transformer (lambda (form rename compare) (syntax-rules-transformer form rename compare)))))) - -(import (srfi 149)) From 9faf823908750472878177b7cb36b6a69a3cd724 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 13:50:58 +0900 Subject: [PATCH 26/49] Support procedure `environment` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r5rs.ss | 17 ++++++++++++----- include/meevax/kernel/library.hpp | 1 + src/kernel/environment.cpp | 8 ++++++-- src/kernel/library.cpp | 20 +++++++++++++++++++- src/library/meevax.cpp | 2 +- test/r5rs.ss | 2 +- 8 files changed, 44 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index d6669c738..b50e40054 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.996.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.998.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.996_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.998_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.996 +Meevax Lisp System, version 0.3.998 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 727af32ed..2294f408a 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.996 +0.3.998 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index 7ed6cd8a9..7249610c0 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,9 +1,9 @@ (define-library (scheme r5rs) - (import (meevax evaluate) + (import (meevax environment) + (meevax evaluate) (meevax syntax) ; for let-syntax letrec-syntax (scheme r4rs) - (srfi 149) - ) + (srfi 149)) (export quote lambda if set! cond case and or let let* letrec begin do delay quasiquote let-syntax letrec-syntax syntax-rules define define-syntax @@ -37,8 +37,7 @@ peek-char eof-object? char-ready? write display newline write-char load) - (begin - ; (define values + (begin ; (define values ; (lambda xs ; (call-with-current-continuation ; (lambda (cc) @@ -92,5 +91,13 @@ (windup! %current-dynamic-extents current-dynamic-extents) (k1 k2))))))) + (define (scheme-report-environment version) + (environment `(scheme ,(string->symbol (string-append "r" (number->string version) "rs"))))) + + (define (null-environment version) + (environment `(only `(scheme ,(string->symbol (string-append "r" (number->string version) "rs"))) + quote lambda if set! cond case and or let let* + letrec begin do delay quasiquote let-syntax + letrec-syntax syntax-rules define define-syntax))) ) ) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index fedd88ca5..d0ac1cafb 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -117,6 +117,7 @@ inline namespace kernel DEFINE_BASIS_LIBRARY(character); DEFINE_BASIS_LIBRARY(context); DEFINE_BASIS_LIBRARY(control); + DEFINE_BASIS_LIBRARY(environment); DEFINE_BASIS_LIBRARY(equivalence); DEFINE_BASIS_LIBRARY(evaluate); DEFINE_BASIS_LIBRARY(exception); diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index ab9c7327d..6bbe553f2 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -144,9 +144,13 @@ inline namespace kernel else if (car(import_set).as().value == "rename") { } - else // + else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) { - libraries.at(lexical_cast(import_set)).export_to(*this); + std::get<1>(*iter).export_to(*this); + } + else + { + throw error(make("no such library"), import_set); } } diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 6e7eb2479..36bc7c74b 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -50,6 +50,23 @@ inline namespace kernel "set!"); } + library::library(environment_library_t) + { + define("environment", [](let const& xs) + { + let const e = make(); + + for (let const& x : xs) + { + e.as().import(x); + } + + return e; + }); + + export_("environment"); + } + library::library(equivalence_library_t) { define("eq?", [](let const& xs) { return eq (car(xs), cadr(xs)); }); @@ -889,7 +906,7 @@ inline namespace kernel { define("eval", [](let const& xs) { - return cadr(xs).as().mac_env.as().evaluate(car(xs)); // DIRTY HACK! + return cadr(xs).as().evaluate(car(xs)); }); export_("eval"); @@ -1065,6 +1082,7 @@ inline namespace kernel define_library("(meevax character)", character_library); define_library("(meevax context)", context_library); define_library("(meevax control)", control_library); + define_library("(meevax environment)", environment_library); define_library("(meevax equivalence)", equivalence_library); define_library("(meevax evaluate)", evaluate_library); define_library("(meevax exception)", exception_library); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 7348e5c81..61b1c5db5 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -49,7 +49,7 @@ namespace meevax std::vector const codes { srfi_211, r4rs_essential, - srfi_45, // (scheme lazy) + srfi_45, r4rs, srfi_149, r5rs, diff --git a/test/r5rs.ss b/test/r5rs.ss index e81be2d99..62f965465 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -864,7 +864,7 @@ ; ---- 6.5 --------------------------------------------------------------------- -; (check (eval '(* 7 3) (scheme-report-environment 5)) => 21) ; ERROR +(check (eval '(* 7 3) (scheme-report-environment 5)) => 21) ; (check (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) ; (f + 10)) => 20) ; ERROR From 028c94acf2453dadd6fed6bfc1f28c2781db7824 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 14:33:54 +0900 Subject: [PATCH 27/49] Update export declaration to support export-spec `(rename ...)` Signed-off-by: yamacir-kit --- README.md | 6 ++--- VERSION | 2 +- basis/r4rs.ss | 41 ++++++++++++++++--------------- include/meevax/kernel/library.hpp | 37 ++++++++++++++++++++++++++++ src/kernel/environment.cpp | 41 ++++++++++++++++++++----------- 5 files changed, 89 insertions(+), 38 deletions(-) diff --git a/README.md b/README.md index b50e40054..ec1fb707a 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.998.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.999.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.998_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.999_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.998 +Meevax Lisp System, version 0.3.999 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 2294f408a..b1f42987b 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.998 +0.3.999 diff --git a/basis/r4rs.ss b/basis/r4rs.ss index 5992654c3..ca9c0d102 100644 --- a/basis/r4rs.ss +++ b/basis/r4rs.ss @@ -20,23 +20,24 @@ negative? odd? even? max min + * - / abs quotient remainder modulo gcd lcm numerator denominator floor ceiling truncate round rationalize exp log sin cos tan asin acos atan sqrt expt make-rectangular - make-polar real-part imag-part magnitude angle exact->inexact - inexact->exact number->string string->number char? char=? char? char<=? char>=? char-ci=? char-ci? char-ci<=? - char-ci>=? char-alphabetic? char-numeric? char-whitespace? - char-upper-case? char-lower-case? char->integer integer->char - char-upcase char-downcase string? make-string string string-length - string-ref string-set! string=? string? string<=? string>=? - string-ci=? string-ci? string-ci<=? string-ci>=? - substring string-append string->list list->string string-copy - string-fill! vector? make-vector vector vector-length vector-ref - vector-set! vector->list list->vector vector-fill! procedure? apply - map for-each force call-with-current-continuation! - call-with-input-file call-with-output-file input-port? output-port? - current-input-port current-output-port with-input-from-file - with-output-to-file open-input-file open-output-file close-input-port - close-output-port read read-char peek-char eof-object? char-ready? - write display newline write-char load) + make-polar real-part imag-part magnitude angle + (rename inexact exact->inexact) (rename exact inexact->exact) + number->string string->number char? char=? char? char<=? + char>=? char-ci=? char-ci? char-ci<=? char-ci>=? + char-alphabetic? char-numeric? char-whitespace? char-upper-case? + char-lower-case? char->integer integer->char char-upcase + char-downcase string? make-string string string-length string-ref + string-set! string=? string? string<=? string>=? string-ci=? + string-ci? string-ci<=? string-ci>=? substring + string-append string->list list->string string-copy string-fill! + vector? make-vector vector vector-length vector-ref vector-set! + vector->list list->vector vector-fill! procedure? apply map for-each + force call-with-current-continuation! call-with-input-file + call-with-output-file input-port? output-port? current-input-port + current-output-port with-input-from-file with-output-to-file + open-input-file open-output-file close-input-port close-output-port + read read-char peek-char eof-object? char-ready? write display newline + write-char load) (begin (define-syntax let* (er-macro-transformer @@ -118,9 +119,9 @@ (atan (imag-part z) (real-part z))) - (define exact->inexact inexact) - - (define inexact->exact exact) + ; (define exact->inexact inexact) + ; + ; (define inexact->exact exact) (define (list-tail x k) (let list-tail ((x x) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index d0ac1cafb..be2ca00a6 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -81,6 +81,43 @@ inline namespace kernel (export_(read(xs)), ...); } + auto resolve_export_specs() + { + let bindings = unit; + + for (let const& export_spec : export_specs) + { + if (export_spec.is() and car(export_spec).is() + and car(export_spec).as().value == "rename") + { + PRINT(export_spec); + + if (let const& binding = identify(cadr(export_spec), unit); binding.as().is_free()) + { + std::cout << make(make("exported but undefined"), cadr(export_spec)) << std::endl; + } + else + { + bindings = cons(make(caddr(export_spec), binding.as().load()), bindings); + } + } + else + { + if (let const& binding = identify(export_spec, unit); binding.as().is_free()) + { + std::cout << make(make("exported but undefined"), export_spec) << std::endl; + } + else + { + bindings = cons(binding, bindings); + } + } + } + + return bindings; + } + + [[deprecated]] auto export_to(environment & destination) { for (let const& export_spec : export_specs) diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 6bbe553f2..405070e8f 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -132,26 +132,39 @@ inline namespace kernel auto environment::import(const_reference import_set) -> void { - if (car(import_set).as().value == "only") + if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) { - } - else if (car(import_set).as().value == "except") - { - } - else if (car(import_set).as().value == "prefix") - { - } - else if (car(import_set).as().value == "rename") - { - } - else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) - { - std::get<1>(*iter).export_to(*this); + for (let const& binding : std::get<1>(*iter).resolve_export_specs()) + { + define(binding.as().symbol(), + binding.as().load()); + } } else { throw error(make("no such library"), import_set); } + + // if (car(import_set).as().value == "only") + // { + // } + // else if (car(import_set).as().value == "except") + // { + // } + // else if (car(import_set).as().value == "prefix") + // { + // } + // else if (car(import_set).as().value == "rename") + // { + // } + // else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) + // { + // std::get<1>(*iter).export_to(*this); + // } + // else + // { + // throw error(make("no such library"), import_set); + // } } auto environment::load(std::string const& s) -> object From 2ac50919fcc6475e0bdb113a38e76e655e2aa90f Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 15:09:10 +0900 Subject: [PATCH 28/49] Update import declaration to support import-set `only` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r5rs.ss | 2 +- include/meevax/kernel/library.hpp | 26 ++--------------------- src/kernel/environment.cpp | 35 ++++++++++++++++++++++++++----- test/r5rs.ss | 4 ++-- 6 files changed, 39 insertions(+), 36 deletions(-) diff --git a/README.md b/README.md index ec1fb707a..a48bff536 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.999.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1000.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.999_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1000_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.999 +Meevax Lisp System, version 0.3.1000 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index b1f42987b..4c29b42f3 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.999 +0.3.1000 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index 7249610c0..e6fce1cea 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -95,7 +95,7 @@ (environment `(scheme ,(string->symbol (string-append "r" (number->string version) "rs"))))) (define (null-environment version) - (environment `(only `(scheme ,(string->symbol (string-append "r" (number->string version) "rs"))) + (environment `(only (scheme ,(string->symbol (string-append "r" (number->string version) "rs"))) quote lambda if set! cond case and or let let* letrec begin do delay quasiquote let-syntax letrec-syntax syntax-rules define define-syntax))) diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index be2ca00a6..7aaa8f438 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -90,11 +90,9 @@ inline namespace kernel if (export_spec.is() and car(export_spec).is() and car(export_spec).as().value == "rename") { - PRINT(export_spec); - if (let const& binding = identify(cadr(export_spec), unit); binding.as().is_free()) { - std::cout << make(make("exported but undefined"), cadr(export_spec)) << std::endl; + std::cout << error(make("exported but undefined"), cadr(export_spec)) << std::endl; } else { @@ -105,7 +103,7 @@ inline namespace kernel { if (let const& binding = identify(export_spec, unit); binding.as().is_free()) { - std::cout << make(make("exported but undefined"), export_spec) << std::endl; + std::cout << error(make("exported but undefined"), export_spec) << std::endl; } else { @@ -117,26 +115,6 @@ inline namespace kernel return bindings; } - [[deprecated]] - auto export_to(environment & destination) - { - for (let const& export_spec : export_specs) - { - if (export_spec.is() and car(export_spec).is() - and car(export_spec).as().value == "rename") - { - } - else if (let const& binding = (*this)[export_spec]; binding.is()) - { - std::cout << "; warning: " << export_spec << " is exported but undefined." << std::endl; - } - else - { - destination.define(export_spec, binding); - } - } - } - friend auto operator <<(std::ostream & os, library const& library) -> std::ostream & { return os << library.global(); diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 405070e8f..fa4ac3a9f 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -130,20 +130,45 @@ inline namespace kernel return second; } - auto environment::import(const_reference import_set) -> void + auto resolve_import_set(const_reference import_set) -> object { - if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) + if (car(import_set).as().value == "only") { - for (let const& binding : std::get<1>(*iter).resolve_export_specs()) + let const exported_bindings = resolve_import_set(cadr(import_set)); + + let filtered_bindings = unit; + + for (let const& identifier : cddr(import_set)) { - define(binding.as().symbol(), - binding.as().load()); + if (let const& binding = assq(identifier, exported_bindings); select(binding)) + { + filtered_bindings = cons(binding, filtered_bindings); + } + else + { + std::cout << error(make("no such identifier"), identifier); + } } + + return filtered_bindings; + } + else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) + { + return std::get<1>(*iter).resolve_export_specs(); } else { throw error(make("no such library"), import_set); } + } + + auto environment::import(const_reference import_set) -> void + { + for (let const& binding : resolve_import_set(import_set)) + { + define(binding.as().symbol(), + binding.as().load()); + } // if (car(import_set).as().value == "only") // { diff --git a/test/r5rs.ss b/test/r5rs.ss index 62f965465..3e600df20 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -866,8 +866,8 @@ (check (eval '(* 7 3) (scheme-report-environment 5)) => 21) -; (check (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) -; (f + 10)) => 20) ; ERROR +(check (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) + (f + 10)) => 20) ; ---- EXAMPLE ----------------------------------------------------------------- From 842299312fda6d7c3142af5587a23a4bfb795367 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 21:11:16 +0900 Subject: [PATCH 29/49] Cleanup R7RS libraries Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 626 ++++++++++++++++++++++--------------- src/kernel/environment.cpp | 21 -- 4 files changed, 386 insertions(+), 269 deletions(-) diff --git a/README.md b/README.md index a48bff536..260971ce5 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1000.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1001.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1000_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1001_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1000 +Meevax Lisp System, version 0.3.1001 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 4c29b42f3..bb18647f5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1000 +0.3.1001 diff --git a/basis/overture.ss b/basis/overture.ss index cc3d526ab..ef2dda883 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -6,6 +6,247 @@ (scheme r5rs) (srfi 211 explicit-renaming) ) + + (export quote + lambda + if + set! + ; include + ; include-ci + cond + ; else + ; => + case + and + or + when + unless + ; cond-expand + let + let* + letrec + letrec* + ; let-values + ; let*-values + begin + do + ; make-parameter + ; parameterize + ; guard + quasiquote + ; unquote + ; unquote-splicing + let-syntax + letrec-syntax + ; syntax-rules + ; _ + ; ... + ; syntax-error + define + ; define-values + define-syntax + ; define-record-type + eqv? + eq? + equal? + number? + complex? + real? + rational? + integer? + exact? + inexact? + exact-integer? + = + < + > + <= + >= + zero? + positive? + negative? + odd? + even? + max + min + + + * + - + / + abs + floor/ + floor-quotient + floor-remainder + truncate/ + truncate-quotient + truncate-remainder + quotient + remainder + modulo + gcd + lcm + numerator + denominator + floor + ceiling + truncate + round + rationalize + square + ; exact-integer-sqrt + expt + inexact + exact + number->string + string->number + not + boolean? + boolean=? + pair? + cons + car + cdr + set-car! + set-cdr! + caar + cadr + cdar + cddr + null? + list? + ; make-list + list + length + append + reverse + list-tail + list-ref + list-set! + memq + memv + member + assq + assv + assoc + ; list-copy + symbol? + ; symbol=? + symbol->string + string->symbol + char? + char=? + char? + char<=? + char>=? + char->integer + integer->char + string? + make-string + string + string-length + string-ref + string-set! + string=? + string>? + string=? + substring + string-append + string->list + list->string + string-copy + ; string-copy! + string-fill! + vector? + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector + vector->string + ; string->vector + ; vector-copy + ; vector-copy! + ; vector-append + vector-fill! + ; bytevector? + ; make-bytevector + ; bytevector + ; bytevector-length + ; bytevector-u8-ref + ; bytevector-u8-set! + ; bytevector-copy + ; bytevector-copy! + ; bytevector-append + ; utf8->string + ; string->utf8 + procedure? + apply + map + ; string-map + ; vector-map + for-each + ; string-for-each + ; vector-for-each + call-with-current-continuation + call/cc + values + call-with-values + dynamic-wind + ; with-exception-handler + ; raise + ; raise-continuable + ; error + ; error-object? + ; error-object-message + ; error-object-irritants + ; read-error? + ; file-error? + ; call-with-port + ; input-port? + ; output-port? + ; textual-port? + ; binary-port? + ; port? + ; input-port-open? + ; output-port-open? + ; current-input-port + ; current-output-port + ; current-error-port + ; close-port + ; close-input-port + ; close-output-port + ; open-input-string + ; open-output-string + ; get-output-string + ; open-input-bytevector + ; open-output-bytevector + ; get-output-bytevector + ; read-char + ; peek-char + ; read-line + ; eof-object? + ; eof-object + ; char-ready? + ; read-string + ; read-u8 + ; peek-u8 + ; u8-ready? + ; read-bytevector + ; read-bytevector! + ; newline + ; write-char + ; write-string + ; write-u8 + ; write-bytevector + ; flush-output-port + ; features + ) + (begin (define (unspecified) (if #f #f)) (define-syntax when @@ -61,255 +302,152 @@ (define call/cc call-with-current-continuation) ) - (export * - + - - - ; ... - / - < - <= - = - ; => - > - >= - ; _ - abs - and - append - apply - assoc - assq - assv - begin - ; binary-port? - boolean=? - boolean? - ; bytevector - ; bytevector-append - ; bytevector-copy - ; bytevector-copy! - ; bytevector-length - ; bytevector-u8-ref - ; bytevector-u8-set! - ; bytevector? - caar - cadr - call-with-current-continuation - ; call-with-port - call-with-values - call/cc - car - case - cdar - cddr - cdr - ceiling - char->integer - ; char-ready? - char<=? - char=? - char>? - char? - ; close-input-port - ; close-output-port - ; close-port - complex? - cond - ; cond-expand - cons - ; current-error-port - ; current-input-port - ; current-output-port - define - ; define-record-type - define-syntax - ; define-values - denominator - do - dynamic-wind - ; else - ; eof-object - ; eof-object? - eq? - equal? - eqv? - ; error - ; error-object-irritants - ; error-object-message - ; error-object? - even? - exact - ; exact-integer-sqrt - exact-integer? - exact? - expt - ; features - ; file-error? - floor - floor-quotient - floor-remainder - floor/ - ; flush-output-port - for-each - gcd - ; get-output-bytevector - ; get-output-string - ; guard - if - ; include - ; include-ci - inexact - inexact? - ; input-port-open? - ; input-port? - integer->char - integer? - lambda - lcm - length - let - let* - ; let*-values - let-syntax - ; let-values - letrec - letrec* - letrec-syntax - list - list->string - list->vector - ; list-copy - list-ref - list-set! - list-tail - list? - ; make-bytevector - ; make-list - ; make-parameter - make-string - make-vector - map - max - member - memq - memv - min - modulo - negative? - ; newline - not - null? - number->string - number? - numerator - odd? - ; open-input-bytevector - ; open-input-string - ; open-output-bytevector - ; open-output-string - or - ; output-port-open? - ; output-port? - pair? - ; parameterize - ; peek-char - ; peek-u8 - ; port? - positive? - procedure? - quasiquote - quote - quotient - ; raise - ; raise-continuable - rational? - rationalize - ; read-bytevector - ; read-bytevector! - ; read-char - ; read-error? - ; read-line - ; read-string - ; read-u8 - real? - remainder - reverse - round - set! - set-car! - set-cdr! - square - string - string->list - string->number - string->symbol - ; string->utf8 - ; string->vector - string-append - string-copy - ; string-copy! - string-fill! - ; string-for-each - string-length - ; string-map - string-ref - string-set! - string<=? - string=? - string>? - string? - substring - symbol->string - ; symbol=? - symbol? - ; syntax-error - ; syntax-rules - ; textual-port? - truncate - truncate-quotient - truncate-remainder - truncate/ - ; u8-ready? - unless - ; unquote - ; unquote-splicing - ; utf8->string - values - vector - vector->list - vector->string - ; vector-append - ; vector-copy - ; vector-copy! - vector-fill! - ; vector-for-each - vector-length - ; vector-map - vector-ref - vector-set! - vector? - when - ; with-exception-handler - ; write-bytevector - ; write-char - ; write-string - ; write-u8 - zero? + ) + +(define-library (scheme delay) + (export delay + delay-force + force + promise? + make-promise + ) + ) + +(define-library (scheme case-lambda) + (export case-lambda + ) + ) + +(define-library (scheme inexact) + (export finite? + infinite? + nan? + exp + log + sin + cos + tan + asin + acos + atan + sqrt + ) + ) + +(define-library (scheme complex) + (export make-rectangular + make-polar + real-part + imag-part + angle ) ) (define-library (scheme cxr) (import (meevax pair)) - (export caaar caadr cadar caddr - cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr - cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr - cddaar cddadr cdddar cddddr)) + (export caaar + caadr + cadar + caddr + cdaar + cdadr + cddar + cdddr + caaaar + caaadr + caadar + caaddr + cadaar + cadadr + caddar + cadddr + cdaaar + cdaadr + cdadar + cdaddr + cddaar + cddadr + cdddar + cddddr)) + +(define-library (scheme char) + (export char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + digit-value + char-upcase + char-downcase + char-foldcase + string-ci=? + string-ci? + string-ci<=? + string-ci>=? + string-upcase + string-downcase + string-foldcase + ) + ) + +(define-library (scheme eval) + (export environment + eval + ) + ) + +(define-library (scheme file) + (export call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file + open-input-file + open-binary-input-file + open-output-file + open-binary-output-file + file-exists? + delete-file + ) + ) + +(define-library (scheme read) + (export read) + ) + +(define-library (scheme write) + (export write + write-shared + write-simple + display + ) + ) + +(define-library (scheme load) + (export load + ) + ) + +(define-library (scheme process-context) + (export command-line + exit + emergency-exit + get-environment-variable + get-environment-variables + ) + ) + +(define-library (scheme time) + (export current-second + current-jiffy + jiffies-per-second + ) + ) (import (scheme r5rs) (scheme base) diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index fa4ac3a9f..4af1ae2a5 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -169,27 +169,6 @@ inline namespace kernel define(binding.as().symbol(), binding.as().load()); } - - // if (car(import_set).as().value == "only") - // { - // } - // else if (car(import_set).as().value == "except") - // { - // } - // else if (car(import_set).as().value == "prefix") - // { - // } - // else if (car(import_set).as().value == "rename") - // { - // } - // else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) - // { - // std::get<1>(*iter).export_to(*this); - // } - // else - // { - // throw error(make("no such library"), import_set); - // } } auto environment::load(std::string const& s) -> object From a6c56c49cd38f1ee8188ac4559c20316ce66346e Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Sun, 15 May 2022 21:21:27 +0900 Subject: [PATCH 30/49] Update library `(scheme base)` to import `(srfi 39)` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/overture.ss | 5 +++-- basis/srfi-39.ss | 2 -- src/library/meevax.cpp | 2 +- 5 files changed, 8 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 260971ce5..9ed42918a 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1001.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1002.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1001_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1002_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1001 +Meevax Lisp System, version 0.3.1002 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index bb18647f5..4d73811f3 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1001 +0.3.1002 diff --git a/basis/overture.ss b/basis/overture.ss index ef2dda883..47e9bc6e8 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -4,6 +4,7 @@ (meevax syntax) ; for quote-syntax (meevax vector) ; for vector->string (scheme r5rs) + (srfi 39) ; Parameter objects (srfi 211 explicit-renaming) ) @@ -30,8 +31,8 @@ ; let*-values begin do - ; make-parameter - ; parameterize + make-parameter + parameterize ; guard quasiquote ; unquote diff --git a/basis/srfi-39.ss b/basis/srfi-39.ss index ca2c097b6..a045aa1dc 100644 --- a/basis/srfi-39.ss +++ b/basis/srfi-39.ss @@ -77,5 +77,3 @@ `(,(rename 'dynamic-bind) (,(rename 'list) ,@(map car (cadr form))) (,(rename 'list) ,@(map cadr (cadr form))) (,(rename 'lambda) () ,@(cddr form)))))))) - -(import (srfi 39)) ; TEMPORARY diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 61b1c5db5..a42aad07e 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -53,12 +53,12 @@ namespace meevax r4rs, srfi_149, r5rs, + srfi_39, overture, srfi_8, srfi_1, srfi_23, srfi_34, - srfi_39, srfi_78, r7rs, }; From d483739d569aac14e26845df70d7236d81a5b098 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 16 May 2022 00:37:48 +0900 Subject: [PATCH 31/49] Move many procedures into library `(scheme base)` from global environment Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 350 +++++++++++++++++++++++------------ basis/r7rs.ss | 217 ---------------------- basis/srfi-23.ss | 11 +- basis/srfi-34.ss | 204 +++++++++----------- src/library/meevax.cpp | 4 +- test/er-macro-transformer.ss | 4 + test/transformer.ss | 4 + 9 files changed, 343 insertions(+), 459 deletions(-) diff --git a/README.md b/README.md index 9ed42918a..ac1dd084f 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1002.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1003.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1002_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1003_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1002 +Meevax Lisp System, version 0.3.1003 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 4d73811f3..85e8fb8e1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1002 +0.3.1003 diff --git a/basis/overture.ss b/basis/overture.ss index 47e9bc6e8..767747568 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -1,9 +1,27 @@ (define-library (scheme base) - (import (meevax character) ; for digit-value - (meevax number) ; for exact-integer? - (meevax syntax) ; for quote-syntax - (meevax vector) ; for vector->string + (import (only (meevax exception) error? read-error? file-error? syntax-error?) + (only (meevax number) exact-integer?) + (only (meevax vector) vector->string) + (only (meevax port) + binary-port? + textual-port? + port? + input-port-open? + output-port-open? + standard-input-port + standard-output-port + standard-error-port + eof-object + %read-char + %peek-char + read-ready? + put-char + put-string + %flush-output-port + ) (scheme r5rs) + (srfi 23) ; Error reporting mechanism + (srfi 34) ; Exception Handling for Programs (srfi 39) ; Parameter objects (srfi 211 explicit-renaming) ) @@ -33,13 +51,13 @@ do make-parameter parameterize - ; guard + guard quasiquote ; unquote ; unquote-splicing let-syntax letrec-syntax - ; syntax-rules + syntax-rules ; _ ; ... ; syntax-error @@ -188,7 +206,7 @@ procedure? apply map - ; string-map + string-map ; vector-map for-each ; string-for-each @@ -198,53 +216,53 @@ values call-with-values dynamic-wind - ; with-exception-handler - ; raise - ; raise-continuable - ; error - ; error-object? - ; error-object-message - ; error-object-irritants - ; read-error? - ; file-error? - ; call-with-port - ; input-port? - ; output-port? - ; textual-port? - ; binary-port? - ; port? - ; input-port-open? - ; output-port-open? - ; current-input-port - ; current-output-port - ; current-error-port - ; close-port - ; close-input-port - ; close-output-port + with-exception-handler + raise + raise-continuable + error + error-object? + (rename car error-object-message) + (rename cdr error-object-irritants) + read-error? + file-error? + call-with-port + input-port? + output-port? + textual-port? + binary-port? + port? + input-port-open? + output-port-open? + current-input-port + current-output-port + current-error-port + close-port + close-input-port + close-output-port ; open-input-string ; open-output-string ; get-output-string ; open-input-bytevector ; open-output-bytevector ; get-output-bytevector - ; read-char - ; peek-char + read-char + peek-char ; read-line - ; eof-object? - ; eof-object - ; char-ready? + eof-object? + eof-object + char-ready? ; read-string ; read-u8 ; peek-u8 ; u8-ready? ; read-bytevector ; read-bytevector! - ; newline - ; write-char - ; write-string + newline + write-char + write-string ; write-u8 ; write-bytevector - ; flush-output-port + flush-output-port ; features ) @@ -300,19 +318,112 @@ (define symbol=? eqv?) + (define (string-map f x . xs) + (define (string-map-1 x) + (list->string + (map f (string->list x)))) + (define (string-map-n xs) + (map list->string + (map (lambda (c) (map f c)) + (map string->list xs)))) + (if (null? xs) + (string-map-1 x) + (string-map-n (cons x xs)))) + (define call/cc call-with-current-continuation) + (define (error-object? x) + (or (error? x) + (read-error? x) + (file-error? x) + (syntax-error? x))) + + ; (define (call-with-port port procedure) + ; (let-values ((results (procedure port))) + ; (close-port port) + ; (apply values results))) + + (define (call-with-port port procedure) + (let ((result (procedure port))) + (close-port port) + result)) + + (define current-input-port + (make-parameter (standard-input-port) + (lambda (x) + (cond ((not (input-port? x)) + (error "current-input-port: not input-port" x)) + ((not (input-port-open? x)) + (error "current-input-port: not input-port-open" x)) + (else x))))) + + (define current-output-port + (make-parameter (standard-output-port) + (lambda (x) + (cond ((not (output-port? x)) + (error "current-output-port: not output-port" x)) + ((not (output-port-open? x)) + (error "current-output-port: not output-port-open" x)) + (else x))))) + + (define current-error-port + (make-parameter (standard-error-port) + (lambda (x) + (cond ((not (output-port? x)) + (error "current-error-port: not output-port" x)) + ((not (output-port-open? x)) + (error "current-error-port: not output-port-open" x)) + (else x))))) + + (define (close-port x) + (cond ((input-port? x) (close-input-port x)) + ((output-port? x) (close-output-port x)) + (else (unspecified)))) + + (define (read-char . x) + (%read-char (if (pair? x) + (car x) + (current-input-port)))) + + (define (peek-char . x) + (%peek-char (if (pair? x) + (car x) + (current-input-port)))) + + (define (char-ready? . x) + (read-ready? (if (pair? x) + (car x) + (current-input-port)))) + + (define (write-char x . port) + (put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-string string . xs) + (case (length xs) + ((0) (put-string string (current-output-port))) + ((1) (put-string string (car xs))) + (else (put-string (apply string-copy string (cadr xs)) (car xs))))) + + (define (newline . port) + (apply write-char #\newline port)) + + (define (flush-output-port . port) + (%flush-output-port (if (pair? port) + (car port) + (current-output-port)))) + ) ) -(define-library (scheme delay) +(define-library (scheme lazy) + (import (srfi 45)) (export delay - delay-force + (rename lazy delay-force) force promise? - make-promise - ) - ) + (rename eager make-promise))) (define-library (scheme case-lambda) (export case-lambda @@ -372,6 +483,27 @@ cddddr)) (define-library (scheme char) + (import (only (meevax character) digit-value) + (only (scheme r5rs) + char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char-upcase + char-downcase + string-ci=? + string-ci? + string-ci<=? + string-ci>=?) + (only (scheme base) define string-map)) + (export char-ci=? char-ci? @@ -385,7 +517,7 @@ digit-value char-upcase char-downcase - char-foldcase + (rename char-downcase char-foldcase) string-ci=? string-ci? @@ -393,9 +525,16 @@ string-ci>=? string-upcase string-downcase - string-foldcase - ) - ) + string-foldcase) + + (begin (define (string-upcase x) + (string-map char-upcase x)) + + (define (string-downcase x) + (string-map char-downcase x)) + + (define (string-foldcase x) + (string-map char-foldcase x)))) (define-library (scheme eval) (export environment @@ -404,29 +543,63 @@ ) (define-library (scheme file) + (import (only (meevax port) open-input-file open-output-file) + (only (scheme r5rs) call-with-input-file call-with-output-file) + (only (scheme base) define parameterize current-input-port current-output-port) + ) (export call-with-input-file call-with-output-file with-input-from-file with-output-to-file open-input-file - open-binary-input-file + ; open-binary-input-file open-output-file - open-binary-output-file - file-exists? - delete-file + ; open-binary-output-file + ; file-exists? + ; delete-file ) + (begin (define (with-input-from-file path thunk) + (parameterize ((current-input-port (open-input-file path))) + (thunk))) + + (define (with-output-to-file path thunk) + (parameterize ((current-output-port (open-output-file path))) + (thunk))) + ) ) (define-library (scheme read) + (import (meevax read) + (scheme base)) (export read) - ) + (begin (define (read . x) + (%read (if (pair? x) + (car x) + (current-input-port)))))) (define-library (scheme write) + (import (scheme base) + (only (meevax write) %write-simple) + (only (meevax port) put-char) + ) (export write - write-shared + ; write-shared write-simple display ) + (begin (define (write-simple x . port) + (%write-simple x (if (pair? port) + (car port) + (current-output-port)))) + + (define write write-simple) ; DUMMY + + (define (display datum . port) + (cond ((char? datum) (apply write-char datum port)) + ((string? datum) (apply write-string datum port)) + (else (apply write datum port)))) + + ) ) (define-library (scheme load) @@ -452,73 +625,14 @@ (import (scheme r5rs) (scheme base) + (scheme char) (scheme cxr) + (scheme file) + (scheme lazy) + (scheme read) + (scheme write) (srfi 211 explicit-renaming) (srfi 211 syntactic-closures) ) (define (unspecified) (if #f #f)) - -(define (traditional-macro-transformer f) - (lambda (form use-env mac-env) - (apply f (cdr form)))) - -; ---- 6.11. Exceptions -------------------------------------------------------- - -(define (error-object? x) - (or (error? x) - (read-error? x) - (file-error? x) - (syntax-error? x))) - -(define error-object-message car) - -(define error-object-irritants cdr) - -; ---- 6.12. Environments and evaluation --------------------------------------- - -; ---- 6.13. Input and output -------------------------------------------------- - -; (define (call-with-port port procedure) -; (let-values ((results (procedure port))) -; (close-port port) -; (apply values results))) - -(define (call-with-port port procedure) - (let ((result (procedure port))) - (close-port port) - result)) - -(define (close-port x) - (cond ((input-port? x) (close-input-port x)) - ((output-port? x) (close-output-port x)) - (else (unspecified)))) - -(define (read . x) (%read (if (pair? x) (car x) (current-input-port)))) -(define (read-char . x) (%read-char (if (pair? x) (car x) (current-input-port)))) -(define (peek-char . x) (%peek-char (if (pair? x) (car x) (current-input-port)))) -(define (char-ready? . x) (read-ready? (if (pair? x) (car x) (current-input-port)))) - -(define (write-simple x . port) (%write-simple x (if (pair? port) (car port) (current-output-port)))) -(define (write-char x . port) (put-char x (if (pair? port) (car port) (current-output-port)))) - -(define write write-simple) - -(define (display datum . port) - (cond ((char? datum) (apply write-char datum port)) - ((string? datum) (apply write-string datum port)) - (else (apply write datum port)))) - -(define (newline . port) - (apply write-char #\newline port)) - -(define (write-string string . xs) - (case (length xs) - ((0) (put-string string (current-output-port))) - ((1) (put-string string (car xs))) - (else (put-string (apply string-copy string (cadr xs)) (car xs))))) - -(define (flush-output-port . port) - (%flush-output-port (if (pair? port) - (car port) - (current-output-port)))) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 40953e4b5..2b30e363c 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -183,225 +183,8 @@ ((do "step" x y) y))) -; ---- 4.2.5. Delayed evaluation ----------------------------------------------- - -(define-library (scheme lazy) - (import (scheme r4rs essential) - (srfi 45)) - (export delay delay-force force make-promise promise?) - (begin (define make-promise eager) - (define delay-force lazy))) - -(import (scheme lazy)) - -; ---- 4.2.6. Dynamic bindings ------------------------------------------------- - -make-parameter ; is defined in srfi-39.ss - -parameterize ; is defined in srfi-39.ss - -; ---- 4.2.7. Exception handling ----------------------------------------------- - -(define-syntax guard - (syntax-rules () - ((guard (var clause ...) e1 e2 ...) - ((call/cc - (lambda (guard-k) - (with-exception-handler - (lambda (condition) - ((call/cc - (lambda (handler-k) - (guard-k - (lambda () - (let ((var condition)) - (guard-aux - (handler-k - (lambda () - (raise-continuable condition))) - clause ...)))))))) - (lambda () - (call-with-values - (lambda () e1 e2 ...) - (lambda args - (guard-k - (lambda () - (apply values args))))))))))))) - -(define-syntax guard-aux - (syntax-rules (else =>) - ((guard-aux reraise (else result1 result2 ...)) - (begin result1 result2 ...)) - ((guard-aux reraise (test => result)) - (let ((temp test)) - (if temp - (result temp) - reraise))) - ((guard-aux reraise (test => result) - clause1 clause2 ...) - (let ((temp test)) - (if temp - (result temp) - (guard-aux reraise clause1 clause2 ...)))) - ((guard-aux reraise (test)) - (or test reraise)) - ((guard-aux reraise (test) clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (guard-aux reraise clause1 clause2 ...)))) - ((guard-aux reraise (test result1 result2 ...)) - (if test - (begin result1 result2 ...) - reraise)) - ((guard-aux reraise - (test result1 result2 ...) - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (guard-aux reraise clause1 clause2 ...))))) - -; ---- 4.2.8. Quasiquotation --------------------------------------------------- - -; ---- 4.2.9. Case-lambda ------------------------------------------------------ - -; ---- 6.1. Equivalence predicates --------------------------------------------- - -; ---- 6.2. Numbers ------------------------------------------------------------ - -; TODO exact-integer-sqrt - -; ---- 6.3. Booleans ----------------------------------------------------------- - -; ---- 6.4. Pairs and lists ---------------------------------------------------- - -; ---- 6.5 Symbols ------------------------------------------------------------- - -; ---- 6.6 Characters ---------------------------------------------------------- - -(define char-foldcase char-downcase) - -; ---- 6.7 Strings ------------------------------------------------------------- - -(define (string-upcase x) (string-map char-upcase x)) -(define (string-downcase x) (string-map char-downcase x)) -(define (string-foldcase x) (string-map char-foldcase x)) - -; string-copy! - -; ---- 6.8. Vectors ------------------------------------------------------------ - -; ---- 6.9. Bytevectors -------------------------------------------------------- - -(define (bytevector? x) #f) - -; ---- 6.10. Control features -------------------------------------------------- - -(define (string-map f x . xs) - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) - (if (null? xs) - (string-map-1 x) - (string-map-n (cons x xs)))) - -; TODO vector-map - -; TODO string-for-each -; TODO vector-for-each - -; ---- 6.11. Exceptions -------------------------------------------------------- - -; ---- 6.12. Environments and evaluation --------------------------------------- - -; TODO environment -; TODO scheme-report-environment -; TODO null-environment - -; ---- 6.13. Input and output -------------------------------------------------- - -(define current-input-port - (make-parameter (standard-input-port) - (lambda (x) - (cond ((not (input-port? x)) - (error "current-input-port: not input-port" x)) - ((not (input-port-open? x)) - (error "current-input-port: not input-port-open" x)) - (else x))))) - -(define current-output-port - (make-parameter (standard-output-port) - (lambda (x) - (cond ((not (output-port? x)) - (error "current-output-port: not output-port" x)) - ((not (output-port-open? x)) - (error "current-output-port: not output-port-open" x)) - (else x))))) - -(define current-error-port - (make-parameter (standard-error-port) - (lambda (x) - (cond ((not (output-port? x)) - (error "current-error-port: not output-port" x)) - ((not (output-port-open? x)) - (error "current-error-port: not output-port-open" x)) - (else x))))) - -(define (with-input-from-file path thunk) - (parameterize ((current-input-port (open-input-file path))) - (thunk))) - -(define (with-output-to-file path thunk) - (parameterize ((current-output-port (open-output-file path))) - (thunk))) - -; TODO open-input-bytevector -; TODO open-output-bytevector -; TODO get-output-bytevector - -; TODO write-u8 -; TODO write-bytevector - - -; ---- 6.14. System interface -------------------------------------------------- - -; TODO file-exists? -; TODO delete-file -; TODO command-line - -; ------------------------------------------------------------------------------ -; -; (exit) process-context library procedure -; (exit obj) process-context library procedure -; -; Runs all outstanding dynamic-wind after procedures, terminates the running -; program, and communicates an exit value to the operating system. If no -; argument is supplied, or if obj is #t, the exit procedure should communicate -; to the operating system that the program exited normally. If obj is #f, the -; exit procedure should communicate to the operating system that the program -; exited abnormally. Otherwise, exit should translate obj into an appropriate -; exit value for the operating system, if possible. -; -; The exit procedure must not signal an exception or return to its -; continuation. -; -; Note: Because of the requirement to run handlers, this procedure is not just -; the operating system’s exit procedure. -; -; ------------------------------------------------------------------------------ - (define (exit . normally?) (for-each (lambda (before/after) ((cdr before/after))) %current-dynamic-extents) (apply emergency-exit normally?)) - -; TODO get-environment-variable -; TODO get-environment-variables - -; TODO current-second -; TODO current-jiffy -; TODO jiffies-per-second diff --git a/basis/srfi-23.ss b/basis/srfi-23.ss index c3a6d38e8..091f35505 100644 --- a/basis/srfi-23.ss +++ b/basis/srfi-23.ss @@ -1,4 +1,7 @@ -; (import (srfi 18)) - -(define (error . xs) - (raise (apply make-error xs))) +(define-library (srfi 23) + (import (only (meevax exception) make-error) + (only (scheme r5rs) define apply) + (only (srfi 34) raise)) + (export error) + (begin (define (error . xs) + (raise (apply make-error xs))))) diff --git a/basis/srfi-34.ss b/basis/srfi-34.ss index fe0a4fc7d..404b73064 100644 --- a/basis/srfi-34.ss +++ b/basis/srfi-34.ss @@ -1,5 +1,3 @@ -; ------------------------------------------------------------------------------ -; ; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. ; ; Permission is hereby granted, free of charge, to any person obtaining a copy @@ -19,124 +17,102 @@ ; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ; IN THE SOFTWARE. -; -; ------------------------------------------------------------------------------ -(define %current-exception-handlers (list default-exception-handler)) +(define-library (srfi 34) + (import (only (meevax exception) default-exception-handler) + (scheme r5rs) + ) -(define (%with-exception-handlers new-handlers thunk) - (let ((old-handlers %current-exception-handlers)) - (dynamic-wind - (lambda () (set! %current-exception-handlers new-handlers)) ; install - thunk - (lambda () (set! %current-exception-handlers old-handlers))))) ; uninstall + (export with-exception-handler + raise + raise-continuable + guard + ) -; ------------------------------------------------------------------------------ -; -; (with-exception-handler handler thunk) procedure -; -; It is an error if handler does not accept one argument. It is also an error -; if thunk does not accept zero arguments. The with-exception-handler -; procedure returns the results of invoking thunk. Handler is installed as the -; current exception handler in the dynamic environment used for the invocation -; of thunk. -; -; ------------------------------------------------------------------------------ + (begin (define %current-exception-handlers (list default-exception-handler)) -(define (with-exception-handler handler thunk) - (%with-exception-handlers (cons handler %current-exception-handlers) thunk)) + (define (%with-exception-handlers new-handlers thunk) + (let ((old-handlers %current-exception-handlers)) + (dynamic-wind + (lambda () (set! %current-exception-handlers new-handlers)) ; install + thunk + (lambda () (set! %current-exception-handlers old-handlers))))) ; uninstall -; ------------------------------------------------------------------------------ -; -; (raise obj) procedure -; -; Raises an exception by invoking the current exception handler on obj. The -; handler is called with the same dynamic environment as that of the call to -; raise, except that the current exception handler is the one that was in -; place when the handler being called was installed. If the handler returns, a -; secondary exception is raised in the same dynamic environment as the -; handler. The relationship between obj and the object raised by the secondary -; exception is unspecified. -; -; ------------------------------------------------------------------------------ + (define (with-exception-handler handler thunk) + (%with-exception-handlers (cons handler %current-exception-handlers) thunk)) -(define (raise x) - (let ((inner (car %current-exception-handlers)) - (outer (cdr %current-exception-handlers))) - (%with-exception-handlers outer - (lambda () - (inner x) - (error "If the handler returns, a secondary exception is raised in the same dynamic environment as the handler"))))) + (define (raise x) + (let ((inner (car %current-exception-handlers)) + (outer (cdr %current-exception-handlers))) + (%with-exception-handlers outer + (lambda () + (inner x) + (error "If the handler returns, a secondary exception is raised in the same dynamic environment as the handler"))))) -; ------------------------------------------------------------------------------ -; -; (raise-continuable obj) procedure -; -; Raises an exception by invoking the current exception handler on obj. The -; handler is called with the same dynamic environment as the call to -; raise-continuable, except that: (1) the current exception handler is the one -; that was in place when the handler being called was installed, and (2) if -; the handler being called returns, then it will again become the current -; exception handler. If the handler returns, the values it returns become the -; values returned by the call to raise-continuable. -; -; ------------------------------------------------------------------------------ + (define (raise-continuable x) + (let ((inner (car %current-exception-handlers)) + (outer (cdr %current-exception-handlers))) + (%with-exception-handlers outer + (lambda () + (inner x))))) -(define (raise-continuable x) - (let ((inner (car %current-exception-handlers)) - (outer (cdr %current-exception-handlers))) - (%with-exception-handlers outer - (lambda () - (inner x))))) + (define-syntax guard + (syntax-rules () + ((guard (var clause ...) e1 e2 ...) + ((call/cc + (lambda (guard-k) + (with-exception-handler + (lambda (condition) + ((call/cc + (lambda (handler-k) + (guard-k + (lambda () + (let ((var condition)) + (guard-aux + (handler-k + (lambda () + (raise-continuable condition))) + clause ...)))))))) + (lambda () + (call-with-values + (lambda () e1 e2 ...) + (lambda args + (guard-k + (lambda () + (apply values args))))))))))))) -; (define-syntax guard -; (syntax-rules () -; ((guard (var clause ...) e1 e2 ...) -; ((call-with-current-continuation -; (lambda (guard-k) -; (with-exception-handler -; (lambda (condition) -; ((call-with-current-continuation -; (lambda (handler-k) -; (guard-k -; (lambda () -; (let ((var condition)) ; clauses may SET! var -; (guard-aux (handler-k (lambda () -; (raise condition))) -; clause ...)))))))) -; (lambda () -; (call-with-values -; (lambda () e1 e2 ...) -; (lambda args -; (guard-k (lambda () -; (apply values args))))))))))))) -; -; (define-syntax guard-aux -; (syntax-rules (else =>) -; ((guard-aux reraise (else result1 result2 ...)) -; (begin result1 result2 ...)) -; ((guard-aux reraise (test => result)) -; (let ((temp test)) -; (if temp -; (result temp) -; reraise))) -; ((guard-aux reraise (test => result) clause1 clause2 ...) -; (let ((temp test)) -; (if temp -; (result temp) -; (guard-aux reraise clause1 clause2 ...)))) -; ((guard-aux reraise (test)) -; test) -; ((guard-aux reraise (test) clause1 clause2 ...) -; (let ((temp test)) -; (if temp -; temp -; (guard-aux reraise clause1 clause2 ...)))) -; ((guard-aux reraise (test result1 result2 ...)) -; (if test -; (begin result1 result2 ...) -; reraise)) -; ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) -; (if test -; (begin result1 result2 ...) -; (guard-aux reraise clause1 clause2 ...))))) + (define-syntax guard-aux + (syntax-rules (else =>) + ((guard-aux reraise (else result1 result2 ...)) + (begin result1 result2 ...)) + ((guard-aux reraise (test => result)) + (let ((temp test)) + (if temp + (result temp) + reraise))) + ((guard-aux reraise (test => result) + clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test)) + (or test reraise)) + ((guard-aux reraise (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (guard-aux reraise clause1 clause2 ...)))) + ((guard-aux reraise (test result1 result2 ...)) + (if test + (begin result1 result2 ...) + reraise)) + ((guard-aux reraise + (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (guard-aux reraise clause1 clause2 ...))))) + + ) + ) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index a42aad07e..a0adc8c65 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -53,12 +53,12 @@ namespace meevax r4rs, srfi_149, r5rs, + srfi_34, // Exception Handling for Programs + srfi_23, // Error reporting mechanism srfi_39, overture, srfi_8, srfi_1, - srfi_23, - srfi_34, srfi_78, r7rs, }; diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 45f959eaf..2deb4480e 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,3 +1,7 @@ +(define (traditional-macro-transformer f) + (lambda (form use-env mac-env) + (apply f (cdr form)))) + (define-syntax swap! (traditional-macro-transformer (lambda (a b) diff --git a/test/transformer.ss b/test/transformer.ss index c95cc4ff7..eaf78536b 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,3 +1,7 @@ +(define (traditional-macro-transformer f) + (lambda (form use-env mac-env) + (apply f (cdr form)))) + (define-syntax swap! (traditional-macro-transformer (lambda (a b) From f469313678ebb2df7ca5ad2aef1e834ec3552f96 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 16 May 2022 00:53:42 +0900 Subject: [PATCH 32/49] Fix `library::declare` to not to evaluate `begin` as syntax Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- include/meevax/kernel/library.hpp | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index ac1dd084f..4498cbfe7 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1003.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1004.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1003_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1004_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1003 +Meevax Lisp System, version 0.3.1004 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 85e8fb8e1..b44af5a89 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1003 +0.3.1004 diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 7aaa8f438..3b7deec8e 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -59,7 +59,7 @@ inline namespace kernel else if (declaration.is() and car(declaration).is() and car(declaration).as().value == "begin") { - for (let const& command_or_definition : declaration) + for (let const& command_or_definition : cdr(declaration)) { declare(command_or_definition); } From 26ba13fa2ddd6715fa2399ccf949484c11cad613 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Mon, 16 May 2022 20:24:28 +0900 Subject: [PATCH 33/49] Update SRFI 78 to be R7RS style library Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/srfi-78.ss | 473 +++++++++++++++++------------------ example/example.ss | 5 +- src/library/meevax.cpp | 6 +- test/abandoned.ss | 8 +- test/chibi-basic.ss | 4 +- test/er-macro-transformer.ss | 4 +- test/identifier.ss | 4 +- test/internal-definition.ss | 4 +- test/let-syntax.ss | 7 +- test/letrec-syntax.ss | 16 +- test/numerical-operations.ss | 4 +- test/r4rs-appendix.ss | 4 +- test/r4rs.ss | 4 +- test/r5rs.ss | 4 +- test/r7rs.ss | 4 +- test/read.ss | 8 +- test/sicp-1.ss | 4 +- test/srfi-45.ss | 2 + test/srfi-8.ss | 4 +- test/transformer.ss | 4 +- 22 files changed, 295 insertions(+), 286 deletions(-) diff --git a/README.md b/README.md index 4498cbfe7..507c5d70e 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1004.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1005.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1004_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1005_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1004 +Meevax Lisp System, version 0.3.1005 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index b44af5a89..a4e98fd83 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1004 +0.3.1005 diff --git a/basis/srfi-78.ss b/basis/srfi-78.ss index 3988e85d9..7e5acba71 100644 --- a/basis/srfi-78.ss +++ b/basis/srfi-78.ss @@ -19,253 +19,230 @@ ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -; -; ----------------------------------------------------------------------- -; -; Lightweight testing (reference implementation) -; ============================================== -; -; Sebastian.Egner@philips.com -; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions) -; -; history of this file: -; SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67 -; SE, 19-Jan-2006: (arg ...) made optional in check-ec -; -; Naming convention "check:" is used only internally. - -; -- portability -- - -; PLT: (require (lib "23.ss" "srfi") (lib "42.ss" "srfi")) -; Scheme48: ,open srfi-23 srfi-42 - -; -- utilities -- - -(define check:write write) - -; You can also use a pretty printer if you have one. -; However, the output might not improve for most cases -; because the pretty printers usually output a trailing -; newline. - -; PLT: (require (lib "pretty.ss")) (define check:write pretty-print) -; Scheme48: ,open pp (define check:write p) - -; -- mode -- - -(define check:mode #f) - -(define (check-set-mode! mode) - (set! check:mode - (case mode - ((off) 0) - ((summary) 1) - ((report-failed) 10) - ((report) 100) - (else (error "unrecognized mode" mode))))) - -(check-set-mode! 'report) - -; -- state -- - -(define check:correct #f) -(define check:failed #f) - -(define (check-reset!) - (set! check:correct 0) - (set! check:failed '())) - -(define (check:add-correct!) - (set! check:correct (+ check:correct 1))) -(define (check:add-failed! expression actual-result expected-result) - (set! check:failed - (cons (list expression actual-result expected-result) - check:failed))) - -(check-reset!) - -; -- reporting -- - -(define (check:report-expression expression) - (newline) - (check:write expression) - (display " => ")) - -(define (check:report-actual-result actual-result) - (check:write actual-result) - (display " ; ")) - -(define (check:report-correct cases) - (display "correct") - (if (not (= cases 1)) - (begin (display " (") - (display cases) - (display " cases checked)"))) - (newline)) - -(define (check:report-failed expected-result) - (display "*** failed ***") - (newline) - (display " ; expected result: ") - (check:write expected-result) - (newline)) - -(define (check-report) - (if (>= check:mode 1) - (begin - (newline) - (display "; *** checks *** : ") - (display check:correct) - (display " correct, ") - (display (length check:failed)) - (display " failed.") - (if (or (null? check:failed) (<= check:mode 1)) - (newline) - (let* ((w (car (reverse check:failed))) - (expression (car w)) - (actual-result (cadr w)) - (expected-result (caddr w))) - (display " First failed example:") - (newline) +(define-library (srfi 78) + (import (scheme base) + (scheme cxr) + (scheme write) + (srfi 211 explicit-renaming)) + + (export check + ; check-ec + check-report + check-set-mode! + check-reset! + check-passed? + ) + + (begin (define check:write write) + + (define check:mode #f) + + (define (check-set-mode! mode) + (set! check:mode + (case mode + ((off) 0) + ((summary) 1) + ((report-failed) 10) + ((report) 100) + (else (error "unrecognized mode" mode))))) + + (check-set-mode! 'report) + + (define check:correct #f) + + (define check:failed #f) + + (define (check-reset!) + (set! check:correct 0) + (set! check:failed '())) + + (define (check:add-correct!) + (set! check:correct (+ check:correct 1))) + + (define (check:add-failed! expression actual-result expected-result) + (set! check:failed + (cons (list expression actual-result expected-result) + check:failed))) + + (check-reset!) + + (define (check:report-expression expression) + (newline) + (check:write expression) + (display " => ")) + + (define (check:report-actual-result actual-result) + (check:write actual-result) + (display " ; ")) + + (define (check:report-correct cases) + (display "correct") + (if (not (= cases 1)) + (begin (display " (") + (display cases) + (display " cases checked)"))) + (newline)) + + (define (check:report-failed expected-result) + (display "*** failed ***") + (newline) + (display " ; expected result: ") + (check:write expected-result) + (newline)) + + (define (check-report) + (if (>= check:mode 1) + (begin (newline) + (display "; *** checks *** : ") + (display check:correct) + (display " correct, ") + (display (length check:failed)) + (display " failed.") + (if (or (null? check:failed) (<= check:mode 1)) + (newline) + (let* ((w (car (reverse check:failed))) + (expression (car w)) + (actual-result (cadr w)) + (expected-result (caddr w))) + (display " First failed example:") + (newline) + (check:report-expression expression) + (check:report-actual-result actual-result) + (check:report-failed expected-result)))))) + + (define (check-passed? expected-total-count) + (and (zero? (length check:failed)) + (= check:correct expected-total-count))) + + (define (check:proc expression thunk equal expected-result) + (case check:mode + ((0) #f) + ((1) + (let ((actual-result (thunk))) + (if (equal actual-result expected-result) + (check:add-correct!) + (check:add-failed! expression actual-result expected-result)))) + ((10) + (let ((actual-result (thunk))) + (if (equal actual-result expected-result) + (check:add-correct!) + (begin + (check:report-expression expression) + (check:report-actual-result actual-result) + (check:report-failed expected-result) + (check:add-failed! expression actual-result expected-result))))) + ((100) (check:report-expression expression) - (check:report-actual-result actual-result) - (check:report-failed expected-result)))))) - -(define (check-passed? expected-total-count) - (and (zero? (length check:failed)) - (= check:correct expected-total-count))) - -; -- simple checks -- - -(define (check:proc expression thunk equal expected-result) - (case check:mode - ((0) #f) - ((1) - (let ((actual-result (thunk))) - (if (equal actual-result expected-result) - (check:add-correct!) - (check:add-failed! expression actual-result expected-result)))) - ((10) - (let ((actual-result (thunk))) - (if (equal actual-result expected-result) - (check:add-correct!) - (begin - (check:report-expression expression) - (check:report-actual-result actual-result) - (check:report-failed expected-result) - (check:add-failed! expression actual-result expected-result))))) - ((100) - (check:report-expression expression) - (let ((actual-result (thunk))) - (check:report-actual-result actual-result) - (if (equal actual-result expected-result) - (begin (check:report-correct 1) - (check:add-correct!)) - (begin (check:report-failed expected-result) - (check:add-failed! expression - actual-result - expected-result))))) - (else (error "unrecognized check:mode" check:mode))) - (if #f #f)) - -; (define-syntax check -; (syntax-rules (=>) -; ((check expr => expected) -; (check expr (=> equal?) expected)) -; ((check expr (=> equal) expected) -; (if (>= check:mode 1) -; (check:proc 'expr (lambda () expr) equal expected))))) - -(define-syntax check - (er-macro-transformer - (lambda (form rename compare) - (cond ((compare (rename '=>) (caddr form)) - `(,(rename 'check) ,(cadr form) (,(rename '=>) ,(rename 'equal?)) ,(cadddr form))) - ((compare (rename '=>) (caaddr form)) - (if (<= 1 check:mode) - `(,(rename 'check:proc) ',(cadr form) - (,(rename 'lambda) () ,(cadr form)) - ,(cadr (caddr form)) - ',(cadddr form)))) - (else (unspecified)))))) - -; -- parametric checks -- - -; (define (check:proc-ec w) -; (let ((correct? (car w)) -; (expression (cadr w)) -; (actual-result (caddr w)) -; (expected-result (cadddr w)) -; (cases (car (cddddr w)))) -; (if correct? -; (begin (if (>= check:mode 100) -; (begin (check:report-expression expression) -; (check:report-actual-result actual-result) -; (check:report-correct cases))) -; (check:add-correct!)) -; (begin (if (>= check:mode 10) -; (begin (check:report-expression expression) -; (check:report-actual-result actual-result) -; (check:report-failed expected-result))) -; (check:add-failed! expression -; actual-result -; expected-result))))) -; -; (define-syntax check-ec:make -; (syntax-rules (=>) -; ((check-ec:make qualifiers expr (=> equal) expected (arg ...)) -; (if (>= check:mode 1) -; (check:proc-ec -; (let ((cases 0)) -; (let ((w (first-ec -; #f -; qualifiers -; (:let equal-pred equal) -; (:let expected-result expected) -; (:let actual-result -; (let ((arg arg) ...) ; (*) -; expr)) -; (begin (set! cases (+ cases 1))) -; (if (not (equal-pred actual-result expected-result))) -; (list (list 'let (list (list 'arg arg) ...) 'expr) -; actual-result -; expected-result -; cases)))) -; (if w -; (cons #f w) -; (list #t -; '(check-ec qualifiers -; expr (=> equal) -; expected (arg ...)) -; (if #f #f) -; (if #f #f) -; cases))))))))) -; -; ; (*) is a compile-time check that (arg ...) is a list -; ; of pairwise disjoint bound variables at this point. -; -; (define-syntax check-ec -; (syntax-rules (nested =>) -; ((check-ec expr => expected) -; (check-ec:make (nested) expr (=> equal?) expected ())) -; ((check-ec expr (=> equal) expected) -; (check-ec:make (nested) expr (=> equal) expected ())) -; ((check-ec expr => expected (arg ...)) -; (check-ec:make (nested) expr (=> equal?) expected (arg ...))) -; ((check-ec expr (=> equal) expected (arg ...)) -; (check-ec:make (nested) expr (=> equal) expected (arg ...))) -; -; ((check-ec qualifiers expr => expected) -; (check-ec:make qualifiers expr (=> equal?) expected ())) -; ((check-ec qualifiers expr (=> equal) expected) -; (check-ec:make qualifiers expr (=> equal) expected ())) -; ((check-ec qualifiers expr => expected (arg ...)) -; (check-ec:make qualifiers expr (=> equal?) expected (arg ...))) -; ((check-ec qualifiers expr (=> equal) expected (arg ...)) -; (check-ec:make qualifiers expr (=> equal) expected (arg ...))) -; -; ((check-ec (nested q1 ...) q etc ...) -; (check-ec (nested q1 ... q) etc ...)) -; ((check-ec q1 q2 etc ...) -; (check-ec (nested q1 q2) etc ...)))) + (let ((actual-result (thunk))) + (check:report-actual-result actual-result) + (if (equal actual-result expected-result) + (begin (check:report-correct 1) + (check:add-correct!)) + (begin (check:report-failed expected-result) + (check:add-failed! expression + actual-result + expected-result))))) + (else (error "unrecognized check:mode" check:mode))) + (if #f #f)) + + ; (define-syntax check + ; (syntax-rules (=>) + ; ((check expr => expected) + ; (check expr (=> equal?) expected)) + ; ((check expr (=> equal) expected) + ; (if (>= check:mode 1) + ; (check:proc 'expr (lambda () expr) equal expected))))) + + (define-syntax check + (er-macro-transformer + (lambda (form rename compare) + (cond ((compare (rename '=>) (caddr form)) + `(,(rename 'check) ,(cadr form) (,(rename '=>) ,(rename 'equal?)) ,(cadddr form))) + ((compare (rename '=>) (caaddr form)) + (if (<= 1 check:mode) + `(,(rename 'check:proc) ',(cadr form) + (,(rename 'lambda) () ,(cadr form)) + ,(cadr (caddr form)) + ',(cadddr form)))) + (else (unspecified)))))) + + ; (define (check:proc-ec w) + ; (let ((correct? (car w)) + ; (expression (cadr w)) + ; (actual-result (caddr w)) + ; (expected-result (cadddr w)) + ; (cases (car (cddddr w)))) + ; (if correct? + ; (begin (if (>= check:mode 100) + ; (begin (check:report-expression expression) + ; (check:report-actual-result actual-result) + ; (check:report-correct cases))) + ; (check:add-correct!)) + ; (begin (if (>= check:mode 10) + ; (begin (check:report-expression expression) + ; (check:report-actual-result actual-result) + ; (check:report-failed expected-result))) + ; (check:add-failed! expression + ; actual-result + ; expected-result))))) + ; + ; (define-syntax check-ec:make + ; (syntax-rules (=>) + ; ((check-ec:make qualifiers expr (=> equal) expected (arg ...)) + ; (if (>= check:mode 1) + ; (check:proc-ec + ; (let ((cases 0)) + ; (let ((w (first-ec + ; #f + ; qualifiers + ; (:let equal-pred equal) + ; (:let expected-result expected) + ; (:let actual-result + ; (let ((arg arg) ...) ; (*) + ; expr)) + ; (begin (set! cases (+ cases 1))) + ; (if (not (equal-pred actual-result expected-result))) + ; (list (list 'let (list (list 'arg arg) ...) 'expr) + ; actual-result + ; expected-result + ; cases)))) + ; (if w + ; (cons #f w) + ; (list #t + ; '(check-ec qualifiers + ; expr (=> equal) + ; expected (arg ...)) + ; (if #f #f) + ; (if #f #f) + ; cases))))))))) + ; + ; ; (*) is a compile-time check that (arg ...) is a list + ; ; of pairwise disjoint bound variables at this point. + ; + ; (define-syntax check-ec + ; (syntax-rules (nested =>) + ; ((check-ec expr => expected) + ; (check-ec:make (nested) expr (=> equal?) expected ())) + ; ((check-ec expr (=> equal) expected) + ; (check-ec:make (nested) expr (=> equal) expected ())) + ; ((check-ec expr => expected (arg ...)) + ; (check-ec:make (nested) expr (=> equal?) expected (arg ...))) + ; ((check-ec expr (=> equal) expected (arg ...)) + ; (check-ec:make (nested) expr (=> equal) expected (arg ...))) + ; + ; ((check-ec qualifiers expr => expected) + ; (check-ec:make qualifiers expr (=> equal?) expected ())) + ; ((check-ec qualifiers expr (=> equal) expected) + ; (check-ec:make qualifiers expr (=> equal) expected ())) + ; ((check-ec qualifiers expr => expected (arg ...)) + ; (check-ec:make qualifiers expr (=> equal?) expected (arg ...))) + ; ((check-ec qualifiers expr (=> equal) expected (arg ...)) + ; (check-ec:make qualifiers expr (=> equal) expected (arg ...))) + ; + ; ((check-ec (nested q1 ...) q etc ...) + ; (check-ec (nested q1 ... q) etc ...)) + ; ((check-ec q1 q2 etc ...) + ; (check-ec (nested q1 q2) etc ...)))) + ) + ) diff --git a/example/example.ss b/example/example.ss index 7a9a976b9..8261ff990 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,5 @@ -(import (meevax foreign-function-interface)) +(import (meevax foreign-function-interface) + (srfi 78)) (define dummy-procedure (foreign-function "build/libexample.so" "dummy_procedure")) @@ -10,4 +11,4 @@ (check (foreign-function? length-of-arguments) => #t) (check (length-of-arguments 'hoge 42 #(1 2 3) 3.14) => 4) -(exit (check-passed? check:correct)) +(exit (check-passed? 4)) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index a0adc8c65..8df815096 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -32,9 +32,7 @@ namespace meevax import("(meevax macro)"); import("(meevax number)"); import("(meevax port)"); - import("(meevax read)"); import("(meevax syntax)"); // quote-syntax - import("(meevax write)"); define("features", [](auto&&...) { @@ -55,12 +53,12 @@ namespace meevax r5rs, srfi_34, // Exception Handling for Programs srfi_23, // Error reporting mechanism - srfi_39, + srfi_39, // Parameter objects overture, srfi_8, srfi_1, - srfi_78, r7rs, + srfi_78, // Lightweight testing }; for (auto const& code : codes) diff --git a/test/abandoned.ss b/test/abandoned.ss index 59bf26507..3f972666a 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (define p1 (make-parameter 1)) (define p2 (make-parameter "hoge")) @@ -7,8 +9,8 @@ (parameterize ((p1 42) (p2 "fuga")) - (print "p1 = " (p1)) (newline) - (print "p2 = " (p2)) (newline) + (display "p1 = ") (display (p1)) (newline) + (display "p2 = ") (display (p2)) (newline) (check (p1) => 42) (check (p2) => "fuga") (list (p1) (p2))) @@ -109,4 +111,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 38)) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 7475855e7..76abdbdee 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; ---- Chibi-Scheme's Basic Tests ---------------------------------------------- ; ; NOTE @@ -287,4 +289,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 29)) diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 2deb4480e..69ad5981d 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (define (traditional-macro-transformer f) (lambda (form use-env mac-env) (apply f (cdr form)))) @@ -46,4 +48,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 5)) diff --git a/test/identifier.ss b/test/identifier.ss index 98fab025d..03408f85c 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (define value 42) ; ------------------------------------------------------------------------------ @@ -72,4 +74,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 25)) diff --git a/test/internal-definition.ss b/test/internal-definition.ss index bd396453e..f2d771455 100644 --- a/test/internal-definition.ss +++ b/test/internal-definition.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (define a 100) (define b 200) @@ -17,4 +19,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 5)) diff --git a/test/let-syntax.ss b/test/let-syntax.ss index fe52f0a31..ecbf1750c 100644 --- a/test/let-syntax.ss +++ b/test/let-syntax.ss @@ -1,4 +1,5 @@ -; (import (scheme base)) +(import (scheme base) + (srfi 78)) (define result (list)) @@ -58,6 +59,6 @@ (check result => outer) -; (check-report) +(check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 5)) diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index f4a0f852c..d140aa17c 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (letrec-syntax ((my-and (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form)) #t) @@ -25,11 +27,13 @@ (if even?)) (check (my-or x (let temp) (if y) y) => 7))) -(check (let ((x 'outer)) - (letrec-syntax ((m (er-macro-transformer - (lambda (form rename compare) - (rename 'x))))) - (let ((x 'inner)) - (m)))) => outer) +; (check (let ((x 'outer)) +; (letrec-syntax ((m (er-macro-transformer +; (lambda (form rename compare) +; (rename 'x))))) +; (let ((x 'inner)) +; (m)))) => outer) (check-report) + +(exit (check-passed? 2)) diff --git a/test/numerical-operations.ss b/test/numerical-operations.ss index 83aa5cf20..f64c59807 100644 --- a/test/numerical-operations.ss +++ b/test/numerical-operations.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; ---- 6.2.6. Numerical operations --------------------------------------------- (check (rational? 1/3) => #t) @@ -106,4 +108,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 58)) diff --git a/test/r4rs-appendix.ss b/test/r4rs-appendix.ss index dc62d0f7f..2fbb6af33 100644 --- a/test/r4rs-appendix.ss +++ b/test/r4rs-appendix.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; (check (symbol? (syntax x)) => #f) ; (check @@ -195,4 +197,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 1)) diff --git a/test/r4rs.ss b/test/r4rs.ss index a8ffc922c..93e81836a 100644 --- a/test/r4rs.ss +++ b/test/r4rs.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (check (* 5 8) => 40) ;;; The FACT procedure computes the factorial @@ -660,4 +662,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 285)) diff --git a/test/r5rs.ss b/test/r5rs.ss index 3e600df20..69de8b8cb 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; ---- 1.3.4 ------------------------------------------------------------------- (check (* 5 8) => 40) @@ -950,4 +952,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 290)) diff --git a/test/r7rs.ss b/test/r7rs.ss index d0d598cad..ad9938319 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; ---- 2.1. Identifiers -------------------------------------------------------- (check (symbol? '...) => #t) @@ -1188,4 +1190,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 367)) diff --git a/test/read.ss b/test/read.ss index 7ea447e92..a132081f1 100644 --- a/test/read.ss +++ b/test/read.ss @@ -1,7 +1,7 @@ -; (import (scheme base) -; (scheme file) -; (scheme read) -; (srfi 78)) +(import (scheme base) + (scheme file) + (scheme read) + (srfi 78)) (let ((lambda.ss "/home/yamasa/.meevax/test/lambda.ss")) (check (read (open-input-file lambda.ss)) => #\x03bb) diff --git a/test/sicp-1.ss b/test/sicp-1.ss index e4d071e82..40c4cca4c 100644 --- a/test/sicp-1.ss +++ b/test/sicp-1.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ; ---- Section 1.1.1 ----------------------------------------------------------- (check 486 => 486) @@ -480,4 +482,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 78)) diff --git a/test/srfi-45.ss b/test/srfi-45.ss index 20fc33c42..707fb21ea 100644 --- a/test/srfi-45.ss +++ b/test/srfi-45.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + ;========================================================================= ; Memoization test 1: diff --git a/test/srfi-8.ss b/test/srfi-8.ss index 867512cad..a7f098b34 100644 --- a/test/srfi-8.ss +++ b/test/srfi-8.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (check (call-with-values (lambda () (values 4 5)) (lambda (a b) b)) @@ -23,4 +25,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 5)) diff --git a/test/transformer.ss b/test/transformer.ss index eaf78536b..9a3f93ad3 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,3 +1,5 @@ +(import (srfi 78)) + (define (traditional-macro-transformer f) (lambda (form use-env mac-env) (apply f (cdr form)))) @@ -123,4 +125,4 @@ (check-report) -(exit (check-passed? check:correct)) +(exit (check-passed? 12)) From fa576f0a214cd3724170f4c6ebc8c7ed87eb353d Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 17 May 2022 02:34:59 +0900 Subject: [PATCH 34/49] Update SRFI 8 to be R7RS style library Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/srfi-1.ss | 2 ++ basis/srfi-8.ss | 22 +++++++++------------- src/library/meevax.cpp | 7 +------ src/main.cpp | 2 +- test/er-macro-transformer.ss | 3 ++- test/identifier.ss | 3 ++- test/transformer.ss | 6 +++++- 9 files changed, 26 insertions(+), 27 deletions(-) diff --git a/README.md b/README.md index 507c5d70e..5efa5acf8 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1005.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1006.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1005_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1006_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1005 +Meevax Lisp System, version 0.3.1006 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index a4e98fd83..fb38e1547 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1005 +0.3.1006 diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index cdc2dec7d..632cf86c8 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -1,3 +1,5 @@ +(import (srfi 8)) + ; ------------------------------------------------------------------------------ ; ; https://srfi.schemers.org/srfi-1/srfi-1.html diff --git a/basis/srfi-8.ss b/basis/srfi-8.ss index ba2b1663e..5cfa89e53 100644 --- a/basis/srfi-8.ss +++ b/basis/srfi-8.ss @@ -1,13 +1,9 @@ -; (define-syntax receive -; (syntax-rules () -; ((receive parameters expression . body) -; (call-with-values -; (lambda () expression) -; (lambda parameters . body))))) - -(define-syntax receive - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'call-with-values) - (,(rename 'lambda) () ,(caddr form)) - (,(rename 'lambda) ,(cadr form) ,@(cdddr form)))))) +(define-library (srfi 8) + (import (scheme base)) + (export receive) + (begin (define-syntax receive + (syntax-rules () + ((receive parameters expression . body) + (call-with-values + (lambda () expression) + (lambda parameters . body))))))) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 8df815096..2b77fa8c9 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -25,14 +25,9 @@ namespace meevax import("(meevax character)"); import("(meevax context)"); import("(meevax control)"); - import("(meevax evaluate)"); - import("(meevax exception)"); - import("(meevax experimental)"); import("(meevax inexact)"); - import("(meevax macro)"); import("(meevax number)"); import("(meevax port)"); - import("(meevax syntax)"); // quote-syntax define("features", [](auto&&...) { @@ -55,7 +50,7 @@ namespace meevax srfi_23, // Error reporting mechanism srfi_39, // Parameter objects overture, - srfi_8, + srfi_8, // receive: Binding to multiple values srfi_1, r7rs, srfi_78, // Lightweight testing diff --git a/src/main.cpp b/src/main.cpp index ad46f07ab..80ff27476 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -38,7 +38,7 @@ auto main(int const argc, char const* const* const argv) -> int while (main.is_interactive_mode() and main.char_ready()) { main.print(horizontal_rule()); - main.write(standard_output, main.current_prompt()); + main.write(standard_output, length(main.global()), "/", main.current_prompt()); main.print(main.evaluate(main.read())); } diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 69ad5981d..0166630ae 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (only (meevax macro) transformer?) + (srfi 78)) (define (traditional-macro-transformer f) (lambda (form use-env mac-env) diff --git a/test/identifier.ss b/test/identifier.ss index 03408f85c..e110b6bcc 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (meevax macro) + (srfi 78)) (define value 42) diff --git a/test/transformer.ss b/test/transformer.ss index 9a3f93ad3..4b8b878e6 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,4 +1,8 @@ -(import (srfi 78)) +(import (only (meevax macro) transformer?) + (srfi 78) + (srfi 211 syntactic-closures) + (srfi 211 explicit-renaming) + ) (define (traditional-macro-transformer f) (lambda (form use-env mac-env) From afdfd33b5b8fc3391475ac7e6b3459def89ba7f5 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 17 May 2022 03:51:21 +0900 Subject: [PATCH 35/49] Update SRFI 1 to be R7RS style library Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 17 +- basis/srfi-1.ss | 1908 ++++++++++++++++++++++----------------------- test/srfi-8.ss | 3 +- 5 files changed, 940 insertions(+), 996 deletions(-) diff --git a/README.md b/README.md index 5efa5acf8..ecc0c9a18 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1006.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1007.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1006_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1007_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1006 +Meevax Lisp System, version 0.3.1007 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index fb38e1547..52634bc74 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1006 +0.3.1007 diff --git a/basis/overture.ss b/basis/overture.ss index 767747568..cc726f262 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -133,7 +133,7 @@ cddr null? list? - ; make-list + make-list list length append @@ -147,7 +147,7 @@ assq assv assoc - ; list-copy + list-copy symbol? ; symbol=? symbol->string @@ -313,9 +313,22 @@ (define boolean=? eqv?) + (define (make-list k . x) + (let ((x (if (pair? x) (car x) #f))) + (do ((i k (- i 1)) + (xs '() (cons x xs))) + ((<= i 0) xs)))) + (define (list-set! x k object) (set-car! (list-tail x k) object)) + (define (list-copy x) + (let list-copy ((x x)) + (if (pair? x) + (cons (car x) + (list-copy (cdr x))) + x))) + (define symbol=? eqv?) (define (string-map f x . xs) diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index 632cf86c8..4f19b076a 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -1,7 +1,3 @@ -(import (srfi 8)) - -; ------------------------------------------------------------------------------ -; ; https://srfi.schemers.org/srfi-1/srfi-1.html ; ; Copyright (c) 1998, 1999 by Olin Shivers. @@ -9,989 +5,923 @@ ; You may do as you please with this code as long as you do not remove this ; copyright notice or hold me liable for its use. Please send bug reports to ; shivers@ai.mit.edu. -Olin -; -; ------------------------------------------------------------------------------ - -; cons - -; list - -(define (xcons x y) - (cons y x)) - -(define (tree-copy x) - (letrec ((tree-copy (lambda (x) - (if (not (pair? x)) x - (cons (tree-copy (car x)) - (tree-copy (cdr x))))))) - (tree-copy x))) - -(define (make-list len . maybe-elt) - (let ((elt (cond ((null? maybe-elt) #f) ; Default value - ((null? (cdr maybe-elt)) (car maybe-elt)) - (else (error "Too many arguments to MAKE-LIST" - (cons len maybe-elt)))))) - (do ((i len (- i 1)) - (ans '() (cons elt ans))) - ((<= i 0) ans)))) - -(define (list-tabulate len proc) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - -(define (cons* first . rest) - (let rec ((x first) - (rest rest)) - (if (pair? rest) - (cons x (rec (car rest) - (cdr rest))) - x))) - -(define (list-copy x) - (let rec ((x x)) - (if (pair? x) - (cons (car x) (rec (cdr x))) - x))) - -; (define (iota count . maybe-start+step) -; (if (< count 0) (error "Negative step count" iota count)) -; (let-optionals maybe-start+step ((start 0) (step 1)) -; (let loop ((n 0) (r '())) -; (if (= n count) -; (reverse r) -; (loop (+ 1 n) -; (cons (+ start (* n step)) r)))))) - -(define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - -(define (proper-list? x) - (let rec ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (rec x lag))) - (null? x))) - (null? x)))) - -; (define list? proper-list?) - -(define (dotted-list? x) - (let rec ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (rec x lag))) - (not (null? x)))) - (not (null? x))))) - -(define (circular-list? x) - (let rec ((x x) (lag x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (or (eq? x lag) (rec x lag)))))))) - -(define (not-pair? x) (not (pair? x))) - -(define (null-list? x) - (cond ((pair? x) #f) - ((null? x) #t) - (else (error "null-list?: argument out of domain" x)))) - -(define (list= = . lists) - (or (null? lists) ; special case - (let lp1 ((list-a (car lists)) - (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((pair-a list-a) - (pair-b list-b)) - (if (null-list? pair-a) - (and (null-list? pair-b) - (lp1 list-b others)) - (and (not (null-list? pair-b)) - (= (car pair-a) - (car pair-b)) - (lp2 (cdr pair-a) - (cdr pair-b))))))))))) - -; (define (length x) -; (let rec ((x x) (len 0)) -; (if (pair? x) -; (rec (cdr x) (+ len 1)) -; len))) - -(define (length+ x) ; Returns #f if X is circular. - (let rec ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (rec x lag len))) - len)) - len))) - -(define (zip list1 . more-lists) (apply map list list1 more-lists)) - -; (define (caar x) (car (car x))) -; (define (cadr x) (car (cdr x))) -; (define (cdar x) (cdr (car x))) -; (define (cddr x) (cdr (cdr x))) - -; (define (caaar x) (car (car (car x)))) -; (define (caadr x) (car (car (cdr x)))) -; (define (cadar x) (car (cdr (car x)))) -; (define (caddr x) (car (cdr (cdr x)))) -; (define (cdaar x) (cdr (car (car x)))) -; (define (cdadr x) (cdr (car (cdr x)))) -; (define (cddar x) (cdr (cdr (car x)))) -; (define (cdddr x) (cdr (cdr (cdr x)))) - -; (define (caaaar x) (car (car (car (car x))))) -; (define (caaadr x) (car (car (car (cdr x))))) -; (define (caadar x) (car (car (cdr (car x))))) -; (define (caaddr x) (car (car (cdr (cdr x))))) -; (define (cadaar x) (car (cdr (car (car x))))) -; (define (cadadr x) (car (cdr (car (cdr x))))) -; (define (caddar x) (car (cdr (cdr (car x))))) -; (define (cadddr x) (car (cdr (cdr (cdr x))))) -; (define (cdaaar x) (cdr (car (car (car x))))) -; (define (cdaadr x) (cdr (car (car (cdr x))))) -; (define (cdadar x) (cdr (car (cdr (car x))))) -; (define (cdaddr x) (cdr (car (cdr (cdr x))))) -; (define (cddaar x) (cdr (cdr (car (car x))))) -; (define (cddadr x) (cdr (cdr (car (cdr x))))) -; (define (cdddar x) (cdr (cdr (cdr (car x))))) -; (define (cddddr x) (cdr (cdr (cdr (cdr x))))) - -(define (first x) (car x)) -(define (second x) (car (cdr x))) -(define (third x) (car (cdr (cdr x)))) -(define (fourth x) (car (cdr (cdr (cdr x))))) -(define (fifth x) (car (cdr (cdr (cdr (cdr x)))))) -(define (sixth x) (car (cdr (cdr (cdr (cdr (cdr x))))))) -(define (seventh x) (car (cdr (cdr (cdr (cdr (cdr (cdr x)))))))) -(define (eighth x) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))) -(define (ninth x) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x)))))))))) -(define (tenth x) (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))))) - -(define (car+cdr pair) - (values (car pair) - (cdr pair))) - -(define (take x k) - (let rec ((x x) - (k k)) - (if (zero? k) '() - (cons (car x) - (rec (cdr x) (- k 1)))))) - -(define (take! x k) - (if (zero? k) - (begin (set-cdr! (drop x (- k 1)) '()) x))) - -(define (drop x k) - (let rec ((x x) (k k)) - (if (zero? k) x - (rec (cdr x) (- k 1))))) - -(define (drop! lis k) - (if (negative? k) - (let ((nelts (+ k (length lis)))) - (if (zero? nelts) '() - (begin (set-cdr! (list-tail lis (- nelts 1)) '()) - lis))) - (list-tail lis k))) - -(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) - (let rec ((lag x) - (lead (cdr lead))) - (if (pair? lead) - (rec (cdr lag) - (cdr lead)) - (begin (set-cdr! lag '()) x))) - '()))) - -; (define (list-ref x k) (car (drop x k))) - -(define (split-at x k) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) - -(define (split-at! x k) - (if (zero? k) - (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) - (values x suffix)))) - -(define (last x) (car (last-pair x))) - -(define (last-pair lis) - (let rec ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (rec tail) lis)))) - -(define (unzip1 lis) (map car lis)) - -(define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - -(define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - -(define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - -(define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - -; (define (append . xs) -; (if (pair? xs) -; (letrec ((append (lambda (x xs) -; (if (pair? xs) -; ((lambda (tail) -; (fold-right cons tail x)) -; (append (car xs) -; (cdr xs))) -; x)))) -; (append (car xs) -; (cdr xs))) -; '())) - -(define (append! . lists) - (let lp ((lists lists) (prev '())) ; First, scan through lists looking for a non-empty one. - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - (let lp2 ((tail-cons (last-pair first)) ; Now, do the splicing. - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - -; (define (append-reverse rev-head tail) (fold cons tail rev-head)) -; -; (define (append-reverse! rev-head tail) -; (pair-fold (lambda (pair tail) -; (set-cdr! pair tail) pair) -; tail -; rev-head)) - -; Hand-inline the FOLD and PAIR-FOLD ops for speed. - -(define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - -(define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - -(define (concatenate xs) (reduce-right append '() xs)) -(define (concatenate! xs) (reduce-right append! '() xs)) - -; Return (map cdr lists). -; However, if any element of LISTS is empty, just abort and return '(). -(define (%cdrs xs) - (call-with-current-continuation! - (lambda (abort) - (letrec ((recur (lambda (xs) - (if (pair? xs) - ((lambda (x) - (if (null-list? x) - (abort '()) - (cons (cdr x) - (recur (cdr xs))))) - (car xs)) - '())))) - (recur xs))))) - -(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (letrec ((recur (lambda (lists) - (if (pair? lists) - (cons (caar lists) - (recur (cdr lists))) - (list last-elt))))) - (recur lists))) - -(define (%cars+cdrs lists) - (call-with-current-continuation! - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - -(define (%cars+cdrs+ lists cars-final) - (call-with-current-continuation! - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - -(define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - -(define (count pred list1 . lists) - (if (pair? lists) - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - -(define (unfold-right p f g seed . maybe-tail) - (let lp ((seed seed) - (ans (if (pair? maybe-tail) (car maybe-tail) '()))) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - -(define (unfold p f g seed . maybe-tail-gen) - (if (pair? maybe-tail-gen) - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) - (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - -(define (fold kons knil lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - (let lp ((lis lis1) (ans knil)) - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - -(define (fold-right f knil x . xs) - (if (pair? xs) - (letrec ((recur (lambda (lists) - ((lambda (cdrs) - (if (null? cdrs) knil - (apply f (%cars+ lists (recur cdrs))))) - (%cdrs lists))))) - (recur (cons x xs))) - (letrec ((recur (lambda (x) - (if (null-list? x) knil - ((lambda (head) - (f head (recur (cdr x)))) - (car x)))))) - (recur x)))) - -(define (pair-fold-right f zero lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - (let recur ((lis lis1)) - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - -(define (pair-fold f zero lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (lp tail (f lis ans))))))) - -(define (reduce f ridentity lis) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - -(define (reduce-right f ridentity lis) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - -(define (append-map f lis1 . lists) (really-append-map append-map append f lis1 lists)) -(define (append-map! f lis1 . lists) (really-append-map append-map! append! f lis1 lists)) - -(define (really-append-map who appender f lis1 lists) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - -; (define (for-each f x . xs) -; (define (for-each f x) -; (if (pair? x) -; (begin (f (car x)) -; (for-each f (cdr x))))) -; (if (null? xs) -; (for-each f x) -; (begin (apply map f x xs) -; (if #f #f)))) - -(define (pair-for-each proc lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) - (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) - (proc lis) - (lp tail)))))) - -(define (map! f lis1 . lists) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - -(define (filter-map f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) - (else tail))))))) - -(define (map-in-order f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) - (cons x (recur cdrs))) - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) - (cons x (recur tail))))))) - -; (define map map-in-order) - -(define (filter pred lis) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) - -; (define (filter pred lis) ; Another version that shares longest tail. -; (receive (ans no-del?) -; (let recur ((l l)) -; (if (null-list? l) (values l #t) -; (let ((x (car l)) -; (tl (cdr l))) -; (if (pred x) -; (receive (ans no-del?) (recur tl) -; (if no-del? -; (values l #t) -; (values (cons x ans) #f))) -; (receive (ans no-del?) (recur tl) ; Delete X. -; (values ans #f)))))) -; ans)) - -; Things are much simpler if you are willing to push N stack frames & do N -; set-cdr! writes, where N is the length of the answer. -(define (filter! pred lis) - (let recur ((lis lis)) - (if (pair? lis) - (cond ((pred (car lis)) - (set-cdr! lis (recur (cdr lis))) - lis) - (else (recur (cdr lis)))) - lis))) - -; (define (filter! pred lis) -; (let lp ((ans lis)) -; (cond ((null-list? ans) ans) -; ((not (pred (car ans))) (lp (cdr ans))) -; (else (letrec ((scan-in (lambda (prev lis) -; (if (pair? lis) -; (if (pred (car lis)) -; (scan-in lis (cdr lis)) -; (scan-out prev (cdr lis)))))) -; (scan-out (lambda (prev lis) -; (let lp ((lis lis)) -; (if (pair? lis) -; (if (pred (car lis)) -; (begin (set-cdr! prev lis) -; (scan-in lis (cdr lis))) -; (lp (cdr lis))) -; (set-cdr! prev lis)))))) -; (scan-in ans (cdr ans)) -; ans))))) - -(define (partition pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - -(define (partition! pred lis) - (if (null-list? lis) - (values lis lis) - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) - (if (pred (car lis)) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) - (else (scan-out prev-l l (cdr l)) - (values lis l)))) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) - (scan-in l prev-l (cdr l)) - (values l lis)) - (else (lp l (cdr l))))))))) - -(define (remove satisfy? x) (filter (lambda (y) (not (satisfy? y))) x)) -(define (remove! satisfy? x) (filter! (lambda (y) (not (satisfy? y))) x)) - -(define (delete x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (y) (not (= x y))) lis))) - -(define (delete! x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (y) (not (= x y))) lis))) - -(define (member x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (find-tail (lambda (y) (= x y)) lis))) - -; (define (memq key x) (member key x eq?)) -; (define (memv key x) (member key x eqv?)) - -(define (delete-duplicates lis . maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - -(define (delete-duplicates! lis maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - -; (define (assoc x lis . maybe-=) -; (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) -; (find (lambda (entry) (= x (car entry))) lis))) -; -; (define (assq key alist) (assoc key alist eq?)) -; (define (assv key alist) (assoc key alist eqv?)) - -(define (alist-cons key datum alist) - (cons (cons key datum) alist)) - -(define (alist-copy alist) - (map (lambda (each) - (cons (car each) - (cdr each))) - alist)) - -(define (alist-delete key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (elt) (not (= key (car elt)))) alist))) - -(define (alist-delete! key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (elt) (not (= key (car elt)))) alist))) - -(define (find pred list) - (cond ((find-tail pred list) => car) - (else #f))) - -(define (find-tail pred list) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - -(define (take-while pred lis) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) - -(define (take-while! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) - (if (pair? rest) - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (set-cdr! prev '()))))) - lis))) - -(define (drop-while pred lis) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) - -(define (span pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - -(define (span! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (begin (set-cdr! prev '()) - rest))))))) - (values lis suffix)))) - -(define (break break? x) (span (lambda (x) (not (break? x))) x)) -(define (break! break? x) (span! (lambda (x) (not (break? x))) x)) - -(define (any pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) - (or (pred head) (lp (car tail) (cdr tail)))))))) - -(define (every pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) - (and (pred head) (lp (car tail) (cdr tail)))))))) - -(define (list-index pred lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - -; (define (reverse xs) -; (fold cons '() xs)) - -(define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - -(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) - -(define (lset<= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - -(define (lset= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - -(define (lset-adjoin = lis . elts) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - -(define (lset-union = . lists) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) + +(define-library (srfi 1) + (import (scheme base) + (scheme cxr) + (srfi 8)) + + (export cons list xcons cons* make-list list-tabulate list-copy circular-list + iota pair? null? proper-list? circular-list? dotted-list? not-pair? + null-list? list= car cdr caar cadr cdar cddr caaar caadr cadar caddr + cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list-ref first second third fourth fifth sixth seventh eighth ninth + tenth car+cdr take drop take-right drop-right take! drop-right! + split-at split-at! last last-pair length length+ append concatenate + reverse append! concatenate! reverse! append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 count map for-each fold unfold + pair-fold reduce fold-right unfold-right pair-fold-right reduce-right + append-map append-map! map! pair-for-each filter-map map-in-order + filter partition remove filter! partition! remove! member memq memv + find find-tail any every list-index take-while drop-while take-while! + span break span! break! delete delete-duplicates delete! + delete-duplicates! assoc assq assv alist-cons alist-copy alist-delete + alist-delete! lset<= lset= lset-adjoin lset-union lset-union! + lset-intersection lset-intersection! lset-difference lset-difference! + lset-xor lset-xor! lset-diff+intersection lset-diff+intersection! + set-car! set-cdr!) + + (begin (define (xcons x y) + (cons y x)) + + (define (tree-copy x) + (letrec ((tree-copy (lambda (x) + (if (not (pair? x)) x + (cons (tree-copy (car x)) + (tree-copy (cdr x))))))) + (tree-copy x))) + + (define (list-tabulate len proc) + (do ((i (- len 1) (- i 1)) + (ans '() (cons (proc i) ans))) + ((< i 0) ans))) + + (define (cons* first . rest) + (let rec ((x first) + (rest rest)) + (if (pair? rest) + (cons x (rec (car rest) + (cdr rest))) + x))) + + (define (circular-list val1 . vals) + (let ((ans (cons val1 vals))) + (set-cdr! (last-pair ans) ans) + ans)) + + (define (iota count . maybe-start+step) + (if (< count 0) (error "Negative step count" iota count)) + (let-optionals maybe-start+step ((start 0) (step 1)) + (let loop ((n 0) (r '())) + (if (= n count) + (reverse r) + (loop (+ 1 n) + (cons (+ start (* n step)) r)))))) + + (define proper-list? list?) + + (define (dotted-list? x) + (let rec ((x x) (lag x)) + (if (pair? x) + (let ((x (cdr x))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (and (not (eq? x lag)) (rec x lag))) + (not (null? x)))) + (not (null? x))))) + + (define (circular-list? x) + (let rec ((x x) (lag x)) + (and (pair? x) + (let ((x (cdr x))) + (and (pair? x) + (let ((x (cdr x)) + (lag (cdr lag))) + (or (eq? x lag) (rec x lag)))))))) + + (define (not-pair? x) (not (pair? x))) + + (define (null-list? x) + (cond ((pair? x) #f) + ((null? x) #t) + (else (error "argument out of domain" (list 'null-list? x))))) + + (define (list= = . lists) + (or (null? lists) ; special case + (let lp1 ((list-a (car lists)) + (others (cdr lists))) + (or (null? others) + (let ((list-b (car others)) + (others (cdr others))) + (if (eq? list-a list-b) ; EQ? => LIST= + (lp1 list-b others) + (let lp2 ((pair-a list-a) + (pair-b list-b)) + (if (null-list? pair-a) + (and (null-list? pair-b) + (lp1 list-b others)) + (and (not (null-list? pair-b)) + (= (car pair-a) + (car pair-b)) + (lp2 (cdr pair-a) + (cdr pair-b))))))))))) + + (define first car) + + (define second cadr) + + (define third caddr) + + (define fourth cadddr) + + (define (fifth x) + (car (cddddr x))) + + (define (sixth x) + (cadr (cddddr x))) + + (define (seventh x) + (caddr (cddddr x))) + + (define (eighth x) + (cadddr (cddddr x))) + + (define (ninth x) + (car (cddddr (cddddr x)))) + + (define (tenth x) + (cadr (cddddr (cddddr x)))) + + (define (car+cdr pair) + (values (car pair) + (cdr pair))) + + (define (take x k) + (let rec ((x x) + (k k)) + (if (zero? k) '() + (cons (car x) + (rec (cdr x) (- k 1)))))) + + (define (take! x k) + (if (zero? k) + (begin (set-cdr! (drop x (- k 1)) '()) x))) + + (define (drop x k) + (let rec ((x x) (k k)) + (if (zero? k) x + (rec (cdr x) (- k 1))))) + + (define (drop! lis k) + (if (negative? k) + (let ((nelts (+ k (length lis)))) + (if (zero? nelts) '() + (begin (set-cdr! (list-tail lis (- nelts 1)) '()) + lis))) + (list-tail lis k))) + + (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) + (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) + (receive (prefix suffix) (recur (cdr lis) (- k 1)) + (values (cons (car lis) prefix) suffix))))) + + (define (split-at! x k) + (if (zero? k) + (values '() x) + (let* ((prev (drop x (- k 1))) + (suffix (cdr prev))) + (set-cdr! prev '()) + (values x suffix)))) + + (define (last x) (car (last-pair x))) + + (define (last-pair lis) + (let rec ((lis lis)) + (let ((tail (cdr lis))) + (if (pair? tail) (rec tail) lis)))) + + (define (length+ x) ; Returns #f if X is circular. + (let rec ((x x) (lag x) (len 0)) + (if (pair? x) + (let ((x (cdr x)) + (len (+ len 1))) + (if (pair? x) + (let ((x (cdr x)) + (lag (cdr lag)) + (len (+ len 1))) + (and (not (eq? x lag)) (rec x lag len))) + len)) + len))) + + (define (append! . lists) + (let lp ((lists lists) (prev '())) ; First, scan through lists looking for a non-empty one. + (if (not (pair? lists)) prev + (let ((first (car lists)) + (rest (cdr lists))) + (if (not (pair? first)) (lp rest first) + (let lp2 ((tail-cons (last-pair first)) ; Now, do the splicing. + (rest rest)) + (if (pair? rest) + (let ((next (car rest)) + (rest (cdr rest))) + (set-cdr! tail-cons next) + (lp2 (if (pair? next) (last-pair next) tail-cons) + rest)) + first))))))) + + (define (concatenate xs) + (reduce-right append '() xs)) + + (define (concatenate! xs) + (reduce-right append! '() xs)) + + (define (reverse! lis) + (let lp ((lis lis) (ans '())) + (if (null-list? lis) ans + (let ((tail (cdr lis))) + (set-cdr! lis ans) + (lp tail lis))))) + + (define (append-reverse rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (lp (cdr rev-head) (cons (car rev-head) tail))))) + + (define (append-reverse! rev-head tail) + (let lp ((rev-head rev-head) (tail tail)) + (if (null-list? rev-head) tail + (let ((next-rev (cdr rev-head))) + (set-cdr! rev-head tail) + (lp next-rev rev-head))))) + + (define (zip list1 . more-lists) + (apply map list list1 more-lists)) + + (define (unzip1 lis) + (map car lis)) + + (define (unzip2 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle + (let ((elt (car lis))) ; dotted lists. + (receive (a b) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b))))))) + + (define (unzip3 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis) + (let ((elt (car lis))) + (receive (a b c) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c))))))) + + (define (unzip4 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d))))))) + + (define (unzip5 lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis lis lis lis) + (let ((elt (car lis))) + (receive (a b c d e) (recur (cdr lis)) + (values (cons (car elt) a) + (cons (cadr elt) b) + (cons (caddr elt) c) + (cons (cadddr elt) d) + (cons (car (cddddr elt)) e))))))) + + (define (count pred list1 . lists) + (if (pair? lists) + (let lp ((list1 list1) (lists lists) (i 0)) + (if (null-list? list1) i + (receive (as ds) (%cars+cdrs lists) + (if (null? as) i + (lp (cdr list1) ds + (if (apply pred (car list1) as) (+ i 1) i)))))) + (let lp ((lis list1) (i 0)) + (if (null-list? lis) i + (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) + + (define (fold kons knil lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans knil)) + (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) + (if (null? cars+ans) ans ; Done. + (lp cdrs (apply kons cars+ans))))) + (let lp ((lis lis1) (ans knil)) + (if (null-list? lis) ans + (lp (cdr lis) (kons (car lis) ans)))))) + + (define (unfold p f g seed . maybe-tail-gen) + (if (pair? maybe-tail-gen) + (let ((tail-gen (car maybe-tail-gen))) + (if (pair? (cdr maybe-tail-gen)) + (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) + (let recur ((seed seed)) + (if (p seed) (tail-gen seed) + (cons (f seed) (recur (g seed))))))) + (let recur ((seed seed)) + (if (p seed) '() + (cons (f seed) (recur (g seed))))))) + + (define (pair-fold f zero lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (ans zero)) + (let ((tails (%cdrs lists))) + (if (null? tails) ans + (lp tails (apply f (append! lists (list ans))))))) + + (let lp ((lis lis1) (ans zero)) + (if (null-list? lis) ans + (let ((tail (cdr lis))) + (lp tail (f lis ans))))))) + + (define (reduce f ridentity lis) + (if (null-list? lis) ridentity + (fold f (car lis) (cdr lis)))) + + (define (fold-right f knil x . xs) + (if (pair? xs) + (letrec ((recur (lambda (lists) + ((lambda (cdrs) + (if (null? cdrs) knil + (apply f (%cars+ lists (recur cdrs))))) + (%cdrs lists))))) + (recur (cons x xs))) + (letrec ((recur (lambda (x) + (if (null-list? x) knil + ((lambda (head) + (f head (recur (cdr x)))) + (car x)))))) + (recur x)))) + + (define (unfold-right p f g seed . maybe-tail) + (let lp ((seed seed) + (ans (if (pair? maybe-tail) (car maybe-tail) '()))) + (if (p seed) ans + (lp (g seed) + (cons (f seed) ans))))) + + (define (pair-fold-right f zero lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (let ((cdrs (%cdrs lists))) + (if (null? cdrs) zero + (apply f (append! lists (list (recur cdrs))))))) + (let recur ((lis lis1)) + (if (null-list? lis) zero (f lis (recur (cdr lis))))))) + + (define (reduce-right f ridentity lis) + (if (null-list? lis) ridentity + (let recur ((head (car lis)) (lis (cdr lis))) + (if (pair? lis) + (f head (recur (car lis) (cdr lis))) + head)))) + + (define (append-map f lis1 . lists) + (really-append-map append-map append f lis1 lists)) + + (define (append-map! f lis1 . lists) + (really-append-map append-map! append! f lis1 lists)) + + (define (really-append-map who appender f lis0 lists) + (if (pair? lists) + (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) + (if (null? cars) '() + (let recur ((cars cars) (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) vals + (appender vals (recur cars2 cdrs2)))))))) + (if (null-list? lis1) '() + (let recur ((elt (car lis1)) (rest (cdr lis1))) + (let ((vals (f elt))) + (if (null-list? rest) vals + (appender vals (recur (car rest) (cdr rest))))))))) + + (define (map! f lis1 . lists) + (if (pair? lists) + (let lp ((lis1 lis1) (lists lists)) + (if (not (null-list? lis1)) + (receive (heads tails) (%cars+cdrs/no-test lists) + (set-car! lis1 (apply f (car lis1) heads)) + (lp (cdr lis1) tails)))) + (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) + lis1) + + (define (pair-for-each proc lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists))) + (let ((tails (%cdrs lists))) + (if (pair? tails) + (begin (apply proc lists) + (lp tails))))) + (let lp ((lis lis1)) + (if (not (null-list? lis)) + (let ((tail (cdr lis))) + (proc lis) + (lp tail)))))) + + (define (filter-map f lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) ; Tail call in this arm. + '()))) + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (recur (cdr lis)))) + (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (else tail))))))) + + (define (map-in-order f lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (let ((x (apply f cars))) + (cons x (recur cdrs))) + '()))) + (let recur ((lis lis1)) + (if (null-list? lis) lis + (let ((tail (cdr lis)) + (x (f (car lis)))) + (cons x (recur tail))))))) + + (define (filter pred lis) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let ((head (car lis)) + (tail (cdr lis))) + (if (pred head) + (let ((new-tail (recur tail))) + (if (eq? tail new-tail) lis + (cons head new-tail))) + (recur tail)))))) + + ; (define (filter pred lis) ; Another version that shares longest tail. + ; (receive (ans no-del?) + ; (let recur ((l l)) + ; (if (null-list? l) (values l #t) + ; (let ((x (car l)) + ; (tl (cdr l))) + ; (if (pred x) + ; (receive (ans no-del?) (recur tl) + ; (if no-del? + ; (values l #t) + ; (values (cons x ans) #f))) + ; (receive (ans no-del?) (recur tl) ; Delete X. + ; (values ans #f)))))) + ; ans)) + + (define (partition pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. + (let ((elt (car lis)) + (tail (cdr lis))) + (receive (in out) (recur tail) + (if (pred elt) + (values (if (pair? out) (cons elt in) lis) out) + (values in (if (pair? in) (cons elt out) lis)))))))) + + (define (remove satisfy? x) + (filter (lambda (y) (not (satisfy? y))) x)) + + ; Things are much simpler if you are willing to push N stack frames & do N + ; set-cdr! writes, where N is the length of the answer. + (define (filter! pred lis) + (let recur ((lis lis)) + (if (pair? lis) + (cond ((pred (car lis)) + (set-cdr! lis (recur (cdr lis))) + lis) + (else (recur (cdr lis)))) + lis))) + + ; (define (filter! pred lis) + ; (let lp ((ans lis)) + ; (cond ((null-list? ans) ans) + ; ((not (pred (car ans))) (lp (cdr ans))) + ; (else (letrec ((scan-in (lambda (prev lis) + ; (if (pair? lis) + ; (if (pred (car lis)) + ; (scan-in lis (cdr lis)) + ; (scan-out prev (cdr lis)))))) + ; (scan-out (lambda (prev lis) + ; (let lp ((lis lis)) + ; (if (pair? lis) + ; (if (pred (car lis)) + ; (begin (set-cdr! prev lis) + ; (scan-in lis (cdr lis))) + ; (lp (cdr lis))) + ; (set-cdr! prev lis)))))) + ; (scan-in ans (cdr ans)) + ; ans))))) + + (define (partition! pred lis) + (if (null-list? lis) + (values lis lis) + (letrec ((scan-in (lambda (in-prev out-prev lis) + (let lp ((in-prev in-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (lp lis (cdr lis)) + (begin (set-cdr! out-prev lis) + (scan-out in-prev lis (cdr lis)))) + (set-cdr! out-prev lis))))) + (scan-out (lambda (in-prev out-prev lis) + (let lp ((out-prev out-prev) (lis lis)) + (if (pair? lis) + (if (pred (car lis)) + (begin (set-cdr! in-prev lis) + (scan-in lis out-prev (cdr lis))) + (lp lis (cdr lis))) + (set-cdr! in-prev lis)))))) + (if (pred (car lis)) + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values lis l)) + ((pred (car l)) (lp l (cdr l))) + (else (scan-out prev-l l (cdr l)) + (values lis l)))) + (let lp ((prev-l lis) (l (cdr lis))) + (cond ((not (pair? l)) (values l lis)) + ((pred (car l)) + (scan-in l prev-l (cdr l)) + (values l lis)) + (else (lp l (cdr l))))))))) + + (define (remove! satisfy? x) + (filter! (lambda (y) (not (satisfy? y))) x)) + + (define (find pred list) + (cond ((find-tail pred list) => car) + (else #f))) + + (define (find-tail pred list) + (let lp ((list list)) + (and (not (null-list? list)) + (if (pred (car list)) list + (lp (cdr list)))))) + + (define (any pred lis1 . lists) + (if (pair? lists) + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (and (pair? heads) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (or (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) + (and (not (null-list? lis1)) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) + (or (pred head) (lp (car tail) (cdr tail)))))))) + + (define (every pred lis1 . lists) + (if (pair? lists) + (receive (heads tails) (%cars+cdrs (cons lis1 lists)) + (or (not (pair? heads)) + (let lp ((heads heads) (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply pred heads) (lp next-heads next-tails)) + (apply pred heads)))))) + (or (null-list? lis1) + (let lp ((head (car lis1)) (tail (cdr lis1))) + (if (null-list? tail) + (pred head) + (and (pred head) (lp (car tail) (cdr tail)))))))) + + (define (list-index pred lis1 . lists) + (if (pair? lists) + (let lp ((lists (cons lis1 lists)) (n 0)) + (receive (heads tails) (%cars+cdrs lists) + (and (pair? heads) + (if (apply pred heads) n + (lp tails (+ n 1)))))) + (let lp ((lis lis1) (n 0)) + (and (not (null-list? lis)) + (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) + + (define (take-while pred lis) + (let recur ((lis lis)) + (if (null-list? lis) '() + (let ((x (car lis))) + (if (pred x) + (cons x (recur (cdr lis))) + '()))))) + + (define (drop-while pred lis) + (let lp ((lis lis)) + (if (null-list? lis) '() + (if (pred (car lis)) + (lp (cdr lis)) + lis)))) + + (define (take-while! pred lis) + (if (or (null-list? lis) (not (pred (car lis)))) '() + (begin (let lp ((prev lis) (rest (cdr lis))) + (if (pair? rest) + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (set-cdr! prev '()))))) + lis))) + + (define (span pred lis) + (let recur ((lis lis)) + (if (null-list? lis) (values '() '()) + (let ((x (car lis))) + (if (pred x) + (receive (prefix suffix) (recur (cdr lis)) + (values (cons x prefix) suffix)) + (values '() lis)))))) + + (define (break break? x) + (span (lambda (x) (not (break? x))) x)) + + (define (span! pred lis) + (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) + (let ((suffix (let lp ((prev lis) (rest (cdr lis))) + (if (null-list? rest) rest + (let ((x (car rest))) + (if (pred x) (lp rest (cdr rest)) + (begin (set-cdr! prev '()) + rest))))))) + (values lis suffix)))) + + (define (break! break? x) + (span! (lambda (x) (not (break? x))) x)) + + (define (delete x lis . maybe-=) + (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) + (filter (lambda (y) (not (= x y))) lis))) + + (define (delete-duplicates lis . maybe-=) + (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail))))))) + + (define (delete! x lis . maybe-=) + (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) + (filter! (lambda (y) (not (= x y))) lis))) + + (define (delete-duplicates! lis maybe-=) + (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) + (let recur ((lis lis)) + (if (null-list? lis) lis + (let* ((x (car lis)) + (tail (cdr lis)) + (new-tail (recur (delete! x tail elt=)))) + (if (eq? tail new-tail) lis (cons x new-tail))))))) + + (define (alist-cons key datum alist) + (cons (cons key datum) alist)) + + (define (alist-copy alist) + (map (lambda (each) + (cons (car each) + (cdr each))) + alist)) + + (define (alist-delete key alist . maybe-=) + (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) + (filter (lambda (elt) (not (= key (car elt)))) alist))) + + (define (alist-delete! key alist . maybe-=) + (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) + (filter! (lambda (elt) (not (= key (car elt)))) alist))) + + (define (lset<= = . lists) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) (rest (cdr rest))) + (and (or (eq? s2 s1) ; Fast path + (%lset2<= = s1 s2)) ; Real test + (lp s2 rest))))))) + + (define (lset= = . lists) + (or (not (pair? lists)) ; 0-ary case + (let lp ((s1 (car lists)) (rest (cdr lists))) + (or (not (pair? rest)) + (let ((s2 (car rest)) + (rest (cdr rest))) + (and (or (eq? s1 s2) ; Fast path + (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test + (lp s2 rest))))))) + + (define (lset-adjoin = lis . elts) + (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) + lis elts)) + + (define (lset-union = . lists) + (reduce (lambda (lis ans) ; Compute ANS + LIS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) + ans + (cons elt ans))) + ans lis)))) + '() lists)) + + (define (lset-union! = . lists) + (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (pair-fold (lambda (pair ans) + (let ((elt (car pair))) + (if (any (lambda (x) (= x elt)) ans) ans - (cons elt ans))) - ans lis)))) - '() lists)) - -(define (lset-union! = . lists) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - -(define (lset-intersection = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - -(define (lset-intersection! = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - -(define (lset-difference = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - -(define (lset-difference! = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - -(define (lset-xor = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - -(define (lset-xor! = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - -(define (lset-diff+intersection = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - -(define (lset-diff+intersection! = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) + (begin (set-cdr! pair ans) pair)))) + ans lis)))) + '() lists)) + + (define (lset-intersection = lis1 . lists) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + + (define (lset-intersection! = lis1 . lists) + (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. + (cond ((any null-list? lists) '()) ; Short cut + ((null? lists) lis1) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (member x lis =)) lists)) + lis1))))) + + (define (lset-difference = lis1 . lists) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + + (define (lset-difference! = lis1 . lists) + (let ((lists (filter pair? lists))) ; Throw out empty lists. + (cond ((null? lists) lis1) ; Short cut + ((memq lis1 lists) '()) ; Short cut + (else (filter! (lambda (x) + (every (lambda (lis) (not (member x lis =))) + lists)) + lis1))))) + + (define (lset-xor = . lists) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection = a b) + (cond ((null? a-b) (lset-difference = b a)) + ((null? a-int-b) (append b a)) + (else (fold (lambda (xb ans) + (if (member xb a-int-b =) ans (cons xb ans))) + a-b + b))))) + '() lists)) + + (define (lset-xor! = . lists) + (reduce (lambda (b a) ; Compute A xor B: + ;; Note that this code relies on the constant-time + ;; short-cuts provided by LSET-DIFF+INTERSECTION, + ;; LSET-DIFFERENCE & APPEND to provide constant-time short + ;; cuts for the cases A = (), B = (), and A eq? B. It takes + ;; a careful case analysis to see it, but it's carefully + ;; built in. + + ;; Compute a-b and a^b, then compute b-(a^b) and + ;; cons it onto the front of a-b. + (receive (a-b a-int-b) (lset-diff+intersection! = a b) + (cond ((null? a-b) (lset-difference! = b a)) + ((null? a-int-b) (append! b a)) + (else (pair-fold (lambda (b-pair ans) + (if (member (car b-pair) a-int-b =) ans + (begin (set-cdr! b-pair ans) b-pair))) + a-b + b))))) + '() lists)) + + (define (lset-diff+intersection = lis1 . lists) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) + + (define (lset-diff+intersection! = lis1 . lists) + (cond ((every null-list? lists) (values lis1 '())) ; Short cut + ((memq lis1 lists) (values '() lis1)) ; Short cut + (else (partition! (lambda (elt) + (not (any (lambda (lis) (member elt lis =)) + lists))) + lis1)))) + ) + + (begin ; Return (map cdr lists). + ; However, if any element of LISTS is empty, just abort and return '(). + (define (%cdrs xs) + (call-with-current-continuation! + (lambda (abort) + (letrec ((recur (lambda (xs) + (if (pair? xs) + ((lambda (x) + (if (null-list? x) + (abort '()) + (cons (cdr x) + (recur (cdr xs))))) + (car xs)) + '())))) + (recur xs))))) + + (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) + (letrec ((recur (lambda (lists) + (if (pair? lists) + (cons (caar lists) + (recur (cdr lists))) + (list last-elt))))) + (recur lists))) + + (define (%cars+cdrs lists) + (call-with-current-continuation! + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values '() '())))))) + + (define (%cars+cdrs+ lists cars-final) + (call-with-current-continuation! + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values (list cars-final) '())))))) + + (define (%cars+cdrs/no-test lists) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs))))) + (values '() '())))) + + (define (%lset2<= = lis1 lis2) + (every (lambda (x) (member x lis2 =)) lis1)))) diff --git a/test/srfi-8.ss b/test/srfi-8.ss index a7f098b34..68f854600 100644 --- a/test/srfi-8.ss +++ b/test/srfi-8.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (srfi 8) + (srfi 78)) (check (call-with-values (lambda () (values 4 5)) From dc856f9837958f5892bce2ace623a1447a842923 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 17 May 2022 04:44:28 +0900 Subject: [PATCH 36/49] Remove some importation from `overture.ss` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/overture.ss | 13 +------------ src/library/meevax.cpp | 4 ++-- test/abandoned.ss | 4 +++- test/chibi-basic.ss | 3 ++- test/er-macro-transformer.ss | 4 +++- test/identifier.ss | 3 ++- test/let-syntax.ss | 3 ++- test/letrec-syntax.ss | 3 ++- test/r4rs-appendix.ss | 4 +++- test/r4rs.ss | 6 +++--- test/r5rs.ss | 6 +++--- test/r7rs.ss | 9 ++++++++- 14 files changed, 38 insertions(+), 32 deletions(-) diff --git a/README.md b/README.md index ecc0c9a18..6a9a18f1b 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1007.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1008.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1007_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1008_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1007 +Meevax Lisp System, version 0.3.1008 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 52634bc74..0894c5b9f 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1007 +0.3.1008 diff --git a/basis/overture.ss b/basis/overture.ss index cc726f262..080f649f4 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -425,10 +425,7 @@ (define (flush-output-port . port) (%flush-output-port (if (pair? port) (car port) - (current-output-port)))) - - ) - ) + (current-output-port)))))) (define-library (scheme lazy) (import (srfi 45)) @@ -638,14 +635,6 @@ (import (scheme r5rs) (scheme base) - (scheme char) - (scheme cxr) - (scheme file) - (scheme lazy) - (scheme read) - (scheme write) - (srfi 211 explicit-renaming) - (srfi 211 syntactic-closures) ) (define (unspecified) (if #f #f)) diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 2b77fa8c9..e494387bc 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -50,9 +50,9 @@ namespace meevax srfi_23, // Error reporting mechanism srfi_39, // Parameter objects overture, - srfi_8, // receive: Binding to multiple values - srfi_1, r7rs, + srfi_8, // receive: Binding to multiple values + srfi_1, // List Library srfi_78, // Lightweight testing }; diff --git a/test/abandoned.ss b/test/abandoned.ss index 3f972666a..be59db07a 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -1,4 +1,6 @@ -(import (srfi 78)) +(import (scheme char) + (srfi 78) + (srfi 211 explicit-renaming)) (define p1 (make-parameter 1)) (define p2 (make-parameter "hoge")) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 76abdbdee..314187259 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (srfi 78) + (srfi 211 explicit-renaming)) ; ---- Chibi-Scheme's Basic Tests ---------------------------------------------- ; diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 0166630ae..6251a6c16 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,5 +1,7 @@ (import (only (meevax macro) transformer?) - (srfi 78)) + (srfi 78) + (srfi 211 explicit-renaming) + ) (define (traditional-macro-transformer f) (lambda (form use-env mac-env) diff --git a/test/identifier.ss b/test/identifier.ss index e110b6bcc..5f952642e 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,5 +1,6 @@ (import (meevax macro) - (srfi 78)) + (srfi 78) + (srfi 211 explicit-renaming)) (define value 42) diff --git a/test/let-syntax.ss b/test/let-syntax.ss index ecbf1750c..f318f3ed2 100644 --- a/test/let-syntax.ss +++ b/test/let-syntax.ss @@ -1,5 +1,6 @@ (import (scheme base) - (srfi 78)) + (srfi 78) + (srfi 211 explicit-renaming)) (define result (list)) diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index d140aa17c..a5aa13912 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (srfi 78) + (srfi 211 explicit-renaming)) (letrec-syntax ((my-and (er-macro-transformer (lambda (form rename compare) diff --git a/test/r4rs-appendix.ss b/test/r4rs-appendix.ss index 2fbb6af33..c085fce48 100644 --- a/test/r4rs-appendix.ss +++ b/test/r4rs-appendix.ss @@ -1,4 +1,6 @@ -(import (srfi 78)) +(import (srfi 78) + (srfi 211 syntactic-closures) + (srfi 211 explicit-renaming)) ; (check (symbol? (syntax x)) => #f) diff --git a/test/r4rs.ss b/test/r4rs.ss index 93e81836a..0b5a6ab5d 100644 --- a/test/r4rs.ss +++ b/test/r4rs.ss @@ -625,9 +625,9 @@ (force p))))) (define x 5) -(check (promise? p) => #t) +; (check (promise? p) => #t) (check (force p) => 6) -(check (promise? p) => #t) +; (check (promise? p) => #t) (check (begin (set! x 10) (force p)) => 6) @@ -662,4 +662,4 @@ (check-report) -(exit (check-passed? 285)) +(exit (check-passed? 283)) diff --git a/test/r5rs.ss b/test/r5rs.ss index 69de8b8cb..32e51e91d 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -806,11 +806,11 @@ (define x 5) -(check (promise? p) => #t) +; (check (promise? p) => #t) (check (force p) => 6) -(check (promise? p) => #t) +; (check (promise? p) => #t) (check (begin (set! x 10) (force p)) => 6) @@ -952,4 +952,4 @@ (check-report) -(exit (check-passed? 290)) +(exit (check-passed? 288)) diff --git a/test/r7rs.ss b/test/r7rs.ss index ad9938319..f12f3a3ca 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1,4 +1,11 @@ -(import (srfi 78)) +(import + (scheme char) + (scheme file) + (scheme lazy) + (scheme read) + (scheme write) + (srfi 78) + ) ; ---- 2.1. Identifiers -------------------------------------------------------- From 7aecc8f95b2a6781121642e93b0064497bb3aec2 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Tue, 17 May 2022 05:22:44 +0900 Subject: [PATCH 37/49] Move all remaining (possibly) definitions into libraries. Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 195 +++++++++++++++++++++++++++++++++-- basis/r5rs.ss | 66 +++++++----- basis/r7rs.ss | 189 --------------------------------- example/example.ss | 1 + test/abandoned.ss | 1 + test/chibi-basic.ss | 3 +- test/er-macro-transformer.ss | 1 + test/identifier.ss | 1 + test/internal-definition.ss | 3 +- test/let-syntax.ss | 1 + test/letrec-syntax.ss | 3 +- test/numerical-operations.ss | 3 +- test/r4rs-appendix.ss | 3 +- test/r4rs.ss | 3 +- test/r5rs.ss | 7 +- test/r7rs.ss | 5 +- test/sicp-1.ss | 3 +- test/srfi-8.ss | 3 +- test/transformer.ss | 1 + 21 files changed, 260 insertions(+), 240 deletions(-) diff --git a/README.md b/README.md index 6a9a18f1b..a2bfc7d6b 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1008.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1009.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1008_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1009_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1008 +Meevax Lisp System, version 0.3.1009 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 0894c5b9f..3abec1b74 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1008 +0.3.1009 diff --git a/basis/overture.ss b/basis/overture.ss index 080f649f4..f73154289 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -45,8 +45,8 @@ let* letrec letrec* - ; let-values - ; let*-values + let-values + let*-values begin do make-parameter @@ -425,7 +425,185 @@ (define (flush-output-port . port) (%flush-output-port (if (pair? port) (car port) - (current-output-port)))))) + (current-output-port)))) + ) + + (begin (define-syntax cond + (syntax-rules (else =>) + ((cond (else result1 result2 ...)) + (begin result1 result2 ...)) + ((cond (test => result)) + (let ((temp test)) + (if temp (result temp)))) + ((cond (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (cond clause1 clause2 ...)))) + ((cond (test)) test) + ((cond (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...)))) + ((cond (test result1 result2 ...)) + (if test (begin result1 result2 ...))) + ((cond (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...))))) + + (define-syntax case ; errata version + (syntax-rules (else =>) + ((case (key ...) clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else => result)) + (result key)) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) => result)) + (if (memv key '(atoms ...)) + (result key))) + ((case key ((atoms ...) => result) clause clauses ...) + (if (memv key '(atoms ...)) + (result key) + (case key clause clauses ...))) + ((case key ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key ((atoms ...) result1 result2 ...) clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + + (define-syntax and + (syntax-rules () + ((and) #t) + ((and test) test) + ((and test1 test2 ...) + (if test1 (and test2 ...) #f)))) + + (define-syntax or + (syntax-rules () + ((or) #f) + ((or test) test) + ((or test1 test2 ...) + (let ((x test1)) + (if x x (or test2 ...)))))) + + (define-syntax when + (syntax-rules () + ((when test result1 result2 ...) + (if test + (begin result1 result2 ...))))) + + (define-syntax unless + (syntax-rules () + ((unless test result1 result2 ...) + (if (not test) + (begin result1 result2 ...))))) + + (define-syntax let + (syntax-rules () + ((let ((name val) ...) body1 body2 ...) + ((lambda (name ...) body1 body2 ...) val ...)) + ((let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) + + (define-syntax let* + (syntax-rules () + ((let* () body1 body2 ...) + (let () body1 body2 ...)) + ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) + (let ((name1 val1)) + (let* ((name2 val2) ...) body1 body2 ...))))) + + (define-syntax letrec* + (syntax-rules () + ((letrec* ((var1 init1) ...) body1 body2 ...) + (let ((var1 ) ...) + (set! var1 init1) + ... + (let () body1 body2 ...))))) + + (define-syntax let-values + (syntax-rules () + ((let-values (binding ...) body0 body1 ...) + (let-values "bind" (binding ...) () (begin body0 body1 ...))) + ((let-values "bind" () tmps body) + (let tmps body)) + ((let-values "bind" ((b0 e0) binding ...) tmps body) + (let-values "mktmp" b0 e0 () (binding ...) tmps body)) + ((let-values "mktmp" () e0 args bindings tmps body) + (call-with-values + (lambda () e0) + (lambda args + (let-values "bind" bindings tmps body)))) + ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) + (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) + ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) + (call-with-values + (lambda () e0) + (lambda (arg ... . x) + (let-values "bind" bindings (tmp ... (a x)) body)))))) + + ; (define-syntax let-values + ; (er-macro-transformer + ; (lambda (form rename compare) + ; (if (null? (cadr form)) + ; `(,(rename 'let) () ,@(cddr form)) + ; `(,(rename 'call-with-values) + ; (,(rename 'lambda) () ,(cadar (cadr form))) + ; (,(rename 'lambda) ,(caar (cadr form)) + ; (,(rename 'let-values) ,(cdr (cadr form)) + ; ,@(cddr form)))))))) + + (define-syntax let*-values + (syntax-rules () + ((let*-values () body0 body1 ...) + (let () body0 body1 ...)) + ((let*-values (binding0 binding1 ...) + body0 body1 ...) + (let-values (binding0) + (let*-values (binding1 ...) + body0 body1 ...))))) + + ; (define-syntax let*-values + ; (er-macro-transformer + ; (lambda (form rename compare) + ; (if (null? (cadr form)) + ; `(,(rename 'let) () ,@(cddr form)) + ; `(,(rename 'let-values) (,(caadr form)) + ; (,(rename 'let*-values) ,(cdadr form) + ; ,@(cddr form))))))) + + (define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))))) (define-library (scheme lazy) (import (srfi 45)) @@ -618,11 +796,14 @@ ) (define-library (scheme process-context) - (export command-line + (import (meevax context) + (meevax continuation) + ) + (export ; command-line exit emergency-exit - get-environment-variable - get-environment-variables + ; get-environment-variable + ; get-environment-variables ) ) @@ -636,5 +817,3 @@ (import (scheme r5rs) (scheme base) ) - -(define (unspecified) (if #f #f)) diff --git a/basis/r5rs.ss b/basis/r5rs.ss index e6fce1cea..ee996b9c5 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,5 +1,44 @@ +(define-library (meevax continuation) + (import (meevax context) + (meevax syntax) + (scheme r4rs essential)) + + (export call-with-current-continuation dynamic-wind exit) + + (begin (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html + + (define (dynamic-wind before thunk after) + (before) + (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) + ((lambda (result) ; TODO let-values + (set! %current-dynamic-extents (cdr %current-dynamic-extents)) + (after) + result) ; TODO (apply values result) + (thunk))) + + (define (call-with-current-continuation procedure) + (define (windup! from to) + (set! %current-dynamic-extents from) + (cond ((eq? from to)) + ((null? from) (windup! from (cdr to)) ((caar to))) + ((null? to) ((cdar from)) (windup! (cdr from) to)) + (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) + (set! %current-dynamic-extents to)) + (let ((current-dynamic-extents %current-dynamic-extents)) + (call-with-current-continuation! (lambda (k1) + (procedure (lambda (k2) + (windup! %current-dynamic-extents current-dynamic-extents) + (k1 k2))))))) + + (define (exit . normally?) + (for-each (lambda (before/after) + ((cdr before/after))) + %current-dynamic-extents) + (apply emergency-exit normally?)))) + (define-library (scheme r5rs) - (import (meevax environment) + (import (meevax continuation) + (meevax environment) (meevax evaluate) (meevax syntax) ; for let-syntax letrec-syntax (scheme r4rs) @@ -66,31 +105,6 @@ (apply consumer (cdr vs)) (consumer vs)))) - (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html - - (define (dynamic-wind before thunk after) - (before) - (set! %current-dynamic-extents (cons (cons before after) %current-dynamic-extents)) - ((lambda (result) ; TODO let-values - (set! %current-dynamic-extents (cdr %current-dynamic-extents)) - (after) - result) ; TODO (apply values result) - (thunk))) - - (define (call-with-current-continuation procedure) - (define (windup! from to) - (set! %current-dynamic-extents from) - (cond ((eq? from to)) - ((null? from) (windup! from (cdr to)) ((caar to))) - ((null? to) ((cdar from)) (windup! (cdr from) to)) - (else ((cdar from)) (windup! (cdr from) (cdr to)) ((caar to)))) - (set! %current-dynamic-extents to)) - (let ((current-dynamic-extents %current-dynamic-extents)) - (call-with-current-continuation! (lambda (k1) - (procedure (lambda (k2) - (windup! %current-dynamic-extents current-dynamic-extents) - (k1 k2))))))) - (define (scheme-report-environment version) (environment `(scheme ,(string->symbol (string-append "r" (number->string version) "rs"))))) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 2b30e363c..8b1378917 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -1,190 +1 @@ -; ---- 4.2.1. Conditionals ----------------------------------------------------- -(define-syntax cond - (syntax-rules (else =>) - ((cond (else result1 result2 ...)) - (begin result1 result2 ...)) - ((cond (test => result)) - (let ((temp test)) - (if temp (result temp)))) - ((cond (test => result) clause1 clause2 ...) - (let ((temp test)) - (if temp - (result temp) - (cond clause1 clause2 ...)))) - ((cond (test)) test) - ((cond (test) clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (cond clause1 clause2 ...)))) - ((cond (test result1 result2 ...)) - (if test (begin result1 result2 ...))) - ((cond (test result1 result2 ...) - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (cond clause1 clause2 ...))))) - -(define-syntax case ; errata version - (syntax-rules (else =>) - ((case (key ...) clauses ...) - (let ((atom-key (key ...))) - (case atom-key clauses ...))) - ((case key - (else => result)) - (result key)) - ((case key - (else result1 result2 ...)) - (begin result1 result2 ...)) - ((case key - ((atoms ...) => result)) - (if (memv key '(atoms ...)) - (result key))) - ((case key ((atoms ...) => result) clause clauses ...) - (if (memv key '(atoms ...)) - (result key) - (case key clause clauses ...))) - ((case key ((atoms ...) result1 result2 ...)) - (if (memv key '(atoms ...)) - (begin result1 result2 ...))) - ((case key ((atoms ...) result1 result2 ...) clause clauses ...) - (if (memv key '(atoms ...)) - (begin result1 result2 ...) - (case key clause clauses ...))))) - -(define-syntax and - (syntax-rules () - ((and) #t) - ((and test) test) - ((and test1 test2 ...) - (if test1 (and test2 ...) #f)))) - -(define-syntax or - (syntax-rules () - ((or) #f) - ((or test) test) - ((or test1 test2 ...) - (let ((x test1)) - (if x x (or test2 ...)))))) - -(define-syntax when - (syntax-rules () - ((when test result1 result2 ...) - (if test - (begin result1 result2 ...))))) - -(define-syntax unless - (syntax-rules () - ((unless test result1 result2 ...) - (if (not test) - (begin result1 result2 ...))))) - -; ---- 4.2.2. Binding constructs ----------------------------------------------- - -(define-syntax let - (syntax-rules () - ((let ((name val) ...) body1 body2 ...) - ((lambda (name ...) body1 body2 ...) val ...)) - ((let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) - -(define-syntax let* - (syntax-rules () - ((let* () body1 body2 ...) - (let () body1 body2 ...)) - ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) - (let ((name1 val1)) - (let* ((name2 val2) ...) body1 body2 ...))))) - -(define-syntax letrec* - (syntax-rules () - ((letrec* ((var1 init1) ...) body1 body2 ...) - (let ((var1 ) ...) - (set! var1 init1) - ... - (let () body1 body2 ...))))) - -(define-syntax let-values - (syntax-rules () - ((let-values (binding ...) body0 body1 ...) - (let-values "bind" (binding ...) () (begin body0 body1 ...))) - ((let-values "bind" () tmps body) - (let tmps body)) - ((let-values "bind" ((b0 e0) binding ...) tmps body) - (let-values "mktmp" b0 e0 () (binding ...) tmps body)) - ((let-values "mktmp" () e0 args bindings tmps body) - (call-with-values - (lambda () e0) - (lambda args - (let-values "bind" bindings tmps body)))) - ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) - (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) - ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) - (call-with-values - (lambda () e0) - (lambda (arg ... . x) - (let-values "bind" bindings (tmp ... (a x)) body)))))) - -; (define-syntax let-values -; (er-macro-transformer -; (lambda (form rename compare) -; (if (null? (cadr form)) -; `(,(rename 'let) () ,@(cddr form)) -; `(,(rename 'call-with-values) -; (,(rename 'lambda) () ,(cadar (cadr form))) -; (,(rename 'lambda) ,(caar (cadr form)) -; (,(rename 'let-values) ,(cdr (cadr form)) -; ,@(cddr form)))))))) - -(define-syntax let*-values - (syntax-rules () - ((let*-values () body0 body1 ...) - (let () body0 body1 ...)) - ((let*-values (binding0 binding1 ...) - body0 body1 ...) - (let-values (binding0) - (let*-values (binding1 ...) - body0 body1 ...))))) - -; (define-syntax let*-values -; (er-macro-transformer -; (lambda (form rename compare) -; (if (null? (cadr form)) -; `(,(rename 'let) () ,@(cddr form)) -; `(,(rename 'let-values) (,(caadr form)) -; (,(rename 'let*-values) ,(cdadr form) -; ,@(cddr form))))))) - -; ---- 4.2.3. Sequencing ------------------------------------------------------- - -; ---- 4.2.4. Iteration -------------------------------------------------------- - -(define-syntax do - (syntax-rules () - ((do ((var init step ...) ...) - (test expr ...) - command ...) - (letrec - ((loop - (lambda (var ...) - (if test - (begin - (if #f #f) - expr ...) - (begin - command - ... - (loop (do "step" var step ...) - ...)))))) - (loop init ...))) - ((do "step" x) - x) - ((do "step" x y) - y))) - -(define (exit . normally?) - (for-each (lambda (before/after) - ((cdr before/after))) - %current-dynamic-extents) - (apply emergency-exit normally?)) diff --git a/example/example.ss b/example/example.ss index 8261ff990..8e9ee3543 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,5 @@ (import (meevax foreign-function-interface) + (scheme process-context) (srfi 78)) (define dummy-procedure (foreign-function "build/libexample.so" "dummy_procedure")) diff --git a/test/abandoned.ss b/test/abandoned.ss index be59db07a..28b699b7c 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -1,4 +1,5 @@ (import (scheme char) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 314187259..813274eec 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -1,4 +1,5 @@ -(import (srfi 78) +(import (scheme process-context) + (srfi 78) (srfi 211 explicit-renaming)) ; ---- Chibi-Scheme's Basic Tests ---------------------------------------------- diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 6251a6c16..254541b6f 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,4 +1,5 @@ (import (only (meevax macro) transformer?) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming) ) diff --git a/test/identifier.ss b/test/identifier.ss index 5f952642e..a408577a6 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,4 +1,5 @@ (import (meevax macro) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/internal-definition.ss b/test/internal-definition.ss index f2d771455..a553679dc 100644 --- a/test/internal-definition.ss +++ b/test/internal-definition.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (scheme process-context) + (srfi 78)) (define a 100) (define b 200) diff --git a/test/let-syntax.ss b/test/let-syntax.ss index f318f3ed2..71ee53e19 100644 --- a/test/let-syntax.ss +++ b/test/let-syntax.ss @@ -1,4 +1,5 @@ (import (scheme base) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index a5aa13912..64005da8e 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -1,4 +1,5 @@ -(import (srfi 78) +(import (scheme process-context) + (srfi 78) (srfi 211 explicit-renaming)) (letrec-syntax ((my-and (er-macro-transformer diff --git a/test/numerical-operations.ss b/test/numerical-operations.ss index f64c59807..4a8a59870 100644 --- a/test/numerical-operations.ss +++ b/test/numerical-operations.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (scheme process-context) + (srfi 78)) ; ---- 6.2.6. Numerical operations --------------------------------------------- diff --git a/test/r4rs-appendix.ss b/test/r4rs-appendix.ss index c085fce48..efb53544a 100644 --- a/test/r4rs-appendix.ss +++ b/test/r4rs-appendix.ss @@ -1,4 +1,5 @@ -(import (srfi 78) +(import (scheme process-context) + (srfi 78) (srfi 211 syntactic-closures) (srfi 211 explicit-renaming)) diff --git a/test/r4rs.ss b/test/r4rs.ss index 0b5a6ab5d..3bcc56c47 100644 --- a/test/r4rs.ss +++ b/test/r4rs.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (scheme process-context) + (srfi 78)) (check (* 5 8) => 40) diff --git a/test/r5rs.ss b/test/r5rs.ss index 32e51e91d..ff9cfd0cf 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (scheme process-context) + (srfi 78)) ; ---- 1.3.4 ------------------------------------------------------------------- @@ -108,7 +109,7 @@ (check (case (car '(c d)) ((a) 'a) - ((b) 'b)) => #,(unspecified)) + ((b) 'b)) => #,(if #f #f)) (check (case (car '(c d)) ((a e i o u) 'vowel) @@ -165,7 +166,7 @@ (+ x 1)) => 6) (check (begin (display "4 plus 1 equals ") - (display (+ 4 1))) => #,(unspecified)) + (display (+ 4 1))) => #,(if #f #f)) ; ---- 4.2.4 ------------------------------------------------------------------- diff --git a/test/r7rs.ss b/test/r7rs.ss index f12f3a3ca..58d580dbf 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -2,6 +2,7 @@ (scheme char) (scheme file) (scheme lazy) + (scheme process-context) (scheme read) (scheme write) (srfi 78) @@ -124,7 +125,7 @@ ((1 4 6 8 9) 'composite)) => composite) (check (case (car '(c d)) ((a) 'a) - ((b) 'b)) => #,(unspecified)) + ((b) 'b)) => #,(if #f #f)) (check (case (car '(c d)) ((a e i o u) 'vowel) ((w y) 'semivowel) @@ -205,7 +206,7 @@ (check (begin (display "4 plus 1 equals ") - (display (+ 4 1))) => #,(unspecified)) + (display (+ 4 1))) => #,(if #f #f)) ; ---- 4.2.4. Iteration -------------------------------------------------------- diff --git a/test/sicp-1.ss b/test/sicp-1.ss index 40c4cca4c..1e6d8dffc 100644 --- a/test/sicp-1.ss +++ b/test/sicp-1.ss @@ -1,4 +1,5 @@ -(import (srfi 78)) +(import (scheme process-context) + (srfi 78)) ; ---- Section 1.1.1 ----------------------------------------------------------- diff --git a/test/srfi-8.ss b/test/srfi-8.ss index 68f854600..f09398591 100644 --- a/test/srfi-8.ss +++ b/test/srfi-8.ss @@ -1,4 +1,5 @@ -(import (srfi 8) +(import (scheme process-context) + (srfi 8) (srfi 78)) (check diff --git a/test/transformer.ss b/test/transformer.ss index 4b8b878e6..a56972778 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,4 +1,5 @@ (import (only (meevax macro) transformer?) + (scheme process-context) (srfi 78) (srfi 211 syntactic-closures) (srfi 211 explicit-renaming) From d5213da9e3a411ccf3d3c599da99b8dd3459f14a Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 18 May 2022 00:23:04 +0900 Subject: [PATCH 38/49] Remove bultin script `overture.ss` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/overture.ss | 819 -------------------------------- basis/r7rs.ss | 814 +++++++++++++++++++++++++++++++ example/example.ss | 3 +- include/meevax/kernel/basis.hpp | 1 - src/kernel/basis.cpp | 1 - src/library/meevax.cpp | 1 - test/abandoned.ss | 4 +- test/chibi-basic.ss | 3 +- test/er-macro-transformer.ss | 2 + test/identifier.ss | 1 + test/internal-definition.ss | 3 +- test/letrec-syntax.ss | 3 +- test/numerical-operations.ss | 3 +- test/r4rs-appendix.ss | 3 +- test/r4rs.ss | 5 +- test/r5rs.ss | 3 +- test/r7rs.ss | 8 +- test/sicp-1.ss | 3 +- test/srfi-8.ss | 3 +- test/transformer.ss | 2 + 22 files changed, 851 insertions(+), 842 deletions(-) delete mode 100644 basis/overture.ss diff --git a/README.md b/README.md index a2bfc7d6b..38d2abfe0 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1009.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1010.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1009_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1010_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1009 +Meevax Lisp System, version 0.3.1010 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 3abec1b74..55bb38e24 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1009 +0.3.1010 diff --git a/basis/overture.ss b/basis/overture.ss deleted file mode 100644 index f73154289..000000000 --- a/basis/overture.ss +++ /dev/null @@ -1,819 +0,0 @@ -(define-library (scheme base) - (import (only (meevax exception) error? read-error? file-error? syntax-error?) - (only (meevax number) exact-integer?) - (only (meevax vector) vector->string) - (only (meevax port) - binary-port? - textual-port? - port? - input-port-open? - output-port-open? - standard-input-port - standard-output-port - standard-error-port - eof-object - %read-char - %peek-char - read-ready? - put-char - put-string - %flush-output-port - ) - (scheme r5rs) - (srfi 23) ; Error reporting mechanism - (srfi 34) ; Exception Handling for Programs - (srfi 39) ; Parameter objects - (srfi 211 explicit-renaming) - ) - - (export quote - lambda - if - set! - ; include - ; include-ci - cond - ; else - ; => - case - and - or - when - unless - ; cond-expand - let - let* - letrec - letrec* - let-values - let*-values - begin - do - make-parameter - parameterize - guard - quasiquote - ; unquote - ; unquote-splicing - let-syntax - letrec-syntax - syntax-rules - ; _ - ; ... - ; syntax-error - define - ; define-values - define-syntax - ; define-record-type - eqv? - eq? - equal? - number? - complex? - real? - rational? - integer? - exact? - inexact? - exact-integer? - = - < - > - <= - >= - zero? - positive? - negative? - odd? - even? - max - min - + - * - - - / - abs - floor/ - floor-quotient - floor-remainder - truncate/ - truncate-quotient - truncate-remainder - quotient - remainder - modulo - gcd - lcm - numerator - denominator - floor - ceiling - truncate - round - rationalize - square - ; exact-integer-sqrt - expt - inexact - exact - number->string - string->number - not - boolean? - boolean=? - pair? - cons - car - cdr - set-car! - set-cdr! - caar - cadr - cdar - cddr - null? - list? - make-list - list - length - append - reverse - list-tail - list-ref - list-set! - memq - memv - member - assq - assv - assoc - list-copy - symbol? - ; symbol=? - symbol->string - string->symbol - char? - char=? - char? - char<=? - char>=? - char->integer - integer->char - string? - make-string - string - string-length - string-ref - string-set! - string=? - string>? - string=? - substring - string-append - string->list - list->string - string-copy - ; string-copy! - string-fill! - vector? - make-vector - vector - vector-length - vector-ref - vector-set! - vector->list - list->vector - vector->string - ; string->vector - ; vector-copy - ; vector-copy! - ; vector-append - vector-fill! - ; bytevector? - ; make-bytevector - ; bytevector - ; bytevector-length - ; bytevector-u8-ref - ; bytevector-u8-set! - ; bytevector-copy - ; bytevector-copy! - ; bytevector-append - ; utf8->string - ; string->utf8 - procedure? - apply - map - string-map - ; vector-map - for-each - ; string-for-each - ; vector-for-each - call-with-current-continuation - call/cc - values - call-with-values - dynamic-wind - with-exception-handler - raise - raise-continuable - error - error-object? - (rename car error-object-message) - (rename cdr error-object-irritants) - read-error? - file-error? - call-with-port - input-port? - output-port? - textual-port? - binary-port? - port? - input-port-open? - output-port-open? - current-input-port - current-output-port - current-error-port - close-port - close-input-port - close-output-port - ; open-input-string - ; open-output-string - ; get-output-string - ; open-input-bytevector - ; open-output-bytevector - ; get-output-bytevector - read-char - peek-char - ; read-line - eof-object? - eof-object - char-ready? - ; read-string - ; read-u8 - ; peek-u8 - ; u8-ready? - ; read-bytevector - ; read-bytevector! - newline - write-char - write-string - ; write-u8 - ; write-bytevector - flush-output-port - ; features - ) - - (begin (define (unspecified) (if #f #f)) - - (define-syntax when - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) ,(cadr form) - (,(rename 'begin) ,@(cddr form)))))) - - (define-syntax unless - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'if) (,(rename 'not) ,(cadr form)) - (,(rename 'begin) ,@(cddr form)))))) - - (define-syntax letrec* - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'let) () - ,@(map (lambda (x) (cons (rename 'define) x)) - (cadr form)) - ,@(cddr form))))) - - (define (floor-quotient x y) - (floor (/ x y))) - - (define floor-remainder modulo) - - (define (floor/ x y) - (values (floor-quotient x y) - (floor-remainder x y))) - - (define truncate-quotient quotient) - - (define truncate-remainder remainder) - - (define (truncate/ x y) - (values (truncate-quotient x y) - (truncate-remainder x y))) - - (define (square z) (* z z)) - - (define inexact exact->inexact) - - (define exact inexact->exact) - - (define boolean=? eqv?) - - (define (make-list k . x) - (let ((x (if (pair? x) (car x) #f))) - (do ((i k (- i 1)) - (xs '() (cons x xs))) - ((<= i 0) xs)))) - - (define (list-set! x k object) - (set-car! (list-tail x k) object)) - - (define (list-copy x) - (let list-copy ((x x)) - (if (pair? x) - (cons (car x) - (list-copy (cdr x))) - x))) - - (define symbol=? eqv?) - - (define (string-map f x . xs) - (define (string-map-1 x) - (list->string - (map f (string->list x)))) - (define (string-map-n xs) - (map list->string - (map (lambda (c) (map f c)) - (map string->list xs)))) - (if (null? xs) - (string-map-1 x) - (string-map-n (cons x xs)))) - - (define call/cc call-with-current-continuation) - - (define (error-object? x) - (or (error? x) - (read-error? x) - (file-error? x) - (syntax-error? x))) - - ; (define (call-with-port port procedure) - ; (let-values ((results (procedure port))) - ; (close-port port) - ; (apply values results))) - - (define (call-with-port port procedure) - (let ((result (procedure port))) - (close-port port) - result)) - - (define current-input-port - (make-parameter (standard-input-port) - (lambda (x) - (cond ((not (input-port? x)) - (error "current-input-port: not input-port" x)) - ((not (input-port-open? x)) - (error "current-input-port: not input-port-open" x)) - (else x))))) - - (define current-output-port - (make-parameter (standard-output-port) - (lambda (x) - (cond ((not (output-port? x)) - (error "current-output-port: not output-port" x)) - ((not (output-port-open? x)) - (error "current-output-port: not output-port-open" x)) - (else x))))) - - (define current-error-port - (make-parameter (standard-error-port) - (lambda (x) - (cond ((not (output-port? x)) - (error "current-error-port: not output-port" x)) - ((not (output-port-open? x)) - (error "current-error-port: not output-port-open" x)) - (else x))))) - - (define (close-port x) - (cond ((input-port? x) (close-input-port x)) - ((output-port? x) (close-output-port x)) - (else (unspecified)))) - - (define (read-char . x) - (%read-char (if (pair? x) - (car x) - (current-input-port)))) - - (define (peek-char . x) - (%peek-char (if (pair? x) - (car x) - (current-input-port)))) - - (define (char-ready? . x) - (read-ready? (if (pair? x) - (car x) - (current-input-port)))) - - (define (write-char x . port) - (put-char x (if (pair? port) - (car port) - (current-output-port)))) - - (define (write-string string . xs) - (case (length xs) - ((0) (put-string string (current-output-port))) - ((1) (put-string string (car xs))) - (else (put-string (apply string-copy string (cadr xs)) (car xs))))) - - (define (newline . port) - (apply write-char #\newline port)) - - (define (flush-output-port . port) - (%flush-output-port (if (pair? port) - (car port) - (current-output-port)))) - ) - - (begin (define-syntax cond - (syntax-rules (else =>) - ((cond (else result1 result2 ...)) - (begin result1 result2 ...)) - ((cond (test => result)) - (let ((temp test)) - (if temp (result temp)))) - ((cond (test => result) clause1 clause2 ...) - (let ((temp test)) - (if temp - (result temp) - (cond clause1 clause2 ...)))) - ((cond (test)) test) - ((cond (test) clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (cond clause1 clause2 ...)))) - ((cond (test result1 result2 ...)) - (if test (begin result1 result2 ...))) - ((cond (test result1 result2 ...) - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (cond clause1 clause2 ...))))) - - (define-syntax case ; errata version - (syntax-rules (else =>) - ((case (key ...) clauses ...) - (let ((atom-key (key ...))) - (case atom-key clauses ...))) - ((case key - (else => result)) - (result key)) - ((case key - (else result1 result2 ...)) - (begin result1 result2 ...)) - ((case key - ((atoms ...) => result)) - (if (memv key '(atoms ...)) - (result key))) - ((case key ((atoms ...) => result) clause clauses ...) - (if (memv key '(atoms ...)) - (result key) - (case key clause clauses ...))) - ((case key ((atoms ...) result1 result2 ...)) - (if (memv key '(atoms ...)) - (begin result1 result2 ...))) - ((case key ((atoms ...) result1 result2 ...) clause clauses ...) - (if (memv key '(atoms ...)) - (begin result1 result2 ...) - (case key clause clauses ...))))) - - (define-syntax and - (syntax-rules () - ((and) #t) - ((and test) test) - ((and test1 test2 ...) - (if test1 (and test2 ...) #f)))) - - (define-syntax or - (syntax-rules () - ((or) #f) - ((or test) test) - ((or test1 test2 ...) - (let ((x test1)) - (if x x (or test2 ...)))))) - - (define-syntax when - (syntax-rules () - ((when test result1 result2 ...) - (if test - (begin result1 result2 ...))))) - - (define-syntax unless - (syntax-rules () - ((unless test result1 result2 ...) - (if (not test) - (begin result1 result2 ...))))) - - (define-syntax let - (syntax-rules () - ((let ((name val) ...) body1 body2 ...) - ((lambda (name ...) body1 body2 ...) val ...)) - ((let tag ((name val) ...) body1 body2 ...) - ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) - - (define-syntax let* - (syntax-rules () - ((let* () body1 body2 ...) - (let () body1 body2 ...)) - ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) - (let ((name1 val1)) - (let* ((name2 val2) ...) body1 body2 ...))))) - - (define-syntax letrec* - (syntax-rules () - ((letrec* ((var1 init1) ...) body1 body2 ...) - (let ((var1 ) ...) - (set! var1 init1) - ... - (let () body1 body2 ...))))) - - (define-syntax let-values - (syntax-rules () - ((let-values (binding ...) body0 body1 ...) - (let-values "bind" (binding ...) () (begin body0 body1 ...))) - ((let-values "bind" () tmps body) - (let tmps body)) - ((let-values "bind" ((b0 e0) binding ...) tmps body) - (let-values "mktmp" b0 e0 () (binding ...) tmps body)) - ((let-values "mktmp" () e0 args bindings tmps body) - (call-with-values - (lambda () e0) - (lambda args - (let-values "bind" bindings tmps body)))) - ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) - (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) - ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) - (call-with-values - (lambda () e0) - (lambda (arg ... . x) - (let-values "bind" bindings (tmp ... (a x)) body)))))) - - ; (define-syntax let-values - ; (er-macro-transformer - ; (lambda (form rename compare) - ; (if (null? (cadr form)) - ; `(,(rename 'let) () ,@(cddr form)) - ; `(,(rename 'call-with-values) - ; (,(rename 'lambda) () ,(cadar (cadr form))) - ; (,(rename 'lambda) ,(caar (cadr form)) - ; (,(rename 'let-values) ,(cdr (cadr form)) - ; ,@(cddr form)))))))) - - (define-syntax let*-values - (syntax-rules () - ((let*-values () body0 body1 ...) - (let () body0 body1 ...)) - ((let*-values (binding0 binding1 ...) - body0 body1 ...) - (let-values (binding0) - (let*-values (binding1 ...) - body0 body1 ...))))) - - ; (define-syntax let*-values - ; (er-macro-transformer - ; (lambda (form rename compare) - ; (if (null? (cadr form)) - ; `(,(rename 'let) () ,@(cddr form)) - ; `(,(rename 'let-values) (,(caadr form)) - ; (,(rename 'let*-values) ,(cdadr form) - ; ,@(cddr form))))))) - - (define-syntax do - (syntax-rules () - ((do ((var init step ...) ...) - (test expr ...) - command ...) - (letrec - ((loop - (lambda (var ...) - (if test - (begin - (if #f #f) - expr ...) - (begin - command - ... - (loop (do "step" var step ...) - ...)))))) - (loop init ...))) - ((do "step" x) - x) - ((do "step" x y) - y))))) - -(define-library (scheme lazy) - (import (srfi 45)) - (export delay - (rename lazy delay-force) - force - promise? - (rename eager make-promise))) - -(define-library (scheme case-lambda) - (export case-lambda - ) - ) - -(define-library (scheme inexact) - (export finite? - infinite? - nan? - exp - log - sin - cos - tan - asin - acos - atan - sqrt - ) - ) - -(define-library (scheme complex) - (export make-rectangular - make-polar - real-part - imag-part - angle - ) - ) - -(define-library (scheme cxr) - (import (meevax pair)) - (export caaar - caadr - cadar - caddr - cdaar - cdadr - cddar - cdddr - caaaar - caaadr - caadar - caaddr - cadaar - cadadr - caddar - cadddr - cdaaar - cdaadr - cdadar - cdaddr - cddaar - cddadr - cdddar - cddddr)) - -(define-library (scheme char) - (import (only (meevax character) digit-value) - (only (scheme r5rs) - char-ci=? - char-ci? - char-ci<=? - char-ci>=? - char-alphabetic? - char-numeric? - char-whitespace? - char-upper-case? - char-lower-case? - char-upcase - char-downcase - string-ci=? - string-ci? - string-ci<=? - string-ci>=?) - (only (scheme base) define string-map)) - - (export char-ci=? - char-ci? - char-ci<=? - char-ci>=? - char-alphabetic? - char-numeric? - char-whitespace? - char-upper-case? - char-lower-case? - digit-value - char-upcase - char-downcase - (rename char-downcase char-foldcase) - string-ci=? - string-ci? - string-ci<=? - string-ci>=? - string-upcase - string-downcase - string-foldcase) - - (begin (define (string-upcase x) - (string-map char-upcase x)) - - (define (string-downcase x) - (string-map char-downcase x)) - - (define (string-foldcase x) - (string-map char-foldcase x)))) - -(define-library (scheme eval) - (export environment - eval - ) - ) - -(define-library (scheme file) - (import (only (meevax port) open-input-file open-output-file) - (only (scheme r5rs) call-with-input-file call-with-output-file) - (only (scheme base) define parameterize current-input-port current-output-port) - ) - (export call-with-input-file - call-with-output-file - with-input-from-file - with-output-to-file - open-input-file - ; open-binary-input-file - open-output-file - ; open-binary-output-file - ; file-exists? - ; delete-file - ) - (begin (define (with-input-from-file path thunk) - (parameterize ((current-input-port (open-input-file path))) - (thunk))) - - (define (with-output-to-file path thunk) - (parameterize ((current-output-port (open-output-file path))) - (thunk))) - ) - ) - -(define-library (scheme read) - (import (meevax read) - (scheme base)) - (export read) - (begin (define (read . x) - (%read (if (pair? x) - (car x) - (current-input-port)))))) - -(define-library (scheme write) - (import (scheme base) - (only (meevax write) %write-simple) - (only (meevax port) put-char) - ) - (export write - ; write-shared - write-simple - display - ) - (begin (define (write-simple x . port) - (%write-simple x (if (pair? port) - (car port) - (current-output-port)))) - - (define write write-simple) ; DUMMY - - (define (display datum . port) - (cond ((char? datum) (apply write-char datum port)) - ((string? datum) (apply write-string datum port)) - (else (apply write datum port)))) - - ) - ) - -(define-library (scheme load) - (export load - ) - ) - -(define-library (scheme process-context) - (import (meevax context) - (meevax continuation) - ) - (export ; command-line - exit - emergency-exit - ; get-environment-variable - ; get-environment-variables - ) - ) - -(define-library (scheme time) - (export current-second - current-jiffy - jiffies-per-second - ) - ) - -(import (scheme r5rs) - (scheme base) - ) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 8b1378917..3b66635cc 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -1 +1,815 @@ +(define-library (scheme base) + (import (only (meevax exception) error? read-error? file-error? syntax-error?) + (only (meevax number) exact-integer?) + (only (meevax vector) vector->string) + (only (meevax port) + binary-port? + textual-port? + port? + input-port-open? + output-port-open? + standard-input-port + standard-output-port + standard-error-port + eof-object + %read-char + %peek-char + read-ready? + put-char + put-string + %flush-output-port + ) + (scheme r5rs) + (srfi 23) ; Error reporting mechanism + (srfi 34) ; Exception Handling for Programs + (srfi 39) ; Parameter objects + (srfi 211 explicit-renaming) + ) + (export quote + lambda + if + set! + ; include + ; include-ci + cond + ; else + ; => + case + and + or + when + unless + ; cond-expand + let + let* + letrec + letrec* + let-values + let*-values + begin + do + make-parameter + parameterize + guard + quasiquote + ; unquote + ; unquote-splicing + let-syntax + letrec-syntax + syntax-rules + ; _ + ; ... + ; syntax-error + define + ; define-values + define-syntax + ; define-record-type + eqv? + eq? + equal? + number? + complex? + real? + rational? + integer? + exact? + inexact? + exact-integer? + = + < + > + <= + >= + zero? + positive? + negative? + odd? + even? + max + min + + + * + - + / + abs + floor/ + floor-quotient + floor-remainder + truncate/ + truncate-quotient + truncate-remainder + quotient + remainder + modulo + gcd + lcm + numerator + denominator + floor + ceiling + truncate + round + rationalize + square + ; exact-integer-sqrt + expt + inexact + exact + number->string + string->number + not + boolean? + boolean=? + pair? + cons + car + cdr + set-car! + set-cdr! + caar + cadr + cdar + cddr + null? + list? + make-list + list + length + append + reverse + list-tail + list-ref + list-set! + memq + memv + member + assq + assv + assoc + list-copy + symbol? + ; symbol=? + symbol->string + string->symbol + char? + char=? + char? + char<=? + char>=? + char->integer + integer->char + string? + make-string + string + string-length + string-ref + string-set! + string=? + string>? + string=? + substring + string-append + string->list + list->string + string-copy + ; string-copy! + string-fill! + vector? + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector + vector->string + ; string->vector + ; vector-copy + ; vector-copy! + ; vector-append + vector-fill! + ; bytevector? + ; make-bytevector + ; bytevector + ; bytevector-length + ; bytevector-u8-ref + ; bytevector-u8-set! + ; bytevector-copy + ; bytevector-copy! + ; bytevector-append + ; utf8->string + ; string->utf8 + procedure? + apply + map + string-map + ; vector-map + for-each + ; string-for-each + ; vector-for-each + call-with-current-continuation + call/cc + values + call-with-values + dynamic-wind + with-exception-handler + raise + raise-continuable + error + error-object? + (rename car error-object-message) + (rename cdr error-object-irritants) + read-error? + file-error? + call-with-port + input-port? + output-port? + textual-port? + binary-port? + port? + input-port-open? + output-port-open? + current-input-port + current-output-port + current-error-port + close-port + close-input-port + close-output-port + ; open-input-string + ; open-output-string + ; get-output-string + ; open-input-bytevector + ; open-output-bytevector + ; get-output-bytevector + read-char + peek-char + ; read-line + eof-object? + eof-object + char-ready? + ; read-string + ; read-u8 + ; peek-u8 + ; u8-ready? + ; read-bytevector + ; read-bytevector! + newline + write-char + write-string + ; write-u8 + ; write-bytevector + flush-output-port + ; features + ) + + (begin (define (unspecified) (if #f #f)) + + (define-syntax when + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) ,(cadr form) + (,(rename 'begin) ,@(cddr form)))))) + + (define-syntax unless + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'if) (,(rename 'not) ,(cadr form)) + (,(rename 'begin) ,@(cddr form)))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'let) () + ,@(map (lambda (x) (cons (rename 'define) x)) + (cadr form)) + ,@(cddr form))))) + + (define (floor-quotient x y) + (floor (/ x y))) + + (define floor-remainder modulo) + + (define (floor/ x y) + (values (floor-quotient x y) + (floor-remainder x y))) + + (define truncate-quotient quotient) + + (define truncate-remainder remainder) + + (define (truncate/ x y) + (values (truncate-quotient x y) + (truncate-remainder x y))) + + (define (square z) (* z z)) + + (define inexact exact->inexact) + + (define exact inexact->exact) + + (define boolean=? eqv?) + + (define (make-list k . x) + (let ((x (if (pair? x) (car x) #f))) + (do ((i k (- i 1)) + (xs '() (cons x xs))) + ((<= i 0) xs)))) + + (define (list-set! x k object) + (set-car! (list-tail x k) object)) + + (define (list-copy x) + (let list-copy ((x x)) + (if (pair? x) + (cons (car x) + (list-copy (cdr x))) + x))) + + (define symbol=? eqv?) + + (define (string-map f x . xs) + (define (string-map-1 x) + (list->string + (map f (string->list x)))) + (define (string-map-n xs) + (map list->string + (map (lambda (c) (map f c)) + (map string->list xs)))) + (if (null? xs) + (string-map-1 x) + (string-map-n (cons x xs)))) + + (define call/cc call-with-current-continuation) + + (define (error-object? x) + (or (error? x) + (read-error? x) + (file-error? x) + (syntax-error? x))) + + ; (define (call-with-port port procedure) + ; (let-values ((results (procedure port))) + ; (close-port port) + ; (apply values results))) + + (define (call-with-port port procedure) + (let ((result (procedure port))) + (close-port port) + result)) + + (define current-input-port + (make-parameter (standard-input-port) + (lambda (x) + (cond ((not (input-port? x)) + (error "current-input-port: not input-port" x)) + ((not (input-port-open? x)) + (error "current-input-port: not input-port-open" x)) + (else x))))) + + (define current-output-port + (make-parameter (standard-output-port) + (lambda (x) + (cond ((not (output-port? x)) + (error "current-output-port: not output-port" x)) + ((not (output-port-open? x)) + (error "current-output-port: not output-port-open" x)) + (else x))))) + + (define current-error-port + (make-parameter (standard-error-port) + (lambda (x) + (cond ((not (output-port? x)) + (error "current-error-port: not output-port" x)) + ((not (output-port-open? x)) + (error "current-error-port: not output-port-open" x)) + (else x))))) + + (define (close-port x) + (cond ((input-port? x) (close-input-port x)) + ((output-port? x) (close-output-port x)) + (else (unspecified)))) + + (define (read-char . x) + (%read-char (if (pair? x) + (car x) + (current-input-port)))) + + (define (peek-char . x) + (%peek-char (if (pair? x) + (car x) + (current-input-port)))) + + (define (char-ready? . x) + (read-ready? (if (pair? x) + (car x) + (current-input-port)))) + + (define (write-char x . port) + (put-char x (if (pair? port) + (car port) + (current-output-port)))) + + (define (write-string string . xs) + (case (length xs) + ((0) (put-string string (current-output-port))) + ((1) (put-string string (car xs))) + (else (put-string (apply string-copy string (cadr xs)) (car xs))))) + + (define (newline . port) + (apply write-char #\newline port)) + + (define (flush-output-port . port) + (%flush-output-port (if (pair? port) + (car port) + (current-output-port)))) + ) + + (begin (define-syntax cond + (syntax-rules (else =>) + ((cond (else result1 result2 ...)) + (begin result1 result2 ...)) + ((cond (test => result)) + (let ((temp test)) + (if temp (result temp)))) + ((cond (test => result) clause1 clause2 ...) + (let ((temp test)) + (if temp + (result temp) + (cond clause1 clause2 ...)))) + ((cond (test)) test) + ((cond (test) clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...)))) + ((cond (test result1 result2 ...)) + (if test (begin result1 result2 ...))) + ((cond (test result1 result2 ...) + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...))))) + + (define-syntax case ; errata version + (syntax-rules (else =>) + ((case (key ...) clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else => result)) + (result key)) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) => result)) + (if (memv key '(atoms ...)) + (result key))) + ((case key ((atoms ...) => result) clause clauses ...) + (if (memv key '(atoms ...)) + (result key) + (case key clause clauses ...))) + ((case key ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key ((atoms ...) result1 result2 ...) clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + + (define-syntax and + (syntax-rules () + ((and) #t) + ((and test) test) + ((and test1 test2 ...) + (if test1 (and test2 ...) #f)))) + + (define-syntax or + (syntax-rules () + ((or) #f) + ((or test) test) + ((or test1 test2 ...) + (let ((x test1)) + (if x x (or test2 ...)))))) + + (define-syntax when + (syntax-rules () + ((when test result1 result2 ...) + (if test + (begin result1 result2 ...))))) + + (define-syntax unless + (syntax-rules () + ((unless test result1 result2 ...) + (if (not test) + (begin result1 result2 ...))))) + + (define-syntax let + (syntax-rules () + ((let ((name val) ...) body1 body2 ...) + ((lambda (name ...) body1 body2 ...) val ...)) + ((let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (lambda (name ...) body1 body2 ...))) tag) val ...)))) + + (define-syntax let* + (syntax-rules () + ((let* () body1 body2 ...) + (let () body1 body2 ...)) + ((let* ((name1 val1) (name2 val2) ...) body1 body2 ...) + (let ((name1 val1)) + (let* ((name2 val2) ...) body1 body2 ...))))) + + (define-syntax letrec* + (syntax-rules () + ((letrec* ((var1 init1) ...) body1 body2 ...) + (let ((var1 ) ...) + (set! var1 init1) + ... + (let () body1 body2 ...))))) + + (define-syntax let-values + (syntax-rules () + ((let-values (binding ...) body0 body1 ...) + (let-values "bind" (binding ...) () (begin body0 body1 ...))) + ((let-values "bind" () tmps body) + (let tmps body)) + ((let-values "bind" ((b0 e0) binding ...) tmps body) + (let-values "mktmp" b0 e0 () (binding ...) tmps body)) + ((let-values "mktmp" () e0 args bindings tmps body) + (call-with-values + (lambda () e0) + (lambda args + (let-values "bind" bindings tmps body)))) + ((let-values "mktmp" (a . b) e0 (arg ...) bindings (tmp ...) body) + (let-values "mktmp" b e0 (arg ... x) bindings (tmp ... (a x)) body)) + ((let-values "mktmp" a e0 (arg ...) bindings (tmp ...) body) + (call-with-values + (lambda () e0) + (lambda (arg ... . x) + (let-values "bind" bindings (tmp ... (a x)) body)))))) + + ; (define-syntax let-values + ; (er-macro-transformer + ; (lambda (form rename compare) + ; (if (null? (cadr form)) + ; `(,(rename 'let) () ,@(cddr form)) + ; `(,(rename 'call-with-values) + ; (,(rename 'lambda) () ,(cadar (cadr form))) + ; (,(rename 'lambda) ,(caar (cadr form)) + ; (,(rename 'let-values) ,(cdr (cadr form)) + ; ,@(cddr form)))))))) + + (define-syntax let*-values + (syntax-rules () + ((let*-values () body0 body1 ...) + (let () body0 body1 ...)) + ((let*-values (binding0 binding1 ...) + body0 body1 ...) + (let-values (binding0) + (let*-values (binding1 ...) + body0 body1 ...))))) + + ; (define-syntax let*-values + ; (er-macro-transformer + ; (lambda (form rename compare) + ; (if (null? (cadr form)) + ; `(,(rename 'let) () ,@(cddr form)) + ; `(,(rename 'let-values) (,(caadr form)) + ; (,(rename 'let*-values) ,(cdadr form) + ; ,@(cddr form))))))) + + (define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))))) + +(define-library (scheme lazy) + (import (srfi 45)) + (export delay + (rename lazy delay-force) + force + promise? + (rename eager make-promise))) + +(define-library (scheme case-lambda) + (export case-lambda + ) + ) + +(define-library (scheme inexact) + (export finite? + infinite? + nan? + exp + log + sin + cos + tan + asin + acos + atan + sqrt + ) + ) + +(define-library (scheme complex) + (export make-rectangular + make-polar + real-part + imag-part + angle + ) + ) + +(define-library (scheme cxr) + (import (meevax pair)) + (export caaar + caadr + cadar + caddr + cdaar + cdadr + cddar + cdddr + caaaar + caaadr + caadar + caaddr + cadaar + cadadr + caddar + cadddr + cdaaar + cdaadr + cdadar + cdaddr + cddaar + cddadr + cdddar + cddddr)) + +(define-library (scheme char) + (import (only (meevax character) digit-value) + (only (scheme r5rs) + char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + char-upcase + char-downcase + string-ci=? + string-ci? + string-ci<=? + string-ci>=?) + (only (scheme base) define string-map)) + + (export char-ci=? + char-ci? + char-ci<=? + char-ci>=? + char-alphabetic? + char-numeric? + char-whitespace? + char-upper-case? + char-lower-case? + digit-value + char-upcase + char-downcase + (rename char-downcase char-foldcase) + string-ci=? + string-ci? + string-ci<=? + string-ci>=? + string-upcase + string-downcase + string-foldcase) + + (begin (define (string-upcase x) + (string-map char-upcase x)) + + (define (string-downcase x) + (string-map char-downcase x)) + + (define (string-foldcase x) + (string-map char-foldcase x)))) + +(define-library (scheme eval) + (export environment + eval + ) + ) + +(define-library (scheme file) + (import (only (meevax port) open-input-file open-output-file) + (only (scheme r5rs) call-with-input-file call-with-output-file) + (only (scheme base) define parameterize current-input-port current-output-port) + ) + (export call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file + open-input-file + ; open-binary-input-file + open-output-file + ; open-binary-output-file + ; file-exists? + ; delete-file + ) + (begin (define (with-input-from-file path thunk) + (parameterize ((current-input-port (open-input-file path))) + (thunk))) + + (define (with-output-to-file path thunk) + (parameterize ((current-output-port (open-output-file path))) + (thunk))) + ) + ) + +(define-library (scheme read) + (import (meevax read) + (scheme base)) + (export read) + (begin (define (read . x) + (%read (if (pair? x) + (car x) + (current-input-port)))))) + +(define-library (scheme write) + (import (scheme base) + (only (meevax write) %write-simple) + (only (meevax port) put-char) + ) + (export write + ; write-shared + write-simple + display + ) + (begin (define (write-simple x . port) + (%write-simple x (if (pair? port) + (car port) + (current-output-port)))) + + (define write write-simple) ; DUMMY + + (define (display datum . port) + (cond ((char? datum) (apply write-char datum port)) + ((string? datum) (apply write-string datum port)) + (else (apply write datum port)))) + + ) + ) + +(define-library (scheme load) + (export load + ) + ) + +(define-library (scheme process-context) + (import (meevax context) + (meevax continuation) + ) + (export ; command-line + exit + emergency-exit + ; get-environment-variable + ; get-environment-variables + ) + ) + +(define-library (scheme time) + (export current-second + current-jiffy + jiffies-per-second + ) + ) diff --git a/example/example.ss b/example/example.ss index 8e9ee3543..349888fe5 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,5 +1,6 @@ (import (meevax foreign-function-interface) - (scheme process-context) + (scheme base) + (only (scheme process-context) exit) (srfi 78)) (define dummy-procedure (foreign-function "build/libexample.so" "dummy_procedure")) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index 7cb1e9834..a4deff664 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -29,7 +29,6 @@ inline namespace kernel using string_view = std::experimental::string_view; #endif - extern string_view const overture; extern string_view const r4rs; extern string_view const r4rs_essential; extern string_view const r5rs; diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index 18484f5d1..6b7af5255 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -42,7 +42,6 @@ inline namespace kernel \ } \ } static_assert(true) -DEFINE_BINARY(overture); DEFINE_BINARY(r4rs); DEFINE_BINARY(r4rs_essential); DEFINE_BINARY(r5rs); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index e494387bc..b3fb28d8f 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -49,7 +49,6 @@ namespace meevax srfi_34, // Exception Handling for Programs srfi_23, // Error reporting mechanism srfi_39, // Parameter objects - overture, r7rs, srfi_8, // receive: Binding to multiple values srfi_1, // List Library diff --git a/test/abandoned.ss b/test/abandoned.ss index 28b699b7c..cbc00c5eb 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -1,5 +1,7 @@ -(import (scheme char) +(import (scheme base) + (scheme char) (scheme process-context) + (scheme write) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 813274eec..56fff0d7f 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index 254541b6f..fd43c358c 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,4 +1,6 @@ (import (only (meevax macro) transformer?) + (scheme base) + (scheme cxr) (scheme process-context) (srfi 78) (srfi 211 explicit-renaming) diff --git a/test/identifier.ss b/test/identifier.ss index a408577a6..3d2ee4749 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -1,4 +1,5 @@ (import (meevax macro) + (scheme base) (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/internal-definition.ss b/test/internal-definition.ss index a553679dc..84d6c6e9f 100644 --- a/test/internal-definition.ss +++ b/test/internal-definition.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78)) (define a 100) diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index 64005da8e..e86b6042f 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78) (srfi 211 explicit-renaming)) diff --git a/test/numerical-operations.ss b/test/numerical-operations.ss index 4a8a59870..ad5fae28b 100644 --- a/test/numerical-operations.ss +++ b/test/numerical-operations.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78)) ; ---- 6.2.6. Numerical operations --------------------------------------------- diff --git a/test/r4rs-appendix.ss b/test/r4rs-appendix.ss index efb53544a..19f384e84 100644 --- a/test/r4rs-appendix.ss +++ b/test/r4rs-appendix.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78) (srfi 211 syntactic-closures) (srfi 211 explicit-renaming)) diff --git a/test/r4rs.ss b/test/r4rs.ss index 3bcc56c47..efaa1d8a6 100644 --- a/test/r4rs.ss +++ b/test/r4rs.ss @@ -1,6 +1,9 @@ -(import (scheme process-context) +(import (scheme r4rs) + (scheme process-context) (srfi 78)) +(define call-with-current-continuation call-with-current-continuation!) ; TEMPORARY + (check (* 5 8) => 40) ;;; The FACT procedure computes the factorial diff --git a/test/r5rs.ss b/test/r5rs.ss index ff9cfd0cf..cfa836056 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme r5rs) + (only (scheme process-context) exit) (srfi 78)) ; ---- 1.3.4 ------------------------------------------------------------------- diff --git a/test/r7rs.ss b/test/r7rs.ss index 58d580dbf..556d5df68 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1,4 +1,4 @@ -(import +(import (scheme base) (scheme char) (scheme file) (scheme lazy) @@ -752,8 +752,7 @@ (check (round 7/2) => 4) ; exact (check (round 7) => 7) -(check (rationalize - (inexact->exact .3) 1/10) => 1/3) ; exact +(check (rationalize (exact .3) 1/10) => 1/3) ; exact (check (rationalize .3 1/10) => #,(/ 1.0 3.0)) ; inexact (check (square 42) => 1764) @@ -960,8 +959,7 @@ (check (vector-ref '#(1 1 2 3 5 8 13 21) 5) => 8) (check (vector-ref '#(1 1 2 3 5 8 13 21) - (inexact->exact - (round (* 2 (acos -1))))) => 13) + (exact (round (* 2 (acos -1))))) => 13) (check (let ((vec (vector 0 '(2 2 2 2) "Anna"))) (vector-set! vec 1 '("Sue" "Sue")) vec) => #(0 ("Sue" "Sue") "Anna")) diff --git a/test/sicp-1.ss b/test/sicp-1.ss index 1e6d8dffc..69a0967ea 100644 --- a/test/sicp-1.ss +++ b/test/sicp-1.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 78)) ; ---- Section 1.1.1 ----------------------------------------------------------- diff --git a/test/srfi-8.ss b/test/srfi-8.ss index f09398591..d6bc66b33 100644 --- a/test/srfi-8.ss +++ b/test/srfi-8.ss @@ -1,4 +1,5 @@ -(import (scheme process-context) +(import (scheme base) + (scheme process-context) (srfi 8) (srfi 78)) diff --git a/test/transformer.ss b/test/transformer.ss index a56972778..3bdf79774 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,4 +1,6 @@ (import (only (meevax macro) transformer?) + (scheme base) + (scheme cxr) (scheme process-context) (srfi 78) (srfi 211 syntactic-closures) From bb21666b1140139eed19aff195ff29ef62827086 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 18 May 2022 00:43:50 +0900 Subject: [PATCH 39/49] Update SRFI 6 to be R7RS style library Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r7rs.ss | 19 +++++++------------ basis/srfi-6.ss | 3 +++ include/meevax/kernel/basis.hpp | 1 + src/kernel/basis.cpp | 1 + src/library/meevax.cpp | 3 ++- 7 files changed, 18 insertions(+), 17 deletions(-) create mode 100644 basis/srfi-6.ss diff --git a/README.md b/README.md index 38d2abfe0..7a2554cea 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1010.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1011.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1010_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1011_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1010 +Meevax Lisp System, version 0.3.1011 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 55bb38e24..b1d0f13a5 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1010 +0.3.1011 diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 3b66635cc..be9a64a9b 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -20,6 +20,7 @@ %flush-output-port ) (scheme r5rs) + (srfi 6) ; Basic String Ports (srfi 23) ; Error reporting mechanism (srfi 34) ; Exception Handling for Programs (srfi 39) ; Parameter objects @@ -120,7 +121,7 @@ string->number not boolean? - boolean=? + (rename eqv? boolean=?) pair? cons car @@ -149,7 +150,7 @@ assoc list-copy symbol? - ; symbol=? + (rename eqv? symbol=?) symbol->string string->symbol char? @@ -212,7 +213,7 @@ ; string-for-each ; vector-for-each call-with-current-continuation - call/cc + (rename call-with-current-continuation call/cc) values call-with-values dynamic-wind @@ -239,9 +240,9 @@ close-port close-input-port close-output-port - ; open-input-string - ; open-output-string - ; get-output-string + open-input-string + open-output-string + get-output-string ; open-input-bytevector ; open-output-bytevector ; get-output-bytevector @@ -311,8 +312,6 @@ (define exact inexact->exact) - (define boolean=? eqv?) - (define (make-list k . x) (let ((x (if (pair? x) (car x) #f))) (do ((i k (- i 1)) @@ -329,8 +328,6 @@ (list-copy (cdr x))) x))) - (define symbol=? eqv?) - (define (string-map f x . xs) (define (string-map-1 x) (list->string @@ -343,8 +340,6 @@ (string-map-1 x) (string-map-n (cons x xs)))) - (define call/cc call-with-current-continuation) - (define (error-object? x) (or (error? x) (read-error? x) diff --git a/basis/srfi-6.ss b/basis/srfi-6.ss new file mode 100644 index 000000000..d45acd27d --- /dev/null +++ b/basis/srfi-6.ss @@ -0,0 +1,3 @@ +(define-library (srfi 6) + (import (only (meevax port) open-input-string open-output-string get-output-string)) + (export open-input-string open-output-string get-output-string)) diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index a4deff664..2b2dcdbd4 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -34,6 +34,7 @@ inline namespace kernel extern string_view const r5rs; extern string_view const r7rs; extern string_view const srfi_1; + extern string_view const srfi_6; extern string_view const srfi_8; extern string_view const srfi_23; extern string_view const srfi_34; diff --git a/src/kernel/basis.cpp b/src/kernel/basis.cpp index 6b7af5255..b0f9ea6df 100644 --- a/src/kernel/basis.cpp +++ b/src/kernel/basis.cpp @@ -47,6 +47,7 @@ DEFINE_BINARY(r4rs_essential); DEFINE_BINARY(r5rs); DEFINE_BINARY(r7rs); DEFINE_BINARY(srfi_1); +DEFINE_BINARY(srfi_6); DEFINE_BINARY(srfi_8); DEFINE_BINARY(srfi_23); DEFINE_BINARY(srfi_34); diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index b3fb28d8f..ea3c14487 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -27,7 +27,7 @@ namespace meevax import("(meevax control)"); import("(meevax inexact)"); import("(meevax number)"); - import("(meevax port)"); + // import("(meevax port)"); define("features", [](auto&&...) { @@ -46,6 +46,7 @@ namespace meevax r4rs, srfi_149, r5rs, + srfi_6, // Basic String Ports srfi_34, // Exception Handling for Programs srfi_23, // Error reporting mechanism srfi_39, // Parameter objects From 39016c476264e33c29e1dd65b0dc9504a6a64018 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 18 May 2022 02:13:07 +0900 Subject: [PATCH 40/49] Update interaction-environment to be empty Signed-off-by: yamacir-kit --- README.md | 6 ++-- VERSION | 2 +- basis/r4rs-essential.ss | 18 +++++----- basis/r7rs.ss | 10 +++--- example/example.ss | 2 +- src/kernel/environment.cpp | 2 +- src/kernel/library.cpp | 64 +++++++++++++++++++++--------------- src/library/meevax.cpp | 17 ---------- test/numerical-operations.ss | 1 + test/r4rs.ss | 2 +- test/r7rs.ss | 1 + 11 files changed, 61 insertions(+), 64 deletions(-) diff --git a/README.md b/README.md index 7a2554cea..0fe87828f 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1011.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1012.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1011_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1012_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1011 +Meevax Lisp System, version 0.3.1012 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index b1d0f13a5..0289cc906 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1011 +0.3.1012 diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss index f4862815c..664ba7b89 100644 --- a/basis/r4rs-essential.ss +++ b/basis/r4rs-essential.ss @@ -2,6 +2,8 @@ (import (meevax character) (meevax control) (meevax equivalence) + (meevax environment) + (meevax foreign-function) (meevax list) (meevax number) (meevax pair) @@ -456,14 +458,14 @@ (char-ci-compare x xs >=)) (define (char-alphabetic? x) - (<= #,(char->integer #\a) + (<= (char->integer #\a) (char->integer (char-downcase x)) - #,(char->integer #\z))) + (char->integer #\z))) (define (char-numeric? x) - (<= #,(char->integer #\0) + (<= (char->integer #\0) (char->integer x) - #,(char->integer #\9))) + (char->integer #\9))) (define (char-whitespace? x) (or (eqv? x #\space) @@ -472,14 +474,14 @@ (eqv? x #\return))) (define (char-upper-case? x) - (<= #,(char->integer #\A) + (<= (char->integer #\A) (char->integer x) - #,(char->integer #\Z))) + (char->integer #\Z))) (define (char-lower-case? x) - (<= #,(char->integer #\a) + (<= (char->integer #\a) (char->integer x) - #,(char->integer #\z))) + (char->integer #\z))) (define (char-downcase c) (if (char-lower-case? c) c diff --git a/basis/r7rs.ss b/basis/r7rs.ss index be9a64a9b..1b3472d75 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -19,6 +19,7 @@ put-string %flush-output-port ) + (meevax version) (scheme r5rs) (srfi 6) ; Basic String Ports (srfi 23) ; Error reporting mechanism @@ -264,8 +265,7 @@ ; write-u8 ; write-bytevector flush-output-port - ; features - ) + features) (begin (define (unspecified) (if #f #f)) @@ -614,6 +614,8 @@ ) (define-library (scheme inexact) + (import (only (meevax inexact) finite? infinite? nan?) + (only (scheme r5rs) exp log sin cos tan asin acos atan sqrt)) (export finite? infinite? nan? @@ -625,9 +627,7 @@ asin acos atan - sqrt - ) - ) + sqrt)) (define-library (scheme complex) (export make-rectangular diff --git a/example/example.ss b/example/example.ss index 349888fe5..c1f39dee0 100644 --- a/example/example.ss +++ b/example/example.ss @@ -1,4 +1,4 @@ -(import (meevax foreign-function-interface) +(import (meevax foreign-function) (scheme base) (only (scheme process-context) exit) (srfi 78)) diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 4af1ae2a5..3f358b5f7 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -146,7 +146,7 @@ inline namespace kernel } else { - std::cout << error(make("no such identifier"), identifier); + throw error(make("no such identifier"), identifier); } } diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 36bc7c74b..396cc099e 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -64,7 +64,13 @@ inline namespace kernel return e; }); + define("load", [](let const& xs) + { + return car(xs).as().load(cadr(xs).as()); + }); + export_("environment"); + export_("load"); } library::library(equivalence_library_t) @@ -654,13 +660,18 @@ inline namespace kernel library::library(control_library_t) { - define("closure?", [](let const& xs) { return car(xs).is(); }); - define("continuation?", [](let const& xs) { return car(xs).is(); }); - define("foreign-function?", [](let const& xs) { return car(xs).is(); }); + define("closure?", [](let const& xs) + { + return car(xs).is(); + }); - export_("closure?", - "continuation?", - "foreign-function?"); + define("continuation?", [](let const& xs) + { + return car(xs).is(); + }); + + export_("closure?"); + export_("continuation?"); } library::library(exception_library_t) @@ -1100,46 +1111,45 @@ inline namespace kernel define_library("(meevax vector)", vector_library); define_library("(meevax write)", write_library); - define_library("(meevax gc)", [](library & meevax_gc) + define_library("(meevax foreign-function)", [](library & library) { - meevax_gc.define("gc-collect", [](auto&&...) + library.define("foreign-function", [](let const& xs) { - return make(gc.collect()); + return make(cadr(xs).as(), car(xs).as()); }); - meevax_gc.define("gc-count", [](auto&&...) + library.define("foreign-function?", [](let const& xs) { - return make(gc.count()); + return car(xs).is(); }); - meevax_gc.export_("gc-collect", "gc-count"); + library.export_("foreign-function"); + library.export_("foreign-function?"); }); - define_library("(meevax foreign-function-interface)", [](library & meevax_ffi) + define_library("(meevax garbage-collector)", [](library & library) { - meevax_ffi.define("foreign-function", [](let const& xs) + library.define("gc-collect", [](auto&&...) { - return make(cadr(xs).as(), car(xs).as()); + return make(gc.collect()); }); - meevax_ffi.export_("foreign-function"); + library.define("gc-count", [](auto&&...) + { + return make(gc.count()); + }); + + library.export_("gc-collect", "gc-count"); }); - define_library("(meevax foo)", [](library & library) + define_library("(meevax version)", [](library & library) { - library.export_("a"); - library.export_("b"); - library.export_("c"); - - library.define("a", [](let const&) + library.define("features", [](auto&&...) { - LINE(); - return unit; + return features(); }); - library.define("b", make(42)); - - library.define("c", make("dummy")); + library.export_("features"); }); } } // namespace kernel diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index ea3c14487..7c8ae0727 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -22,23 +22,6 @@ namespace meevax { environment::environment(master_t) { - import("(meevax character)"); - import("(meevax context)"); - import("(meevax control)"); - import("(meevax inexact)"); - import("(meevax number)"); - // import("(meevax port)"); - - define("features", [](auto&&...) - { - return features(); - }); - - define("load", [this](let const& xs) - { - return load(car(xs).as()); - }); - std::vector const codes { srfi_211, r4rs_essential, diff --git a/test/numerical-operations.ss b/test/numerical-operations.ss index ad5fae28b..14c8691c4 100644 --- a/test/numerical-operations.ss +++ b/test/numerical-operations.ss @@ -1,4 +1,5 @@ (import (scheme base) + (scheme inexact) (scheme process-context) (srfi 78)) diff --git a/test/r4rs.ss b/test/r4rs.ss index efaa1d8a6..5ebe9d73c 100644 --- a/test/r4rs.ss +++ b/test/r4rs.ss @@ -418,7 +418,7 @@ (check (list-ref '(a b c d) 2) => c) (check (list-ref '(a b c d) - (exact (round 1.8))) => c) + (inexact->exact (round 1.8))) => c) (check (memq 'a '(a b c)) => (a b c)) (check (memq 'b '(a b c)) => (b c)) diff --git a/test/r7rs.ss b/test/r7rs.ss index 556d5df68..d09eda3d2 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -1,6 +1,7 @@ (import (scheme base) (scheme char) (scheme file) + (scheme inexact) (scheme lazy) (scheme process-context) (scheme read) From c97f190053a2e1c7ea4dbc52eba603bf56701497 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Wed, 18 May 2022 03:52:41 +0900 Subject: [PATCH 41/49] Support experimental procedure `interaction-environment` Signed-off-by: yamacir-kit --- README.md | 6 +-- VERSION | 2 +- include/meevax/kernel/basis.hpp | 6 +-- include/meevax/kernel/environment.hpp | 9 +--- include/meevax/kernel/library.hpp | 4 +- include/meevax/string/repeat.hpp | 1 + src/kernel/library.cpp | 43 ++++++++++++++++++- src/library/meevax.cpp | 60 +++++++++++++-------------- src/main.cpp | 17 ++++++-- test/environment.cpp | 6 ++- 10 files changed, 100 insertions(+), 54 deletions(-) diff --git a/README.md b/README.md index 0fe87828f..121dd571f 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1012.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1013.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1012_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1013_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1012 +Meevax Lisp System, version 0.3.1013 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 0289cc906..36a250dfa 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1012 +0.3.1013 diff --git a/include/meevax/kernel/basis.hpp b/include/meevax/kernel/basis.hpp index 2b2dcdbd4..a0206fe8d 100644 --- a/include/meevax/kernel/basis.hpp +++ b/include/meevax/kernel/basis.hpp @@ -14,8 +14,8 @@ limitations under the License. */ -#ifndef INCLUDED_MEEVAX_KERNEL_LIBRARY_HPP -#define INCLUDED_MEEVAX_KERNEL_LIBRARY_HPP +#ifndef INCLUDED_MEEVAX_KERNEL_BASIS_HPP +#define INCLUDED_MEEVAX_KERNEL_BASIS_HPP #include @@ -46,4 +46,4 @@ inline namespace kernel } // namespace kernel } // namespace meevax -#endif // INCLUDED_MEEVAX_KERNEL_LIBRARY_HPP +#endif // INCLUDED_MEEVAX_KERNEL_BASIS_HPP diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 1817ae21e..fe1dc5e67 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -28,11 +28,6 @@ inline namespace kernel { inline namespace experimental { - struct master_t - { - explicit master_t() = default; - } constexpr master; - struct empty_t { explicit empty_t() = default; @@ -66,11 +61,9 @@ inline namespace kernel explicit environment(empty_t) // FOR MIGRATION {} - explicit environment(master_t); // FOR MIGRATION - template ...)> explicit environment(Ts&&... xs) - : environment { master } + : environment { empty } { (import(xs), ...); diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 3b7deec8e..5b31446fe 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -44,7 +44,9 @@ inline namespace kernel } } - static auto boot() -> void; + static auto boot_meevax_libraries() -> void; + + static auto boot_scheme_libraries() -> void; auto declare(const_reference declaration) -> void { diff --git a/include/meevax/string/repeat.hpp b/include/meevax/string/repeat.hpp index 8e56d00ca..1d4e263db 100644 --- a/include/meevax/string/repeat.hpp +++ b/include/meevax/string/repeat.hpp @@ -17,6 +17,7 @@ #ifndef INCLUDED_MEEVAX_STRING_REPEAT_HPP #define INCLUDED_MEEVAX_STRING_REPEAT_HPP +#include #include #include diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 396cc099e..4900a69e9 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -14,7 +14,7 @@ limitations under the License. */ -#include +#include #include namespace meevax @@ -69,7 +69,13 @@ inline namespace kernel return car(xs).as().load(cadr(xs).as()); }); + define("interaction-environment", [](auto&&...) + { + return unspecified_object; + }); + export_("environment"); + export_("interaction-environment"); export_("load"); } @@ -1088,7 +1094,7 @@ inline namespace kernel std::map libraries {}; - auto library::boot() -> void + auto library::boot_meevax_libraries() -> void { define_library("(meevax character)", character_library); define_library("(meevax context)", context_library); @@ -1152,5 +1158,38 @@ inline namespace kernel library.export_("features"); }); } + + auto library::boot_scheme_libraries() -> void + { + std::vector const codes { + srfi_211, + r4rs_essential, + srfi_45, + r4rs, + srfi_149, + r5rs, + srfi_6, // Basic String Ports + srfi_34, // Exception Handling for Programs + srfi_23, // Error reporting mechanism + srfi_39, // Parameter objects + r7rs, + srfi_8, // receive: Binding to multiple values + srfi_1, // List Library + srfi_78, // Lightweight testing + }; + + auto sandbox = environment(); + + for (auto const& code : codes) + { + // NOTE: Since read performs a putback operation on a given stream, it must be copied and used. + auto port = std::stringstream(std::string(code)); + + for (let e = sandbox.read(port); e != eof_object; e = sandbox.read(port)) + { + sandbox.evaluate(e); + } + } + } } // namespace kernel } // namespace meevax diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index 7c8ae0727..6863d803f 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -20,34 +20,34 @@ namespace meevax { - environment::environment(master_t) - { - std::vector const codes { - srfi_211, - r4rs_essential, - srfi_45, - r4rs, - srfi_149, - r5rs, - srfi_6, // Basic String Ports - srfi_34, // Exception Handling for Programs - srfi_23, // Error reporting mechanism - srfi_39, // Parameter objects - r7rs, - srfi_8, // receive: Binding to multiple values - srfi_1, // List Library - srfi_78, // Lightweight testing - }; - - for (auto const& code : codes) - { - // NOTE: Since read performs a putback operation on a given stream, it must be copied and used. - auto port = std::stringstream(std::string(code)); - - for (let e = read(port); e != eof_object; e = read(port)) - { - evaluate(e); - } - } - } + // environment::environment(master_t) + // { + // // std::vector const codes { + // // srfi_211, + // // r4rs_essential, + // // srfi_45, + // // r4rs, + // // srfi_149, + // // r5rs, + // // srfi_6, // Basic String Ports + // // srfi_34, // Exception Handling for Programs + // // srfi_23, // Error reporting mechanism + // // srfi_39, // Parameter objects + // // r7rs, + // // srfi_8, // receive: Binding to multiple values + // // srfi_1, // List Library + // // srfi_78, // Lightweight testing + // // }; + // // + // // for (auto const& code : codes) + // // { + // // // NOTE: Since read performs a putback operation on a given stream, it must be copied and used. + // // auto port = std::stringstream(std::string(code)); + // // + // // for (let e = read(port); e != eof_object; e = read(port)) + // // { + // // evaluate(e); + // // } + // // } + // } } // namespace meevax diff --git a/src/main.cpp b/src/main.cpp index 80ff27476..88163888b 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -23,9 +23,18 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - library::boot(); + let interaction_environment = make(); - auto main = environment(master); + auto&& main = interaction_environment.as(); + + library::boot_meevax_libraries(); + + libraries.at("(meevax environment)").define("interaction-environment", [&](auto&&...) + { + return interaction_environment; + }); + + library::boot_scheme_libraries(); main.configure(argc, argv); @@ -37,8 +46,8 @@ auto main(int const argc, char const* const* const argv) -> int while (main.is_interactive_mode() and main.char_ready()) { - main.print(horizontal_rule()); - main.write(standard_output, length(main.global()), "/", main.current_prompt()); + main.print(u8"\u250c", repeat(u8"\u2500", 79)); + main.write(standard_output, u8"\u2502", length(main.global()), "/", main.current_prompt()); main.print(main.evaluate(main.read())); } diff --git a/test/environment.cpp b/test/environment.cpp index 83f1e2c70..77fc2ea40 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -24,9 +24,11 @@ auto main() -> int assert(gc_count == constants.size() + specials_count); { - library::boot(); + auto interaction_environment = environment(); - auto root = environment(master); + library::boot_meevax_libraries(); + + library::boot_scheme_libraries(); } environment::symbols.clear(); From 24b0167859d6d6cada6205345fcb4615a75ce9fa Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 00:51:40 +0900 Subject: [PATCH 42/49] Fix procedure `load` to assume optional environment-specifier as `interaction-environment` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r4rs-essential.ss | 13 +++++++++++-- basis/r7rs.ss | 5 ++--- src/kernel/library.cpp | 16 +++------------- 5 files changed, 20 insertions(+), 22 deletions(-) diff --git a/README.md b/README.md index 121dd571f..a07a687b4 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1013.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1015.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1013_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1015_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1013 +Meevax Lisp System, version 0.3.1015 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 36a250dfa..7c299c9e2 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1013 +0.3.1015 diff --git a/basis/r4rs-essential.ss b/basis/r4rs-essential.ss index 664ba7b89..2dfbc860a 100644 --- a/basis/r4rs-essential.ss +++ b/basis/r4rs-essential.ss @@ -1,13 +1,14 @@ (define-library (scheme r4rs essential) (import (meevax character) (meevax control) - (meevax equivalence) (meevax environment) + (meevax equivalence) (meevax foreign-function) (meevax list) (meevax number) (meevax pair) (meevax port) + (meevax read) (meevax string) (meevax symbol) (meevax syntax) @@ -596,4 +597,12 @@ (else (apply write datum port)))) (define (newline . port) - (apply write-char #\newline port)))) + (apply write-char #\newline port)) + + (define (load filename . environment) + (%load (if (pair? environment) + (car environment) + (interaction-environment)) + filename)) + ) + ) diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 1b3472d75..7f9d2fe77 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -786,9 +786,8 @@ ) (define-library (scheme load) - (export load - ) - ) + (import (only (scheme r5rs) load)) + (export load)) (define-library (scheme process-context) (import (meevax context) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 4900a69e9..47e082888 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -64,7 +64,7 @@ inline namespace kernel return e; }); - define("load", [](let const& xs) + define("%load", [](let const& xs) { return car(xs).as().load(cadr(xs).as()); }); @@ -76,7 +76,7 @@ inline namespace kernel export_("environment"); export_("interaction-environment"); - export_("load"); + export_("%load"); } library::library(equivalence_library_t) @@ -935,17 +935,7 @@ inline namespace kernel { try { - switch (length(xs)) - { - case 0: - return read(standard_input); - - case 1: - return read(car(xs)); - - default: - throw invalid_application(intern("read") | xs); - } + return read(car(xs)); } catch (eof const&) { From d25a84f8c840bbf45b64d56810202cfd07de32fd Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 00:57:56 +0900 Subject: [PATCH 43/49] Rename library `(meevax continuation)` to `(scheme r5rs continuation)` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- basis/r5rs.ss | 6 +++--- basis/r7rs.ss | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index a07a687b4..c7406b564 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1015.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1016.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1015_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1016_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1015 +Meevax Lisp System, version 0.3.1016 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 7c299c9e2..6b2f84590 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1015 +0.3.1016 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index ee996b9c5..e38d39540 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -1,4 +1,4 @@ -(define-library (meevax continuation) +(define-library (scheme r5rs continuation) (import (meevax context) (meevax syntax) (scheme r4rs essential)) @@ -37,11 +37,11 @@ (apply emergency-exit normally?)))) (define-library (scheme r5rs) - (import (meevax continuation) - (meevax environment) + (import (meevax environment) (meevax evaluate) (meevax syntax) ; for let-syntax letrec-syntax (scheme r4rs) + (scheme r5rs continuation) (srfi 149)) (export quote lambda if set! cond case and or let let* letrec begin do delay diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 7f9d2fe77..56ba253f0 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -791,7 +791,7 @@ (define-library (scheme process-context) (import (meevax context) - (meevax continuation) + (scheme r5rs continuation) ) (export ; command-line exit From d200a3adf1d5b93b0e3d6682b6803de1ffd4f1cd Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 01:25:15 +0900 Subject: [PATCH 44/49] Rename `environment::import` to `declare_import` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r5rs.ss | 4 +- include/meevax/kernel/environment.hpp | 16 ++--- src/kernel/environment.cpp | 84 +++++++++++++-------------- src/kernel/library.cpp | 2 +- 6 files changed, 56 insertions(+), 58 deletions(-) diff --git a/README.md b/README.md index c7406b564..b0cb0839f 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1016.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1017.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1016_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1017_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1016 +Meevax Lisp System, version 0.3.1017 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 6b2f84590..f9ed4d48b 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1016 +0.3.1017 diff --git a/basis/r5rs.ss b/basis/r5rs.ss index e38d39540..74cffe131 100644 --- a/basis/r5rs.ss +++ b/basis/r5rs.ss @@ -112,6 +112,4 @@ (environment `(only (scheme ,(string->symbol (string-append "r" (number->string version) "rs"))) quote lambda if set! cond case and or let let* letrec begin do delay quasiquote let-syntax - letrec-syntax syntax-rules define define-syntax))) - ) - ) + letrec-syntax syntax-rules define define-syntax))))) diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index fe1dc5e67..6360a652f 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -81,6 +81,14 @@ inline namespace kernel auto apply(const_reference, const_reference) -> object; + auto declare_import(const_reference) -> void; + + template ...)> + auto declare_import(Ts&&... xs) -> void + { + (declare_import(read(xs)), ...); + } + auto define(const_reference, const_reference = undefined) -> void; auto define(symbol::value_type const&, const_reference = undefined) -> void; @@ -113,14 +121,6 @@ inline namespace kernel auto global() const noexcept -> const_reference; - auto import(const_reference) -> void; - - template ...)> - auto import(Ts&&... xs) -> void - { - (import(read(xs)), ...); - } - auto load(std::string const&) -> object; auto scope() const noexcept -> const_reference; diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 3f358b5f7..ab9b974b8 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -49,6 +49,47 @@ inline namespace kernel return result; } + auto resolve_import_set(const_reference import_set) -> object + { + if (car(import_set).as().value == "only") + { + let const exported_bindings = resolve_import_set(cadr(import_set)); + + let filtered_bindings = unit; + + for (let const& identifier : cddr(import_set)) + { + if (let const& binding = assq(identifier, exported_bindings); select(binding)) + { + filtered_bindings = cons(binding, filtered_bindings); + } + else + { + throw error(make("no such identifier"), identifier); + } + } + + return filtered_bindings; + } + else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) + { + return std::get<1>(*iter).resolve_export_specs(); + } + else + { + throw error(make("no such library"), import_set); + } + } + + auto environment::declare_import(const_reference import_set) -> void + { + for (let const& binding : resolve_import_set(import_set)) + { + define(binding.as().symbol(), + binding.as().load()); + } + } + auto environment::define(const_reference name, const_reference value) -> void { assert(name.is_also()); @@ -74,7 +115,7 @@ inline namespace kernel { for (let const& import_set : cdr(expression)) { - import(import_set); + declare_import(import_set); } return unspecified_object; @@ -130,47 +171,6 @@ inline namespace kernel return second; } - auto resolve_import_set(const_reference import_set) -> object - { - if (car(import_set).as().value == "only") - { - let const exported_bindings = resolve_import_set(cadr(import_set)); - - let filtered_bindings = unit; - - for (let const& identifier : cddr(import_set)) - { - if (let const& binding = assq(identifier, exported_bindings); select(binding)) - { - filtered_bindings = cons(binding, filtered_bindings); - } - else - { - throw error(make("no such identifier"), identifier); - } - } - - return filtered_bindings; - } - else if (auto iter = libraries.find(lexical_cast(import_set)); iter != std::end(libraries)) - { - return std::get<1>(*iter).resolve_export_specs(); - } - else - { - throw error(make("no such library"), import_set); - } - } - - auto environment::import(const_reference import_set) -> void - { - for (let const& binding : resolve_import_set(import_set)) - { - define(binding.as().symbol(), - binding.as().load()); - } - } - auto environment::load(std::string const& s) -> object { if (let port = make(s); port and port.as().is_open()) diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 47e082888..97386949d 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -58,7 +58,7 @@ inline namespace kernel for (let const& x : xs) { - e.as().import(x); + e.as().declare_import(x); } return e; From a79138d5fcf7b2364330f28fe7fcab125e782fd4 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 01:52:46 +0900 Subject: [PATCH 45/49] Rename `library::export_` to `declare_export` Signed-off-by: yamacir-kit --- README.md | 6 +- VERSION | 2 +- basis/r7rs.ss | 4 +- include/meevax/kernel/library.hpp | 8 +- src/kernel/library.cpp | 275 +++++++++++++++--------------- 5 files changed, 147 insertions(+), 148 deletions(-) diff --git a/README.md b/README.md index b0cb0839f..b8c51ab5c 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1017.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1018.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1017_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1018_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1017 +Meevax Lisp System, version 0.3.1018 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index f9ed4d48b..6ef3389f0 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1017 +0.3.1018 diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 56ba253f0..18faafef0 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -666,7 +666,7 @@ cddddr)) (define-library (scheme char) - (import (only (meevax character) digit-value) + (import (only (meevax character) char-codepoint) (only (scheme r5rs) char-ci=? char-ci() and car(declaration).is() @@ -72,15 +72,15 @@ inline namespace kernel } } - auto export_(const_reference export_spec) -> void + auto declare_export(const_reference export_spec) -> void { export_specs.push_back(export_spec); } template ...)> - auto export_(Ts&&... xs) -> void + auto declare_export(Ts&&... xs) -> void { - (export_(read(xs)), ...); + (declare_export(read(xs)), ...); } auto resolve_export_specs() diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 97386949d..795e02862 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -36,18 +36,18 @@ inline namespace kernel define("quote-syntax", quote_syntax); define("set!", set); - export_("begin", - "call-with-current-continuation!", - "define", - "define-syntax", - "if", - "lambda", - "let-syntax", - "letrec", - "letrec-syntax", - "quote", - "quote-syntax", - "set!"); + declare_export("begin"); + declare_export("call-with-current-continuation!"); + declare_export("define"); + declare_export("define-syntax"); + declare_export("if"); + declare_export("lambda"); + declare_export("let-syntax"); + declare_export("letrec"); + declare_export("letrec-syntax"); + declare_export("quote"); + declare_export("quote-syntax"); + declare_export("set!"); } library::library(environment_library_t) @@ -74,9 +74,9 @@ inline namespace kernel return unspecified_object; }); - export_("environment"); - export_("interaction-environment"); - export_("%load"); + declare_export("environment"); + declare_export("interaction-environment"); + declare_export("%load"); } library::library(equivalence_library_t) @@ -84,7 +84,8 @@ inline namespace kernel define("eq?", [](let const& xs) { return eq (car(xs), cadr(xs)); }); define("eqv?", [](let const& xs) { return eqv(car(xs), cadr(xs)); }); - export_("eq?", "eqv?"); + declare_export("eq?", + "eqv?"); } library::library(number_library_t) @@ -179,18 +180,27 @@ inline namespace kernel return make(lexical_cast(car(xs))); }); - export_("number?", "complex?", "real?", "rational?", "integer?", - "exact-integer?", "%complex?", "ratio?", "single-float?", "double-float?", - - "=", "!=", "<", "<=", ">", ">=", "+", "*", "-", "/", "%", - - "floor", "ceiling", "truncate", "round", - - "expt", - - "exact", "inexact", - - "integer->char", "number->string"); + declare_export("number?", + "complex?", + "real?", + "rational?", + "integer?", + "exact-integer?", + "%complex?", + "ratio?", + "single-float?", + "double-float?", + "=", "!=", "<", "<=", ">", ">=", + "+", "*", "-", "/", "%", + "floor", + "ceiling", + "truncate", + "round", + "expt", + "exact", + "inexact", + "integer->char", + "number->string"); } library::library(inexact_library_t) @@ -248,11 +258,10 @@ inline namespace kernel } }); - export_("finite?", "infinite?", "nan?", - "exp", "sqrt", "log", - "sin", "asin", "sinh", "asinh", - "cos", "acos", "cosh", "acosh", - "tan", "atan", "tanh", "atanh"); + declare_export("finite?", "infinite?", "nan?", "exp", "sqrt", "log", + "sin", "asin", "sinh", "asinh", + "cos", "acos", "cosh", "acosh", + "tan", "atan", "tanh", "atanh"); } library::library(pair_library_t) @@ -304,21 +313,23 @@ inline namespace kernel define("set-car!", [](auto&& xs) { return caar(xs) = cadr(xs); }); define("set-cdr!", [](auto&& xs) { return cdar(xs) = cadr(xs); }); - export_("pair?", "cons", - - "car", "cdr", - - "caar", "cadr", "cdar", "cddr", - - "caaar", "caadr", "cadar", "caddr", - "cdaar", "cdadr", "cddar", "cdddr", - - "caaaar", "caaadr", "caadar", "caaddr", - "cadaar", "cadadr", "caddar", "cadddr", - "cdaaar", "cdaadr", "cdadar", "cdaddr", - "cddaar", "cddadr", "cdddar", "cddddr", - - "set-car!", "set-cdr!"); + declare_export("pair?", "cons", "car", "cdr", "set-car!", "set-cdr!", + "caar", "caaar", "caaaar", + "cadr", "caadr", "caaadr", + "cdar", "cadar", "caadar", + "cddr", "caddr", "caaddr", + "cdaar", "cadaar", + "cdadr", "cadadr", + "cddar", "caddar", + "cdddr", "cadddr", + "cdaaar", + "cdaadr", + "cdadar", + "cdaddr", + "cddaar", + "cddadr", + "cdddar", + "cddddr"); } library::library(list_library_t) @@ -350,10 +361,7 @@ inline namespace kernel return make(for_each_in, car(xs)); }); - export_("null?", - "append", - "list->string", - "list->vector"); + declare_export("null?", "append", "list->string", "list->vector"); } library::library(symbol_library_t) @@ -368,7 +376,7 @@ inline namespace kernel return make(car(xs).as()); }); - export_("symbol?", "symbol->string"); + declare_export("symbol?", "symbol->string"); } library::library(character_library_t) @@ -390,7 +398,7 @@ inline namespace kernel } }); - define("digit-value", [](let const& xs) + define("char-codepoint", [](let const& xs) { if (auto c = car(xs).as(); std::isdigit(c.codepoint)) { @@ -402,10 +410,7 @@ inline namespace kernel } }); - export_("char?", - "char->integer", - "digit-value" // TODO => character:codepoint - ); + declare_export("char?", "char->integer", "char-codepoint"); } library::library(string_library_t) @@ -530,24 +535,21 @@ inline namespace kernel return intern(car(xs).as()); }); - export_("string?", "make-string", - - "string-append", - "string-copy", - "string-length", - "string-ref", - "string-set!", - - "string=?", - "string?", - "string>=?", - - "string->list", - "string->number", - "string->symbol" - ); + declare_export("string?", + "make-string", + "string-append", + "string-copy", + "string-length", + "string-ref", + "string-set!", + "string=?", + "string?", + "string>=?", + "string->list", + "string->number", + "string->symbol"); } library::library(vector_library_t) @@ -651,17 +653,15 @@ inline namespace kernel } }); - export_("vector?", - - "vector", "make-vector", - - "vector-length", - "vector-ref", - "vector-set!", - "vector-fill!", - - "vector->list", - "vector->string"); + declare_export("vector?", + "vector", + "make-vector", + "vector-length", + "vector-ref", + "vector-set!", + "vector-fill!", + "vector->list", + "vector->string"); } library::library(control_library_t) @@ -676,8 +676,8 @@ inline namespace kernel return car(xs).is(); }); - export_("closure?"); - export_("continuation?"); + declare_export("closure?"); + declare_export("continuation?"); } library::library(exception_library_t) @@ -697,12 +697,12 @@ inline namespace kernel define( "file-error?", [](let const& xs) { return car(xs).is< file_error>(); }); define("syntax-error?", [](let const& xs) { return car(xs).is(); }); - export_("default-exception-handler", - "make-error", - "error?", - "read-error?", - "file-error?", - "syntax-error?"); + declare_export("default-exception-handler", + "make-error", + "error?", + "read-error?", + "file-error?", + "syntax-error?"); } library::library(port_library_t) @@ -891,32 +891,32 @@ inline namespace kernel return unspecified_object; }); - export_("input-port?", - "output-port?", - "binary-port?", - "textual-port?", - "port?", - "input-port-open?", - "output-port-open?", - "standard-input-port", - "standard-output-port", - "standard-error-port", - "open-input-file", - "open-output-file", - "close-input-port", - "close-output-port", - "open-input-string", - "open-output-string", - "get-output-string", - "%read-char", - "%peek-char", - "eof-object?", - "eof-object", - "read-ready?", - "%read-string", - "put-char", - "put-string", - "%flush-output-port"); + declare_export("input-port?", + "output-port?", + "binary-port?", + "textual-port?", + "port?", + "input-port-open?", + "output-port-open?", + "standard-input-port", + "standard-output-port", + "standard-error-port", + "open-input-file", + "open-output-file", + "close-input-port", + "close-output-port", + "open-input-string", + "open-output-string", + "get-output-string", + "%read-char", + "%peek-char", + "eof-object?", + "eof-object", + "read-ready?", + "%read-string", + "put-char", + "put-string", + "%flush-output-port"); } library::library(evaluate_library_t) @@ -926,7 +926,7 @@ inline namespace kernel return cadr(xs).as().evaluate(car(xs)); }); - export_("eval"); + declare_export("eval"); } library::library(read_library_t) @@ -947,7 +947,7 @@ inline namespace kernel } }); - export_("%read"); + declare_export("%read"); } library::library(write_library_t) @@ -977,7 +977,7 @@ inline namespace kernel return standard_output; }); - export_("%write-simple", "print"); + declare_export("%write-simple", "print"); } library::library(macro_library_t) @@ -1014,11 +1014,11 @@ inline namespace kernel return make(car(xs), cadr(xs), caddr(xs)); }); - export_("identifier?", - "identifier->symbol", - "transformer?", - "syntactic-closure?", - "make-syntactic-closure"); + declare_export("identifier?", + "identifier->symbol", + "transformer?", + "syntactic-closure?", + "make-syntactic-closure"); } library::library(experimental_library_t) @@ -1048,10 +1048,9 @@ inline namespace kernel return std::numeric_limits::is_iec559; }); - export_("type-of", - "disassemble", - "ieee-float?" - ); + declare_export("type-of", + "disassemble", + "ieee-float?"); } library::library(context_library_t) @@ -1079,7 +1078,7 @@ inline namespace kernel } }); - export_("emergency-exit"); + declare_export("emergency-exit"); } std::map libraries {}; @@ -1119,8 +1118,8 @@ inline namespace kernel return car(xs).is(); }); - library.export_("foreign-function"); - library.export_("foreign-function?"); + library.declare_export("foreign-function"); + library.declare_export("foreign-function?"); }); define_library("(meevax garbage-collector)", [](library & library) @@ -1135,7 +1134,7 @@ inline namespace kernel return make(gc.count()); }); - library.export_("gc-collect", "gc-count"); + library.declare_export("gc-collect", "gc-count"); }); define_library("(meevax version)", [](library & library) @@ -1145,7 +1144,7 @@ inline namespace kernel return features(); }); - library.export_("features"); + library.declare_export("features"); }); } From b4881b8ff6422c19951b88f30d3e6f1f8706834f Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 01:58:32 +0900 Subject: [PATCH 46/49] Remove constructor `environment(empty_t)` Signed-off-by: yamacir-kit --- README.md | 6 +++--- VERSION | 2 +- include/meevax/kernel/environment.hpp | 11 ----------- include/meevax/kernel/library.hpp | 2 -- 4 files changed, 4 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index b8c51ab5c..dd24d2ebf 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1018.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1019.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1018_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1019_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +117,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1018 +Meevax Lisp System, version 0.3.1019 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 6ef3389f0..cc1fb3be3 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1018 +0.3.1019 diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 6360a652f..60d6d12fe 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -26,14 +26,6 @@ namespace meevax { inline namespace kernel { - inline namespace experimental - { - struct empty_t - { - explicit empty_t() = default; - } constexpr empty; - } // namespace experimental - class environment : public virtual pair , public configurator , public machine @@ -58,9 +50,6 @@ inline namespace kernel explicit environment(environment const&) = default; - explicit environment(empty_t) // FOR MIGRATION - {} - template ...)> explicit environment(Ts&&... xs) : environment { empty } diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 4d6314897..6f080740f 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -30,13 +30,11 @@ inline namespace kernel template )> explicit library(F&& declare) - : environment { empty } { declare(*this); } explicit library(const_reference declarations) - : environment { empty } { for (let const& declaration : declarations) { From cb0093d5f6f5a286c4d0b678aa9eca351de5a561 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 02:37:11 +0900 Subject: [PATCH 47/49] Update README Signed-off-by: yamacir-kit --- README.md | 35 +++++++++++++++------------ VERSION | 2 +- configure/README.md | 29 ++++++++++++---------- include/meevax/kernel/environment.hpp | 1 - 4 files changed, 36 insertions(+), 31 deletions(-) diff --git a/README.md b/README.md index dd24d2ebf..b78290396 100644 --- a/README.md +++ b/README.md @@ -41,19 +41,22 @@ Subset of R7RS-small. ### SRFIs -| Number | Name | Import from | Note | -|------------------------------------------------------:|:---------------------------------------------------------|:------------|:-----------| -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | built-in | | -| [ 5](https://srfi.schemers.org/srfi-5/srfi-5.html) | A compatible let form with signatures and rest arguments | built-in | R7RS 4.2.4 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | built-in | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | built-in | | -| [10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | -| [23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | built-in | R7RS 6.11 | -| [39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | built-in | R7RS 4.2.6 | -| [45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | built-in | [#296](https://github.com/yamacir-kit/meevax/issues/296) -| [62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | built-in | R7RS 2.2 | -| [78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | built-in | Except `check-ec` -| [87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | built-in | R7RS 4.2.1 | +| Number | Title | Import from | Note | +|--------------------------------------------------------:|:---------------------------------------------------------|:-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|:-----------| +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | +| [ 5](https://srfi.schemers.org/srfi-5/srfi-5.html) | A compatible let form with signatures and rest arguments | [`(scheme r4rs essential)`](./basis/r4rs-essential.ss)
[`(scheme r4rs)`](./basis/r4rs.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.4 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | +| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.6 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | [#296](https://github.com/yamacir-kit/meevax/issues/296) +| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | built-in | R7RS 2.2 | +| [ 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 | [`(scheme r4rs essential)`](./basis/r4rs-essential.ss)
[`(scheme r4rs)`](./basis/r4rs.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.1 | +| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic `syntax-rules` template extensions | [`(srfi 149)`](./basis/srfi-149.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.3.2 | +| [211](https://srfi.schemers.org/srfi-211/srfi-211.html) | Scheme Macro Libraries | [`(srfi 211 explicit-renaming)`](./basis/srfi-211.ss) | | ## Requirements @@ -100,9 +103,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1019.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1020.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1019_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1020_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -117,7 +120,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1019 +Meevax Lisp System, version 0.3.1020 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index cc1fb3be3..960bf4e56 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1019 +0.3.1020 diff --git a/configure/README.md b/configure/README.md index 5ae8012e5..9c295ffcc 100644 --- a/configure/README.md +++ b/configure/README.md @@ -41,19 +41,22 @@ Subset of R7RS-small. ### SRFIs -| Number | Name | Import from | Note | -|------------------------------------------------------:|:---------------------------------------------------------|:------------|:-----------| -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | built-in | | -| [ 5](https://srfi.schemers.org/srfi-5/srfi-5.html) | A compatible let form with signatures and rest arguments | built-in | R7RS 4.2.4 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | built-in | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | built-in | | -| [10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | -| [23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | built-in | R7RS 6.11 | -| [39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | built-in | R7RS 4.2.6 | -| [45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | built-in | [#296](https://github.com/yamacir-kit/meevax/issues/296) -| [62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | built-in | R7RS 2.2 | -| [78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | built-in | Except `check-ec` -| [87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | built-in | R7RS 4.2.1 | +| Number | Title | Import from | Note | +|--------------------------------------------------------:|:---------------------------------------------------------|:-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|:-----------| +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | +| [ 5](https://srfi.schemers.org/srfi-5/srfi-5.html) | A compatible let form with signatures and rest arguments | [`(scheme r4rs essential)`](./basis/r4rs-essential.ss)
[`(scheme r4rs)`](./basis/r4rs.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.4 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | built-in | | +| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 6.11 | +| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.6 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | [#296](https://github.com/yamacir-kit/meevax/issues/296) +| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | built-in | R7RS 2.2 | +| [ 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 | [`(scheme r4rs essential)`](./basis/r4rs-essential.ss)
[`(scheme r4rs)`](./basis/r4rs.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.2.1 | +| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic `syntax-rules` template extensions | [`(srfi 149)`](./basis/srfi-149.ss)
[`(scheme r5rs)`](./basis/r5rs.ss)
[`(scheme base)`](./basis/r7rs.ss) | R7RS 4.3.2 | +| [211](https://srfi.schemers.org/srfi-211/srfi-211.html) | Scheme Macro Libraries | [`(srfi 211 explicit-renaming)`](./basis/srfi-211.ss) | | ## Requirements diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index 60d6d12fe..baaa15cab 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -52,7 +52,6 @@ inline namespace kernel template ...)> explicit environment(Ts&&... xs) - : environment { empty } { (import(xs), ...); From 6197de749a690845f72407ccd34dd065d022e799 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 03:35:42 +0900 Subject: [PATCH 48/49] Add new free function `interaction_environment()` Signed-off-by: yamacir-kit --- README.md | 6 ++--- VERSION | 2 +- include/meevax/kernel/library.hpp | 6 ++--- src/kernel/library.cpp | 13 ++++++---- src/main.cpp | 13 ++-------- test/environment.cpp | 42 +++++++++++++++++-------------- 6 files changed, 40 insertions(+), 42 deletions(-) diff --git a/README.md b/README.md index b78290396..ee6a2c914 100644 --- a/README.md +++ b/README.md @@ -103,9 +103,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1020.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1021.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1020_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1021_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -120,7 +120,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1020 +Meevax Lisp System, version 0.3.1021 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index 960bf4e56..0f08ec682 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1020 +0.3.1021 diff --git a/include/meevax/kernel/library.hpp b/include/meevax/kernel/library.hpp index 6f080740f..a84a88fc0 100644 --- a/include/meevax/kernel/library.hpp +++ b/include/meevax/kernel/library.hpp @@ -24,6 +24,8 @@ namespace meevax { inline namespace kernel { + auto interaction_environment() -> const_reference; + struct library : public environment { std::vector export_specs; @@ -42,9 +44,7 @@ inline namespace kernel } } - static auto boot_meevax_libraries() -> void; - - static auto boot_scheme_libraries() -> void; + static auto boot() -> void; auto declare(const_reference declaration) -> void { diff --git a/src/kernel/library.cpp b/src/kernel/library.cpp index 795e02862..6b25b0375 100644 --- a/src/kernel/library.cpp +++ b/src/kernel/library.cpp @@ -21,6 +21,12 @@ namespace meevax { inline namespace kernel { + auto interaction_environment() -> const_reference + { + let static const interaction_environment = make(); + return interaction_environment; + } + library::library(syntax_library_t) { define("begin", machine::begin); @@ -71,7 +77,7 @@ inline namespace kernel define("interaction-environment", [](auto&&...) { - return unspecified_object; + return interaction_environment(); }); declare_export("environment"); @@ -1083,7 +1089,7 @@ inline namespace kernel std::map libraries {}; - auto library::boot_meevax_libraries() -> void + auto library::boot() -> void { define_library("(meevax character)", character_library); define_library("(meevax context)", context_library); @@ -1146,10 +1152,7 @@ inline namespace kernel library.declare_export("features"); }); - } - auto library::boot_scheme_libraries() -> void - { std::vector const codes { srfi_211, r4rs_essential, diff --git a/src/main.cpp b/src/main.cpp index 88163888b..a406c956e 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -23,18 +23,9 @@ auto main(int const argc, char const* const* const argv) -> int return with_exception_handler([&]() { - let interaction_environment = make(); + library::boot(); - auto&& main = interaction_environment.as(); - - library::boot_meevax_libraries(); - - libraries.at("(meevax environment)").define("interaction-environment", [&](auto&&...) - { - return interaction_environment; - }); - - library::boot_scheme_libraries(); + auto&& main = interaction_environment().as(); main.configure(argc, argv); diff --git a/test/environment.cpp b/test/environment.cpp index 77fc2ea40..8e18f4f0d 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -7,37 +7,41 @@ auto main() -> int { using namespace meevax; - const auto specials_count = 11; - assert(standard_error.is()); - assert(standard_input.is()); - assert(standard_output.is()); - assert(e0.is()); - assert(e1.is()); - assert(eof_object.is()); - assert(eos_object.is()); - assert(f.is()); - assert(t.is()); - assert(undefined.is()); - assert(unspecified_object.is()); + const auto specials_count = 13; + { + assert(standard_error.is()); + assert(standard_input.is()); + assert(standard_output.is()); + assert(e0.is()); + assert(e1.is()); + assert(eof_object.is()); + assert(eos_object.is()); + assert(f.is()); + assert(t.is()); + assert(undefined.is()); + assert(unspecified_object.is()); + assert(interaction_environment().is()); // 2 = environment itself and prompt + } + + assert(constants.size() == 19); const auto gc_count = gc.count(); + assert(gc_count == constants.size() + specials_count); - { - auto interaction_environment = environment(); + library::boot(); - library::boot_meevax_libraries(); + environment::symbols.clear(); - library::boot_scheme_libraries(); - } + assert(environment::symbols.empty()); + + const_cast(interaction_environment()).reset(); // DIRTY HACK! - environment::symbols.clear(); libraries.clear(); gc.collect(); gc.collect(); // for vector type - assert(environment::symbols.empty()); assert(gc_count == gc.count()); return EXIT_SUCCESS; From 324bf6ad778002af4d0a36a1557192b015ab8dc4 Mon Sep 17 00:00:00 2001 From: yamacir-kit Date: Thu, 19 May 2022 04:11:56 +0900 Subject: [PATCH 49/49] Remove option `--prompt` Signed-off-by: yamacir-kit --- README.md | 7 +++---- VERSION | 2 +- configure/README.md | 1 - include/meevax/kernel/configurator.hpp | 13 ------------- include/meevax/kernel/environment.hpp | 1 - src/kernel/environment.cpp | 9 ++++++++- src/main.cpp | 2 +- test/environment.cpp | 4 ++-- 8 files changed, 15 insertions(+), 24 deletions(-) diff --git a/README.md b/README.md index ee6a2c914..7b5b85056 100644 --- a/README.md +++ b/README.md @@ -103,9 +103,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |:-------------------|:-- -| `all` (default) | Build shared-library `libmeevax.0.3.1021.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.1022.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.1021_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.1022_amd64.deb`. | `install` | Copy files into `/usr/local` __(1)__. | `install.deb` | `all` + `package` + `sudo apt install .deb` | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install .deb` @@ -120,7 +120,7 @@ __(1)__ Meevax installed by `make install` cannot be uninstalled by the system's ## Usage ``` -Meevax Lisp System, version 0.3.1021 +Meevax Lisp System, version 0.3.1022 Usage: meevax [OPTION...] [FILE...] @@ -131,7 +131,6 @@ Options: -h, --help Display this help text and exit. -i, --interactive Take over control of root environment. -l, --load=FILENAME Same as -e '(load FILENAME)' - --prompt=STRING Same as -e '(set-prompt! STRING)' -t, --trace Display stacks of virtual machine for each steps. -v, --version Display version information and exit. --verbose Display detailed informations. diff --git a/VERSION b/VERSION index 0f08ec682..470ab8bb7 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.1021 +0.3.1022 diff --git a/configure/README.md b/configure/README.md index 9c295ffcc..ff51d4c63 100644 --- a/configure/README.md +++ b/configure/README.md @@ -131,7 +131,6 @@ Options: -h, --help Display this help text and exit. -i, --interactive Take over control of root environment. -l, --load=FILENAME Same as -e '(load FILENAME)' - --prompt=STRING Same as -e '(set-prompt! STRING)' -t, --trace Display stacks of virtual machine for each steps. -v, --version Display version information and exit. --verbose Display detailed informations. diff --git a/include/meevax/kernel/configurator.hpp b/include/meevax/kernel/configurator.hpp index 1d4546d06..69e0a8bff 100644 --- a/include/meevax/kernel/configurator.hpp +++ b/include/meevax/kernel/configurator.hpp @@ -52,8 +52,6 @@ inline namespace kernel let trace = f; let verbose = f; - let prompt = make(u8"λ> "); - public: explicit configurator() : short_options @@ -156,11 +154,6 @@ inline namespace kernel return load(x.as()); }), - std::make_pair("prompt", [this](const_reference x, auto&&...) - { - return prompt = x; - }), - std::make_pair("write", [this](const_reference x, auto&&...) { return print(x), unspecified_object; @@ -260,11 +253,6 @@ inline namespace kernel }(); } - auto current_prompt() const - { - return static_cast(prompt.as()); - } - auto display_version() const -> void { print("Meevax Lisp ", version()); @@ -283,7 +271,6 @@ inline namespace kernel print(" -h, --help Display this help text and exit."); print(" -i, --interactive Take over control of root environment."); print(" -l, --load=FILENAME Same as -e '(load FILENAME)'"); - print(" --prompt=STRING Same as -e '(set-prompt! STRING)'"); print(" -t, --trace Display stacks of virtual machine for each steps."); print(" -v, --version Display version information and exit."); print(" --verbose Display detailed informations."); diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index baaa15cab..9abdc7d07 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -58,7 +58,6 @@ inline namespace kernel define("set-batch!", [this](let const& xs, auto&&...) { return batch = car(xs); }); define("set-debug!", [this](let const& xs, auto&&...) { return debug = car(xs); }); define("set-interactive!", [this](let const& xs, auto&&...) { return interactive = car(xs); }); - define("set-prompt!", [this](let const& xs, auto&&...) { return prompt = car(xs); }); define("set-trace!", [this](let const& xs, auto&&...) { return trace = car(xs); }); define("set-verbose!", [this](let const& xs, auto&&...) { return verbose = car(xs); }); } diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index ab9b974b8..bbf5b6f9d 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -83,11 +83,18 @@ inline namespace kernel auto environment::declare_import(const_reference import_set) -> void { - for (let const& binding : resolve_import_set(import_set)) + let const bindings = resolve_import_set(import_set); + + for (let const& binding : bindings) { define(binding.as().symbol(), binding.as().load()); } + + if (is_interactive_mode()) + { + print(faint("; ", length(bindings), " identifiers imported.")); + } } auto environment::define(const_reference name, const_reference value) -> void diff --git a/src/main.cpp b/src/main.cpp index a406c956e..d933c29c6 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -38,7 +38,7 @@ auto main(int const argc, char const* const* const argv) -> int while (main.is_interactive_mode() and main.char_ready()) { main.print(u8"\u250c", repeat(u8"\u2500", 79)); - main.write(standard_output, u8"\u2502", length(main.global()), "/", main.current_prompt()); + main.write(standard_output, u8"\u2502\u03bb> "); main.print(main.evaluate(main.read())); } diff --git a/test/environment.cpp b/test/environment.cpp index 8e18f4f0d..ceb52a956 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -7,7 +7,7 @@ auto main() -> int { using namespace meevax; - const auto specials_count = 13; + const auto specials_count = 12; { assert(standard_error.is()); assert(standard_input.is()); @@ -20,7 +20,7 @@ auto main() -> int assert(t.is()); assert(undefined.is()); assert(unspecified_object.is()); - assert(interaction_environment().is()); // 2 = environment itself and prompt + assert(interaction_environment().is()); } assert(constants.size() == 19);