Merge pull request #334 from yamacir-kit/module

Module

Author: yamacir-kit

README.md

@@ -47,7 +47,7 @@ subset of **R7RS Scheme** implementation.
 
 There is no stable version.
 
-Development HEAD: 0.3.409.
+Development HEAD: 0.3.474.
 
 ### Characteristic Features
 

VERSION

@@ -1 +1 @@
-0.3.409
+0.3.474

basis/overture.ss

@@ -12,7 +12,7 @@
 ; display do dynamic-wind else                 equal?           even?
 ; exact->inexact exact?                for-each force gcd    imag-part
 ; inexact->exact inexact? input-port?               integer?
-; interaction-environment        lcm length let let* let-syntax letrec
+; interaction-environment        lcm length let let* let-syntax
 ; letrec-syntax list                           list-ref list-tail list?      log
 ; magnitude make-polar make-rectangular                         map max member
 ; memq memv min modulo negative? newline not null-environment null?
@@ -261,13 +261,11 @@
           #f)
       (any-2+ f (cons x xs))))
 
-(define-syntax (letrec bindings . body)
+(define-syntax (letrec* bindings . body)
   ((lambda (definitions)
      `((,lambda () ,@definitions ,@body)) )
    (map (lambda (x) (cons define x)) bindings)))
 
-(define-syntax letrec* letrec) ; TODO MOVE INTO (scheme base)
-
 (define-syntax (let bindings . body)
   (if (identifier? bindings)
       `(,letrec ((,bindings (,lambda ,(map car (car body)) ,@(cdr body))))
@@ -702,9 +700,9 @@
 ; ---- 6.10. Control features --------------------------------------------------
 
 (define (procedure? x)
-  (or (native-procedure? x)
-      (closure? x)
-      (continuation? x)))
+  (or (closure? x)
+      (continuation? x)
+      (foreign-function? x)))
 
 (define %current-dynamic-extents '()) ; https://www.cs.hmc.edu/~fleck/envision/scheme48/meeting/node7.html
 

basis/srfi-39.ss

@@ -24,17 +24,17 @@
             (if (null? conv) (lambda (x) x) (car conv))))
       (let ((global-cell
               (cons #f (converter init))))
-        (define 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))))
+        (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-bind
   (lambda (parameters values body)
@@ -59,12 +59,10 @@
 
 (define dynamic-env-local '())
 
-(define dynamic-env-local-get
-  (lambda () dynamic-env-local))
+(define (dynamic-env-local-get) dynamic-env-local)
 
-(define dynamic-env-local-set!
-  (lambda (new-env)
-    (set! dynamic-env-local new-env)))
+(define (dynamic-env-local-set! new-env)
+  (set! dynamic-env-local new-env))
 
 ; (define-syntax parameterize
 ;   (er-macro-transformer

example/foreign-function.ss

@@ -1,6 +1,10 @@
-(define dummy-procedure     (foreign-function "build/libexample-1.so" "dummy_procedure"))
-(define length-of-arguments (foreign-function "build/libexample-1.so" "length_of_arguments"))
+(let ((dummy-procedure (foreign-function "build/libexample-1.so" "dummy_procedure")))
+  (check (foreign-function? dummy-procedure) => #t)
+  )
 
-(check (length-of-arguments 'hoge 42 #(1 2 3) 3.14) => 4)
+(let ((length-of-arguments (foreign-function "build/libexample-1.so" "length_of_arguments")))
+  (check (foreign-function? length-of-arguments) => #t)
+  (check (length-of-arguments 'hoge 42 #(1 2 3) 3.14) => 4)
+  )
 
 (exit (check-passed? check:correct))

include/meevax/functional/curry.hpp

@@ -23,16 +23,15 @@ namespace meevax
 {
 inline namespace functional
 {
-  template <typename F>
-  constexpr auto curry(F&& f) -> decltype(auto)
+  template <typename Function>
+  constexpr auto curry(Function&& function) -> decltype(auto)
   {
     return [&](auto&&... xs)
     {
       return [&](auto&&... ys) -> decltype(auto)
       {
-        return
-          f(std::forward<decltype(xs)>(xs)...,
-            std::forward<decltype(ys)>(ys)...);
+        return function(std::forward<decltype(xs)>(xs)...,
+                        std::forward<decltype(ys)>(ys)...);
       };
     };
   }

include/meevax/kernel/configurator.hpp

@@ -48,7 +48,7 @@ inline namespace kernel
     let trace       = f;
     let verbose     = f;
 
-    let prompt = make<symbol>("> ");
+    let prompt = make<string>(u8"λ> ");
 
     template <typename Key>
     using dispatcher = std::unordered_map<Key, std::function<PROCEDURE()>>;
@@ -261,9 +261,9 @@ inline namespace kernel
       }();
     }
 
-    auto current_prompt() const -> auto const&
+    auto current_prompt() const
     {
-      return prompt;
+      return static_cast<std::string>(prompt.as<string>());
     }
 
     void display_version() const
@@ -300,8 +300,8 @@ inline namespace kernel
       write_line("  -e, --evaluate=STRING  read and evaluate given STRING at configuration step.");
       write_line("  -h, --help             display this help text and exit.");
       write_line("  -i, --interactive      take over control of root syntactic-continuation.");
-      write_line("  -l, --load=FILE        same as -e '(load FILE)'");
-      write_line("      --prompt=SYMBOL    same as -e '(set-prompt! SYMBOL)'");
+      write_line("  -l, --load=FILENAME    same as -e '(load FILENAME)'");
+      write_line("      --prompt=STRING    same as -e '(set-prompt! STRING)'");
       write_line("  -t, --trace            display stacks of virtual machine for each steps.");
       write_line("  -v, --version          display version information and exit.");
       write_line("      --verbose          display detailed informations.");
@@ -317,14 +317,14 @@ inline namespace kernel
       write_line("  meevax -i");
       write_line("    => start interactive session.");
       write_line();
-      write_line("  meevax -i --prompt '#,(string->symbol \"my-prompt> \")'");
-      write_line("    => start interactive session with given prompt.");
+      write_line("  meevax -i --prompt '\"my-prompt> \"'");
+      write_line("    => Start interactive session with given prompt.");
       write_line();
       write_line("  meevax -e '(+ 1 2 3)'");
-      write_line("    => display 6.");
+      write_line("    => Display 6.");
       write_line();
       write_line("  meevax -e \"(define home \\\"$HOME\\\")\" -i");
-      write_line("    => define value of environment variable $HOME to interaction-environment,");
+      write_line("    => Define value of environment variable $HOME to interaction-environment,");
       write_line("       and then start interactive session.");
     }
 

include/meevax/kernel/de_brujin_index.hpp renamed to include/meevax/kernel/de_bruijn_index.hpp

@@ -14,8 +14,8 @@
    limitations under the License.
 */
 
-#ifndef INCLUDED_MEEVAX_KERNEL_DE_BRUJIN_INDEX_HPP
-#define INCLUDED_MEEVAX_KERNEL_DE_BRUJIN_INDEX_HPP
+#ifndef INCLUDED_MEEVAX_KERNEL_DE_BRUIJN_INDEX_HPP
+#define INCLUDED_MEEVAX_KERNEL_DE_BRUIJN_INDEX_HPP
 
 #include <meevax/kernel/list.hpp>
 
@@ -24,37 +24,37 @@ namespace meevax
 inline namespace kernel
 {
   template <typename Comparator = default_equivalence_comparator>
-  class de_bruijn_index
-    : public let
+  struct de_bruijn_index
   {
-    bool variadic;
-
-  public:
     Comparator compare {};
 
+    bool is_variadic;
+
+    let const index;
+
     template <typename... Ts>
     explicit de_bruijn_index(Ts&&... xs)
-      : let { lookup(std::forward<decltype(xs)>(xs)...) }
+      : index { notate(std::forward<decltype(xs)>(xs)...) }
     {}
 
-    let lookup(let const& value, let const& frames)
+    auto notate(pair::const_reference value, pair::const_reference frames) -> pair::value_type // XXX UGLY CODE!!!
     {
       std::size_t layer = 0;
 
-      for (const auto& frame : frames)
+      for (auto const& frame : frames)
       {
         std::size_t index = 0;
 
-        for (auto iter = std::begin(frame); iter != std::end(frame); ++iter)
+        for (let node = frame; node; node = cdr(node))
         {
-          if (static_cast<let const&>(iter).is<pair>() and compare(*iter, value))
+          if (node.is<pair>() and compare(car(node), value))
           {
-            variadic = false;
+            is_variadic = false;
             return cons(make<exact_integer>(layer), make<exact_integer>(index));
           }
-          else if (static_cast<let const&>(iter).is<symbol>() and compare(iter, value))
+          else if (node.is<symbol>() and compare(node, value))
           {
-            variadic = true;
+            is_variadic = true;
             return cons(make<exact_integer>(layer), make<exact_integer>(index));
           }
 
@@ -67,12 +67,17 @@ inline namespace kernel
       return unit;
     }
 
-    bool is_variadic() const noexcept
+    auto is_bound() const -> bool
+    {
+      return not is_free();
+    }
+
+    auto is_free() const -> bool
     {
-      return variadic;
+      return index.is<null>();
     }
   };
 } // namespace kernel
 } // namespace meevax
 
-#endif // INCLUDED_MEEVAX_KERNEL_DE_BRUJIN_INDEX_HPP
+#endif // INCLUDED_MEEVAX_KERNEL_DE_BRUIJN_INDEX_HPP

include/meevax/kernel/error.hpp

@@ -142,6 +142,8 @@ inline namespace kernel
       return underlying_cast(exit_status::failure);
     }
   }
+
+  auto invalid_application(let const&) -> error;
 } // namespace kernel
 } // namespace meevax
 

include/meevax/kernel/heterogeneous.hpp

@@ -41,12 +41,7 @@ inline namespace kernel
 
       ~binder() override = default;
 
-      auto type() const noexcept -> std::type_info const& override
-      {
-        return typeid(Bound);
-      }
-
-      bool eqv(heterogeneous const& x) const override
+      auto eqv(heterogeneous const& x) const -> bool override
       {
         if constexpr (is_equality_comparable<Bound>::value)
         {
@@ -65,6 +60,11 @@ inline namespace kernel
         }
       }
 
+      auto type() const noexcept -> std::type_info const& override
+      {
+        return typeid(Bound);
+      }
+
       auto write_to(std::ostream & port) const -> std::ostream & override
       {
         return delay<write>().yield<decltype(port)>(port, static_cast<Bound const&>(*this));
@@ -92,8 +92,7 @@ inline namespace kernel
       #undef BOILERPLATE
     };
 
-  public: /* ---- CONSTRUCTORS ---------------------------------------------- */
-
+  public:
     using Pointer<Top>::Pointer;
 
     template <typename Bound, typename... Ts, REQUIRES(std::is_compound<Bound>)>
@@ -109,60 +108,53 @@ inline namespace kernel
       }
     }
 
-  public: /* ---- TYPE PREDICATES ------------------------------------------- */
-
-    auto type() const -> decltype(auto)
-    {
-      return *this ? Pointer<Top>::load().type() : typeid(null);
-    }
-
     template <typename U>
-    auto is() const
+    inline auto as() const -> U &
     {
-      return type() == typeid(typename std::decay<U>::type);
-    }
-
-    template <typename U,
-              typename std::enable_if<
-                std::is_null_pointer<typename std::decay<U>::type>::value
-              >::type = 0>
-    auto is() const
-    {
-      return not static_cast<bool>(*this);
+      if (pointer<U> data = dynamic_cast<pointer<U>>(Pointer<Top>::get()); data)
+      {
+        return *data;
+      }
+      else
+      {
+        throw make_error("no viable conversion from ", demangle(Pointer<Top>::load().type()), " to ", demangle(typeid(U)));
+      }
     }
 
-    template <typename U>
-    auto is_polymorphically() const
+    inline auto eqv(heterogeneous const& rhs) const -> bool
     {
-      return dynamic_cast<pointer<const U>>(Pointer<Top>::get()) != nullptr;
+      return type() == rhs.type() and Pointer<Top>::load().eqv(rhs);
     }
 
-  public: /* ---- ACCESSORS ------------------------------------------------- */
-
     template <typename U>
-    auto as() const -> typename std::add_lvalue_reference<U>::type
+    inline auto is() const
     {
-      if (pointer<U> address = dynamic_cast<pointer<U>>(Pointer<Top>::get()); address)
+      if constexpr (std::is_null_pointer<typename std::decay<U>::type>::value)
       {
-        return *address;
+        return not static_cast<bool>(*this);
       }
       else
       {
-        throw make_error(
-          "no viable conversion from ", demangle(Pointer<Top>::load().type()), " to ", demangle(typeid(U)));
+        return type() == typeid(typename std::decay<U>::type);
       }
     }
 
-    bool eqv(heterogeneous const& rhs) const
+    template <typename U>
+    inline auto is_also() const
     {
-      return type() == rhs.type() and Pointer<Top>::load().eqv(rhs);
+      return dynamic_cast<pointer<U>>(Pointer<Top>::get()) != nullptr;
+    }
+
+    inline auto type() const -> std::type_info const&
+    {
+      return *this ? Pointer<Top>::load().type() : typeid(null);
     }
   };
 
   template <template <typename...> typename Pointer, typename Top>
-  auto operator <<(std::ostream & port, heterogeneous<Pointer, Top> const& datum) -> std::ostream &
+  auto operator <<(std::ostream & os, heterogeneous<Pointer, Top> const& datum) -> std::ostream &
   {
-    return (datum.template is<null>() ? port << magenta << "()" : datum.load().write_to(port)) << reset;
+    return (datum.template is<null>() ? os << magenta << "()" : datum.load().write_to(os)) << reset;
   }
 
   #define BOILERPLATE(SYMBOL)                                                  \