diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 89d1995e2..572c7c2b4 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -6,7 +6,7 @@ on: jobs: Ubuntu: runs-on: ${{ matrix.system }} - timeout-minutes: 240 + timeout-minutes: 360 env: CXX: ${{ matrix.compiler }} strategy: diff --git a/README.md b/README.md index 6001b9755..ea3b8fd77 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.948.so` and executable `meevax`. +| `all` (default) | Build shared-library `libmeevax.0.3.970.so` and executable `meevax`. | `test` | Test executable `meevax`. -| `package` | Generate debian package `meevax_0.3.948_amd64.deb`. +| `package` | Generate debian package `meevax_0.3.970_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.948 +Meevax Lisp System, version 0.3.970 Usage: meevax [OPTION...] [FILE...] diff --git a/VERSION b/VERSION index a417c4cf1..b07bb1d95 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.3.948 +0.3.970 diff --git a/basis/overture.ss b/basis/overture.ss index 7b4e61a29..4ce4cd481 100644 --- a/basis/overture.ss +++ b/basis/overture.ss @@ -18,7 +18,7 @@ (lambda (form use-env mac-env) (make-syntactic-closure use-env '() (f form mac-env)))) -(define (experimental:er-macro-transformer f) +(define (er-macro-transformer f) (lambda (form use-env mac-env) (define rename:list (list)) (define (rename x) @@ -35,23 +35,21 @@ (begin (set! rename:list (alist-cons x (make-syntactic-closure mac-env '() x) rename:list)) (cdar rename:list))))) (define (compare x y) - (free-identifier=? (if (syntactic-closure? x) x - (make-syntactic-closure use-env '() x)) - (if (syntactic-closure? y) y - (make-syntactic-closure use-env '() 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 define-syntax define) - -(experimental:define-syntax import - (experimental:er-macro-transformer +(define-syntax import + (er-macro-transformer (lambda (form rename compare) (list (rename 'quote) (cons 'import (cdr form)))))) ; ------------------------------------------------------------------------------ -(experimental:define-syntax cond - (experimental:er-macro-transformer +(define-syntax cond + (er-macro-transformer (lambda (form rename compare) (if (null? (cdr form)) (unspecified) @@ -76,8 +74,8 @@ (cons (rename 'cond) (cddr form)))))) (cadr form)))))) -(experimental:define-syntax and - (experimental:er-macro-transformer +(define-syntax and + (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form))) ((null? (cddr form)) @@ -88,8 +86,8 @@ (cddr form)) #f)))))) -(experimental:define-syntax or - (experimental:er-macro-transformer +(define-syntax or + (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form)) #f) ((null? (cddr form)) @@ -125,8 +123,8 @@ (car xs))) (reverse xs)))) -(experimental:define-syntax quasiquote - (experimental:er-macro-transformer +(define-syntax quasiquote + (er-macro-transformer (lambda (form rename compare) (define (expand x depth) (cond ((pair? x) @@ -170,14 +168,14 @@ (define (not x) (if x #f #t)) -(experimental:define-syntax when - (experimental:er-macro-transformer +(define-syntax when + (er-macro-transformer (lambda (form rename compare) `(,(rename 'if) ,(cadr form) (,(rename 'begin) ,@(cddr form)))))) -(experimental:define-syntax unless - (experimental:er-macro-transformer +(define-syntax unless + (er-macro-transformer (lambda (form rename compare) `(,(rename 'if) (,(rename 'not) ,(cadr form)) (,(rename 'begin) ,@(cddr form)))))) @@ -244,8 +242,8 @@ #f) (any-2+ f (cons x xs)))) -(experimental:define-syntax let - (experimental:er-macro-transformer +(define-syntax let + (er-macro-transformer (lambda (form rename compare) (if (identifier? (cadr form)) `(,(rename 'letrec) ((,(cadr form) @@ -255,8 +253,8 @@ ,@(map cadr (cadr form))))))) -(experimental:define-syntax let* - (experimental:er-macro-transformer +(define-syntax let* + (er-macro-transformer (lambda (form rename compare) (if (null? (cadr form)) `(,(rename 'let) () ,@(cddr form)) @@ -264,8 +262,8 @@ (,(rename 'let*) ,(cdadr form) ,@(cddr form))))))) -(experimental:define-syntax letrec* - (experimental:er-macro-transformer +(define-syntax letrec* + (er-macro-transformer (lambda (form rename compare) `(,(rename 'let) () ,@(map (lambda (x) (cons (rename 'define) x)) @@ -282,8 +280,8 @@ (define (memq o x) (member o x eq?)) (define (memv o x) (member o x eqv?)) -(experimental:define-syntax case - (experimental:er-macro-transformer +(define-syntax case + (er-macro-transformer (lambda (form rename compare) (define (body xs) (cond ((null? xs) (rename 'result)) @@ -307,8 +305,8 @@ `(,(rename 'let) ((,(rename 'result) ,(cadr form))) ,(each-clause (cddr form)))))) -(experimental:define-syntax do - (experimental:er-macro-transformer +(define-syntax do + (er-macro-transformer (lambda (form rename compare) (let ((body `(,(rename 'begin) ,@(cdddr form) (,(rename 'rec) ,@(map (lambda (x) @@ -660,11 +658,10 @@ ; (apply consumer xs))) (define (call-with-values producer consumer) - ((lambda (vs) + (let ((vs (producer))) (if (values? vs) (apply consumer (cdr vs)) - (consumer vs))) - (producer))) + (consumer vs)))) ; ---- 6.11. Exceptions -------------------------------------------------------- diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 567f5b399..b3608cc2b 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -1,6 +1,6 @@ ; ---- 4.2.1. Conditionals ----------------------------------------------------- -(experimental:define-syntax cond +(define-syntax cond (syntax-rules (else =>) ((cond (else result1 result2 ...)) (begin result1 result2 ...)) @@ -26,10 +26,9 @@ (begin result1 result2 ...) (cond clause1 clause2 ...))))) -(experimental:define-syntax case ; errata version +(define-syntax case ; errata version (syntax-rules (else =>) - ((case (key ...) - clauses ...) + ((case (key ...) clauses ...) (let ((atom-key (key ...))) (case atom-key clauses ...))) ((case key @@ -42,31 +41,26 @@ ((atoms ...) => result)) (if (memv key '(atoms ...)) (result key))) - ((case key - ((atoms ...) => result) - clause clauses ...) + ((case key ((atoms ...) => result) clause clauses ...) (if (memv key '(atoms ...)) (result key) (case key clause clauses ...))) - ((case key - ((atoms ...) result1 result2 ...)) + ((case key ((atoms ...) result1 result2 ...)) (if (memv key '(atoms ...)) (begin result1 result2 ...))) - ((case key - ((atoms ...) result1 result2 ...) - clause clauses ...) + ((case key ((atoms ...) result1 result2 ...) clause clauses ...) (if (memv key '(atoms ...)) (begin result1 result2 ...) (case key clause clauses ...))))) -(experimental:define-syntax and +(define-syntax and (syntax-rules () ((and) #t) ((and test) test) ((and test1 test2 ...) (if test1 (and test2 ...) #f)))) -(experimental:define-syntax or +(define-syntax or (syntax-rules () ((or) #f) ((or test) test) @@ -74,13 +68,13 @@ (let ((x test1)) (if x x (or test2 ...)))))) -(experimental:define-syntax when +(define-syntax when (syntax-rules () ((when test result1 result2 ...) (if test (begin result1 result2 ...))))) -(experimental:define-syntax unless +(define-syntax unless (syntax-rules () ((unless test result1 result2 ...) (if (not test) @@ -88,14 +82,14 @@ ; ---- 4.2.2. Binding constructs ----------------------------------------------- -(experimental:define-syntax let +(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 ...)))) -(experimental:define-syntax let* +(define-syntax let* (syntax-rules () ((let* () body1 body2 ...) (let () body1 body2 ...)) @@ -103,7 +97,7 @@ (let ((name1 val1)) (let* ((name2 val2) ...) body1 body2 ...))))) -(experimental:define-syntax letrec* +(define-syntax letrec* (syntax-rules () ((letrec* ((var1 init1) ...) body1 body2 ...) (let ((var1 ) ...) @@ -111,71 +105,62 @@ ... (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 -; (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)))))) - -(experimental:define-syntax let-values - (experimental: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)))))))) +; (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 -; (syntax-rules () -; ((let*-values () body0 body1 ...) -; (let () body0 body1 ...)) -; ((let*-values (binding0 binding1 ...) -; body0 body1 ...) -; (let-values (binding0) -; (let*-values (binding1 ...) -; body0 body1 ...))))) - -(experimental:define-syntax let*-values - (experimental: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))))))) +; (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 -------------------------------------------------------- -(experimental:define-syntax do +(define-syntax do (syntax-rules () ((do ((var init step ...) ...) (test expr ...) @@ -202,7 +187,7 @@ delay ; is defined in srfi-45.ss -(define-syntax delay-force lazy) ; lazy is defined in srfi-45.ss +(define delay-force lazy) ; lazy is defined in srfi-45.ss force ; is defined in srfi-45.ss @@ -218,7 +203,7 @@ parameterize ; is defined in srfi-39.ss ; ---- 4.2.7. Exception handling ----------------------------------------------- -(experimental:define-syntax guard +(define-syntax guard (syntax-rules () ((guard (var clause ...) e1 e2 ...) ((call/cc @@ -243,7 +228,7 @@ parameterize ; is defined in srfi-39.ss (lambda () (apply values args))))))))))))) -(experimental:define-syntax guard-aux +(define-syntax guard-aux (syntax-rules (else =>) ((guard-aux reraise (else result1 result2 ...)) (begin result1 result2 ...)) diff --git a/basis/srfi-149.ss b/basis/srfi-149.ss index a97ce9a80..c8f0b3c16 100644 --- a/basis/srfi-149.ss +++ b/basis/srfi-149.ss @@ -43,7 +43,7 @@ (define (syntax-rules-transformer expr rename compare) (let ((ellipsis-specified? (identifier? (cadr expr))) (count 0) - (_er-macro-transformer (rename 'experimental:er-macro-transformer)) + (_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)) @@ -267,7 +267,7 @@ (list (rename 'strip-syntactic-closures) _expr)) #f))))))))) -(experimental:define-syntax syntax-rules - (experimental:er-macro-transformer +(define-syntax syntax-rules + (er-macro-transformer (lambda (form rename compare) (syntax-rules-transformer form rename compare)))) diff --git a/basis/srfi-39.ss b/basis/srfi-39.ss index bad07d511..53b5c756c 100644 --- a/basis/srfi-39.ss +++ b/basis/srfi-39.ss @@ -64,8 +64,8 @@ (define (dynamic-env-local-set! new-env) (set! dynamic-env-local new-env)) -(experimental:define-syntax parameterize - (experimental:er-macro-transformer +(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))) diff --git a/basis/srfi-45.ss b/basis/srfi-45.ss index f42d4eab7..2e8416d5d 100644 --- a/basis/srfi-45.ss +++ b/basis/srfi-45.ss @@ -24,13 +24,13 @@ (promise-merge! new promise)) (force promise)))) -(experimental:define-syntax lazy - (experimental:er-macro-transformer +(define-syntax lazy + (er-macro-transformer (lambda (form rename compare) `(,(rename 'promise) #f (,(rename 'lambda) () ,(cadr form)))))) -(experimental:define-syntax delay - (experimental:er-macro-transformer +(define-syntax delay + (er-macro-transformer (lambda (form rename compare) `(,(rename 'lazy) (,(rename 'promise) #t ,(cadr form)))))) diff --git a/basis/srfi-78.ss b/basis/srfi-78.ss index d2a2e3f8e..3988e85d9 100644 --- a/basis/srfi-78.ss +++ b/basis/srfi-78.ss @@ -177,8 +177,8 @@ ; (if (>= check:mode 1) ; (check:proc 'expr (lambda () expr) equal expected))))) -(experimental:define-syntax check - (experimental:er-macro-transformer +(define-syntax check + (er-macro-transformer (lambda (form rename compare) (cond ((compare (rename '=>) (caddr form)) `(,(rename 'check) ,(cadr form) (,(rename '=>) ,(rename 'equal?)) ,(cadddr form))) diff --git a/basis/srfi-8.ss b/basis/srfi-8.ss index 36ca0a621..ba2b1663e 100644 --- a/basis/srfi-8.ss +++ b/basis/srfi-8.ss @@ -5,8 +5,8 @@ ; (lambda () expression) ; (lambda parameters . body))))) -(experimental:define-syntax receive - (experimental:er-macro-transformer +(define-syntax receive + (er-macro-transformer (lambda (form rename compare) `(,(rename 'call-with-values) (,(rename 'lambda) () ,(caddr form)) diff --git a/include/meevax/kernel/environment.hpp b/include/meevax/kernel/environment.hpp index afb480712..25a3a4903 100644 --- a/include/meevax/kernel/environment.hpp +++ b/include/meevax/kernel/environment.hpp @@ -63,14 +63,14 @@ inline namespace kernel auto apply(const_reference, const_reference) -> object; - auto define(const_reference, const_reference) -> void; + auto define(const_reference, const_reference = undefined) -> void; - auto define(std::string const&, const_reference) -> void; + auto define(std::string const&, const_reference = undefined) -> void; template auto define(std::string const& name, Ts&&... xs) -> void { - define(intern(name), make(name, std::forward(xs)...)); + define(name, make(name, std::forward(xs)...)); } auto evaluate(const_reference) -> object; @@ -79,48 +79,36 @@ inline namespace kernel auto execute(const_reference) -> object; - auto fork(const_reference scope) const + auto fork() const { - let const copy = make(*this); - copy.as().scope() = scope; - return copy; + return make(*this); } - auto reserve(const_reference x) -> const_reference + auto fork(const_reference scope) const // DIRTY HACK!!! { - assert(is_identifier(x)); - - let const result = make(x); - - result.as().strip() = result; // NOTE: Identifier is self-evaluate if is free-identifier. - - assert(result.as().is_free()); - - global_environment() = result | global_environment(); - - return car(global_environment()); + let const copy = make(*this); + copy.as().scope() = scope; + return copy; } - auto global_environment() noexcept -> reference; + auto global() noexcept -> reference; - auto global_environment() const noexcept -> const_reference; + auto global() const noexcept -> const_reference; template auto import(std::integer_sequence) -> void; auto import() -> void; - static auto is_identifier(const_reference) -> bool; - auto load(std::string const&) -> object; auto scope() const noexcept -> const_reference; auto scope() noexcept -> reference; - auto notate(const_reference, const_reference) -> object; + auto identify(const_reference, const_reference) -> object; - auto notate(const_reference, const_reference) const -> object; + auto identify(const_reference, const_reference) const -> object; }; auto operator >>(std::istream &, environment &) -> std::istream &; diff --git a/include/meevax/kernel/ghost.hpp b/include/meevax/kernel/ghost.hpp index 971abc64b..1c96ee89d 100644 --- a/include/meevax/kernel/ghost.hpp +++ b/include/meevax/kernel/ghost.hpp @@ -30,12 +30,12 @@ inline namespace kernel extern let const unspecified_object; - struct undefined + struct unbound {}; - auto operator <<(std::ostream &, undefined const&) -> std::ostream &; + auto operator <<(std::ostream &, unbound const&) -> std::ostream &; - extern let const undefined_object; + extern let const undefined; } // namespace kernel } // namespace meevax diff --git a/include/meevax/kernel/identifier.hpp b/include/meevax/kernel/identifier.hpp new file mode 100644 index 000000000..4934e7125 --- /dev/null +++ b/include/meevax/kernel/identifier.hpp @@ -0,0 +1,29 @@ +/* + 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_IDENTIFIER_HPP +#define INCLUDED_MEEVAX_KERNEL_IDENTIFIER_HPP + +namespace meevax +{ +inline namespace kernel +{ + struct identifier + {}; +} // namespace kernel +} // namespace meevax + +#endif // INCLUDED_MEEVAX_KERNEL_IDENTIFIER_HPP diff --git a/include/meevax/kernel/identity.hpp b/include/meevax/kernel/identity.hpp new file mode 100644 index 000000000..e7c5696a7 --- /dev/null +++ b/include/meevax/kernel/identity.hpp @@ -0,0 +1,100 @@ +/* + 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_IDENTITY_HPP +#define INCLUDED_MEEVAX_KERNEL_IDENTITY_HPP + +#include +#include + +namespace meevax +{ +inline namespace kernel +{ + struct identity : public virtual pair + { + using pair::pair; + + virtual auto is_bound() const -> bool = 0; + + virtual auto is_free() const -> bool = 0; + + virtual auto load(const_reference e) -> reference; + + virtual auto load(const_reference) const -> const_reference = 0; + + virtual auto make_load_instruction() const -> object = 0; + + virtual auto make_store_instruction() const -> object = 0; + + virtual auto symbol() const -> const_reference; + }; + + auto operator <<(std::ostream & os, identity const& datum) -> std::ostream &; + + struct absolute : public identity + { + using identity::identity; + + auto is_bound() const -> bool override; + + auto is_free() const -> bool override; + + auto load(const_reference = unit) -> reference override; + + auto load(const_reference = unit) const -> const_reference override; + + auto make_load_instruction() const -> object override; + + auto make_store_instruction() const -> object override; + }; + + struct keyword : public absolute + { + using absolute::absolute; + }; + + struct relative : public identity // ( . ) = ( . ) + { + using identity::identity; + + auto is_bound() const -> bool override; + + auto is_free() const -> bool override; + + auto load(const_reference) const -> const_reference override; + + auto make_load_instruction() const -> object override; + + auto make_store_instruction() const -> object override; + }; + + auto operator ==(relative const&, relative const&) -> bool; + + struct variadic : public relative // ( . ) = ( . ) + { + using relative::relative; + + auto load(const_reference e) const -> const_reference override; + + auto make_load_instruction() const -> object override; + + auto make_store_instruction() const -> object override; + }; +} // namespace kernel +} // namespace meevax + +#endif // INCLUDED_MEEVAX_KERNEL_IDENTITY_HPP diff --git a/include/meevax/kernel/machine.hpp b/include/meevax/kernel/machine.hpp index 7856930df..7a6733e9b 100644 --- a/include/meevax/kernel/machine.hpp +++ b/include/meevax/kernel/machine.hpp @@ -20,9 +20,9 @@ #include #include #include +#include #include #include -#include #include #include #include @@ -39,9 +39,6 @@ inline namespace kernel machine() {} - IMPORT(environment, global_environment, const); - IMPORT(environment, scope, ); - protected: let s, // stack (holding intermediate results and return address) e, // environment (giving values to symbols) @@ -101,22 +98,37 @@ inline namespace kernel } }; - struct syntactic_closure + struct syntactic_closure : public identifier { - let const enclosure; + let const syntactic_environment; - let const free_variables; + let const free_variables = unit; let const expression; - auto notate() + let const identity; + + explicit syntactic_closure(let const& syntactic_environment, + let const&, // Currently ignored + let const& expression) + : syntactic_environment { syntactic_environment } + , expression { expression } + , identity { identify() } + {} + + auto identify() + { + return syntactic_environment.as().identify(expression, syntactic_environment.as().scope()); + } + + friend auto operator ==(syntactic_closure const& x, syntactic_closure const& y) -> bool { - return enclosure.as().notate(expression, enclosure.as().scope()); + return eqv(x.identity, y.identity); } friend auto operator <<(std::ostream & os, syntactic_closure const& datum) -> std::ostream & { - return os << magenta("#,(") << blue("make-syntactic-closure ") << datum.enclosure << " " << magenta("'") << datum.free_variables << " " << magenta("'") << datum.expression << magenta(")"); + return os << magenta("#,(") << blue("make-syntactic-closure ") << datum.syntactic_environment << " " << magenta("'") << datum.free_variables << " " << magenta("'") << datum.expression << magenta(")"); } }; @@ -173,24 +185,24 @@ inline namespace kernel { if (current_expression.is()) { - let const& n = current_environment.notate(current_expression, current_scope); + let const& id = current_environment.identify(current_expression, current_scope); - return cons(n.as().make_load_instruction(), n, + return cons(id.as().make_load_instruction(), id, current_continuation); } else if (current_expression.is()) { - if (let const& n = std::as_const(current_environment).notate(current_expression, current_scope); select(n)) + if (let const& id = std::as_const(current_environment).identify(current_expression, current_scope); select(id)) { - return cons(n.as().make_load_instruction(), n, + return cons(id.as().make_load_instruction(), id, current_continuation); } else { return compile(current_context, - current_expression.as().enclosure.template as(), + current_expression.as().syntactic_environment.template as(), current_expression.as().expression, - current_expression.as().enclosure.template as().scope(), + current_expression.as().syntactic_environment.template as().scope(), current_continuation); } } @@ -200,17 +212,17 @@ inline namespace kernel current_continuation); } } - else if (let const& notation = std::as_const(current_environment).notate(car(current_expression), current_scope); notation.is()) + else if (let const& id = std::as_const(current_environment).identify(car(current_expression), current_scope); id.is()) { - assert(notation.as().strip().is_also()); + assert(id.as().load().is_also()); return compile(context::none, current_environment, - notation.as().strip().as().expand(current_expression, current_environment.fork(current_scope)), + id.as().load().as().expand(current_expression, current_environment.fork(current_scope)), current_scope, current_continuation); } - else if (let const& applicant = notation.is() ? notation.as().strip() : car(current_expression); applicant.is_also()) + else if (let const& applicant = id.is() ? id.as().load() : car(current_expression); applicant.is_also()) { return applicant.as().compile(current_context, current_environment, @@ -293,18 +305,18 @@ inline namespace kernel { case mnemonic::load_absolute: /* ----------------------------------------- * - * s e (%load-absolute . c) d => (x . s) e c d + * s e (%load-absolute . c) d => (x . s) e c d * - * where = ( . x) + * where = ( . x) * * ------------------------------------------------------------------- */ [[fallthrough]]; case mnemonic::load_relative: /* ----------------------------------------- * - * s e (%load-relative . c) d => (x . s) e c d + * s e (%load-relative . c) d => (x . s) e c d * - * where = ( i . j) + * where = ( i . j) * * x = (list-ref (list-ref e i) j) * @@ -313,14 +325,14 @@ inline namespace kernel case mnemonic::load_variadic: /* ----------------------------------------- * - * s e (%load-variadic . c) d => (x . s) e c d + * s e (%load-variadic . c) d => (x . s) e c d * - * where = ( i . j) + * where = ( i . j) * * x = (list-tail (list-ref e i) j) * * ------------------------------------------------------------------- */ - s = cons(cadr(c).template as().strip(e), s); + s = cons(cadr(c).template as().load(e), s); c = cddr(c); goto decode; @@ -388,24 +400,24 @@ inline namespace kernel case mnemonic::define: /* ------------------------------------------------ * - * (x' . s) e (%define . c) d => (x' . s) e c d + * (x' . s) e (%define . c) d => (x' . s) e c d * - * where = ( . x := x') + * where = ( . x := x') * * ------------------------------------------------------------------- */ - cadr(c).template as().strip() = car(s); + cadr(c).template as().load() = car(s); c = cddr(c); goto decode; case mnemonic::define_syntax: /* ----------------------------------------- * - * ( . s) e (%define . c) d => (x' . s) e c d + * ( . s) e (%define . c) d => (x' . s) e c d * - * where = ( . x := ) + * where = ( . x := ) * * ------------------------------------------------------------------- */ assert(car(s).template is()); - cadr(c).template as().strip() = make(car(s), static_cast(*this).fork(unit)); + cadr(c).template as().load() = make(car(s), static_cast(*this).fork()); c = cddr(c); goto decode; @@ -418,11 +430,11 @@ inline namespace kernel { for (let const& keyword_ : car(cadr(c).template as().scope())) { - let & binding = keyword_.as().strip(); + let & binding = keyword_.as().load(); let const& f = environment(static_cast(*this)).execute(binding); - binding = make(f, static_cast(*this).fork(unit)); + binding = make(f, static_cast(*this).fork(cadr(c).template as().scope())); } }(); @@ -443,21 +455,22 @@ inline namespace kernel * ------------------------------------------------------------------- */ [&]() // DIRTY HACK!!! { - auto env = environment(static_cast(*this)); + let const syntactic_environment + = static_cast(*this).fork(cadr(c).template as().scope()); auto const [transformer_specs, body] = unpair(cadr(c).template as().expression()); for (let const& transformer_spec : transformer_specs) { - env.execute(compile(context::outermost, - env, - cons(make("define-syntax", define_syntax), transformer_spec), - cadr(c).template as().scope())); + syntactic_environment.as().execute(compile(context::outermost, + syntactic_environment.as(), + cons(make("define-syntax", define_syntax), transformer_spec), + cadr(c).template as().scope())); } std::swap(c.as(), machine::body(context::outermost, - env, + syntactic_environment.as(), body, cadr(c).template as().scope(), cddr(c) @@ -605,26 +618,26 @@ inline namespace kernel case mnemonic::store_absolute: /* ---------------------------------------- * - * (x' . s) e (%store-absolute . c) d => (x' . s) e c d + * (x . s) e (%store-absolute . c) d => (x . s) e c d * - * where = ( . x:=x') + * where = ( . :=x) * * ------------------------------------------------------------------- */ [[fallthrough]]; case mnemonic::store_relative: /* ---------------------------------------- * - * (x . s) e (%store-relative . c) d => (x' . s) e c d + * (x . s) e (%store-relative . c) d => (x . s) e c d * * ------------------------------------------------------------------- */ [[fallthrough]]; case mnemonic::store_variadic: /* ---------------------------------------- * - * (x . s) e (%store-variadic . c) d => (x' . s) e c d + * (x . s) e (%store-variadic . c) d => (x . s) e c d * * ------------------------------------------------------------------- */ - cadr(c).template as().strip(e) = car(s); + cadr(c).template as().load(e) = car(s); c = cddr(c); goto decode; @@ -638,7 +651,7 @@ inline namespace kernel } } - static auto notate(const_reference variable, const_reference scope) -> object + static auto identify(const_reference variable, const_reference scope) -> object { for (auto outer = std::begin(scope); outer != std::end(scope); ++outer) { @@ -669,7 +682,7 @@ inline namespace kernel } } - return variable.is() ? variable.as().notate() : f; + return variable.is() ? variable.as().identify() : f; } inline auto reset() -> void @@ -693,13 +706,13 @@ inline namespace kernel * * ----------------------------------------------------------------------- */ { - let const& notation = current_environment.notate(car(current_expression), current_scope); + let const& id = current_environment.identify(car(current_expression), current_scope); return compile(context::none, current_environment, cadr(current_expression), current_scope, - cons(notation.as().make_store_instruction(), notation, + cons(id.as().make_store_instruction(), id, current_continuation)); } @@ -709,9 +722,9 @@ inline namespace kernel { if (form.is()) { - if (let const& notation = std::as_const(current_environment).notate(car(form), current_scope); notation.is()) + if (let const& id = std::as_const(current_environment).identify(car(form), current_scope); id.is()) { - if (let const& callee = notation.as().strip(); callee.is()) + if (let const& callee = id.as().load(); callee.is()) { return callee.as().name == "define"; } @@ -776,7 +789,7 @@ inline namespace kernel cons(cons(make("lambda", lambda), unzip1(binding_specs), append(map(curry(cons)(make("set!", set)), binding_specs), body)), - make_list(length(binding_specs), undefined_object)), + make_list(length(binding_specs), undefined)), current_scope, current_continuation); } @@ -928,7 +941,7 @@ inline namespace kernel current_environment, cons(make("lambda", lambda), cdar(current_expression), cdr(current_expression)), current_scope, - cons(make(mnemonic::define), current_environment.notate(caar(current_expression), current_scope), + cons(make(mnemonic::define), current_environment.identify(caar(current_expression), current_scope), current_continuation)); } else // (define x ...) @@ -937,7 +950,7 @@ inline namespace kernel current_environment, cdr(current_expression) ? cadr(current_expression) : unspecified_object, current_scope, - cons(make(mnemonic::define), current_environment.notate(car(current_expression), current_scope), + cons(make(mnemonic::define), current_environment.identify(car(current_expression), current_scope), current_continuation)); } } @@ -1003,9 +1016,9 @@ inline namespace kernel { return compile(context::none, current_environment, - cdr(current_expression) ? cadr(current_expression) : unspecified_object, + cdr(current_expression) ? cadr(current_expression) : undefined, current_scope, - cons(make(mnemonic::define_syntax), current_environment.notate(car(current_expression), current_scope), + cons(make(mnemonic::define_syntax), current_environment.identify(car(current_expression), current_scope), current_continuation)); } diff --git a/include/meevax/kernel/notation.hpp b/include/meevax/kernel/notation.hpp deleted file mode 100644 index 099bea094..000000000 --- a/include/meevax/kernel/notation.hpp +++ /dev/null @@ -1,139 +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_KERNEL_NOTATION_HPP -#define INCLUDED_MEEVAX_KERNEL_NOTATION_HPP - -#include -#include -#include -#include - -namespace meevax -{ -inline namespace kernel -{ - struct notation : public virtual pair - { - using pair::pair; - - virtual auto make_load_instruction() const -> object = 0; - - virtual auto make_store_instruction() const -> object = 0; - - virtual auto strip(const_reference) const -> const_reference = 0; - - virtual auto strip(const_reference e) -> reference - { - return const_cast(std::as_const(*this).strip(e)); - } - - virtual auto symbol() const -> const_reference - { - assert(first.is()); - return first; - } - - friend auto operator <<(std::ostream & os, notation const& datum) -> std::ostream & - { - return os << "#,(notation " << datum.symbol() << ")"; - } - }; - - struct absolute : public notation - { - using notation::notation; - - auto is_bound() const -> bool - { - return not is_free(); - } - - auto is_free() const -> bool - { - // NOTE: See environment::generate_free_identifier - return strip().is() and std::addressof(strip().as()) == this; - } - - auto make_load_instruction() const -> object override - { - return make(mnemonic::load_absolute); - } - - auto make_store_instruction() const -> object override - { - return make(mnemonic::store_absolute); - } - - auto strip(const_reference = unit) const -> const_reference override - { - return second; - } - - auto strip(const_reference = unit) -> reference override - { - return second; - } - }; - - struct keyword : public absolute - { - using absolute::absolute; - }; - - struct relative : public notation // ( . ) = ( . ) - { - using notation::notation; - - auto make_load_instruction() const -> object override - { - return make(mnemonic::load_relative); - } - - auto make_store_instruction() const -> object override - { - return make(mnemonic::store_relative); - } - - auto strip(const_reference e) const -> const_reference override - { - return list_ref(list_ref(e, car(second)), cdr(second)); - } - }; - - struct variadic : public relative // ( . ) = ( . ) - { - using relative::relative; - - auto make_load_instruction() const -> object override - { - return make(mnemonic::load_variadic); - } - - auto make_store_instruction() const -> object override - { - return make(mnemonic::store_variadic); - } - - auto strip(const_reference e) const -> const_reference override - { - return list_tail(list_ref(e, car(second)), cdr(second)); - } - }; -} // namespace kernel -} // namespace meevax - -#endif // INCLUDED_MEEVAX_KERNEL_NOTATION_HPP diff --git a/include/meevax/kernel/symbol.hpp b/include/meevax/kernel/symbol.hpp index 4381e78c7..221ef590f 100644 --- a/include/meevax/kernel/symbol.hpp +++ b/include/meevax/kernel/symbol.hpp @@ -17,18 +17,28 @@ #ifndef INCLUDED_MEEVAX_KERNEL_SYMBOL_HPP #define INCLUDED_MEEVAX_KERNEL_SYMBOL_HPP +#include #include namespace meevax { inline namespace kernel { - struct symbol : public std::string + struct symbol : public identifier { + using value_type = std::string; + + value_type const value; + template - explicit constexpr symbol(Ts&&... xs) - : std::string { std::forward(xs)... } + explicit symbol(Ts&&... xs) + : value { std::forward(xs)... } {} + + operator std::string() const noexcept + { + return value; + } }; auto operator <<(std::ostream &, symbol const&) -> std::ostream &; diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index e49031f55..d368540d6 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -22,7 +22,7 @@ inline namespace kernel { auto environment::operator [](const_reference name) -> const_reference { - return notate(name, scope()).as().strip(); + return identify(name, scope()).as().load(); } auto environment::operator [](std::string const& name) -> const_reference @@ -50,9 +50,9 @@ inline namespace kernel auto environment::define(const_reference name, const_reference value) -> void { - assert(is_identifier(name)); + assert(name.is_also()); - global_environment() = make(name, value) | global_environment(); + global() = make(name, value) | global(); } auto environment::define(std::string const& name, const_reference value) -> void @@ -108,12 +108,12 @@ inline namespace kernel return execute(); } - auto environment::global_environment() const noexcept -> const_reference + auto environment::global() const noexcept -> const_reference { return second; } - auto environment::global_environment() noexcept -> reference + auto environment::global() noexcept -> reference { return second; } @@ -128,11 +128,6 @@ inline namespace kernel define("set-verbose!", [this](let const& xs, auto&&...) { return verbose = car(xs); }); } - auto environment::is_identifier(const_reference x) -> bool - { - return x.is() or x.is(); - } - auto environment::load(std::string const& s) -> object { if (let port = make(s); port and port.as().is_open()) @@ -160,31 +155,31 @@ inline namespace kernel return first; } - auto environment::notate(const_reference variable, const_reference scope) const -> object + auto environment::identify(const_reference variable, const_reference scope) const -> object { - if (not is_identifier(variable)) + if (not variable.is_also()) { return f; } - else if (let const& notation = machine::notate(variable, scope); select(notation)) + else if (let const& identity = machine::identify(variable, scope); select(identity)) { - return notation; + return identity; } else { - return assq(variable, global_environment()); + return assq(variable, global()); } } - auto environment::notate(const_reference variable, const_reference scope) -> object + auto environment::identify(const_reference variable, const_reference scope) -> object { - if (not is_identifier(variable)) + if (not variable.is_also()) { return f; } - if (let const& notation = std::as_const(*this).notate(variable, scope); select(notation)) + if (let const& id = std::as_const(*this).identify(variable, scope); select(id)) { - return notation; + return id; } else /* -------------------------------------------------------------------- * @@ -203,7 +198,9 @@ inline namespace kernel * * ----------------------------------------------------------------------- */ { - return reserve(variable); + define(variable); + + return car(global()); } } diff --git a/src/kernel/ghost.cpp b/src/kernel/ghost.cpp index 17a953a1a..c08ab9225 100644 --- a/src/kernel/ghost.cpp +++ b/src/kernel/ghost.cpp @@ -27,11 +27,11 @@ inline namespace kernel let const unspecified_object = make(); - auto operator <<(std::ostream & os, undefined const&) -> std::ostream & + auto operator <<(std::ostream & os, unbound const&) -> std::ostream & { - return os << faint("#;undefined"); + return os << faint("#;unbound"); } - let const undefined_object = make(); + let const undefined = make(); } // namespace kernel } // namespace meevax diff --git a/src/kernel/identity.cpp b/src/kernel/identity.cpp new file mode 100644 index 000000000..0feb68920 --- /dev/null +++ b/src/kernel/identity.cpp @@ -0,0 +1,118 @@ +/* + 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 +#include +#include +#include +#include + +namespace meevax +{ +inline namespace kernel +{ + auto identity::load(const_reference e) -> reference + { + return const_cast(std::as_const(*this).load(e)); + } + + auto identity::symbol() const -> const_reference + { + assert(first.is()); + return first; + } + + auto operator <<(std::ostream & os, identity const& datum) -> std::ostream & + { + return os << magenta("#,(") << blue("identity ") << datum.symbol() << magenta(")"); + } + + auto absolute::is_bound() const -> bool + { + return not is_free(); + } + + auto absolute::is_free() const -> bool + { + return load().is(); + } + + auto absolute::load(const_reference) const -> const_reference + { + return second; + } + + auto absolute::load(const_reference) -> reference + { + return second; + } + + auto absolute::make_load_instruction() const -> object + { + return make(mnemonic::load_absolute); + } + + auto absolute::make_store_instruction() const -> object + { + return make(mnemonic::store_absolute); + } + + auto relative::is_bound() const -> bool + { + return true; + } + + auto relative::is_free() const -> bool + { + return false; + } + + auto relative::load(const_reference e) const -> const_reference + { + return list_ref(list_ref(e, car(second)), cdr(second)); + } + + auto relative::make_load_instruction() const -> object + { + return make(mnemonic::load_relative); + } + + auto relative::make_store_instruction() const -> object + { + return make(mnemonic::store_relative); + } + + auto operator ==(relative const&, relative const&) -> bool + { + return false; // No viable comparison. + } + + auto variadic::load(const_reference e) const -> const_reference + { + return list_tail(list_ref(e, car(second)), cdr(second)); + } + + auto variadic::make_load_instruction() const -> object + { + return make(mnemonic::load_variadic); + } + + auto variadic::make_store_instruction() const -> object + { + return make(mnemonic::store_variadic); + } +} // namespace kernel +} // namespace meevax diff --git a/src/kernel/symbol.cpp b/src/kernel/symbol.cpp index 023b7694e..17104399e 100644 --- a/src/kernel/symbol.cpp +++ b/src/kernel/symbol.cpp @@ -22,7 +22,7 @@ inline namespace kernel { auto operator <<(std::ostream & os, symbol const& datum) -> std::ostream & { - return os << (datum.empty() ? "||" : datum.c_str()); + return os << (datum.value.empty() ? "||" : datum.value); } } // namespace kernel } // namespace meevax diff --git a/src/library/meevax.cpp b/src/library/meevax.cpp index b2f4f6d89..6a1524d47 100644 --- a/src/library/meevax.cpp +++ b/src/library/meevax.cpp @@ -26,7 +26,7 @@ namespace meevax define("begin", machine::begin); define("call-with-current-continuation!", call_with_current_continuation); define("define", machine::define); - define("experimental:define-syntax", define_syntax); + define("define-syntax", define_syntax); define("if", if_); define("lambda", lambda); define("let-syntax", let_syntax); @@ -1948,31 +1948,9 @@ namespace meevax define("identifier?", [](let const& xs) { - return is_identifier(car(xs)); + return car(xs).is_also(); }); - /* ------------------------------------------------------------------------- - * - * (unwrap-syntax syntax-object) procedure - * - * If syntax-object is an identifier, then it is returned unchanged. - * Otherwise unwrap-syntax converts the outermost structure of - * syntax-object into a data object whose external representation is the - * same as that of syntax-object. The result is either an identifier, a - * pair whose car and cdr are syntax objects, a vector whose elements are - * syntax objects, an empty list, a string, a boolean, a character, or a - * number. - * - * (identifier? (unwrap-syntax (syntax x))) => #t - * - * (identifier? (car (unwrap-syntax (syntax (x))))) => #t - * - * (unwrap-syntax (cdr (unwrap-syntax (syntax (x))))) => () - * - * ---------------------------------------------------------------------- */ - - // TODO - /* ------------------------------------------------------------------------- * * (free-identifier=? id1 id2) procedure @@ -1985,50 +1963,10 @@ namespace meevax * * ---------------------------------------------------------------------- */ - define("free-identifier=?", [](let const& xs) - { - auto is_same_free_identifier = [](let const& x, let const& y) - { - // std::cout << "; ---- free-identifier=? -------------------------------------------------------" << std::endl; - // std::cout << "; x = " << x << std::endl; - // std::cout << "; y = " << y << std::endl; - - let const& x_notation = x.as().notate(); - // std::cout << "; x notation is " << x_notation << std::endl; - // std::cout << "; is absolute? " << std::boolalpha << x_notation.is() << std::endl; - // std::cout << "; is relative? " << std::boolalpha << x_notation.is() << std::endl; - // std::cout << "; is variadic? " << std::boolalpha << x_notation.is() << std::endl; - - auto x_is_free = x_notation.is() and - x_notation.as().is_free(); - // std::cout << "; is free? " << std::boolalpha << x_is_free << std::endl; - - let const& y_notation = y.as().notate(); - // std::cout << "; y notation is " << y_notation << std::endl; - // std::cout << "; is absolute? " << std::boolalpha << y_notation.is() << std::endl; - // std::cout << "; is relative? " << std::boolalpha << y_notation.is() << std::endl; - // std::cout << "; is variadic? " << std::boolalpha << y_notation.is() << std::endl; - - auto y_is_free = y_notation.is() and - y_notation.as().is_free(); - // std::cout << "; is free? " << std::boolalpha << y_is_free << std::endl; - - auto is_same_notation = eq(x_notation, y_notation); - // std::cout << "; is same notation? = " << std::boolalpha << is_same_notation << std::endl; - - auto both_free = x_is_free and y_is_free; - // std::cout << "; both free? = " << std::boolalpha << both_free << std::endl; - - auto both_same_unbound = both_free and - eqv(x.as().expression, - y.as().expression); - // std::cout << "; both same unbound? = " << std::boolalpha << both_same_unbound << std::endl; - - return is_same_notation or both_same_unbound; - }; - - return is_same_free_identifier(car(xs), cadr(xs)); - }); + // define("free-identifier=?", [](let const& xs) + // { + // return f; + // }); /* ------------------------------------------------------------------------- * diff --git a/test/abandoned.ss b/test/abandoned.ss index 37eb52218..59bf26507 100644 --- a/test/abandoned.ss +++ b/test/abandoned.ss @@ -71,8 +71,8 @@ (let ((s "abcde")) (check (begin (string-fill! s #\x 1) s) => "axxxx")) (let ((s "abcde")) (check (begin (string-fill! s #\x 1 4) s) => "axxxe")) -(experimental:define-syntax loop - (experimental:er-macro-transformer +(define-syntax loop + (er-macro-transformer (lambda (form rename compare) `(,(rename 'call/cc) (,(rename 'lambda) (exit) diff --git a/test/chibi-basic.ss b/test/chibi-basic.ss index 3e142d59d..7475855e7 100644 --- a/test/chibi-basic.ss +++ b/test/chibi-basic.ss @@ -190,7 +190,7 @@ (check (letrec-syntax ((myor - (experimental:er-macro-transformer + (er-macro-transformer (lambda (expr rename compare) (if (null? (cdr expr)) #f @@ -201,8 +201,8 @@ (let ((tmp 5)) (myor #f tmp))) => 5) -(experimental:define-syntax myor - (experimental:er-macro-transformer +(define-syntax myor + (er-macro-transformer (lambda (expr rename compare) (if (null? (cdr expr)) #f (list (rename 'let) (list (list (rename 'tmp) (cadr expr))) @@ -263,7 +263,7 @@ (check (letrec-syntax ((myor - (experimental:er-macro-transformer + (er-macro-transformer (lambda (expr rename compare) (if (null? (cdr expr)) #f diff --git a/test/collector.cpp b/test/collector.cpp index f3c40c198..2466a7af3 100644 --- a/test/collector.cpp +++ b/test/collector.cpp @@ -48,7 +48,7 @@ auto main() -> int let x = make("x"); assert(x.is()); - assert(x.as() == "x"); + assert(x.as().value == "x"); return x; // RVO }; @@ -56,12 +56,12 @@ auto main() -> int let x = f(); assert(x.is()); - assert(x.as() == "x"); + assert(x.as().value == "x"); gc.collect(); assert(x.is()); - assert(x.as() == "x"); + assert(x.as().value == "x"); } gc.collect(); @@ -77,9 +77,9 @@ auto main() -> int assert(x.is()); assert(y.is()); assert(z.is()); - assert(x.as() == "x"); - assert(y.as() == "y"); - assert(z.as() == "z"); + assert(x.as().value == "x"); + assert(y.as().value == "y"); + assert(z.as().value == "z"); assert(gc.count() == gc_count + 3); return list(x, y, z); @@ -113,9 +113,9 @@ auto main() -> int assert(a.is()); assert(b.is()); assert(c.is()); - assert(a.as() == "a"); - assert(b.as() == "b"); - assert(c.as() == "c"); + assert(a.as().value == "a"); + assert(b.as().value == "b"); + assert(c.as().value == "c"); assert(gc.count() == gc_count + 3); return circular_list(a, b, c); @@ -123,17 +123,17 @@ auto main() -> int let x = f(); - assert(car(x).as() == "a"); - assert(cadr(x).as() == "b"); - assert(caddr(x).as() == "c"); - assert(cadddr(x).as() == "a"); + assert(car(x).as().value == "a"); + assert(cadr(x).as().value == "b"); + assert(caddr(x).as().value == "c"); + assert(cadddr(x).as().value == "a"); gc.collect(); - assert(car(x).as() == "a"); - assert(cadr(x).as() == "b"); - assert(caddr(x).as() == "c"); - assert(cadddr(x).as() == "a"); + assert(car(x).as().value == "a"); + assert(cadr(x).as().value == "b"); + assert(caddr(x).as().value == "c"); + assert(cadddr(x).as().value == "a"); } gc.collect(); @@ -146,7 +146,7 @@ auto main() -> int assert(gc.count() == gc_count + 1); assert(x.is()); - assert(x.as() == "hoge"); + assert(x.as().value == "hoge"); x = make(42); diff --git a/test/environment.cpp b/test/environment.cpp index 7504cabc0..84f3263a8 100644 --- a/test/environment.cpp +++ b/test/environment.cpp @@ -17,7 +17,7 @@ auto main() -> int assert(eos_object.is()); assert(f.is()); assert(t.is()); - assert(undefined_object.is()); + assert(undefined.is()); assert(unspecified_object.is()); const auto gc_count = gc.count(); diff --git a/test/er-macro-transformer.ss b/test/er-macro-transformer.ss index b70678e1c..45f959eaf 100644 --- a/test/er-macro-transformer.ss +++ b/test/er-macro-transformer.ss @@ -1,4 +1,4 @@ -(experimental:define-syntax swap! +(define-syntax swap! (traditional-macro-transformer (lambda (a b) `(,let ((,x ,a)) @@ -17,8 +17,8 @@ ; ------------------------------------------------------------------------------ -(experimental:define-syntax swap! - (experimental:er-macro-transformer +(define-syntax swap! + (er-macro-transformer (lambda (form rename compare) (let ((a (cadr form)) (b (caddr form))) diff --git a/test/identifier.ss b/test/identifier.ss index fc74b608d..98fab025d 100644 --- a/test/identifier.ss +++ b/test/identifier.ss @@ -2,8 +2,8 @@ ; ------------------------------------------------------------------------------ -(experimental:define-syntax er-macro-transformer:rename - (experimental:er-macro-transformer +(define-syntax er-macro-transformer:rename + (er-macro-transformer (lambda (form rename compare) (rename (cadr form))))) @@ -20,8 +20,32 @@ ; ------------------------------------------------------------------------------ -(experimental:define-syntax er-macro-transformer:compare - (experimental:er-macro-transformer +(define-syntax er-macro-transformer:rename-1 + (er-macro-transformer + (lambda (form rename compare) + (cons (rename (cadr form)) + (cddr form))))) + +(check (+ 1 2 3 4) => 10) + +(check (er-macro-transformer:rename-1 + 1 2 3 4) => 10) + +; ------------------------------------------------------------------------------ + +(define-syntax %car + (er-macro-transformer + (lambda (form rename compare) + (cons (rename 'car) + (cdr form))))) + +(check (car '(a b)) => a) + +(check (%car '(a b)) => a) + +; ------------------------------------------------------------------------------ + +(define-syntax er-macro-transformer:compare + (er-macro-transformer (lambda (form rename compare) (let ((x (cadr form)) (y (rename x))) diff --git a/test/let-syntax.ss b/test/let-syntax.ss index 1a562290a..fe52f0a31 100644 --- a/test/let-syntax.ss +++ b/test/let-syntax.ss @@ -9,10 +9,10 @@ (let ((f (lambda (a) (+ a 2)))) (set! result (cons (f 0) result)) - (let-syntax ((f (experimental:er-macro-transformer + (let-syntax ((f (er-macro-transformer (lambda (form rename compare) `(,(rename '+) ,(cadr form) 3)))) - (g (experimental:er-macro-transformer + (g (er-macro-transformer (lambda (form rename compare) '())))) (set! result (cons (f 0) result)) @@ -28,7 +28,7 @@ (define (double-y) (let ((+y (lambda (x) (+ x y)))) - (let-syntax ((macro (experimental:er-macro-transformer + (let-syntax ((macro (er-macro-transformer (lambda (form rename compare) `(,(rename '+) ,(cadr form) ,(+y 0)))))) (macro y)))) @@ -41,23 +41,23 @@ ; ------------------------------------------------------------------------------ -; (check (let ((x 'outer)) -; (let-syntax ((m (er-macro-transformer -; (lambda (form rename compare) -; (rename 'x))))) -; (let ((x 'inner)) -; (m)))) => outer) -; -; (define result -; (let ((x 'outer)) -; (let-syntax ((m (er-macro-transformer -; (lambda (form rename compare) -; (rename 'x))))) -; (let ((x 'inner)) -; (m))))) -; -; (check result => outer) - -(check-report) +(check (let ((x 'outer)) + (let-syntax ((m (er-macro-transformer + (lambda (form rename compare) + (rename 'x))))) + (let ((x 'inner)) + (m)))) => outer) + +(define result + (let ((x 'outer)) + (let-syntax ((m (er-macro-transformer + (lambda (form rename compare) + (rename 'x))))) + (let ((x 'inner)) + (m))))) + +(check result => outer) + +; (check-report) (exit (check-passed? check:correct)) diff --git a/test/letrec-syntax.ss b/test/letrec-syntax.ss index d7fbc70a1..933177b39 100644 --- a/test/letrec-syntax.ss +++ b/test/letrec-syntax.ss @@ -2,7 +2,7 @@ (scheme base) (srfi 78)) -(letrec-syntax ((my-and (experimental:er-macro-transformer +(letrec-syntax ((my-and (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form)) #t) ((null? (cddr form)) (cadr form)) @@ -12,7 +12,7 @@ #f))))))) (check (my-and #t #t #f #t) => #f)) -(letrec-syntax ((my-or (experimental:er-macro-transformer +(letrec-syntax ((my-or (er-macro-transformer (lambda (form rename compare) (cond ((null? (cdr form)) #f) ((null? (cddr form)) (cadr form)) @@ -29,4 +29,11 @@ (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-report) diff --git a/test/r5rs.ss b/test/r5rs.ss index e9dc306d6..e81be2d99 100644 --- a/test/r5rs.ss +++ b/test/r5rs.ss @@ -202,50 +202,50 @@ (check `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8) => #(10 5 2 4 3 8)) -; (check `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) => (a `(b ,(+ 1 2) ,(foo 4 d) e) f)) ; ERROR +(check `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) => (a `(b ,(+ 1 2) ,(foo 4 d) e) f)) -; (check (let ((name1 'x) -; (name2 'y)) -; `(a `(b ,,name1 ,'mname2 d) e)) => (a `(b ,x ,'y d) e)) ; ERROR +(check (let ((name1 'x) + (name2 'y)) + `(a `(b ,,name1 ,',name2 d) e)) => (a `(b ,x ,'y d) e)) ; ---- 4.3.1 ------------------------------------------------------------------- -; (check (let-syntax ((when (syntax-rules () -; ((when test stmt1 stmt2 ...) -; (if test -; (begin stmt1 -; stmt2 ...)))))) -; (let ((if #t)) -; (when if (set! if 'now)) -; if)) => now) - -; (check (let ((x 'outer)) -; (let-syntax ((m (syntax-rules () ((m) x)))) -; (let ((x 'inner)) -; (m)))) => outer) ; ERROR - -; (check (letrec-syntax ((my-or (syntax-rules () -; ((my-or) #f) -; ((my-or e) e) -; ((my-or e1 e2 ...) -; (let ((temp e1)) -; (if temp -; temp -; (my-or e2 ...))))))) -; (let ((x #f) -; (y 7) -; (temp 8) -; (let odd?) -; (if even?)) -; (my-or x -; (let temp) -; (if y) -; y))) => 7) +(check (let-syntax ((when (syntax-rules () + ((when test stmt1 stmt2 ...) + (if test + (begin stmt1 + stmt2 ...)))))) + (let ((if #t)) + (when if (set! if 'now)) + if)) => now) + +(check (let ((x 'outer)) + (let-syntax ((m (syntax-rules () ((m) x)))) + (let ((x 'inner)) + (m)))) => outer) + +(check (letrec-syntax ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp + temp + (my-or e2 ...))))))) + (let ((x #f) + (y 7) + (temp 8) + (let odd?) + (if even?)) + (my-or x + (let temp) + (if y) + y))) => 7) ; ---- 4.3.2 ------------------------------------------------------------------- -; (check (let ((=> #f)) -; (cond (#t => 'ok))) => ok) ; ERROR +(check (let ((=> #f)) + (cond (#t => 'ok))) => ok) ; ---- 5.2.1 ------------------------------------------------------------------- diff --git a/test/r7rs.ss b/test/r7rs.ss index 1a7f8356b..d0d598cad 100644 --- a/test/r7rs.ss +++ b/test/r7rs.ss @@ -355,29 +355,16 @@ ; if)) => now) (check (let ((x 'outer)) - (let-syntax ((m ; (syntax-rules () ((m) x)) ; BUG - (experimental:er-macro-transformer - (lambda (form rename compare) - (list (rename 'quote) x))))) + (let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) (m)))) => outer) -(check (letrec-syntax ((my-or ; (syntax-rules () - ; ((my-or) #f) - ; ((my-or e) e) - ; ((my-or e1 e2 ...) - ; (let ((temp e1)) - ; (if temp temp (my-or e2 ...))))) - (experimental:er-macro-transformer - (lambda (form rename compare) - (cond ((null? (cdr form)) #f) - ((null? (cddr form)) (cadr form)) - (else (list (rename 'let) - (list (list (rename 'test) (cadr form))) - (list (rename 'if) - (rename 'test) - (rename 'test) - (cons (rename 'my-or) (cddr form)))))))))) +(check (letrec-syntax ((my-or (syntax-rules () + ((my-or) #f) + ((my-or e) e) + ((my-or e1 e2 ...) + (let ((temp e1)) + (if temp temp (my-or e2 ...))))))) (let ((x #f) (y 7) (temp 8) @@ -387,10 +374,10 @@ ; ---- 4.3.2. Pattern language ------------------------------------------------- -(experimental:define-syntax be-like-begin +(define-syntax be-like-begin (syntax-rules () ((be-like-begin name) - (experimental:define-syntax name + (define-syntax name (syntax-rules () ((name expr (... ...)) (begin expr (... ...)))))))) @@ -404,9 +391,9 @@ ; (define-syntax simple-let ; (syntax-rules () -; (((head ... ((x . y) val) . tail) body1 body2 ...) +; ((_ (head ... ((x . y) val) . tail) body1 body2 ...) ; (syntax-error "expected an identifier but got" (x . y))) -; ((((name val) ...) body1 body2 ...) +; ((_ ((name val) ...) body1 body2 ...) ; ((lambda (name ...) body1 body2 ...) val ...)))) ; ---- 5.3.1. Top level definitions -------------------------------------------- diff --git a/test/transformer.ss b/test/transformer.ss index 0c56b2cf4..c95cc4ff7 100644 --- a/test/transformer.ss +++ b/test/transformer.ss @@ -1,4 +1,4 @@ -(experimental:define-syntax swap! +(define-syntax swap! (traditional-macro-transformer (lambda (a b) `(let ((value ,a)) @@ -21,7 +21,7 @@ ; ; ------------------------------------------------------------------------------ -(experimental:define-syntax swap! +(define-syntax swap! (sc-macro-transformer (lambda (form use-env) (let ((a (make-syntactic-closure use-env '() (cadr form))) @@ -51,7 +51,7 @@ ; ------------------------------------------------------------------------------ -(experimental:define-syntax swap! +(define-syntax swap! (rsc-macro-transformer (lambda (form mac-env) (let ((a (cadr form)) @@ -84,8 +84,8 @@ ; ------------------------------------------------------------------------------ -(experimental:define-syntax swap! - (experimental:er-macro-transformer +(define-syntax swap! + (er-macro-transformer (lambda (form rename compare?) (let ((a (cadr form)) (b (caddr form)) diff --git a/test/vector.cpp b/test/vector.cpp index d8bedd744..bc367661a 100644 --- a/test/vector.cpp +++ b/test/vector.cpp @@ -93,26 +93,26 @@ auto main() -> int assert(v.is()); assert(v.as().size() == 3); - assert(v.as()[0].as() == "a"); - assert(v.as()[1].as() == "b"); - assert(v.as()[2].as() == "c"); + assert(v.as()[0].as().value == "a"); + assert(v.as()[1].as().value == "b"); + assert(v.as()[2].as().value == "c"); gc.collect(); assert(v.is()); assert(v.as().size() == 3); - assert(v.as()[0].as() == "a"); - assert(v.as()[1].as() == "b"); - assert(v.as()[2].as() == "c"); + assert(v.as()[0].as().value == "a"); + assert(v.as()[1].as().value == "b"); + assert(v.as()[2].as().value == "c"); assert(gc.count() == gc_count + 4); gc.collect(); assert(v.is()); assert(v.as().size() == 3); - assert(v.as()[0].as() == "a"); - assert(v.as()[1].as() == "b"); - assert(v.as()[2].as() == "c"); + assert(v.as()[0].as().value == "a"); + assert(v.as()[1].as().value == "b"); + assert(v.as()[2].as().value == "c"); assert(gc.count() == gc_count + 4); v.as().clear();