Merge pull request #392 from yamacir-kit/r5rs

yamacir-kit · web-flow · commit d0f170f5a150 · 2022-05-21T11:14:50.000+09:00
Compliant with R5RS
diff --git 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.1022.so` and executable `meevax`.
+| `all` (default)    | Build shared-library `libmeevax.0.4.0.so` and executable `meevax`.
 | `test`             | Test executable `meevax`.
-| `package`          | Generate debian package `meevax_0.3.1022_amd64.deb`.
+| `package`          | Generate debian package `meevax_0.4.0_amd64.deb`.
 | `install`          | Copy files into `/usr/local` __(1)__.
 | `install.deb`      | `all` + `package` + `sudo apt install <meevax>.deb`
 | `safe-install.deb` | `all` + `test` + `package` + `sudo apt install <meevax>.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.1022
+Meevax Lisp System, version 0.4.0
 
 Usage: meevax [OPTION...] [FILE...]
 
diff --git a/VERSION b/VERSION
@@ -1 +1 @@
-0.3.1022
+0.4.0
diff --git a/include/meevax/kernel/machine.hpp b/include/meevax/kernel/machine.hpp
@@ -39,6 +39,8 @@ inline namespace kernel
     machine()
     {}
 
+    IMPORT(environment, fork, const);
+
   protected:
     let s, // stack (holding intermediate results and return address)
         e, // environment (giving values to symbols)
@@ -113,12 +115,31 @@ inline namespace kernel
                                  let const& expression)
         : syntactic_environment { syntactic_environment }
         , expression { expression }
-        , identity { identify() }
+        , identity { syntactic_environment.as<environment>().identify(expression, syntactic_environment.as<environment>().scope()) }
       {}
 
-      auto identify()
+      auto identify_with_offset(const_reference use_env_scope)
       {
-        return syntactic_environment.as<environment>().identify(expression, syntactic_environment.as<environment>().scope());
+        if (identity.is<relative>())
+        {
+          let const& mac_env_scope = syntactic_environment.as<environment>().scope();
+          auto offset = make<exact_integer>(length(use_env_scope) - length(mac_env_scope));
+          return make<relative>(car(identity),
+                                cadr(identity).template as<exact_integer>() + offset,
+                                cddr(identity));
+        }
+        else if (identity.is<variadic>())
+        {
+          let const& mac_env_scope = syntactic_environment.as<environment>().scope();
+          auto offset = make<exact_integer>(length(use_env_scope) - length(mac_env_scope));
+          return make<variadic>(car(identity),
+                                cadr(identity).template as<exact_integer>() + offset,
+                                cddr(identity));
+        }
+        else
+        {
+          return identity;
+        }
       }
 
       friend auto operator ==(syntactic_closure const& x, syntactic_closure const& y) -> bool
@@ -197,12 +218,21 @@ inline namespace kernel
             return cons(id.as<identity>().make_load_instruction(), id,
                         current_continuation);
           }
-          else
+          else // The syntactic-closure encloses procedure call.
           {
+            let mac_env_scope = current_expression.as<syntactic_closure>().syntactic_environment.template as<environment>().scope();
+
+            auto offset = length(current_scope) - length(mac_env_scope);
+
+            for (auto i = 0; i < offset; ++i)
+            {
+              mac_env_scope = cons(unit, mac_env_scope);
+            }
+
             return compile(current_context,
                            current_expression.as<syntactic_closure>().syntactic_environment.template as<environment>(),
                            current_expression.as<syntactic_closure>().expression,
-                           current_expression.as<syntactic_closure>().syntactic_environment.template as<environment>().scope(),
+                           mac_env_scope,
                            current_continuation);
           }
         }
@@ -421,7 +451,7 @@ inline namespace kernel
         *
         * ------------------------------------------------------------------- */
         assert(car(s).template is<closure>());
-        cadr(c).template as<absolute>().load() = make<transformer>(car(s), static_cast<environment const&>(*this).fork());
+        cadr(c).template as<absolute>().load() = make<transformer>(car(s), fork());
         c = cddr(c);
         goto decode;
 
@@ -438,10 +468,12 @@ inline namespace kernel
 
             let const& f = environment(static_cast<environment const&>(*this)).execute(binding);
 
-            binding = make<transformer>(f, static_cast<environment const&>(*this).fork(cadr(c).template as<syntactic_continuation>().scope()));
+            binding = make<transformer>(f, fork(cdr(cadr(c).template as<syntactic_continuation>().scope())));
           }
         }();
 
+        e = cons(unit, e); // dummy environment
+
         std::swap(c.as<pair>(),
                   body(context::none,
                        static_cast<environment &>(*this),
@@ -459,22 +491,21 @@ inline namespace kernel
         * ------------------------------------------------------------------- */
         [&]() // DIRTY HACK!!!
         {
-          let const syntactic_environment
-            = static_cast<environment const&>(*this).fork(cadr(c).template as<syntactic_continuation>().scope());
+          let const expander = fork(cadr(c).template as<syntactic_continuation>().scope());
 
           auto const [transformer_specs, body] = unpair(cadr(c).template as<syntactic_continuation>().expression());
 
           for (let const& transformer_spec : transformer_specs)
           {
-            syntactic_environment.as<environment>().execute(compile(context::outermost,
-                                                                    syntactic_environment.as<environment>(),
-                                                                    cons(make<syntax>("define-syntax", define_syntax), transformer_spec),
-                                                                    cadr(c).template as<syntactic_continuation>().scope()));
+            expander.as<environment>().execute(compile(context::outermost,
+                                                       expander.as<environment>(),
+                                                       cons(make<syntax>("define-syntax", define_syntax), transformer_spec),
+                                                       cadr(c).template as<syntactic_continuation>().scope()));
           }
 
           std::swap(c.as<pair>(),
                     machine::body(context::outermost,
-                                  syntactic_environment.as<environment>(),
+                                  expander.as<environment>(),
                                   body,
                                   cadr(c).template as<syntactic_continuation>().scope(),
                                   cddr(c)
@@ -686,7 +717,7 @@ inline namespace kernel
         }
       }
 
-      return variable.is<syntactic_closure>() ? variable.as<syntactic_closure>().identify() : f;
+      return variable.is<syntactic_closure>() ? variable.as<syntactic_closure>().identify_with_offset(scope) : f;
     }
 
     inline auto reset() -> void
diff --git a/script/version.sh b/script/version.sh
@@ -4,8 +4,11 @@ root="$(git rev-parse --show-toplevel)"
 
 current_version()
 {
-  count="$(git rev-list --count HEAD)"
-  echo "0.3.$((count - 2135))"
+  # count="$(git rev-list --count HEAD)"
+  # echo "0.3.$((count - 2135))"
+
+  count="$(git rev-list --no-merges --count HEAD)"
+  echo "0.4.$((count - 2854))"
 }
 
 update_version()
@@ -16,7 +19,7 @@ update_version()
 list_version()
 {
   git fetch origin --tags
-  git tag --list | sed -e 's/^/  /'
+  git tag --list --sort=version:refname | sed -e 's/^/  /'
   echo "\e[32m* v$(current_version)\e[0m"
 }
 
diff --git a/src/main.cpp b/src/main.cpp
@@ -32,7 +32,7 @@ auto main(int const argc, char const* const* const argv) -> int
     if (main.is_interactive_mode())
     {
       main.display_version();
-      main.print(features());
+      main.declare_import("(scheme r5rs)");
     }
 
     while (main.is_interactive_mode() and main.char_ready())
diff --git a/test/let-syntax.ss b/test/let-syntax.ss
@@ -51,6 +51,24 @@
            (let ((x 'inner))
              (m)))) => outer)
 
+(check (let ((x 'outer))
+         (let-syntax ((m (er-macro-transformer
+                           (lambda (form rename compare)
+                             (rename 'x)))))
+           (let ((x 'x1))
+             (let ((x 'x2))
+               (let ((x 'x3))
+                 (m)))))) => outer)
+
+(let ((x 'outer))
+  (let-syntax ((m (er-macro-transformer
+                    (lambda (form rename compare)
+                      (rename 'x)))))
+    (let ((x 'x1))
+      (let ((x 'x2))
+        (let ((x 'x3))
+          (check (m) => outer))))))
+
 (define result
   (let ((x 'outer))
     (let-syntax ((m (er-macro-transformer
@@ -63,4 +81,4 @@
 
 (check-report)
 
-(exit (check-passed? 5))
+(exit (check-passed? 7))
diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss
@@ -1,7 +1,8 @@
 (import (scheme base)
         (scheme process-context)
         (srfi 78)
-        (srfi 211 explicit-renaming))
+        (srfi 211 explicit-renaming)
+        (srfi 211 syntactic-closures))
 
 (letrec-syntax ((my-and (er-macro-transformer
                           (lambda (form rename compare)
@@ -30,13 +31,42 @@
         (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)))))
+           (m))) => outer)
+
+(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 'x1))
+             (let ((x 'x2))
+               (let ((x 'x3))
+                 (m)))))) => outer)
+
+(check (let ((x 'outer))
+         (letrec-syntax ((m (sc-macro-transformer
+                              (lambda (form use-env)
+                                'x))))
+           (let ((x 'inner))
+             (m)))) => outer)
+
+(check (let ((x 'outer))
+         (letrec-syntax ((m (rsc-macro-transformer
+                              (lambda (form mac-env)
+                                (make-syntactic-closure mac-env '() 'x)))))
+           (let ((x 'inner))
+             (m)))) => outer)
 
 (check-report)
 
-(exit (check-passed? 2))
+(exit (check-passed? 7))
diff --git a/test/transformer.ss b/test/transformer.ss
@@ -62,6 +62,43 @@
 
 (check (cons x y) => (2 . 1))
 
+(let-syntax ((swap!
+               (sc-macro-transformer
+                 (lambda (form use-env)
+                   (let ((a (make-syntactic-closure use-env '() (cadr form)))
+                         (b (make-syntactic-closure use-env '() (caddr form))))
+                     `(let ((value ,a))
+                        (set! ,a ,b)
+                        (set! ,b value)))))))
+  (let ((a     'non-hygienic!)
+        (b     'non-hygienic!)
+        (let   'non-hygienic!)
+        (set!  'non-hygienic!)
+        (value 'non-hygienic!))
+    (swap! x y)))
+
+(check (cons x y) => (1 . 2))
+
+(let ((return-value 42))
+  (let-syntax ((swap!
+                 (sc-macro-transformer
+                   (lambda (form use-env)
+                     (let ((a (make-syntactic-closure use-env '() (cadr form)))
+                           (b (make-syntactic-closure use-env '() (caddr form))))
+                       `(let ((value ,a))
+                          (set! ,a ,b)
+                          (set! ,b value)
+                          return-value))))))
+    (let ((a     'non-hygienic!)
+          (b     'non-hygienic!)
+          (let   'non-hygienic!)
+          (set!  'non-hygienic!)
+          (value 'non-hygienic!)
+          (return-value 3.14))
+      (check (swap! x y) => 42))))
+
+(check (cons x y) => (2 . 1))
+
 ; ------------------------------------------------------------------------------
 
 (define-syntax swap!
@@ -132,4 +169,4 @@
 
 (check-report)
 
-(exit (check-passed? 12))
+(exit (check-passed? 15))

Original file line number	Diff line number	Diff line change
`@@ -4,8 +4,11 @@ root="$(git rev-parse --show-toplevel)"`
`4`	`4`
`5`	`5`	`current_version()`
`6`	`6`	`{`
`7`		`- count="$(git rev-list --count HEAD)"`
`8`		`- echo "0.3.$((count - 2135))"`
	`7`	`+ # count="$(git rev-list --count HEAD)"`
	`8`	`+ # echo "0.3.$((count - 2135))"`
	`9`	`+`
	`10`	`+ count="$(git rev-list --no-merges --count HEAD)"`
	`11`	`+ echo "0.4.$((count - 2854))"`
`9`	`12`	`}`
`10`	`13`
`11`	`14`	`update_version()`
`@@ -16,7 +19,7 @@ update_version()`
`16`	`19`	`list_version()`
`17`	`20`	`{`
`18`	`21`	`git fetch origin --tags`
`19`		`- git tag --list \| sed -e 's/^/ /'`
	`22`	`+ git tag --list --sort=version:refname \| sed -e 's/^/ /'`
`20`	`23`	`echo "\e[32m* v$(current_version)\e[0m"`
`21`	`24`	`}`
`22`	`25`
Original file line number	Diff line number	Diff line change
`@@ -32,7 +32,7 @@ auto main(int const argc, char const* const* const argv) -> int`
`32`	`32`	`if (main.is_interactive_mode())`
`33`	`33`	`{`
`34`	`34`	`main.display_version();`
`35`		`- main.print(features());`
	`35`	`+ main.declare_import("(scheme r5rs)");`
`36`	`36`	`}`
`37`	`37`
`38`	`38`	`while (main.is_interactive_mode() and main.char_ready())`