├── .github └── workflows │ └── tests.yml ├── .gitignore ├── Cargo.lock ├── Cargo.toml ├── LICENSE ├── NOTICE ├── README.md ├── doc ├── macros.md ├── plan-of-action.md ├── synclos.md └── todo.md ├── inputs ├── count.scm └── sc-test.scm ├── jupyter-kernel ├── .gitignore ├── LICENSE ├── README.md ├── peroxide │ ├── __init__.py │ ├── __main__.py │ ├── install.py │ └── peroxide_kernel.py └── setup.py ├── rustfmt.toml ├── src ├── arena.rs ├── ast.rs ├── bin │ └── peroxide.rs ├── compile.rs ├── environment.rs ├── heap.rs ├── lex.rs ├── lib.rs ├── primitives │ ├── char.rs │ ├── mod.rs │ ├── numeric.rs │ ├── object.rs │ ├── pair.rs │ ├── port.rs │ ├── string.rs │ ├── symbol.rs │ ├── syntactic_closure.rs │ └── vector.rs ├── read.rs ├── repl.rs ├── scheme-lib │ └── init.scm ├── util.rs ├── value.rs └── vm.rs └── tests ├── integration_tests.rs └── scheme ├── r5rs-tests.scm ├── r5rs-tests.scm.orig ├── r5rs_pitfall.scm └── run-scheme.sh /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | push: 5 | branches: [master] 6 | pull_request: 7 | branches: [master] 8 | 9 | env: 10 | CARGO_TERM_COLOR: always 11 | 12 | jobs: 13 | build: 14 | runs-on: ubuntu-latest 15 | steps: 16 | - uses: actions/checkout@v2 17 | - name: Build 18 | run: cargo build --verbose 19 | - name: Run tests 20 | run: cargo test --verbose 21 | - name: Run scheme tests 22 | run: tests/scheme/run-scheme.sh 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | **/*.rs.bk 3 | history.txt 4 | /perf/ 5 | Supprimerait dist/ 6 | Supprimerait peroxide_kernel.egg-info/ 7 | -------------------------------------------------------------------------------- /Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "peroxide" 3 | version = "0.1.0" 4 | authors = ["Matthieu Felix "] 5 | license = "Apache-2.0" 6 | publish = false 7 | 8 | [dependencies] 9 | bitvec = "0.22" 10 | clap = "2.34" 11 | ctrlc = "3.2" 12 | log = "0.4" 13 | num-bigint = "0.4" 14 | num-complex = "0.4" 15 | num-integer = "0.1" 16 | num-rational = "0.4" 17 | num-traits = "0.2" 18 | rustyline = "8.2" 19 | pretty_env_logger = "0.4" 20 | 21 | [profile.release] 22 | debug = true 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2018-2019 Matthieu Felix 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Peroxide 2 | 3 | A scheme interpreter in Rust. Aims for R5RS/R7RS compliance. Heavily based 4 | on the interpreter described in _Lisp in Small Pieces_. 5 | 6 | ## Usage 7 | 8 | You can just run `cargo run` to run the interpreter. Some 9 | internal options can be tweaked; try `cargo run -- --help` 10 | for more information. 11 | 12 | Set `RUST_LOG=peroxide=debug` or `RUST_LOG=peroxide=trace` to see 13 | debugging information, especially GC-related messages. (This may make the 14 | system very slow.) 15 | 16 | ## General implementation notes 17 | 18 | This is a bytecode compiling implementation: scheme code is first converted to bytecode, then interpreted by a virtual 19 | machine. 20 | 21 | The standard library is essentially ripped off [Chibi Scheme](https://github.com/ashinn/chibi-scheme). See 22 | [init.scm](src/scheme-lib/init.scm) for license details. Credit to Alex Shinn for writing it. 23 | 24 | Peroxide is strictly single-threaded. 25 | 26 | This comes with a very simple garbage collector. See the comment in [heap.rs](src/heap.rs) for implementation details. 27 | Unfortunately it meshes poorly with Rust's memory management. The key thing to remember when making changes, 28 | especially to the AST parser, is that any call to `arena.insert()` (the method used to ask the GC for memory) may 29 | trigger a garbage-collection pass and destroy anything that isn't rooted. Make sure to hold `RootPtr`s to any 30 | Scheme data you care about when doing stuff! 31 | 32 | The macro system was another important implementation question. I ended up going with a system similar to Chibi 33 | Scheme's so that I could reuse more of the standard library 🙃. This does mean that, in addition to `syntax-case`, 34 | Peroxide supports the more general syntactic closure macro paradigm. See [doc/macros.md](doc/macros.md) for details. 35 | 36 | ## Todo 37 | 38 | See [todo.md](doc/todo.md) for a list of things to do. 39 | 40 | ## Useful references 41 | 42 | * https://github.com/scheme-requests-for-implementation 43 | * [Page on call/cc](http://www.madore.org/~david/computers/callcc.html#sec_whatis) 44 | * https://schemers.org/Documents/Standards/R5RS/HTML/ 45 | * https://github.com/ashinn/chibi-scheme/blob/master/tests/r5rs-tests.scm 46 | * https://github.com/kenpratt/rusty_scheme/blob/master/src/interpreter/cps_interpreter.rs 47 | * _Lisp in Small Pieces_ 48 | * A GC in rust: https://github.com/withoutboats/shifgrethor 49 | * http://community.schemewiki.org/?scheme-faq-language 50 | * [Dybvig, R. Kent, Robert Hieb, and Carl Bruggeman. "Syntactic abstraction in Scheme." 51 | _Lisp and symbolic computation_ 5.4 (1993): 295-326. 52 | ](https://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf) 53 | * https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref.html#Syntactic-Closures 54 | -------------------------------------------------------------------------------- /doc/macros.md: -------------------------------------------------------------------------------- 1 | # Macro systems in Scheme 2 | 3 | [Good general intro](http://community.schemewiki.org/?scheme-faq-macros) 4 | 5 | [Other general post](http://lambda-the-ultimate.org/node/2753), much more in-depth 6 | 7 | * We can use homoiconicity for non-hygienic Lisp-like macros: functions that run at expansion / parse time, take in a list and return a list that will be parsed as code. 8 | * Unfortunately that doesn't work for hygienic macro, because there is now a need to tell the parser about more than just raw symbols. Scope must be somehow attached to the symbols. 9 | * `gensym` or some other restrictions can be used to solve some of these issues but are not very nice. [discussion](http://community.schemewiki.org/?hygiene-versus-gensym) 10 | * Scheme has a native hygienic macro system based on pattern-matching, `syntax-rules`. It's nice and all, but can't express non-hygienic macros and even for hygienic ones it's not always trivial to use because it's purely pattern matching instead of allowing arbitrary code to be run to generate the resulting macro 11 | * Typically speaking, `syntax-rules` is implemented on top of a lower level system [short discussion on HN](https://news.ycombinator.com/item?id=18555658). There seem to be three of them in common use: 12 | * `syntax-case`, also hygienic (unclear to me if totally or not), complex to implement, `syntax-rules` is easy to define on top of it (it's basically a subset). Officially endorsed by R6RS, which nobody cared about, and which was superseded by R7RS which removed it. 13 | * [Used by Guile (page is for end users)](https://www.gnu.org/software/guile/manual/html_node/Syntax-Case.html#Syntax-Case). 14 | * [A more detailed user guide](https://cs.indiana.edu/~dyb/pubs/tr356.pdf) 15 | * [Long paper about implementation](https://cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf). 16 | * [A portable implementation](https://web.archive.org/web/20091021061917/http://ikarus-scheme.org/r6rs-libraries/) (on top of R5RS + other primitives)? which I haven't looked at. 17 | * Syntactic closures, used in Chibi and MIT scheme 18 | * [schemewiki page on syntactic closures](http://community.schemewiki.org/?syntactic-closures) 19 | * [Used in MIT scheme](https://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/Syntactic-Closures.html#Syntactic-Closures). [Here's the implementation of `syntax-rules` on top of it.](https://git.savannah.gnu.org/cgit/mit-scheme.git/tree/src/runtime/syntax-rules.scm) 20 | * [Chibi implements methods like those of MIT scheme (`er-macro-transformer`, `sc-macro-transformer`, `rsc-macro-transformer`) here](https://github.com/ashinn/chibi-scheme/blob/master/lib/init-7.scm#L147). ([simpler, older version](https://github.com/ashinn/chibi-scheme/blob/2922ed591d1c0dc3be7a92e211ac7b18aa12edcc/lib/init-7.scm#L100)). 21 | * [Chibi implements `syntax-rules` here](https://github.com/ashinn/chibi-scheme/blob/master/lib/init-7.scm#L863). 22 | * [Chibi macro system doc](http://synthcode.com/scheme/chibi/#h3_MacroSystem) 23 | * Implicit/explicit renaming, used in R4RS and Chicken 24 | * implicit: [In R4RS](https://people.csail.mit.edu/jaffer/r4rs_12.html#SEC77), it's the suggested low-level implementation. 25 | * explicit: [Short paper by an R4RS author](https://3e8.org/pub/scheme/doc/lisp-pointers/v4i4/p25-clinger.pdf). Also formerly [used in Chicken](https://wiki.call-cc.org/man/4/Macros). 26 | * It is a bit unclear which of these three are more powerful than others. It is apparently possible to implement `syntax-case` on top syntactic closures (+ some helpers?), [as Chibi does](https://github.com/ashinn/chibi-scheme/blob/master/lib/chibi/syntax-case.scm), but it's a bit complicated and apparently needed to add some stuff to the interpreter. [Git PR with discussion](https://github.com/ashinn/chibi-scheme/pull/496). Many systems which claim (and I believe them) to use syntactic closures end up with functions very much like those described in renaming systems. 27 | * There are also pure-syntax-rules implementations. [This one](https://web.archive.org/web/20171216165612/petrofsky.org/src/alexpander.scm) takes in a scheme program with macros and returns one without macros, and implements syntax-rules only. -------------------------------------------------------------------------------- /doc/plan-of-action.md: -------------------------------------------------------------------------------- 1 | Stuff that needs to be done: 2 | 3 | ### R5RS compliance 4 | 5 | 1. Remaining numeric primitives 6 | 2. Remaining ports-oriented primitives 7 | 3. eval 8 | 4. case folding option 9 | 10 | ### Optimization 11 | 12 | 1. Hook up GC 13 | 2. Make bytecode not-too-stupid 14 | 3. Optimize things like values and the size of ValRefs. 15 | 4. Primitive inlining 16 | 5. Let optimization and other compile-time stuff 17 | -------------------------------------------------------------------------------- /doc/synclos.md: -------------------------------------------------------------------------------- 1 | # Syntactic Closures 2 | 3 | A lot of this is ripped off from 4 | https://lists.gnu.org/archive/html/chicken-users/2008-04/msg00013.html. 5 | 6 | 7 | > There are two completely orthogonal aspects of macro systems—whether they are hygienic 8 | > or unhygienic, and whether they are low-level or high-level. 9 | 10 | Examples of macro systems with various characteristics: 11 | 12 | | | Low-level | High-level | 13 | |------------ |-------------------- |---------------------------------------- | 14 | | Hygienic | Syntactic closures | `syntax-rules` | 15 | | Unhygienic | `defmacro` | [m4](https://www.gnu.org/software/m4/) | 16 | 17 | 18 | ## The need for hygiene 19 | 20 | There are two separate issues with unhygienic macro systems. 21 | 22 | 1. When a macro introduces new symbols, they become visible to any code that's transplanted 23 | from the outer scope, possibly shadowing bindings or at least giving rise to obscure 24 | errors: 25 | 26 | ```scheme 27 | (defmacro swap! (a b) 28 | `(let ((value ,var1)) 29 | (set! ,var1 ,var2) 30 | (set! ,var2 value))) 31 | ``` 32 | 33 | In this case, if one of `a` or `b` is also the symbol `value`, this will generate garbage 34 | code. This problem is entirely solvable using `gensym`, but annoying. 35 | 36 | 2. A macro's expected bindings might no longer be current where the macro is expanded. 37 | For instance, 38 | 39 | ```scheme 40 | (let ((set! display)) 41 | (swap! x y)) 42 | ``` 43 | 44 | Here, `swap!` expected `set!` to be the primitive, but it's some value that the user 45 | was shadowing. 46 | 47 | In either case, what we want is for identifiers to be tied to their environment of 48 | definition, not the environment in which they happen to be transplanted by macro expansion. 49 | 50 | Note that this is not always true! There are examples of useful non-hygienic macros, 51 | but hygiene is desired most of the time. Scheme macro systems such as syntactic closures 52 | let us control hygiene very finely if needed, so we can get the best of both worlds. 53 | 54 | How can we implement hygene? There are several solutions, but Peroxide uses syntactic 55 | closures, which are due to Bawden & Rees. [^1] 56 | 57 | [^1]: Bawden, Alan, and Jonathan Rees. Syntactic Closures. No. AI-M-1049. MASSACHUSETTS 58 | INST OF TECH CAMBRIDGE ARTIFICIAL INTELLIGENCE LAB, 1988. 59 | https://apps.dtic.mil/dtic/tr/fulltext/u2/a195921.pdf 60 | 61 | ## A low-level macro system 62 | 63 | In Peroxide and many other Scheme systems, a macro is a lambda that takes three arguments: 64 | the form to expand, the macro's definition environment, and the macro's expansion 65 | environment. The macro produces code as a result, which will be inserted at the macro 66 | call site. 67 | 68 | For instance, you can declare a low-level macro in the following way: 69 | 70 | ```scheme 71 | (define-syntax unless 72 | ; Note the characteristic signature 73 | (lambda (form usage-env macro-env) 74 | (let ((condition (cadr form)) 75 | (consequent (caddr form))) 76 | `(if (not ,condition) ,consequent)))) 77 | ``` 78 | 79 | When the compiler sees this declaration, it immediately compiles the lambda, and binds 80 | it to the macro `unless`. Later, code like 81 | 82 | ``` 83 | (unless (> 0 count) (fail)) 84 | ``` 85 | 86 | will result in our lambda being called with parameters `(unless (> 0 count) (fail))` (it's 87 | not critically important, but note that the macro name itself is passed to the macro as 88 | part of the form to expand), and two environment objects representing the current and 89 | definition environments. 90 | 91 | The lambda outputs `(if (not (> 0 count)) (fail))`. Symbols are treated completely normally, 92 | i.e. they are assumed to refer to bindings that exist in the environment at the use site. 93 | 94 | Note too that the lambda itself is compiled in the global environment, and, since lambdas 95 | close over their definition environments, this is also where the execution happens. 96 | 97 | Even if the lambda is declared with a local form, such as: 98 | 99 | ```scheme 100 | (define x 'outer) 101 | (let ((x 'inner)) 102 | (let-syntax ((print-x 103 | (lambda (form usage-env macro-env) 104 | `(display ',x)))) 105 | (print-x))) 106 | ``` 107 | 108 | ~~the lambda itself will run in the global environment.~~ The `print-x` macro defined above, 109 | for 110 | instance, will always produce `(display 'outer)` as a result. However, still in the case 111 | above, `macro-env` will be the environment created by the `let` form. Conversely, in 112 | the case of a macro defined with `define-syntax`, `macro-env` will always be 113 | the global environment. 114 | 115 | The reason for this is that macro expansion is interleaved with code compilation, which 116 | precedes code execution. The only environment that we can reasonably hope to exist at 117 | macro expansion time is a global environment—inner environments still don't have any 118 | bytecode to actually create them yet, much less evaluate the values in the environment. 119 | 120 | ## The syntactic closure primitives 121 | 122 | What do these mysterious environment objects look like? And how do we use them to 123 | guarantee hygiene? 124 | 125 | There's not much you can do with an environment object, except shove it in a syntactic 126 | closure. A syntactic closure is created using `make-syntactic-closure`: 127 | 128 | ```scheme 129 | (make-syntactic-closure env free-variables form) 130 | ``` 131 | 132 | The easiest way to use a syntactic closure is on a symbol. Take our `unless` macro as 133 | an example. Its implementation above is vulnerable to shadowing `if` and `not`. We can 134 | rewrite the macro using syntactic closures: 135 | 136 | ```scheme 137 | (define-syntax unless 138 | (lambda (form usage-env macro-env) 139 | (let ((condition (cadr form)) 140 | (consequent (caddr form)) 141 | (renamed-not (make-syntactic-closure macro-env '() 'not)) 142 | (renamed-if (make-syntactic-closure macro-env '() 'if))) 143 | `(,renamed-if (,renamed-not ,condition) ,consequent)))) 144 | ``` 145 | 146 | (We also need to rename `if`, because it's legal to shadow keywords in Scheme.) 147 | 148 | As you might have guessed, the calls to `make-syntactic-closure` here produce symbols 149 | that point to the specified environment (`macro-env`), instead of the current environment. 150 | 151 | `make-syntactic-closure` can also be used to make all symbols within a large form point 152 | to a different environment. For instance: 153 | 154 | ```scheme 155 | (define x 'outer) 156 | (let ((x 'middle)) 157 | (let-syntax ((print-middle-x 158 | (lambda (form usage-env macro-env) 159 | (make-syntactic-closure macro-env '() '(display x))))) 160 | (let ((x 'inner) (display #f)) 161 | (print-middle-x)))) 162 | ``` 163 | 164 | Overall, this technique lets us precisely control which identifiers should come from 165 | which environment, solving hygiene problem #1. 166 | 167 | ### Shadowing a symbol-in-a-syntactic-closure 168 | 169 | After introducing syntactic closures to a Scheme system, we end up with two kinds of 170 | identifiers: regular old symbols, and symbols in a (possibly nested) syntactic closure, 171 | which I'll call ssc. 172 | 173 | All identifiers can be assigned to, and the meaning is straightforward: for an ssc, 174 | we simply edit the memory location pointed to by the binding, like we would for a regular 175 | symbol. The issue of shadowing is more complex. Ignoring syntactic sugar, an identifier 176 | is shadowed by introducing a lambda that uses that identifier as a parameter. 177 | 178 | When an ssc is used as a lambda parameter, any references to it within the body of that 179 | lambda will instead refer to that lambda's parameter. Outside the body of the lambda, 180 | the ssc does not change meaning. This lets a macro effectively declare a binding as 181 | private by using a syntactically closed symbol in a lambda argument or a let definition. 182 | 183 | Note that two different sscs, even with the same environment and the same closed symbol, 184 | will refer to two different parameters if they are shadowed. For instance: 185 | 186 | ```scheme 187 | (define x 0) 188 | (define-syntax mymacro 189 | (lambda (f use-env mac-env) 190 | (let ((x1 (make-syntactic-closure mac-env '() 'x)) 191 | (x2 (make-syntactic-closure mac-env '() 'x))) 192 | `(list 193 | ,(identifier=? mac-env x1 mac-env x2) 194 | ,(let ((x1 2)) 195 | (identifier=? mac-env x1 mac-env x2)))))) 196 | 197 | => (#t #f) 198 | ``` 199 | 200 | In effect, if you need to solve problem 2 by creating a variable that's invisible to 201 | expanded code, you can use an ssc as the target of your `let`. If you're using the ssc 202 | just for that, it also doesn't matter which environment you create the syntactic closure 203 | for. 204 | 205 | ### Other syntactic closure methods 206 | 207 | Of note are also `(identifier? x)`, which returns true iff `x` is either a symbol, or 208 | a (possibly nested) syntactic closure around a symbol, and `(identifier=? ex x ey y)`, which 209 | returns `true` iff `x` and `y` are both identifiers, and they refer to the same binding 210 | when `x` is looked up in `ex` and `y` in `ey`. 211 | Note that this can be true even if `x` and `y` are identifiers in different syntactic 212 | closures, as long as they do refer to the same binding. 213 | 214 | Chibi and Peroxide also make a distinction between `syntax-quote`, which is really just 215 | what `quote` is in most other Scheme systems, and `quote`, which behaves like `syntax-quote` 216 | except it will strip (possibly nested) syntactic closures from its argument. The two 217 | are interchangeable in the absence of syntactic closures. 218 | 219 | ## Issues with nested macros 220 | 221 | Several issues can occur with nested macros. 222 | 223 | 224 | -------------------------------------------------------------------------------- /doc/todo.md: -------------------------------------------------------------------------------- 1 | * Revise this todo list. 2 | 3 | (See also the various TODOs sprinkled through the code) 4 | 5 | * ~~Add apply and eval~~ 6 | * Implement error handling 7 | * It can be handled mostly in userspace, but that creates 8 | extra trickiness around throwing errors from primitives. 9 | * Make sure that syncloses aren't moved outside their domain of validity 10 | * Fix the checked vs unchecked references 11 | * Implement the rest of the stdlib, esp. ports and bytevecs 12 | * Implement libraries 13 | * Allow define-syntax in internal defines 14 | * Implement let optimization 15 | * Inline primitives 16 | * ~~Implement name lookup on error~~ ⇒ needs to be fixed 17 | * Assign names to lambdas when possible 18 | * Keep track of which lines map to which tokens, which map to which 19 | expressions, which map to what bytecode. This will let us have 20 | much better error messages. 21 | * Loooots of code cleanup necessary 22 | * Remove anything to do with ValRef and many things to do with Arena 23 | * I think ideally Arena would be used for inserting only, which would also make it easier to see where 24 | values need to be rooted / protected. 25 | * Figure out how to embed init.scm in a reasonable way (probably by precompiling) 26 | * ~~Allow garbage collection of code like in Python~~ 27 | * ~~Handle interrupts~~ 28 | * Code blocks can (probably?) be refcounted instead of GCd 29 | * ~~Disallow '%' in symbols after initialization is done?~~ 30 | * Allow fully disabling rustyline [using features]( 31 | https://doc.rust-lang.org/cargo/reference/manifest.html#the-features-section). 32 | * Make errors not be strings :) 33 | * Allow meta-commands like `,exit` or `,decompile` 34 | * PoolPtr / Values should only live as long as the Heap or Arena, not forever 35 | -------------------------------------------------------------------------------- /inputs/count.scm: -------------------------------------------------------------------------------- 1 | (define (count-to cnt max) 2 | (if (= cnt max) 3 | cnt 4 | (count-to (+ 1 cnt) max))) 5 | 6 | (count-to 0 10) 7 | (count-to 0 100) 8 | (count-to 0 1000) 9 | (count-to 0 10000) 10 | (count-to 0 100000) 11 | -------------------------------------------------------------------------------- /inputs/sc-test.scm: -------------------------------------------------------------------------------- 1 | (define my-list '()) 2 | (define sc '()) 3 | 4 | (let-syntax ((push 5 | (sc-macro-transformer 6 | (begin 7 | (set! sc (make-syntactic-closure )) 8 | (lambda (exp env) 9 | (let ((item (make-syntactic-closure env '() (cadr exp))) 10 | (list (make-syntactic-closure env '() (caddr exp)))) 11 | `(set! ,list (cons ,item ,list)))))))) 12 | (push 5 my-list)) 13 | 14 | my-list 15 | -------------------------------------------------------------------------------- /jupyter-kernel/.gitignore: -------------------------------------------------------------------------------- 1 | *.ipynb 2 | /.ipynb_checkpoints/ 3 | 4 | env/ 5 | build/ 6 | 7 | **/__pycache__/ 8 | 9 | dist/ 10 | peroxide_kernel.egg-info/ 11 | -------------------------------------------------------------------------------- /jupyter-kernel/LICENSE: -------------------------------------------------------------------------------- 1 | Some files in this directory may be derived from echo_kernel 2 | (https://github.com/jupyter/echo_kernel/). echo_kernel is distributed under 3 | the following terms. 4 | 5 | All changes and additions are licensed under the Apache 2 license (see 6 | LICENSE in parent directory). 7 | 8 | --- 9 | 10 | BSD 3-Clause License 11 | 12 | Copyright (c) 2017, Project Jupyter Contributors 13 | All rights reserved. 14 | 15 | Redistribution and use in source and binary forms, with or without 16 | modification, are permitted provided that the following conditions are met: 17 | 18 | * Redistributions of source code must retain the above copyright notice, this 19 | list of conditions and the following disclaimer. 20 | 21 | * Redistributions in binary form must reproduce the above copyright notice, 22 | this list of conditions and the following disclaimer in the documentation 23 | and/or other materials provided with the distribution. 24 | 25 | * Neither the name of the copyright holder nor the names of its 26 | contributors may be used to endorse or promote products derived from 27 | this software without specific prior written permission. 28 | 29 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 30 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 31 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 32 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 33 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 34 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 35 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 36 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 37 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 38 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 39 | -------------------------------------------------------------------------------- /jupyter-kernel/README.md: -------------------------------------------------------------------------------- 1 | A very janky IPython kernel. Provides syntax highlighting and other 2 | niceties that would be a pain to implement by hand. 3 | 4 | ## Installation 5 | 6 | ```bash 7 | python setup.py install && python -m peroxide.install --sys-prefix 8 | ``` 9 | 10 | ## Todo 11 | 12 | Stop hardcoding the binary path. 13 | -------------------------------------------------------------------------------- /jupyter-kernel/peroxide/__init__.py: -------------------------------------------------------------------------------- 1 | __version__ = '1.1' 2 | 3 | from .peroxide_kernel import PeroxidePexpectKernel 4 | -------------------------------------------------------------------------------- /jupyter-kernel/peroxide/__main__.py: -------------------------------------------------------------------------------- 1 | from ipykernel.kernelapp import IPKernelApp 2 | from . import PeroxidePexpectKernel 3 | 4 | IPKernelApp.launch_instance(kernel_class=PeroxidePexpectKernel) 5 | -------------------------------------------------------------------------------- /jupyter-kernel/peroxide/install.py: -------------------------------------------------------------------------------- 1 | import argparse 2 | import json 3 | import os 4 | import shutil 5 | import sys 6 | 7 | from jupyter_client.kernelspec import KernelSpecManager 8 | from IPython.utils.tempdir import TemporaryDirectory 9 | 10 | kernel_json = { 11 | "argv": [sys.executable, "-m", "peroxide", "-f", "{connection_file}"], 12 | "display_name": "Peroxide", 13 | "language": "text", 14 | } 15 | 16 | 17 | def install_my_kernel_spec(user=True, prefix=None): 18 | with TemporaryDirectory() as td: 19 | os.chmod(td, 0o755) # Starts off as 700, not user readable 20 | with open(os.path.join(td, 'kernel.json'), 'w') as f: 21 | json.dump(kernel_json, f, sort_keys=True) 22 | shutil.copy("../target/debug/main", td) 23 | 24 | KernelSpecManager().install_kernel_spec(td, 'peroxide', user=user, prefix=prefix) 25 | 26 | 27 | def _is_root(): 28 | try: 29 | return os.geteuid() == 0 30 | except AttributeError: 31 | return False # assume not an admin on non-Unix platforms 32 | 33 | 34 | def main(argv=None): 35 | ap = argparse.ArgumentParser() 36 | ap.add_argument('--user', action='store_true', 37 | help="Install to the per-user kernels registry. Default if not root.") 38 | ap.add_argument('--sys-prefix', action='store_true', 39 | help="Install to sys.prefix (e.g. a virtualenv or conda env)") 40 | ap.add_argument('--prefix', 41 | help="Install to the given prefix. " 42 | "Kernelspec will be installed in {PREFIX}/share/jupyter/kernels/") 43 | args = ap.parse_args(argv) 44 | 45 | if args.sys_prefix: 46 | args.prefix = sys.prefix 47 | if not args.prefix and not _is_root(): 48 | args.user = True 49 | 50 | install_my_kernel_spec(user=args.user, prefix=args.prefix) 51 | 52 | 53 | if __name__ == '__main__': 54 | main() 55 | -------------------------------------------------------------------------------- /jupyter-kernel/peroxide/peroxide_kernel.py: -------------------------------------------------------------------------------- 1 | import inspect 2 | 3 | import pexpect 4 | from ipykernel.kernelbase import Kernel 5 | 6 | 7 | class PeroxidePexpectKernel(Kernel): 8 | implementation = 'IPython' 9 | implementation_version = '7.3.0' 10 | language = 'Peroxide Scheme' 11 | language_version = '0.1.0' 12 | language_info = { 13 | 'name': 'Scheme', 14 | 'mimetype': 'text/x-scheme', 15 | 'file_extension': '.scm', 16 | } 17 | banner = "Peroxide Scheme Kernel" 18 | 19 | def __init__(self, **kwargs): 20 | super().__init__(**kwargs) 21 | self.log.error(inspect.getfile(self.__class__)) 22 | self.child = pexpect.spawnu("/Users/matthieu/src/rustscheme/jupyter-kernel/env/share/jupyter/kernels/peroxide/peroxide --no-readline") 23 | self.child.setecho(False) 24 | self.child.expect(">>> ") 25 | 26 | def do_execute(self, code, silent, store_history=True, user_expressions=None, allow_stdin=False): 27 | ret = [] 28 | idx = 0 29 | 30 | for line in code.splitlines(): 31 | self.child.sendline(line) 32 | idx = self.child.expect([">>> ", r"\.\.\. "]) 33 | if idx == 0: 34 | ret.append(self.child.before) 35 | 36 | if idx == 1: 37 | self.child.sendline("#\\invalid") # invalid token 38 | self.child.expect("Error: .*") 39 | ret.append("** Incomplete expression.") 40 | 41 | if not silent: 42 | stream_content = {'name': 'stdout', 'text': ''.join(ret)} 43 | self.send_response(self.iopub_socket, 'stream', stream_content) 44 | 45 | return {'status': 'ok', 46 | # The base class increments the execution count 47 | 'execution_count': self.execution_count, 48 | 'payload': [], 49 | 'user_expressions': {}, 50 | } 51 | -------------------------------------------------------------------------------- /jupyter-kernel/setup.py: -------------------------------------------------------------------------------- 1 | from setuptools import setup 2 | 3 | setup( 4 | name='peroxide_kernel', 5 | version='1.1', 6 | packages=['peroxide'], 7 | description='Simple kernel for Peroxide Scheme', 8 | long_description='Simple kernel for Peroxide Scheme', 9 | author='Matthieu Felix', 10 | author_email='matthieufelix@gmail.com', 11 | url='https://github.com/MattX/peroxide/jupyter-kernel', 12 | install_requires=[ 13 | 'jupyter_client', 'IPython', 'ipykernel', 'pexpect>=4.6.0' 14 | ], 15 | classifiers=[ 16 | 'Intended Audience :: Developers', 17 | 'License :: OSI Approved :: Apache 2', 18 | 'Programming Language :: Python :: 3', 19 | ], 20 | ) 21 | -------------------------------------------------------------------------------- /rustfmt.toml: -------------------------------------------------------------------------------- 1 | imports_granularity = "Module" 2 | group_imports = "StdExternalCrate" 3 | -------------------------------------------------------------------------------- /src/arena.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::{Cell, RefCell}; 16 | use std::collections::HashMap; 17 | 18 | use heap; 19 | use heap::{PoolPtr, RootPtr}; 20 | use util::{is_numeric, simplify_numeric}; 21 | use value::Value; 22 | use vm::Vm; 23 | 24 | /// A frontend for Heap / RHeap that handles convenience operations. 25 | /// 26 | /// Should be renamed MemoryManager or something. 27 | pub struct Arena { 28 | /// Roots held by the arena. This must come before [`heap`], or the `Drop` on `RootPtr` 29 | /// will panic. 30 | /// Clippy thinks this is never used, but just holding it is what's important 31 | #[allow(dead_code)] 32 | roots: Vec, 33 | symbol_map: RefCell>, 34 | gensym_counter: Cell, 35 | pub undefined: PoolPtr, 36 | pub unspecific: PoolPtr, 37 | pub eof: PoolPtr, 38 | pub empty_list: PoolPtr, 39 | pub t: PoolPtr, 40 | pub f: PoolPtr, 41 | heap: heap::RHeap, 42 | } 43 | 44 | impl Arena { 45 | /// Moves a value into the arena, and returns a pointer to its new position. 46 | pub fn insert(&self, v: Value) -> PoolPtr { 47 | match v { 48 | Value::Undefined => self.undefined, 49 | Value::Unspecific => self.unspecific, 50 | Value::EofObject => self.eof, 51 | Value::EmptyList => self.empty_list, 52 | Value::Boolean(true) => self.t, 53 | Value::Boolean(false) => self.f, 54 | Value::Symbol(s) => { 55 | let res = self.symbol_map.borrow().get(&s).cloned(); 56 | match res { 57 | Some(u) => u.pp(), 58 | None => { 59 | let label = s.clone(); 60 | let pos = self.heap.allocate_rooted(Value::Symbol(s)); 61 | let ptr = pos.pp(); 62 | self.symbol_map.borrow_mut().insert(label, pos); 63 | ptr 64 | } 65 | } 66 | } 67 | _ if is_numeric(&v) => self.heap.allocate(simplify_numeric(v)), 68 | _ => self.heap.allocate(v), 69 | } 70 | } 71 | 72 | pub fn root(&self, at: PoolPtr) -> RootPtr { 73 | self.heap.root(at) 74 | } 75 | 76 | pub fn root_vm(&self, vm: &Vm) { 77 | self.heap.root_vm(vm); 78 | } 79 | 80 | pub fn unroot_vm(&self) { 81 | self.heap.unroot_vm(); 82 | } 83 | 84 | pub fn insert_rooted(&self, v: Value) -> RootPtr { 85 | self.root(self.insert(v)) 86 | } 87 | 88 | pub fn gensym(&self, base: Option<&str>) -> PoolPtr { 89 | let base_str = base.map(|s| format!("{}-", s)).unwrap_or_else(|| "".into()); 90 | loop { 91 | let candidate = format!("--gs-{}{}", base_str, self.gensym_counter.get()); 92 | self.gensym_counter.set(self.gensym_counter.get() + 1); 93 | if !self.symbol_map.borrow().contains_key(&candidate) { 94 | return self.insert(Value::Symbol(candidate)); 95 | } 96 | } 97 | } 98 | 99 | pub fn with_gc_mode(gc_mode: heap::GcMode) -> Arena { 100 | let mut roots = Vec::new(); 101 | let values = heap::RHeap::with_gc_mode(gc_mode); 102 | 103 | macro_rules! root { 104 | ($i: ident, $x: expr) => { 105 | roots.push(values.allocate_rooted($x)); 106 | let $i = roots.last().unwrap().ptr; 107 | }; 108 | } 109 | 110 | root!(undefined, Value::Undefined); 111 | root!(unspecific, Value::Unspecific); 112 | root!(eof, Value::EofObject); 113 | root!(empty_list, Value::EmptyList); 114 | root!(f, Value::Boolean(false)); 115 | root!(t, Value::Boolean(true)); 116 | 117 | Arena { 118 | heap: values, 119 | symbol_map: RefCell::new(HashMap::new()), 120 | gensym_counter: Cell::new(0), 121 | undefined, 122 | unspecific, 123 | eof, 124 | empty_list, 125 | f, 126 | t, 127 | roots, 128 | } 129 | } 130 | } 131 | 132 | impl Default for Arena { 133 | fn default() -> Self { 134 | Self::with_gc_mode(heap::GcMode::Normal) 135 | } 136 | } 137 | 138 | #[cfg(test)] 139 | mod tests { 140 | use value::Value; 141 | 142 | use super::*; 143 | 144 | #[test] 145 | fn get_symbol() { 146 | let r = Value::Symbol("abc".into()); 147 | let arena = Arena::default(); 148 | let vr = arena.insert(r.clone()); 149 | assert_eq!(&*vr, &r); 150 | } 151 | 152 | #[test] 153 | fn get_number() { 154 | let arena = Arena::default(); 155 | let vr = arena.insert(Value::Real(0.1)); 156 | assert_eq!(&*vr, &Value::Real(0.1)); 157 | } 158 | } 159 | -------------------------------------------------------------------------------- /src/bin/peroxide.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | extern crate clap; 16 | extern crate core; 17 | extern crate log; 18 | extern crate peroxide; 19 | extern crate pretty_env_logger; 20 | extern crate rustyline; 21 | 22 | use std::env; 23 | use std::str::FromStr; 24 | 25 | use clap::{App, Arg}; 26 | use peroxide::heap::GcMode; 27 | use peroxide::lex::{SegmentationResult, Token}; 28 | use peroxide::repl::{FileRepl, GetLineError, ReadlineRepl, Repl, StdIoRepl}; 29 | use peroxide::Interpreter; 30 | 31 | fn main() { 32 | pretty_env_logger::init(); 33 | let args: Vec = env::args().collect(); 34 | match do_main(args) { 35 | Err(e) => { 36 | println!("error: {}", e); 37 | std::process::exit(1) 38 | } 39 | Ok(()) => std::process::exit(0), 40 | } 41 | } 42 | 43 | fn do_main(args: Vec) -> Result<(), String> { 44 | let options = parse_args(&args.iter().map(|x| &**x).collect::>()) 45 | .map_err(|e| format!("could not parse arguments: {}", e))?; 46 | 47 | let silent = options.input_file.is_some(); 48 | let mut repl: Box = match options.input_file { 49 | Some(f) => Box::new(FileRepl::new(&f)?), 50 | None => { 51 | if options.enable_readline { 52 | Box::new(ReadlineRepl::new(Some("history.txt".to_string()))) 53 | } else { 54 | Box::new(StdIoRepl {}) 55 | } 56 | } 57 | }; 58 | 59 | let interpreter = Interpreter::new(options.gc_mode); 60 | let interruptor_clone = interpreter.interruptor(); 61 | 62 | ctrlc::set_handler(move || { 63 | interruptor_clone.interrupt(); 64 | }) 65 | .map_err(|e| format!("error setting Ctrl+C handler: {}", e.to_string()))?; 66 | 67 | if let Some(path) = options.stdlib_file { 68 | interpreter.initialize(&path)?; 69 | } 70 | loop { 71 | if !handle_one_expr_wrap(&mut *repl, &interpreter, silent) { 72 | break; 73 | } 74 | } 75 | 76 | repl.save_history(); 77 | Ok(()) 78 | } 79 | 80 | // Returns true if the REPL loop should continue, false otherwise. 81 | fn handle_one_expr_wrap(repl: &mut dyn Repl, vm_state: &Interpreter, silent: bool) -> bool { 82 | handle_one_expr(repl, vm_state, silent) 83 | .map_err(|e| println!("Error: {}", e)) 84 | .unwrap_or(true) 85 | } 86 | 87 | fn handle_one_expr( 88 | repl: &mut dyn Repl, 89 | vm_state: &Interpreter, 90 | silent: bool, 91 | ) -> Result { 92 | let mut current_expr_string: Vec = Vec::new(); 93 | let mut exprs: Vec> = Vec::new(); 94 | let mut pending_expr: Vec = Vec::new(); 95 | let mut depth: u64 = 0; 96 | 97 | loop { 98 | let line_opt = if pending_expr.is_empty() { 99 | repl.get_line(">>> ", "") 100 | } else { 101 | repl.get_line("... ", &" ".to_string().repeat((depth * 2) as usize)) 102 | }; 103 | 104 | match line_opt { 105 | Err(GetLineError::Eof) => return Ok(false), 106 | Err(GetLineError::Interrupted) => return Ok(false), 107 | Err(GetLineError::Err(s)) => { 108 | println!("Readline error: {}", s); 109 | return Ok(true); 110 | } 111 | Ok(_) => (), 112 | }; 113 | 114 | let line = line_opt.unwrap(); 115 | let mut tokenize_result = peroxide::lex::lex(&line)?; 116 | current_expr_string.push(line); 117 | pending_expr.append(&mut tokenize_result); 118 | 119 | let SegmentationResult { 120 | mut segments, 121 | remainder, 122 | depth: new_depth, 123 | } = peroxide::lex::segment(pending_expr)?; 124 | exprs.append(&mut segments); 125 | 126 | if remainder.is_empty() { 127 | break; 128 | } 129 | 130 | depth = new_depth; 131 | pending_expr = remainder; 132 | } 133 | 134 | repl.add_to_history(¤t_expr_string.join("\n")); 135 | let _ = rep(vm_state, exprs, silent); 136 | Ok(true) 137 | } 138 | 139 | fn rep(vm_state: &Interpreter, toks: Vec>, silent: bool) -> Result<(), ()> { 140 | for token_vector in toks { 141 | let parse_value = peroxide::read::read_tokens(&vm_state.arena, &token_vector) 142 | .map_err(|e| println!("parse error: {:?}", e))?; 143 | 144 | match vm_state.parse_compile_run(parse_value) { 145 | Ok(v) => { 146 | if !silent { 147 | println!(" => {}", v.pp().pretty_print()) 148 | } 149 | } 150 | Err(e) => println!("{}", e), 151 | } 152 | } 153 | Ok(()) 154 | } 155 | 156 | #[derive(Debug)] 157 | struct Options { 158 | pub enable_readline: bool, 159 | pub stdlib_file: Option, 160 | pub input_file: Option, 161 | pub gc_mode: GcMode, 162 | } 163 | 164 | fn parse_args(args: &[&str]) -> Result { 165 | let matches = App::new("Peroxide") 166 | .version("0.1") 167 | .author("Matthieu Felix ") 168 | .arg( 169 | Arg::with_name("no-std") 170 | .long("no-std") 171 | .help("Do not load the standard library"), 172 | ) 173 | .arg( 174 | Arg::with_name("stdlib-file") 175 | .long("stdlib-file") 176 | .takes_value(true) 177 | .conflicts_with("no-std") 178 | .help("Specify a file to load as the standard library"), 179 | ) 180 | .arg( 181 | Arg::with_name("no-readline") 182 | .long("no-readline") 183 | .help("Disable readline library"), 184 | ) 185 | .arg( 186 | Arg::with_name("gc-mode") 187 | .long("gc-mode") 188 | .possible_values(&["off", "normal", "debug", "debug-heavy"]) 189 | .default_value("normal"), 190 | ) 191 | .arg(Arg::with_name("input-file").help("Sets the input file to use")) 192 | .get_matches_from(args); 193 | 194 | let stdlib_file = if matches.is_present("no-std") { 195 | None 196 | } else { 197 | let stdlib_file = matches 198 | .value_of("stdlib-file") 199 | .unwrap_or("src/scheme-lib/init.scm"); 200 | Some(stdlib_file.to_string()) 201 | }; 202 | 203 | Ok(Options { 204 | enable_readline: !matches.is_present("no-readline"), 205 | stdlib_file, 206 | input_file: matches.value_of("input-file").map(|v| v.to_string()), 207 | gc_mode: GcMode::from_str(matches.value_of("gc-mode").unwrap()).unwrap(), 208 | }) 209 | } 210 | -------------------------------------------------------------------------------- /src/compile.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::RefCell; 16 | 17 | use arena::Arena; 18 | use ast::{Application, Lambda, SyntaxElement}; 19 | use environment::RcEnv; 20 | use heap::{Inventory, PoolPtr, PtrVec}; 21 | use value::Value; 22 | use vm::Instruction; 23 | 24 | /// A unit of code corresponding to a function. 25 | #[derive(Debug, PartialEq, Clone)] 26 | pub struct CodeBlock { 27 | pub name: Option, 28 | pub arity: usize, 29 | pub dotted: bool, 30 | pub instructions: Vec, 31 | pub constants: Vec, 32 | pub code_blocks: Vec, 33 | pub environment: RcEnv, 34 | } 35 | 36 | impl Inventory for CodeBlock { 37 | fn inventory(&self, v: &mut PtrVec) { 38 | for &c in self.constants.iter() { 39 | v.push(c); 40 | } 41 | for &c in self.code_blocks.iter() { 42 | v.push(c); 43 | } 44 | } 45 | } 46 | 47 | impl CodeBlock { 48 | pub fn new(name: Option, arity: usize, dotted: bool, environment: RcEnv) -> Self { 49 | CodeBlock { 50 | name, 51 | arity, 52 | dotted, 53 | instructions: vec![], 54 | constants: vec![], 55 | code_blocks: vec![], 56 | environment, 57 | } 58 | } 59 | 60 | pub fn push(&mut self, i: Instruction) { 61 | self.instructions.push(i); 62 | } 63 | 64 | pub fn replace(&mut self, index: usize, new: Instruction) { 65 | self.instructions[index] = new; 66 | } 67 | 68 | pub fn code_size(&self) -> usize { 69 | self.instructions.len() 70 | } 71 | 72 | pub fn push_constant(&mut self, c: PoolPtr) -> usize { 73 | self.constants.push(c); 74 | self.constants.len() - 1 75 | } 76 | } 77 | 78 | pub fn compile_toplevel( 79 | arena: &Arena, 80 | tree: &SyntaxElement, 81 | environment: RcEnv, 82 | ) -> Result { 83 | let mut code_block = CodeBlock::new(Some("[toplevel]".into()), 0, false, environment); 84 | 85 | // rooted_vec is a bit of a hack to avoid accidentally GCing code blocks. 86 | // Why is this needed? CodeBlock objects are immutable once inserted, so we'll have to insert 87 | // the toplevel one at the very end of the compilation procedure. This means that any sub- 88 | // CodeBlocks aren't rooted even if they are added to the toplevel CodeBlock's code_blocks 89 | // array. To alleviate this, we create this additional mutable vector to which we can add 90 | // items in progress. 91 | let rooted_vec = arena.insert_rooted(Value::Vector(RefCell::new(vec![]))); 92 | 93 | compile(arena, tree, &mut code_block, false, rooted_vec.pp())?; 94 | code_block.push(Instruction::Finish); 95 | let code_block_ptr = arena.insert(Value::CodeBlock(Box::new(code_block))); 96 | // println!("{:?}", code_block_ptr.pretty_print()); 97 | Ok(code_block_ptr) 98 | } 99 | 100 | pub fn compile( 101 | arena: &Arena, 102 | tree: &SyntaxElement, 103 | code: &mut CodeBlock, 104 | tail: bool, 105 | rv: PoolPtr, 106 | ) -> Result<(), String> { 107 | match tree { 108 | SyntaxElement::Quote(q) => { 109 | let idx = code.push_constant(q.quoted.pp()); 110 | code.push(Instruction::Constant(idx)); 111 | } 112 | SyntaxElement::If(i) => { 113 | compile(arena, &i.cond, code, false, rv)?; 114 | let cond_jump = code.code_size(); 115 | code.push(Instruction::NoOp); // Is rewritten as a conditional jump below 116 | compile(arena, &i.t, code, tail, rv)?; 117 | let mut true_end = code.code_size(); 118 | if let Some(ref f) = i.f { 119 | code.push(Instruction::NoOp); 120 | true_end += 1; 121 | compile(arena, f, code, tail, rv)?; 122 | let jump_offset = code.code_size() - true_end; 123 | code.replace(true_end - 1, Instruction::Jump(jump_offset)); 124 | } 125 | code.replace(cond_jump, Instruction::JumpFalse(true_end - cond_jump - 1)); 126 | } 127 | SyntaxElement::Begin(b) => { 128 | compile_sequence(arena, &b.expressions, code, tail, rv)?; 129 | } 130 | SyntaxElement::Set(s) => { 131 | compile(arena, &s.value, code, false, rv)?; 132 | code.push(make_set_instruction(s.altitude, s.depth, s.index)); 133 | } 134 | SyntaxElement::Reference(r) => { 135 | code.push(make_get_instruction(r.altitude, r.depth, r.index)); 136 | } 137 | SyntaxElement::Lambda(l) => { 138 | code.code_blocks.push(compile_lambda(arena, l, rv)?); 139 | code.push(Instruction::CreateClosure(code.code_blocks.len() - 1)); 140 | } 141 | SyntaxElement::Application(a) => compile_application(arena, a, code, tail, rv)?, 142 | }; 143 | Ok(()) 144 | } 145 | 146 | fn compile_application( 147 | arena: &Arena, 148 | a: &Application, 149 | code: &mut CodeBlock, 150 | tail: bool, 151 | rv: PoolPtr, 152 | ) -> Result<(), String> { 153 | if let SyntaxElement::Lambda(l) = &a.function { 154 | // This is an immediately-applied lambda, aka a let. We can directly check arity, as 155 | // well as avoid the need to create a new CodeBlock for the body. 156 | if !l.dotted && l.arity != a.args.len() { 157 | return Err(format!( 158 | "wrong number of arguments to lambda: expected {}, got {}", 159 | l.arity, 160 | a.args.len() 161 | )); 162 | } else if l.dotted && l.arity > a.args.len() { 163 | return Err(format!( 164 | "wrong number of arguments to lambda: expected at least {}, got {}", 165 | l.arity, 166 | a.args.len() 167 | )); 168 | } 169 | 170 | for instr in a.args.iter() { 171 | compile(arena, instr, code, false, rv)?; 172 | code.push(Instruction::PushValue); 173 | } 174 | code.push(Instruction::CreateFrame(a.args.len())); 175 | 176 | if !tail { 177 | code.push(Instruction::PreserveEnv); 178 | } 179 | if l.dotted { 180 | code.push(Instruction::PackFrame(l.arity)); 181 | } 182 | if !l.defines.is_empty() { 183 | // TODO can I avoid extending the frame, since I already know how many defines there are? 184 | code.push(Instruction::ExtendFrame(l.defines.len())); 185 | } 186 | code.push(Instruction::ExtendEnv); 187 | 188 | if !l.defines.is_empty() { 189 | compile_sequence(arena, &l.defines, code, false, rv)?; 190 | } 191 | compile_sequence(arena, &l.expressions, code, tail, rv)?; 192 | 193 | if !tail { 194 | code.push(Instruction::RestoreEnv); 195 | } 196 | } else { 197 | compile(arena, &a.function, code, false, rv)?; 198 | code.push(Instruction::PushValue); 199 | for instr in a.args.iter() { 200 | compile(arena, instr, code, false, rv)?; 201 | code.push(Instruction::PushValue); 202 | } 203 | code.push(Instruction::CreateFrame(a.args.len())); 204 | code.push(Instruction::PopFunction); 205 | if !tail { 206 | code.push(Instruction::PreserveEnv); 207 | } 208 | code.push(Instruction::FunctionInvoke { tail }); 209 | if !tail { 210 | code.push(Instruction::RestoreEnv); 211 | } 212 | } 213 | Ok(()) 214 | } 215 | 216 | fn compile_sequence( 217 | arena: &Arena, 218 | expressions: &[SyntaxElement], 219 | code: &mut CodeBlock, 220 | tail: bool, 221 | rv: PoolPtr, 222 | ) -> Result<(), String> { 223 | for instr in expressions[..expressions.len() - 1].iter() { 224 | compile(arena, instr, code, false, rv)?; 225 | } 226 | compile( 227 | arena, 228 | // This should have been caught at the syntax step. 229 | expressions.last().expect("empty sequence"), 230 | code, 231 | tail, 232 | rv, 233 | ) 234 | } 235 | 236 | fn compile_lambda(arena: &Arena, l: &Lambda, rv: PoolPtr) -> Result { 237 | let mut code = CodeBlock::new(l.name.clone(), l.arity, l.dotted, l.env.clone()); 238 | // See `compile_toplevel` for an explanation of rooted_vec 239 | let rooted_vec = arena.insert_rooted(Value::Vector(RefCell::new(vec![]))); 240 | 241 | code.push(Instruction::CheckArity { 242 | arity: l.arity, 243 | dotted: l.dotted, 244 | }); 245 | if l.dotted { 246 | code.push(Instruction::PackFrame(l.arity)); 247 | } 248 | if !l.defines.is_empty() { 249 | code.push(Instruction::ExtendFrame(l.defines.len())); 250 | } 251 | code.push(Instruction::ExtendEnv); 252 | 253 | if !l.defines.is_empty() { 254 | compile_sequence(arena, &l.defines, &mut code, false, rooted_vec.pp())?; 255 | } 256 | compile_sequence(arena, &l.expressions, &mut code, true, rooted_vec.pp())?; 257 | 258 | code.push(Instruction::Return); 259 | 260 | let code_block_ptr = arena.insert(Value::CodeBlock(Box::new(code))); 261 | rv.try_get_vector() 262 | .unwrap() 263 | .borrow_mut() 264 | .push(code_block_ptr); 265 | // println!("{:?}", code_block_ptr.pretty_print()); 266 | Ok(code_block_ptr) 267 | } 268 | 269 | // TODO fix this 270 | fn make_get_instruction(altitude: usize, depth: usize, index: usize) -> Instruction { 271 | match (altitude, false) { 272 | (0, true) => Instruction::GlobalArgumentGet { index }, 273 | (0, false) => Instruction::CheckedGlobalArgumentGet { index }, 274 | (_, true) => Instruction::LocalArgumentGet { depth, index }, 275 | (_, false) => Instruction::CheckedLocalArgumentGet { depth, index }, 276 | } 277 | } 278 | 279 | fn make_set_instruction(altitude: usize, depth: usize, index: usize) -> Instruction { 280 | match altitude { 281 | 0 => Instruction::GlobalArgumentSet { index }, 282 | _ => Instruction::DeepArgumentSet { depth, index }, 283 | } 284 | } 285 | -------------------------------------------------------------------------------- /src/environment.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | //! Environments are split into two parts for performance reasons: 16 | //! * The `Environment` struct holds a mapping of names to (depth, index) coordinates. It's used 17 | //! at compilation time. 18 | //! * The `ActivationFrame` struct holds a mapping of (depth, index) coordinates to locations 19 | //! in the Arena. It's used at runtime. 20 | //! 21 | //! By convention, depth refers to the distance to the current environment (so 0 is the most 22 | //! local environment), and altitude refers to the distance to the global environment (so 0 is 23 | //! the global environment). 24 | 25 | use std::cell::RefCell; 26 | use std::collections::HashMap; 27 | use std::fmt::{Debug, Error, Formatter}; 28 | use std::option::Option; 29 | use std::rc::Rc; 30 | 31 | use arena::Arena; 32 | use heap::{PoolPtr, RootPtr}; 33 | 34 | pub struct Environment { 35 | parent: Option>>, 36 | 37 | // The value can be a none to hide a value defined in a parent environment. 38 | values: HashMap>, 39 | 40 | /// Map of (altitude, index) to variable name. 41 | variable_names: HashMap<(usize, usize), String>, 42 | } 43 | 44 | impl PartialEq for Environment { 45 | fn eq(&self, _other: &Self) -> bool { 46 | panic!("Comparing environments") 47 | } 48 | } 49 | 50 | impl Debug for Environment { 51 | fn fmt(&self, f: &mut Formatter) -> Result<(), Error> { 52 | if let Some(ref p) = self.parent { 53 | write!(f, "{:?} ← {:?}", p.borrow(), self.values.keys()) 54 | } else { 55 | write!(f, "") 56 | } 57 | } 58 | } 59 | 60 | #[derive(Debug, Clone)] 61 | pub enum EnvironmentValue { 62 | Macro(Macro), 63 | Variable(Variable), 64 | } 65 | 66 | #[derive(Debug, Clone)] 67 | pub struct Variable { 68 | pub altitude: usize, 69 | pub index: usize, 70 | pub initialized: bool, 71 | } 72 | 73 | #[derive(Clone)] 74 | pub struct Macro { 75 | pub lambda: RootPtr, 76 | pub definition_environment: RcEnv, 77 | } 78 | 79 | impl std::fmt::Debug for Macro { 80 | fn fmt(&self, f: &mut std::fmt::Formatter) -> Result<(), std::fmt::Error> { 81 | // hide the environment field to avoid environment -> macro -> environment reference loops 82 | write!(f, "Macro{{Lambda={:?}}}", self.lambda) 83 | } 84 | } 85 | 86 | impl Environment { 87 | pub fn new(parent: Option>>) -> Self { 88 | Environment { 89 | parent, 90 | values: HashMap::new(), 91 | variable_names: HashMap::new(), 92 | } 93 | } 94 | 95 | /// Define a new variable. The variable will be added to the topmost environment frame, and 96 | /// may shadow a variable from a lower frame. 97 | /// 98 | /// The passed ActivationFrameInfo will be updated. 99 | /// 100 | /// It is not an error to define a name that already exists in the topmost environment frame. 101 | /// In this case, a new activation frame location will be allocated to the variable. 102 | pub fn define(&mut self, name: &str, af_info: &RcAfi, initialized: bool) -> usize { 103 | let index = af_info.borrow().entries; 104 | af_info.borrow_mut().entries += 1; 105 | self.define_explicit(name, af_info.borrow().altitude, index, initialized) 106 | } 107 | 108 | /// Define a value on the global environment (bottommost frame). 109 | pub fn define_toplevel(&mut self, name: &str, af_info: &RcAfi) -> usize { 110 | if let Some(ref e) = self.parent { 111 | e.borrow_mut().define_toplevel(name, af_info) 112 | } else { 113 | let toplevel_afi = get_toplevel_afi(af_info); 114 | self.define(name, &toplevel_afi, false) 115 | } 116 | } 117 | 118 | /// Define a variable if it is not already present. Used for top-level defines. 119 | /// 120 | /// Returns the index of the variable in either case. 121 | pub fn define_if_absent(&mut self, name: &str, af_info: &RcAfi, initialized: bool) -> usize { 122 | match self.get(name) { 123 | Some(EnvironmentValue::Variable(v)) => v.index, 124 | _ => self.define(name, af_info, initialized), 125 | } 126 | } 127 | 128 | /// Define a variable pointing to a specific index in the frame. 129 | pub fn define_explicit( 130 | &mut self, 131 | name: &str, 132 | altitude: usize, 133 | index: usize, 134 | initialized: bool, 135 | ) -> usize { 136 | self.variable_names 137 | .insert((altitude, index), name.to_string()); 138 | self.values.insert( 139 | name.to_string(), 140 | Some(EnvironmentValue::Variable(Variable { 141 | altitude, 142 | index, 143 | initialized, 144 | })), 145 | ); 146 | index 147 | } 148 | 149 | /// Define a macro in the current environment (topmost frame). 150 | /// 151 | /// It is legal to call [define_macro] with a name that is already used by a macro. In this 152 | /// case, the macro will be replaced. 153 | /// 154 | /// TODO: definition environment should be a weak ref to avoid cycles? 155 | pub fn define_macro(&mut self, name: &str, lambda: RootPtr, definition_environment: RcEnv) { 156 | self.values.insert( 157 | name.to_string(), 158 | Some(EnvironmentValue::Macro(Macro { 159 | lambda, 160 | definition_environment, 161 | })), 162 | ); 163 | } 164 | 165 | pub fn get(&self, name: &str) -> Option { 166 | if self.values.contains_key(name) { 167 | self.values.get(name).and_then(Clone::clone) 168 | } else if let Some(ref e) = self.parent { 169 | e.borrow().get(name) 170 | } else { 171 | None 172 | } 173 | } 174 | 175 | pub fn get_name(&self, altitude: usize, index: usize) -> String { 176 | if let Some(s) = self.variable_names.get(&(altitude, index)) { 177 | s.clone() 178 | } else if let Some(ref e) = self.parent { 179 | e.borrow().get_name(altitude, index) 180 | } else { 181 | format!("unnamed variable {}/{}", altitude, index) 182 | } 183 | } 184 | 185 | pub fn parent(&self) -> Option<&RcEnv> { 186 | (&self.parent).as_ref() 187 | } 188 | 189 | pub fn mark_initialized(&mut self, name: &str) { 190 | match self.values.get_mut(name) { 191 | Some(Some(EnvironmentValue::Variable(v))) => v.initialized = true, 192 | Some(_) => panic!("Tried to mark non-variable as initialized"), 193 | None => match self.parent { 194 | Some(ref e) => e.borrow_mut().mark_initialized(name), 195 | None => panic!( 196 | "Tried to mark nonexistent variable `{}` as initialized", 197 | name 198 | ), 199 | }, 200 | } 201 | } 202 | 203 | /// Removes all variables whose names starts with `%` from the environment. This is called 204 | /// once the standard library has been loaded so normal code doesn't see the underlying 205 | /// primitives. 206 | pub fn remove_special(&mut self) { 207 | self.values.retain(|k, _v| !k.starts_with('%')); 208 | } 209 | } 210 | 211 | pub type RcEnv = Rc>; 212 | 213 | pub fn filter(closed_env: &RcEnv, free_env: &RcEnv, free_vars: &[String]) -> Result { 214 | // TODO: there are some conditions under which syntactic closures may point to nonexistent 215 | // locations, because they have been popped off. We should take care of that somehow. 216 | 217 | let mut filtered = Environment::new(Some(closed_env.clone())); 218 | for free_var in free_vars.iter() { 219 | let var = free_env.borrow().get(free_var); 220 | filtered.values.insert(free_var.clone(), var.clone()); 221 | if let Some(EnvironmentValue::Variable(v)) = var { 222 | filtered 223 | .variable_names 224 | .insert((v.altitude, v.index), free_var.clone()); 225 | } 226 | } 227 | 228 | Ok(Rc::new(RefCell::new(filtered))) 229 | } 230 | 231 | // TODO make these fields private and have proper accessors 232 | #[derive(Debug, PartialEq, Clone)] 233 | pub struct ActivationFrame { 234 | pub parent: Option, 235 | pub values: Vec, 236 | } 237 | 238 | impl ActivationFrame { 239 | pub fn get_parent<'a>(&self) -> Option<&'a RefCell> { 240 | self.parent.map(|p| p.long_lived().get_activation_frame()) 241 | } 242 | 243 | pub fn get(&self, arena: &Arena, depth: usize, index: usize) -> PoolPtr { 244 | if depth == 0 { 245 | self.values[index] 246 | } else if let Some(p) = self.get_parent() { 247 | p.borrow().get(arena, depth - 1, index) 248 | } else { 249 | panic!("Accessing depth with no parent.") 250 | } 251 | } 252 | 253 | pub fn depth(&self) -> usize { 254 | if let Some(p) = self.get_parent() { 255 | p.borrow().depth() + 1 256 | } else { 257 | 0 258 | } 259 | } 260 | 261 | /// Guarantees that subsequent gets to `index`, or any lower index, on the toplevel 262 | /// environment, will be in bounds. 263 | /// 264 | /// Can only be called on the toplevel environment itself. 265 | pub fn ensure_index(&mut self, arena: &Arena, index: usize) { 266 | if self.parent.is_some() { 267 | panic!("ActivationFrame::ensure_size() called on non-root activation frame."); 268 | } 269 | if index >= self.values.len() { 270 | self.values.resize(index + 1, arena.undefined) 271 | } 272 | } 273 | 274 | pub fn set(&mut self, arena: &Arena, depth: usize, index: usize, value: PoolPtr) { 275 | if depth == 0 { 276 | self.values[index] = value; 277 | } else if let Some(p) = self.get_parent() { 278 | p.borrow_mut().set(arena, depth - 1, index, value); 279 | } else { 280 | panic!("Accessing depth with no parent."); 281 | } 282 | } 283 | } 284 | 285 | /// Compile-time information about an activation frame. 286 | #[derive(Debug)] 287 | pub struct ActivationFrameInfo { 288 | pub parent: Option>>, 289 | pub altitude: usize, 290 | pub entries: usize, 291 | } 292 | 293 | pub type RcAfi = Rc>; 294 | 295 | impl ActivationFrameInfo { 296 | pub fn add_entry(&mut self) -> usize { 297 | let entry_index = self.entries; 298 | self.entries += 1; 299 | entry_index 300 | } 301 | } 302 | 303 | impl Default for ActivationFrameInfo { 304 | fn default() -> Self { 305 | ActivationFrameInfo { 306 | parent: None, 307 | altitude: 0, 308 | entries: 0, 309 | } 310 | } 311 | } 312 | 313 | pub fn extend_af_info(af_info: &RcAfi) -> RcAfi { 314 | let new_af_info = ActivationFrameInfo { 315 | parent: Some(af_info.clone()), 316 | altitude: af_info.borrow().altitude + 1, 317 | entries: 0, 318 | }; 319 | Rc::new(RefCell::new(new_af_info)) 320 | } 321 | 322 | pub fn get_toplevel_afi(af_info: &RcAfi) -> RcAfi { 323 | let borrowed_afi = af_info.borrow(); 324 | if let Some(ref p) = borrowed_afi.parent.clone() { 325 | get_toplevel_afi(p) 326 | } else { 327 | af_info.clone() 328 | } 329 | } 330 | -------------------------------------------------------------------------------- /src/lib.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | extern crate bitvec; 16 | extern crate core; 17 | extern crate log; 18 | extern crate num_bigint; 19 | extern crate num_complex; 20 | extern crate num_integer; 21 | extern crate num_rational; 22 | extern crate num_traits; 23 | extern crate rustyline; 24 | 25 | use std::cell::RefCell; 26 | use std::fs; 27 | use std::rc::Rc; 28 | use std::sync::atomic::AtomicBool; 29 | use std::sync::atomic::Ordering::Relaxed; 30 | use std::sync::Arc; 31 | use std::time::Instant; 32 | 33 | use arena::Arena; 34 | use ast::SyntaxElement; 35 | use environment::{ActivationFrame, ActivationFrameInfo, Environment, RcEnv}; 36 | use heap::{GcMode, RootPtr}; 37 | use read::read_many; 38 | use value::Value; 39 | 40 | pub mod arena; 41 | pub mod ast; 42 | pub mod compile; 43 | pub mod environment; 44 | pub mod heap; 45 | pub mod lex; 46 | pub mod primitives; 47 | pub mod read; 48 | pub mod repl; 49 | pub mod util; 50 | pub mod value; 51 | pub mod vm; 52 | 53 | pub const ERROR_HANDLER_INDEX: usize = 0; 54 | pub const INPUT_PORT_INDEX: usize = 1; 55 | pub const OUTPUT_PORT_INDEX: usize = 2; 56 | 57 | #[derive(Clone, Debug)] 58 | pub struct Interruptor(Arc); 59 | 60 | impl Interruptor { 61 | pub fn interrupt(&self) { 62 | self.0.store(true, Relaxed); 63 | } 64 | } 65 | 66 | // TODO make arena non-pub 67 | /// Structure holding the global state of the interpreter between effective runs of the VM. 68 | pub struct Interpreter { 69 | global_environment: RcEnv, 70 | global_frame: RootPtr, 71 | interruptor: Arc, 72 | start_time: Instant, 73 | // Keep arena last! It must not be dropped before the RootPtr above. 74 | pub arena: Arena, 75 | } 76 | 77 | // Okay this is another dirty hack. This serves to convince the Rust compiler not to automatically 78 | // drop the Interpreter (and thus the Arena) too soon, e.g. in integration tests. If this whole 79 | // library was designed properly, PoolPtrs would have a lifetime not exceeding that of the Arena, 80 | // but unfortunately that is not the case and we are damned to suffer. 81 | impl Drop for Interpreter { 82 | fn drop(&mut self) {} 83 | } 84 | 85 | impl Interpreter { 86 | pub fn new(gc_mode: GcMode) -> Self { 87 | let arena = Arena::with_gc_mode(gc_mode); 88 | let global_environment = Rc::new(RefCell::new(Environment::new(None))); 89 | let global_frame = 90 | arena.insert_rooted(Value::ActivationFrame(RefCell::new(ActivationFrame { 91 | parent: None, 92 | values: vec![arena.f, arena.f, arena.f], 93 | }))); 94 | let afi = Rc::new(RefCell::new(ActivationFrameInfo { 95 | parent: None, 96 | altitude: 0, 97 | entries: 0, 98 | })); 99 | // If you add any magic values here, make sure to also add them to the actual toplevel 100 | // frame above too. 101 | assert_eq!( 102 | global_environment 103 | .borrow_mut() 104 | .define("%error-handler", &afi, true), 105 | ERROR_HANDLER_INDEX 106 | ); 107 | assert_eq!( 108 | global_environment 109 | .borrow_mut() 110 | .define("%current-input-port", &afi, true), 111 | INPUT_PORT_INDEX 112 | ); 113 | assert_eq!( 114 | global_environment 115 | .borrow_mut() 116 | .define("%current-output-port", &afi, true), 117 | OUTPUT_PORT_INDEX 118 | ); 119 | primitives::register_primitives(&arena, &global_environment, &afi, &global_frame); 120 | 121 | Self { 122 | arena, 123 | global_environment, 124 | global_frame, 125 | interruptor: Arc::new(AtomicBool::new(false)), 126 | start_time: Instant::now(), 127 | } 128 | } 129 | 130 | pub fn interruptor(&self) -> Interruptor { 131 | Interruptor(self.interruptor.clone()) 132 | } 133 | 134 | pub fn initialize(&self, fname: &str) -> Result<(), String> { 135 | let contents = fs::read_to_string(fname).map_err(|e| e.to_string())?; 136 | let values = read_many(&self.arena, &contents)?; 137 | //println!("Values: {:?}", values); 138 | for v in values.into_iter() { 139 | // println!("eval> {}", pretty_print(arena, v.pp())); 140 | self.parse_compile_run(v)?; 141 | } 142 | self.global_environment.borrow_mut().remove_special(); 143 | Ok(()) 144 | } 145 | 146 | /// High-level interface to parse, compile, and run a value that's been read. 147 | pub fn parse_compile_run(&self, read: RootPtr) -> Result { 148 | let cloned_env = self.global_environment.clone(); 149 | let global_af_info = Rc::new(RefCell::new(ActivationFrameInfo { 150 | parent: None, 151 | altitude: 0, 152 | entries: self 153 | .global_frame 154 | .pp() 155 | .get_activation_frame() 156 | .borrow() 157 | .values 158 | .len(), 159 | })); 160 | let syntax_tree = ast::parse(&self.arena, self, &cloned_env, &global_af_info, read.pp()) 161 | .map_err(|e| format!("syntax error: {}", e))?; 162 | self.global_frame 163 | .pp() 164 | .get_activation_frame() 165 | .borrow_mut() 166 | .ensure_index(&self.arena, global_af_info.borrow().entries); 167 | // println!(" => {:?}", syntax_tree); 168 | self.compile_run(&syntax_tree) 169 | } 170 | 171 | pub fn compile_run(&self, syntax_tree: &SyntaxElement) -> Result { 172 | let code = 173 | compile::compile_toplevel(&self.arena, syntax_tree, self.global_environment.clone())?; 174 | let code = self.arena.root(code); 175 | vm::run(code, 0, self.global_frame.pp(), self) 176 | .map_err(|e| format!("runtime error: {}", e.pp().pretty_print())) 177 | } 178 | } 179 | -------------------------------------------------------------------------------- /src/primitives/char.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::RefCell; 16 | 17 | use arena::Arena; 18 | use heap::PoolPtr; 19 | use num_bigint::BigInt; 20 | use num_traits::ToPrimitive; 21 | use util::check_len; 22 | use value::Value; 23 | 24 | fn get_char_arg(args: &[PoolPtr], prim_name: &str) -> Result { 25 | check_len(args, Some(1), Some(1))?; 26 | args[0] 27 | .try_get_character() 28 | .ok_or_else(|| format!("{}: not a char: {}", prim_name, args[0].pretty_print())) 29 | } 30 | 31 | pub fn char_p(arena: &Arena, args: &[PoolPtr]) -> Result { 32 | check_len(args, Some(1), Some(1))?; 33 | Ok(match &*args[0] { 34 | Value::Character(_) => arena.t, 35 | _ => arena.f, 36 | }) 37 | } 38 | 39 | pub fn char_to_integer(arena: &Arena, args: &[PoolPtr]) -> Result { 40 | let arg = get_char_arg(args, "char->integer")?; 41 | let val = Value::Integer(BigInt::from(u32::from(arg))); 42 | Ok(arena.insert(val)) 43 | } 44 | 45 | pub fn integer_to_char(arena: &Arena, args: &[PoolPtr]) -> Result { 46 | check_len(args, Some(1), Some(1))?; 47 | let int = args[0] 48 | .try_get_integer() 49 | .ok_or_else(|| format!("integer->char: not an integer: {}", args[0].pretty_print()))?; 50 | let u32i = int 51 | .to_u32() 52 | .ok_or_else(|| format!("integer->char: not a valid char: {}", int))?; 53 | let res = Value::Character( 54 | std::char::from_u32(u32i) 55 | .ok_or_else(|| format!("integer->char: not a valid char: {}", u32i))?, 56 | ); 57 | Ok(arena.insert(res)) 58 | } 59 | 60 | // The following methods could be implemented in a library, but they're annoying to implement for 61 | // Unicode values, so we have them as primitives to leverage Rust's Unicode support. 62 | 63 | pub fn char_alphabetic_p(arena: &Arena, args: &[PoolPtr]) -> Result { 64 | let arg = get_char_arg(args, "char-alphabetic?")?; 65 | Ok(arena.insert(Value::Boolean(arg.is_alphabetic()))) 66 | } 67 | 68 | pub fn char_numeric_p(arena: &Arena, args: &[PoolPtr]) -> Result { 69 | let arg = get_char_arg(args, "char-numeric?")?; 70 | Ok(arena.insert(Value::Boolean(arg.is_numeric()))) 71 | } 72 | 73 | pub fn char_whitespace_p(arena: &Arena, args: &[PoolPtr]) -> Result { 74 | let arg = get_char_arg(args, "char-whitespace?")?; 75 | Ok(arena.insert(Value::Boolean(arg.is_whitespace()))) 76 | } 77 | 78 | pub fn char_upper_case_p(arena: &Arena, args: &[PoolPtr]) -> Result { 79 | let arg = get_char_arg(args, "char-upper-case?")?; 80 | Ok(arena.insert(Value::Boolean(arg.is_uppercase()))) 81 | } 82 | 83 | pub fn char_lower_case_p(arena: &Arena, args: &[PoolPtr]) -> Result { 84 | let arg = get_char_arg(args, "char-lower-case?")?; 85 | Ok(arena.insert(Value::Boolean(arg.is_lowercase()))) 86 | } 87 | 88 | // `char::to_uppercase()` and `char::to_lowercase()` use ascii_uppercase and ascii_lowercase, 89 | // because corresponding upper/lower case values can be strings, but the R5RS standard does not 90 | // anticipate this case. 91 | 92 | pub fn char_upcase(arena: &Arena, args: &[PoolPtr]) -> Result { 93 | let arg = get_char_arg(args, "char-upcase")?; 94 | Ok(arena.insert(Value::Character(arg.to_ascii_uppercase()))) 95 | } 96 | 97 | pub fn char_downcase(arena: &Arena, args: &[PoolPtr]) -> Result { 98 | let arg = get_char_arg(args, "char-downcase")?; 99 | Ok(arena.insert(Value::Character(arg.to_ascii_lowercase()))) 100 | } 101 | 102 | pub fn char_upcase_unicode(arena: &Arena, args: &[PoolPtr]) -> Result { 103 | let arg = get_char_arg(args, "char-upcase-unicode")?; 104 | Ok(arena.insert(Value::String(RefCell::new(arg.to_uppercase().to_string())))) 105 | } 106 | 107 | pub fn char_downcase_unicode(arena: &Arena, args: &[PoolPtr]) -> Result { 108 | let arg = get_char_arg(args, "char-downcase-unicode")?; 109 | Ok(arena.insert(Value::String(RefCell::new(arg.to_lowercase().to_string())))) 110 | } 111 | -------------------------------------------------------------------------------- /src/primitives/mod.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | //! Naming conventions in Rust: replace `?` with `_p`, `!` with `_b`, `->` with `_to_`. 16 | //! 17 | //! ### Needed 18 | //! OK~ eq? eqv? equal? 19 | //! 20 | //! number? complex? real? rational? integer? 21 | //! exact? inexact? 22 | //! OK = < <= > >= 23 | //! 24 | //! OK + * - / 25 | //! quotient remainder modulo 26 | //! numerator denominator 27 | //! floor ceiling truncate round 28 | //! exp log sin cos tan asin acos atan atan2 29 | //! sqrt expt 30 | //! 31 | //! make-rectangular make-polar real-part imag-part magnitude angle 32 | //! exact->inexact inexact->exact 33 | //! number->string string->number 34 | //! 35 | //! OK pair? 36 | //! OK cons car cdr 37 | //! OK set-car! set-cdr! 38 | //! 39 | //! OK symbol? 40 | //! OK symbol->string 41 | //! OK string->symbol 42 | //! 43 | //! OK char? 44 | //! OK char->integer integer->char 45 | //! 46 | //! OK string? 47 | //! OK make-string string-length string-ref string-set! 48 | //! 49 | //! vector? 50 | //! make-vector vector-length vector-ref vector-set! 51 | //! 52 | //! OK procedure? 53 | //! OK apply 54 | //! 55 | //! call-with-current-continuation 56 | //! values call-with-values dynamic-wind ~> library or not? 57 | //! 58 | //! eval scheme-report-environment null-environment 59 | //! 60 | //! input-port? output-port? 61 | //! current-input-port current-output-port 62 | //! open-input-file open-output-file 63 | //! close-input-port close-output-port 64 | //! 65 | //! read-char peek-char eof-object? char-ready? write-char 66 | //! 67 | //! load 68 | 69 | use std::fmt::{Debug, Error, Formatter}; 70 | 71 | use arena::Arena; 72 | use environment::{RcAfi, RcEnv}; 73 | use heap::{PoolPtr, RootPtr}; 74 | use num_traits::ToPrimitive; 75 | use primitives::char::*; 76 | use primitives::numeric::*; 77 | use primitives::object::*; 78 | use primitives::pair::*; 79 | pub use primitives::port::Port; 80 | use primitives::port::*; 81 | use primitives::string::*; 82 | use primitives::symbol::*; 83 | pub use primitives::syntactic_closure::SyntacticClosure; 84 | use primitives::syntactic_closure::*; 85 | use primitives::vector::*; 86 | use value::Value; 87 | 88 | mod char; 89 | mod numeric; 90 | mod object; 91 | mod pair; 92 | mod port; 93 | mod string; 94 | mod symbol; 95 | mod syntactic_closure; 96 | mod vector; 97 | 98 | macro_rules! simple_primitive { 99 | ($name:expr, $implementation:ident) => { 100 | Primitive { 101 | name: $name, 102 | implementation: PrimitiveImplementation::Simple($implementation), 103 | } 104 | }; 105 | } 106 | 107 | static PRIMITIVES: [Primitive; 125] = [ 108 | simple_primitive!("make-syntactic-closure", make_syntactic_closure), 109 | simple_primitive!("identifier=?", identifier_equal_p), 110 | simple_primitive!("identifier?", identifier_p), 111 | simple_primitive!("syntactic-closure?", syntactic_closure_p), 112 | simple_primitive!( 113 | "syntactic-closure-environment", 114 | syntactic_closure_environment 115 | ), 116 | simple_primitive!( 117 | "syntactic-closure-free-variables", 118 | syntactic_closure_free_variables 119 | ), 120 | simple_primitive!("syntactic-closure-expression", syntactic_closure_expression), 121 | simple_primitive!("gensym", gensym), 122 | simple_primitive!("eq?", eq_p), 123 | simple_primitive!("eqv?", eqv_p), 124 | simple_primitive!("equal?", equal_p), 125 | simple_primitive!("number?", number_p), 126 | simple_primitive!("=", equal), 127 | simple_primitive!("<", less_than), 128 | simple_primitive!(">", greater_than), 129 | simple_primitive!("<=", less_than_equal), 130 | simple_primitive!(">=", greater_than_equal), 131 | simple_primitive!("+", add), 132 | simple_primitive!("*", mul), 133 | simple_primitive!("-", sub), 134 | simple_primitive!("/", div), 135 | simple_primitive!("modulo", modulo), 136 | simple_primitive!("remainder", remainder), 137 | simple_primitive!("gcd", gcd), 138 | simple_primitive!("lcm", lcm), 139 | simple_primitive!("real?", real_p), 140 | simple_primitive!("rational?", rational_p), 141 | simple_primitive!("integer?", integer_p), 142 | simple_primitive!("exact?", exact_p), 143 | simple_primitive!("inexact", inexact), 144 | simple_primitive!("exact", exact), 145 | simple_primitive!("nan?", nan_p), 146 | simple_primitive!("infinite?", infinite_p), 147 | simple_primitive!("real-part", real_part), 148 | simple_primitive!("imag-part", imag_part), 149 | simple_primitive!("exp", exp), 150 | simple_primitive!("log", log), 151 | simple_primitive!("cos", cos), 152 | simple_primitive!("sin", sin), 153 | simple_primitive!("tan", tan), 154 | simple_primitive!("acos", acos), 155 | simple_primitive!("asin", asin), 156 | simple_primitive!("%atan", atan), 157 | simple_primitive!("sqrt", sqrt), 158 | simple_primitive!("expt", expt), 159 | simple_primitive!("magnitude", magnitude), 160 | simple_primitive!("angle", angle), 161 | simple_primitive!("make-rectangular", make_rectangular), 162 | simple_primitive!("make-polar", make_polar), 163 | simple_primitive!("string->number", string_to_number), 164 | simple_primitive!("number->string", number_to_string), 165 | simple_primitive!("pair?", pair_p), 166 | simple_primitive!("cons", cons), 167 | simple_primitive!("car", car), 168 | simple_primitive!("cdr", cdr), 169 | simple_primitive!("set-car!", set_car_b), 170 | simple_primitive!("set-cdr!", set_cdr_b), 171 | simple_primitive!("write", write), 172 | simple_primitive!("display", display), 173 | simple_primitive!("newline", newline), 174 | simple_primitive!("symbol?", symbol_p), 175 | simple_primitive!("symbol->string", symbol_to_string), 176 | simple_primitive!("string->symbol", string_to_symbol), 177 | simple_primitive!("char?", char_p), 178 | simple_primitive!("char->integer", char_to_integer), 179 | simple_primitive!("integer->char", integer_to_char), 180 | simple_primitive!("char-alphabetic?", char_alphabetic_p), 181 | simple_primitive!("char-numeric?", char_numeric_p), 182 | simple_primitive!("char-whitespace?", char_whitespace_p), 183 | simple_primitive!("char-lower-case?", char_lower_case_p), 184 | simple_primitive!("char-upper-case?", char_upper_case_p), 185 | simple_primitive!("char-upcase", char_upcase), 186 | simple_primitive!("char-downcase", char_downcase), 187 | simple_primitive!("char-upcase-unicode", char_upcase_unicode), 188 | simple_primitive!("char-downcase-unicode", char_downcase_unicode), 189 | simple_primitive!("string?", string_p), 190 | simple_primitive!("make-string", make_string), 191 | simple_primitive!("string-length", string_length), 192 | simple_primitive!("string-set!", string_set_b), 193 | simple_primitive!("string-ref", string_ref), 194 | simple_primitive!("string", string), 195 | simple_primitive!("substring", substring), 196 | simple_primitive!("string->list", string_to_list), 197 | simple_primitive!("string-append", string_append), 198 | simple_primitive!("string=?", string_equal_p), 199 | simple_primitive!("string?", string_greater_than_p), 201 | simple_primitive!("string<=?", string_less_equal_p), 202 | simple_primitive!("string>=?", string_greater_equal_p), 203 | simple_primitive!("string-ci=?", string_ci_equal_p), 204 | simple_primitive!("string-ci?", string_ci_greater_than_p), 206 | simple_primitive!("string-ci<=?", string_ci_less_equal_p), 207 | simple_primitive!("string-ci>=?", string_ci_greater_equal_p), 208 | simple_primitive!("open-output-string", open_output_string), 209 | simple_primitive!("get-output-string", get_output_string), 210 | simple_primitive!("vector?", vector_p), 211 | simple_primitive!("make-vector", make_vector), 212 | simple_primitive!("vector-length", vector_length), 213 | simple_primitive!("vector-set!", vector_set_b), 214 | simple_primitive!("vector-ref", vector_ref), 215 | simple_primitive!("procedure?", procedure_p), 216 | simple_primitive!("error", error), 217 | simple_primitive!("port?", port_p), 218 | simple_primitive!("input-port?", input_port_p), 219 | simple_primitive!("output-port?", output_port_p), 220 | simple_primitive!("textual-port?", textual_port_p), 221 | simple_primitive!("binary-port?", binary_port_p), 222 | simple_primitive!("close-port", close_port), 223 | simple_primitive!("port-open?", port_open_p), 224 | simple_primitive!("open-input-file", open_input_file), 225 | simple_primitive!("eof-object", eof_object), 226 | simple_primitive!("eof-object?", eof_object_p), 227 | simple_primitive!("read-char", read_char), 228 | simple_primitive!("peek-char", peek_char), 229 | simple_primitive!("read-line", read_line), 230 | simple_primitive!("char-ready?", char_ready_p), 231 | simple_primitive!("read-string", read_string), 232 | Primitive { 233 | name: "apply", 234 | implementation: PrimitiveImplementation::Apply, 235 | }, 236 | Primitive { 237 | name: "%call/cc", // The actual call/cc handles dynamic-winds, and is written in Scheme. 238 | implementation: PrimitiveImplementation::CallCC, 239 | }, 240 | Primitive { 241 | name: "raise", 242 | implementation: PrimitiveImplementation::Raise, 243 | }, 244 | Primitive { 245 | name: "abort", 246 | implementation: PrimitiveImplementation::Abort, 247 | }, 248 | Primitive { 249 | name: "eval", 250 | implementation: PrimitiveImplementation::Eval, 251 | }, 252 | Primitive { 253 | name: "current-jiffy", 254 | implementation: PrimitiveImplementation::CurrentJiffy, 255 | }, 256 | Primitive { 257 | name: "load", 258 | implementation: PrimitiveImplementation::Load, 259 | }, 260 | ]; 261 | 262 | pub struct Primitive { 263 | pub name: &'static str, 264 | pub implementation: PrimitiveImplementation, 265 | } 266 | 267 | #[derive(Copy, Clone)] 268 | pub enum PrimitiveImplementation { 269 | Simple(fn(&Arena, &[PoolPtr]) -> Result), 270 | Io(fn(&Arena, PoolPtr, PoolPtr, &[PoolPtr]) -> Result), 271 | Eval, 272 | Apply, 273 | CallCC, 274 | Raise, 275 | Abort, 276 | CurrentJiffy, 277 | Load, 278 | } 279 | 280 | impl Debug for Primitive { 281 | fn fmt(&self, f: &mut Formatter) -> Result<(), Error> { 282 | write!(f, "primitive {}", self.name) 283 | } 284 | } 285 | 286 | impl PartialEq for Primitive { 287 | fn eq(&self, other: &Primitive) -> bool { 288 | self.name == other.name 289 | } 290 | } 291 | 292 | pub fn register_primitives( 293 | arena: &Arena, 294 | global_environment: &RcEnv, 295 | afi: &RcAfi, 296 | global_frame: &RootPtr, 297 | ) { 298 | let frame = global_frame.pp().long_lived().get_activation_frame(); 299 | for prim in PRIMITIVES.iter() { 300 | global_environment.borrow_mut().define(prim.name, afi, true); 301 | let ptr = arena.insert(Value::Primitive(prim)); 302 | frame.borrow_mut().values.push(ptr); 303 | } 304 | } 305 | 306 | pub fn try_get_index(v: PoolPtr) -> Result { 307 | v.try_get_integer() 308 | .ok_or_else(|| format!("invalid index: {}", v.pretty_print()))? 309 | .to_usize() 310 | .ok_or_else(|| format!("invalid index: {}", v.pretty_print())) 311 | } 312 | -------------------------------------------------------------------------------- /src/primitives/object.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::fmt::Write; 16 | 17 | use arena::Arena; 18 | use heap::PoolPtr; 19 | use util::check_len; 20 | use value; 21 | use value::Value; 22 | 23 | pub fn eq_p(arena: &Arena, args: &[PoolPtr]) -> Result { 24 | check_len(args, Some(2), Some(2))?; 25 | Ok(arena.insert(Value::Boolean(args[0] == args[1]))) 26 | } 27 | 28 | pub fn eqv_p(arena: &Arena, args: &[PoolPtr]) -> Result { 29 | check_len(args, Some(2), Some(2))?; 30 | Ok(arena.insert(Value::Boolean(value::eqv(args[0], args[1])))) 31 | } 32 | 33 | pub fn equal_p(arena: &Arena, args: &[PoolPtr]) -> Result { 34 | check_len(args, Some(2), Some(2))?; 35 | Ok(arena.insert(Value::Boolean(value::equal(args[0], args[1])))) 36 | } 37 | 38 | pub fn procedure_p(arena: &Arena, args: &[PoolPtr]) -> Result { 39 | check_len(args, Some(1), Some(1))?; 40 | Ok(match &*args[0] { 41 | Value::Lambda { .. } => arena.t, 42 | Value::Primitive(_) => arena.t, 43 | Value::Continuation(_) => arena.t, 44 | _ => arena.f, 45 | }) 46 | } 47 | 48 | pub fn display_to_string(args: &[PoolPtr]) -> String { 49 | let mut result = String::new(); 50 | for a in args.iter() { 51 | write!(&mut result, "{}", a.pretty_print()).unwrap(); 52 | } 53 | result 54 | } 55 | 56 | pub fn write(arena: &Arena, args: &[PoolPtr]) -> Result { 57 | print!("{}", display_to_string(args)); 58 | Ok(arena.unspecific) 59 | } 60 | 61 | pub fn display(arena: &Arena, args: &[PoolPtr]) -> Result { 62 | for arg in args { 63 | match &**arg { 64 | Value::String(s) => print!("{}", &s.borrow()), 65 | Value::Character(c) => print!("{}", c), 66 | _ => print!("{}", arg.pretty_print()), 67 | } 68 | } 69 | Ok(arena.unspecific) 70 | } 71 | 72 | pub fn newline(arena: &Arena, _args: &[PoolPtr]) -> Result { 73 | println!(); 74 | Ok(arena.unspecific) 75 | } 76 | 77 | pub fn error(_arena: &Arena, args: &[PoolPtr]) -> Result { 78 | Err(display_to_string(args)) 79 | } 80 | -------------------------------------------------------------------------------- /src/primitives/pair.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::Cell; 16 | 17 | use arena::Arena; 18 | use heap::PoolPtr; 19 | use util::check_len; 20 | use value::Value; 21 | 22 | pub fn pair_p(arena: &Arena, args: &[PoolPtr]) -> Result { 23 | check_len(args, Some(1), Some(1))?; 24 | let ans = matches!(&*args[0], Value::Pair(_, _)); 25 | Ok(arena.insert(Value::Boolean(ans))) 26 | } 27 | 28 | pub fn cons(arena: &Arena, args: &[PoolPtr]) -> Result { 29 | check_len(args, Some(2), Some(2))?; 30 | Ok(arena.insert(Value::Pair(Cell::new(args[0]), Cell::new(args[1])))) 31 | } 32 | 33 | pub fn car(_arena: &Arena, args: &[PoolPtr]) -> Result { 34 | check_len(args, Some(1), Some(1))?; 35 | match &*args[0] { 36 | Value::Pair(car, _) => Ok(car.get()), 37 | _ => Err(format!( 38 | "called car on a non-pair: {}", 39 | args[0].pretty_print() 40 | )), 41 | } 42 | } 43 | 44 | pub fn cdr(_arena: &Arena, args: &[PoolPtr]) -> Result { 45 | check_len(args, Some(1), Some(1))?; 46 | match &*args[0] { 47 | Value::Pair(_, cdr) => Ok(cdr.get()), 48 | _ => Err(format!( 49 | "called cdr on a non-pair: {}", 50 | args[0].pretty_print() 51 | )), 52 | } 53 | } 54 | 55 | pub fn set_car_b(_arena: &Arena, args: &[PoolPtr]) -> Result { 56 | check_len(args, Some(2), Some(2))?; 57 | match &*args[0] { 58 | Value::Pair(car, _) => Ok(car.replace(args[1])), 59 | _ => Err(format!( 60 | "called set-car! on a non-pair: {}", 61 | args[0].pretty_print() 62 | )), 63 | } 64 | } 65 | 66 | pub fn set_cdr_b(_arena: &Arena, args: &[PoolPtr]) -> Result { 67 | check_len(args, Some(2), Some(2))?; 68 | match &*args[0] { 69 | Value::Pair(_, cdr) => Ok(cdr.replace(args[1])), 70 | _ => Err(format!( 71 | "called set-cdr! on a non-pair: {}", 72 | args[0].pretty_print() 73 | )), 74 | } 75 | } 76 | 77 | // Code for a loop-compatible length function. 78 | /* 79 | enum ListType { 80 | Invalid, 81 | Empty, 82 | Some(usize), 83 | } 84 | 85 | fn next(arena: &Arena, pair: usize) -> ListType { 86 | match &*pair[0] { 87 | Value::EmptyList => ListType::Empty, 88 | Value::Pair(car, cdr) => ListType::Some(cdr.borrow().clone()), 89 | _ => ListType::Invalid 90 | } 91 | } 92 | 93 | fn next_twice(arena: &Arena, pair: usize) -> ListType { 94 | match next(arena, pair) { 95 | ListType::Some(s) => next(arena, s), 96 | e => e 97 | } 98 | } 99 | 100 | pub fn length(arena: &Arena, args: &[ValRef]) -> Result { 101 | check_len(args, Some(1), Some(1))?; 102 | 103 | let mut slow = args[0]; 104 | let mut fast = slow; 105 | let mut len = 0usize; 106 | 107 | loop { 108 | match &*slow { 109 | Value::EmptyList => Ok(arena.insert(Value::Integer(len.into()))), 110 | Value::Pair(car, cdr) => { 111 | loop {} 112 | } 113 | } 114 | } 115 | } 116 | */ 117 | -------------------------------------------------------------------------------- /src/primitives/port.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::{RefCell, RefMut}; 16 | use std::fmt; 17 | use std::io::{Error, ErrorKind, Read}; 18 | 19 | use arena::Arena; 20 | use heap; 21 | use heap::PoolPtr; 22 | use num_traits::ToPrimitive; 23 | use util::check_len; 24 | use value::Value; 25 | 26 | pub trait TextInputPort { 27 | fn ready(&mut self) -> std::io::Result; 28 | fn peek(&mut self) -> std::io::Result; 29 | fn read_one(&mut self) -> std::io::Result; 30 | fn read_string(&mut self, n: usize) -> std::io::Result; 31 | fn close(&mut self) -> std::io::Result<()>; 32 | fn is_closed(&self) -> bool; 33 | } 34 | 35 | pub trait BinaryInputPort { 36 | fn ready(&mut self) -> std::io::Result; 37 | fn peek(&mut self) -> std::io::Result; 38 | fn read_one(&mut self) -> std::io::Result; 39 | fn read_buf(&mut self, buf: &mut [u8]) -> std::io::Result; 40 | fn close(&mut self) -> std::io::Result<()>; 41 | fn is_closed(&self) -> bool; 42 | } 43 | 44 | pub trait OutputPort: std::io::Write { 45 | fn close(&mut self) -> std::io::Result<()>; 46 | fn is_closed(&self) -> bool; 47 | } 48 | 49 | fn read_u8_helper(reader: &mut impl Read) -> std::io::Result { 50 | let mut byte_buf = [0_u8]; 51 | let num_read = reader.read(&mut byte_buf)?; 52 | if num_read == 0 { 53 | Err(std::io::Error::from(ErrorKind::UnexpectedEof)) 54 | } else { 55 | Ok(byte_buf[0]) 56 | } 57 | } 58 | 59 | fn read_char_helper(reader: &mut impl Read) -> std::io::Result { 60 | let mut buf = [0_u8; 4]; 61 | for i in 0..4 { 62 | let maybe_u8 = read_u8_helper(reader); 63 | match maybe_u8 { 64 | Err(e) => { 65 | return if i != 0 && e.kind() == ErrorKind::UnexpectedEof { 66 | Err(std::io::Error::new( 67 | ErrorKind::InvalidData, 68 | "stream does not contain valid UTF-8", 69 | )) 70 | } else { 71 | Err(e) 72 | } 73 | } 74 | Ok(b) => buf[i] = b, 75 | } 76 | let uchar = std::char::from_u32(u32::from_le_bytes(buf)); 77 | if let Some(c) = uchar { 78 | return Ok(c); 79 | } 80 | } 81 | Err(std::io::Error::new( 82 | ErrorKind::InvalidData, 83 | "stream does not contain valid UTF-8", 84 | )) 85 | } 86 | 87 | pub struct FileTextInputPort { 88 | reader: Option>, 89 | peek_buffer: Option, 90 | } 91 | 92 | impl FileTextInputPort { 93 | fn new(name: &std::path::Path) -> std::io::Result { 94 | let file = std::fs::File::open(name)?; 95 | Ok(Self { 96 | reader: Some(std::io::BufReader::new(file)), 97 | peek_buffer: None, 98 | }) 99 | } 100 | } 101 | 102 | impl TextInputPort for FileTextInputPort { 103 | fn ready(&mut self) -> std::io::Result { 104 | Ok(true) 105 | } 106 | 107 | fn peek(&mut self) -> std::io::Result { 108 | if let Some(c) = self.peek_buffer { 109 | Ok(c) 110 | } else { 111 | let c = read_char_helper(self.reader.as_mut().unwrap())?; 112 | self.peek_buffer = Some(c); 113 | Ok(c) 114 | } 115 | } 116 | 117 | fn read_one(&mut self) -> std::io::Result { 118 | if let Some(c) = self.peek_buffer { 119 | self.peek_buffer = None; 120 | Ok(c) 121 | } else { 122 | read_char_helper(self.reader.as_mut().unwrap()) 123 | } 124 | } 125 | 126 | fn read_string(&mut self, n: usize) -> std::io::Result { 127 | let mut result = String::with_capacity(n); // We will need at least n, maybe more. 128 | let mut n = n; 129 | if let Some(c) = self.peek_buffer { 130 | self.peek_buffer = None; 131 | n -= 1; 132 | result.push(c); 133 | } 134 | for _ in 0..n { 135 | match read_char_helper(self.reader.as_mut().unwrap()) { 136 | Err(e) => { 137 | if e.kind() == ErrorKind::UnexpectedEof { 138 | break; 139 | } 140 | } 141 | Ok(c) => result.push(c), 142 | } 143 | } 144 | if n != 0 && result.is_empty() { 145 | Err(std::io::Error::from(ErrorKind::UnexpectedEof)) 146 | } else { 147 | Ok(result) 148 | } 149 | } 150 | 151 | fn close(&mut self) -> std::io::Result<()> { 152 | self.reader = None; 153 | Ok(()) 154 | } 155 | 156 | fn is_closed(&self) -> bool { 157 | self.reader.is_none() 158 | } 159 | } 160 | 161 | pub struct StringOutputPort { 162 | underlying: String, 163 | } 164 | 165 | impl std::io::Write for StringOutputPort { 166 | fn write(&mut self, buf: &[u8]) -> std::io::Result { 167 | let as_str = std::str::from_utf8(buf).map_err(|_| Error::from(ErrorKind::InvalidData))?; 168 | self.underlying.push_str(as_str); 169 | Ok(buf.len()) 170 | } 171 | 172 | fn flush(&mut self) -> std::io::Result<()> { 173 | Ok(()) 174 | } 175 | } 176 | 177 | impl OutputPort for StringOutputPort { 178 | fn close(&mut self) -> std::io::Result<()> { 179 | Ok(()) 180 | } 181 | 182 | fn is_closed(&self) -> bool { 183 | false 184 | } 185 | } 186 | 187 | pub enum Port { 188 | BinaryInputFile(RefCell>), 189 | TextInputFile(RefCell>), 190 | OutputString(RefCell), 191 | OutputFile(RefCell>), 192 | } 193 | 194 | impl fmt::Debug for Port { 195 | fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { 196 | write!(f, "#") 197 | } 198 | } 199 | 200 | impl Clone for Port { 201 | fn clone(&self) -> Self { 202 | panic!("trying to clone a port"); 203 | } 204 | } 205 | 206 | impl PartialEq for Port { 207 | fn eq(&self, _other: &Self) -> bool { 208 | panic!("trying to compare ports"); 209 | } 210 | } 211 | 212 | impl heap::Inventory for Port { 213 | fn inventory(&self, _v: &mut heap::PtrVec) {} 214 | } 215 | 216 | fn is_port(arg: PoolPtr) -> bool { 217 | arg.try_get_port().is_some() 218 | } 219 | 220 | fn is_input_port(arg: PoolPtr) -> bool { 221 | matches!( 222 | arg.try_get_port().expect("not a port"), 223 | Port::BinaryInputFile(_) | Port::TextInputFile(_) 224 | ) 225 | } 226 | 227 | fn is_output_port(arg: PoolPtr) -> bool { 228 | matches!(arg.try_get_port().expect("not a port"), Port::OutputFile(_)) 229 | } 230 | 231 | fn is_binary_port(arg: PoolPtr) -> bool { 232 | matches!( 233 | arg.try_get_port().expect("not a port"), 234 | Port::BinaryInputFile(_) | Port::OutputFile(_) 235 | ) 236 | } 237 | 238 | fn is_textual_port(arg: PoolPtr) -> bool { 239 | matches!( 240 | arg.try_get_port().expect("not a port"), 241 | Port::TextInputFile(_) | Port::OutputFile(_) 242 | ) 243 | } 244 | 245 | pub fn port_p(arena: &Arena, args: &[PoolPtr]) -> Result { 246 | check_len(args, Some(1), Some(1))?; 247 | let res = is_port(args[0]); 248 | Ok(arena.insert(Value::Boolean(res))) 249 | } 250 | 251 | pub fn input_port_p(arena: &Arena, args: &[PoolPtr]) -> Result { 252 | check_len(args, Some(1), Some(1))?; 253 | let res = is_port(args[0]) && is_input_port(args[0]); 254 | Ok(arena.insert(Value::Boolean(res))) 255 | } 256 | 257 | pub fn output_port_p(arena: &Arena, args: &[PoolPtr]) -> Result { 258 | check_len(args, Some(1), Some(1))?; 259 | let res = is_port(args[0]) && is_output_port(args[0]); 260 | Ok(arena.insert(Value::Boolean(res))) 261 | } 262 | 263 | pub fn textual_port_p(arena: &Arena, args: &[PoolPtr]) -> Result { 264 | check_len(args, Some(1), Some(1))?; 265 | let res = is_port(args[0]) && is_textual_port(args[0]); 266 | Ok(arena.insert(Value::Boolean(res))) 267 | } 268 | 269 | pub fn binary_port_p(arena: &Arena, args: &[PoolPtr]) -> Result { 270 | check_len(args, Some(1), Some(1))?; 271 | let res = is_port(args[0]) && is_binary_port(args[0]); 272 | Ok(arena.insert(Value::Boolean(res))) 273 | } 274 | 275 | pub fn close_port(arena: &Arena, args: &[PoolPtr]) -> Result { 276 | check_len(args, Some(1), Some(1))?; 277 | let port = args[0] 278 | .try_get_port() 279 | .ok_or_else(|| format!("not a port: {}", args[0].pretty_print()))?; 280 | match port { 281 | Port::BinaryInputFile(s) => s.borrow_mut().close(), 282 | Port::TextInputFile(s) => s.borrow_mut().close(), 283 | Port::OutputFile(s) => s.borrow_mut().close(), 284 | Port::OutputString(s) => s.borrow_mut().close(), 285 | } 286 | .map_err(|e| e.to_string())?; 287 | Ok(arena.unspecific) 288 | } 289 | 290 | pub fn port_open_p(arena: &Arena, args: &[PoolPtr]) -> Result { 291 | check_len(args, Some(1), Some(1))?; 292 | let port = args[0] 293 | .try_get_port() 294 | .ok_or_else(|| format!("not a port: {}", args[0].pretty_print()))?; 295 | let v = match port { 296 | Port::BinaryInputFile(s) => s.borrow().is_closed(), 297 | Port::TextInputFile(s) => s.borrow().is_closed(), 298 | Port::OutputFile(s) => s.borrow().is_closed(), 299 | Port::OutputString(s) => s.borrow().is_closed(), 300 | }; 301 | Ok(arena.insert(Value::Boolean(v))) 302 | } 303 | 304 | // TODO: paths don't have to be strings on most OSes. We should let the user specify arbitrary 305 | // bytes. The issue is that I don't think Rust really provides a way to convert arbitrary 306 | // bytes to a path? 307 | fn get_path(val: PoolPtr) -> Option { 308 | match &*val { 309 | Value::String(s) => Some(std::path::PathBuf::from(s.borrow().clone())), 310 | _ => None, 311 | } 312 | } 313 | 314 | pub fn open_input_file(arena: &Arena, args: &[PoolPtr]) -> Result { 315 | check_len(args, Some(1), Some(1))?; 316 | let path = 317 | get_path(args[0]).ok_or_else(|| format!("not a valid path: {}", args[0].pretty_print()))?; 318 | let raw_port = FileTextInputPort::new(&path).map_err(|e| e.to_string())?; 319 | let port = Port::TextInputFile(RefCell::new(Box::new(raw_port))); 320 | Ok(arena.insert(Value::Port(Box::new(port)))) 321 | } 322 | 323 | pub fn eof_object(arena: &Arena, args: &[PoolPtr]) -> Result { 324 | check_len(args, Some(0), Some(0))?; 325 | Ok(arena.eof) 326 | } 327 | 328 | pub fn eof_object_p(arena: &Arena, args: &[PoolPtr]) -> Result { 329 | check_len(args, Some(1), Some(1))?; 330 | Ok(arena.insert(Value::Boolean(args[0] == arena.eof))) 331 | } 332 | 333 | fn get_open_text_input_port<'a>( 334 | val: PoolPtr, 335 | ) -> Result>, String> { 336 | let port: &'a Port = match val.long_lived() { 337 | Value::Port(b) => b, 338 | _ => return Err(format!("not a port: {}", val.pretty_print())), 339 | }; 340 | if let Port::TextInputFile(op) = port { 341 | let port = op.borrow_mut(); 342 | if port.is_closed() { 343 | Err(format!("port is closed: {}", val.pretty_print())) 344 | } else { 345 | Ok(port) 346 | } 347 | } else { 348 | Err(format!("not a text input port: {}", val.pretty_print())) 349 | } 350 | } 351 | 352 | pub fn read_char(arena: &Arena, args: &[PoolPtr]) -> Result { 353 | check_len(args, Some(1), Some(1))?; 354 | let mut port = get_open_text_input_port(args[0])?; 355 | match port.read_one() { 356 | Ok(c) => Ok(arena.insert(Value::Character(c))), 357 | Err(e) => { 358 | if e.kind() == ErrorKind::UnexpectedEof { 359 | Ok(arena.eof) 360 | } else { 361 | Err(e.to_string()) 362 | } 363 | } 364 | } 365 | } 366 | 367 | pub fn peek_char(arena: &Arena, args: &[PoolPtr]) -> Result { 368 | check_len(args, Some(1), Some(1))?; 369 | let mut port = get_open_text_input_port(args[0])?; 370 | match port.peek() { 371 | Ok(c) => Ok(arena.insert(Value::Character(c))), 372 | Err(e) => { 373 | if e.kind() == ErrorKind::UnexpectedEof { 374 | Ok(arena.eof) 375 | } else { 376 | Err(e.to_string()) 377 | } 378 | } 379 | } 380 | } 381 | 382 | pub fn read_line(arena: &Arena, args: &[PoolPtr]) -> Result { 383 | check_len(args, Some(1), Some(1))?; 384 | let mut port = get_open_text_input_port(args[0])?; 385 | let mut result = String::new(); 386 | loop { 387 | match port.read_one() { 388 | Ok('\n') => return Ok(arena.insert(Value::String(RefCell::new(result)))), 389 | Ok('\r') => { 390 | if let Ok('\n') = port.peek() { 391 | port.read_one().unwrap(); 392 | } 393 | return Ok(arena.insert(Value::String(RefCell::new(result)))); 394 | } 395 | Ok(c) => result.push(c), 396 | Err(e) => { 397 | if e.kind() == ErrorKind::UnexpectedEof { 398 | if result.is_empty() { 399 | return Ok(arena.eof); 400 | } else { 401 | return Ok(arena.insert(Value::String(RefCell::new(result)))); 402 | } 403 | } else { 404 | return Err(e.to_string()); 405 | } 406 | } 407 | } 408 | } 409 | } 410 | 411 | pub fn char_ready_p(arena: &Arena, args: &[PoolPtr]) -> Result { 412 | check_len(args, Some(1), Some(1))?; 413 | let mut port = get_open_text_input_port(args[0])?; 414 | match port.ready() { 415 | Ok(ready) => Ok(arena.insert(Value::Boolean(ready))), 416 | Err(e) => { 417 | if e.kind() == ErrorKind::UnexpectedEof { 418 | Ok(arena.t) 419 | } else { 420 | Err(e.to_string()) 421 | } 422 | } 423 | } 424 | } 425 | 426 | pub fn read_string(arena: &Arena, args: &[PoolPtr]) -> Result { 427 | check_len(args, Some(2), Some(2))?; 428 | let len = args[0] 429 | .try_get_integer() 430 | .ok_or_else(|| format!("Not an integer: {}", args[0].pretty_print()))?; 431 | let len = len 432 | .to_usize() 433 | .ok_or_else(|| format!("Not a valid index: {}", len))?; 434 | let mut port = get_open_text_input_port(args[1])?; 435 | match port.read_string(len) { 436 | Ok(s) => Ok(arena.insert(Value::String(RefCell::new(s)))), 437 | Err(e) => { 438 | if e.kind() == ErrorKind::UnexpectedEof { 439 | Ok(arena.eof) 440 | } else { 441 | Err(e.to_string()) 442 | } 443 | } 444 | } 445 | } 446 | 447 | pub fn open_output_string(arena: &Arena, args: &[PoolPtr]) -> Result { 448 | check_len(args, Some(0), Some(0))?; 449 | Ok( 450 | arena.insert(Value::Port(Box::new(Port::OutputString(RefCell::new( 451 | StringOutputPort { 452 | underlying: String::new(), 453 | }, 454 | ))))), 455 | ) 456 | } 457 | 458 | pub fn get_output_string(arena: &Arena, args: &[PoolPtr]) -> Result { 459 | check_len(args, Some(1), Some(1))?; 460 | match args[0] 461 | .try_get_port() 462 | .ok_or_else(|| format!("not a port: {}", args[0].pretty_print()))? 463 | { 464 | Port::OutputString(s) => { 465 | Ok(arena.insert(Value::String(RefCell::new(s.borrow().underlying.clone())))) 466 | } 467 | _ => Err(format!("invalid port type: {}", args[0].pretty_print())), 468 | } 469 | } 470 | -------------------------------------------------------------------------------- /src/primitives/string.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::{Ref, RefCell, RefMut}; 16 | 17 | use arena::Arena; 18 | use heap::PoolPtr; 19 | use num_bigint::BigInt; 20 | use primitives::try_get_index; 21 | use util::check_len; 22 | use value::{list_from_vec, Value}; 23 | 24 | pub fn string_p(arena: &Arena, args: &[PoolPtr]) -> Result { 25 | check_len(args, Some(1), Some(1))?; 26 | Ok(arena.insert(Value::Boolean(args[0].try_get_string().is_some()))) 27 | } 28 | 29 | pub fn make_string(arena: &Arena, args: &[PoolPtr]) -> Result { 30 | check_len(args, Some(1), Some(2))?; 31 | let c = match args.get(1).map(|v| &**v) { 32 | None => 0 as char, 33 | Some(Value::Character(c)) => *c, 34 | _ => { 35 | return Err(format!( 36 | "invalid initial character: {}", 37 | args[1].pretty_print() 38 | )) 39 | } 40 | }; 41 | let length = try_get_index(args[0])?; 42 | let s: String = std::iter::repeat(c).take(length).collect(); 43 | Ok(arena.insert(Value::String(RefCell::new(s)))) 44 | } 45 | 46 | pub fn string_length(arena: &Arena, args: &[PoolPtr]) -> Result { 47 | check_len(args, Some(1), Some(1))?; 48 | let length = get_borrowed_string(&args[0])?.chars().count(); 49 | Ok(arena.insert(Value::Integer(BigInt::from(length)))) 50 | } 51 | 52 | pub fn string_set_b(arena: &Arena, args: &[PoolPtr]) -> Result { 53 | check_len(args, Some(3), Some(3))?; 54 | let mut borrowed_string = get_mut_borrowed_string(&args[0])?; 55 | let char_idx = try_get_index(args[1])?; 56 | let chr = args[2] 57 | .try_get_character() 58 | .ok_or_else(|| format!("invalid character: {}", args[2].pretty_print()))?; 59 | let (byte_idx, _) = borrowed_string 60 | .char_indices() 61 | .nth(char_idx) 62 | .ok_or_else(|| format!("invalid index: {}", char_idx))?; 63 | borrowed_string.replace_range(byte_idx..=byte_idx, &chr.to_string()); 64 | Ok(arena.unspecific) 65 | } 66 | 67 | pub fn string_ref(arena: &Arena, args: &[PoolPtr]) -> Result { 68 | check_len(args, Some(2), Some(2))?; 69 | let borrowed_string = get_borrowed_string(&args[0])?; 70 | let idx = try_get_index(args[1])?; 71 | let chr = borrowed_string 72 | .chars() 73 | .nth(idx) 74 | .ok_or_else(|| format!("Invalid index: {}.", idx))?; 75 | Ok(arena.insert(Value::Character(chr))) 76 | } 77 | 78 | pub fn string(arena: &Arena, args: &[PoolPtr]) -> Result { 79 | let values: Result, String> = args 80 | .iter() 81 | .map(|a| { 82 | a.try_get_character() 83 | .ok_or_else(|| format!("not a char: {}", a.pretty_print())) 84 | }) 85 | .collect(); 86 | let values = values?; 87 | Ok(arena.insert(Value::String(RefCell::new( 88 | values.iter().cloned().collect(), 89 | )))) 90 | } 91 | 92 | pub fn substring(arena: &Arena, args: &[PoolPtr]) -> Result { 93 | check_len(args, Some(3), Some(3))?; 94 | 95 | let borrowed_string = get_borrowed_string(&args[0])?; 96 | let start = try_get_index(args[1])?; 97 | let end = try_get_index(args[2])?; 98 | 99 | let len = borrowed_string.len(); 100 | if start > end || end > len { 101 | return Err(format!("invalid indices for substring: {}->{}", start, end)); 102 | } 103 | let char_iterator = borrowed_string.chars().skip(start).take(end - start); 104 | Ok(arena.insert(Value::String(RefCell::new(char_iterator.collect())))) 105 | } 106 | 107 | pub fn string_to_list(arena: &Arena, args: &[PoolPtr]) -> Result { 108 | check_len(args, Some(1), Some(1))?; 109 | 110 | let borrowed_string = get_borrowed_string(&args[0])?; 111 | let chars: Vec<_> = borrowed_string 112 | .chars() 113 | .map(|c| arena.insert(Value::Character(c))) 114 | .collect(); 115 | 116 | Ok(list_from_vec(arena, &chars)) 117 | } 118 | 119 | pub fn string_append(arena: &Arena, args: &[PoolPtr]) -> Result { 120 | let mut result = String::new(); 121 | for arg in args { 122 | let st = get_borrowed_string(arg)?; 123 | result += &st; 124 | } 125 | Ok(arena.insert(Value::String(RefCell::new(result)))) 126 | } 127 | 128 | fn get_borrowed_string(v: &PoolPtr) -> Result, String> { 129 | Ok(v.long_lived() 130 | .try_get_string() 131 | .ok_or_else(|| format!("not a string: {}", v.pretty_print()))? 132 | .borrow()) 133 | } 134 | 135 | fn get_mut_borrowed_string(v: &PoolPtr) -> Result, String> { 136 | Ok(v.long_lived() 137 | .try_get_string() 138 | .ok_or_else(|| format!("not a string: {}", v.pretty_print()))? 139 | .borrow_mut()) 140 | } 141 | 142 | fn to_string_vec(args: &[PoolPtr]) -> Result>, String> { 143 | args.iter() 144 | .map(|v| { 145 | v.try_get_string() 146 | .map(|s| s.borrow()) 147 | .ok_or_else(|| format!("not a string: {}", v.pretty_print())) 148 | }) 149 | .collect::, String>>() 150 | } 151 | 152 | macro_rules! string_cmp { 153 | ($fun:ident, $w:ident, $e:expr) => { 154 | pub fn $fun(arena: &Arena, args: &[PoolPtr]) -> Result { 155 | let strings = to_string_vec(args)?; 156 | Ok(arena.insert(Value::Boolean(strings.as_slice().windows(2).all(|$w| $e)))) 157 | } 158 | }; 159 | } 160 | 161 | string_cmp!(string_equal_p, w, *w[0] == *w[1]); 162 | string_cmp!(string_less_than_p, w, *w[0] < *w[1]); 163 | string_cmp!(string_greater_than_p, w, *w[0] > *w[1]); 164 | string_cmp!(string_less_equal_p, w, *w[0] <= *w[1]); 165 | string_cmp!(string_greater_equal_p, w, *w[0] >= *w[1]); 166 | 167 | string_cmp!( 168 | string_ci_equal_p, 169 | w, 170 | w[0].to_ascii_lowercase() == w[1].to_ascii_lowercase() 171 | ); 172 | string_cmp!( 173 | string_ci_less_than_p, 174 | w, 175 | w[0].to_ascii_lowercase() < w[1].to_ascii_lowercase() 176 | ); 177 | string_cmp!( 178 | string_ci_greater_than_p, 179 | w, 180 | w[0].to_ascii_lowercase() > w[1].to_ascii_lowercase() 181 | ); 182 | string_cmp!( 183 | string_ci_less_equal_p, 184 | w, 185 | w[0].to_ascii_lowercase() <= w[1].to_ascii_lowercase() 186 | ); 187 | string_cmp!( 188 | string_ci_greater_equal_p, 189 | w, 190 | w[0].to_ascii_lowercase() >= w[1].to_ascii_lowercase() 191 | ); 192 | -------------------------------------------------------------------------------- /src/primitives/symbol.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::RefCell; 16 | 17 | use arena::Arena; 18 | use heap::PoolPtr; 19 | use util::check_len; 20 | use value::Value; 21 | 22 | pub fn symbol_p(arena: &Arena, args: &[PoolPtr]) -> Result { 23 | check_len(args, Some(1), Some(1))?; 24 | Ok(match &*args[0] { 25 | Value::Symbol(_) => arena.t, 26 | _ => arena.f, 27 | }) 28 | } 29 | 30 | pub fn symbol_to_string(arena: &Arena, args: &[PoolPtr]) -> Result { 31 | check_len(args, Some(1), Some(1))?; 32 | match &*args[0] { 33 | Value::Symbol(s) => Ok(arena.insert(Value::String(RefCell::new(s.clone())))), 34 | _ => Err(format!( 35 | "symbol->string: not a symbol: {}", 36 | args[0].pretty_print() 37 | )), 38 | } 39 | } 40 | 41 | pub fn string_to_symbol(arena: &Arena, args: &[PoolPtr]) -> Result { 42 | check_len(args, Some(1), Some(1))?; 43 | match &*args[0] { 44 | Value::String(s) => Ok(arena.insert(Value::Symbol(s.borrow().clone()))), 45 | _ => Err(format!( 46 | "string->symbol: not a string: {}", 47 | args[0].pretty_print() 48 | )), 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /src/primitives/syntactic_closure.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::RefCell; 16 | use std::rc::Rc; 17 | 18 | use arena::Arena; 19 | use environment; 20 | use environment::{Environment, EnvironmentValue, RcEnv}; 21 | use heap::PoolPtr; 22 | use util::check_len; 23 | use value::{list_from_vec, Value}; 24 | 25 | #[derive(Debug, PartialEq, Clone)] 26 | pub struct SyntacticClosure { 27 | pub closed_env: RefCell, 28 | pub free_variables: Vec, 29 | pub expr: PoolPtr, 30 | } 31 | 32 | impl SyntacticClosure { 33 | pub fn push_env(&self, arena: &Arena) -> RcEnv { 34 | let env = self 35 | .closed_env 36 | .borrow() 37 | .try_get_environment() 38 | .expect("syntactic closure created with non-env") 39 | .clone(); 40 | let inner_env = Rc::new(RefCell::new(Environment::new(Some(env)))); 41 | let inner_env_val = Value::Environment(inner_env.clone()); 42 | RefCell::replace(&self.closed_env, arena.insert(inner_env_val)); 43 | inner_env 44 | } 45 | 46 | pub fn pop_env(&self, arena: &Arena) { 47 | let parent_env = self 48 | .closed_env 49 | .borrow() 50 | .try_get_environment() 51 | .expect("syntactic closure created with non-env") 52 | .borrow() 53 | .parent() 54 | .expect("Popping from syntactic closure with no parent env.") 55 | .clone(); 56 | RefCell::replace( 57 | &self.closed_env, 58 | arena.insert(Value::Environment(parent_env)), 59 | ); 60 | } 61 | } 62 | 63 | pub fn make_syntactic_closure(arena: &Arena, args: &[PoolPtr]) -> Result { 64 | check_len(args, Some(3), Some(3))?; 65 | let free_variables = args[1] 66 | .list_to_vec()? 67 | .iter() 68 | .map(|fv| match &**fv { 69 | Value::Symbol(s) => Ok(s.clone()), 70 | _ => Err(format!( 71 | "make-syntactic-closure: not a symbol: {}", 72 | fv.pretty_print() 73 | )), 74 | }) 75 | .collect::, _>>()?; 76 | let closed_env = match &*args[0] { 77 | Value::Environment(_) => Ok(args[0]), 78 | _ => Err(format!( 79 | "make-syntactic-closure: not an environment: {}", 80 | args[0].pretty_print() 81 | )), 82 | }?; 83 | Ok(arena.insert(Value::SyntacticClosure(SyntacticClosure { 84 | closed_env: RefCell::new(closed_env), 85 | free_variables, 86 | expr: args[2], 87 | }))) 88 | } 89 | 90 | /// Resolve an identifier in a given environment. 91 | /// 92 | /// The outer Result is an error if the passed `val` is not a valid identifier. The inner 93 | /// Option corresponds to the normal return type for an environment query. 94 | fn get_in_env(env: &RcEnv, val: PoolPtr) -> Result, String> { 95 | match &*val { 96 | Value::Symbol(s) => Ok(env.borrow().get(s)), 97 | Value::SyntacticClosure(SyntacticClosure { 98 | closed_env, 99 | free_variables, 100 | expr, 101 | }) => { 102 | let borrow = closed_env.borrow(); 103 | let closed_env = borrow 104 | .try_get_environment() 105 | .expect("Syntactic closure created with non-environment argument."); 106 | let inner_env = environment::filter(closed_env, env, free_variables)?; 107 | get_in_env(&inner_env, *expr) 108 | } 109 | _ => Err(format!("non-identifier: {}", val.pretty_print())), 110 | } 111 | } 112 | 113 | pub fn identifier_equal_p(arena: &Arena, args: &[PoolPtr]) -> Result { 114 | check_len(args, Some(4), Some(4))?; 115 | let env1 = args[0].try_get_environment().ok_or_else(|| { 116 | format!( 117 | "identifier=?: not an environment: {}", 118 | args[0].pretty_print() 119 | ) 120 | })?; 121 | let env2 = args[2].try_get_environment().ok_or_else(|| { 122 | format!( 123 | "identifier=?: not an environment: {}", 124 | args[2].pretty_print() 125 | ) 126 | })?; 127 | 128 | if !is_identifier(args[1]) || !is_identifier(args[3]) { 129 | return Ok(arena.f); 130 | } 131 | 132 | let binding1 = get_in_env(env1, args[1])?; 133 | let binding2 = get_in_env(env2, args[3])?; 134 | 135 | let res = match (binding1, binding2) { 136 | (None, None) => coerce_symbol(args[1]) == coerce_symbol(args[3]), 137 | (Some(EnvironmentValue::Variable(v1)), Some(EnvironmentValue::Variable(v2))) => { 138 | v1.altitude == v2.altitude && v1.index == v2.index 139 | } 140 | (Some(EnvironmentValue::Macro(m1)), Some(EnvironmentValue::Macro(m2))) => { 141 | // Lambdas are unique so no need to check environment equality 142 | m1.lambda.pp() == m2.lambda.pp() 143 | } 144 | _ => false, 145 | }; 146 | Ok(arena.insert(Value::Boolean(res))) 147 | } 148 | 149 | fn coerce_symbol(value: PoolPtr) -> String { 150 | match &*value { 151 | Value::Symbol(s) => s.clone(), 152 | Value::SyntacticClosure(sc) => coerce_symbol(sc.expr), 153 | _ => panic!( 154 | "Coercing non-identifier {} to symbol.", 155 | value.pretty_print() 156 | ), 157 | } 158 | } 159 | 160 | fn is_identifier(value: PoolPtr) -> bool { 161 | match &*value { 162 | Value::Symbol(_) => true, 163 | Value::SyntacticClosure(SyntacticClosure { expr, .. }) => is_identifier(*expr), 164 | _ => false, 165 | } 166 | } 167 | 168 | pub fn identifier_p(arena: &Arena, args: &[PoolPtr]) -> Result { 169 | check_len(args, Some(1), Some(1))?; 170 | Ok(arena.insert(Value::Boolean(is_identifier(args[0])))) 171 | } 172 | 173 | pub fn syntactic_closure_p(arena: &Arena, args: &[PoolPtr]) -> Result { 174 | check_len(args, Some(1), Some(1))?; 175 | Ok(arena.insert(Value::Boolean( 176 | args[0].try_get_syntactic_closure().is_some(), 177 | ))) 178 | } 179 | 180 | pub fn syntactic_closure_environment(_arena: &Arena, args: &[PoolPtr]) -> Result { 181 | check_len(args, Some(1), Some(1))?; 182 | let synclos = args[0] 183 | .try_get_syntactic_closure() 184 | .ok_or_else(|| format!("not a syntactic closure: {}", args[0].pretty_print()))?; 185 | Ok(*synclos.closed_env.borrow()) 186 | } 187 | 188 | pub fn syntactic_closure_free_variables( 189 | arena: &Arena, 190 | args: &[PoolPtr], 191 | ) -> Result { 192 | check_len(args, Some(1), Some(1))?; 193 | let synclos = args[0] 194 | .try_get_syntactic_closure() 195 | .ok_or_else(|| format!("not a syntactic closure: {}", args[0].pretty_print()))?; 196 | let symbols = synclos 197 | .free_variables 198 | .iter() 199 | .map(|s| arena.insert(Value::Symbol(s.clone()))); 200 | let sv: Vec<_> = symbols.collect(); 201 | Ok(list_from_vec(arena, &sv)) 202 | } 203 | 204 | pub fn syntactic_closure_expression(_arena: &Arena, args: &[PoolPtr]) -> Result { 205 | check_len(args, Some(1), Some(1))?; 206 | let synclos = args[0] 207 | .try_get_syntactic_closure() 208 | .ok_or_else(|| format!("not a syntactic closure: {}", args[0].pretty_print()))?; 209 | Ok(synclos.expr) 210 | } 211 | 212 | pub fn gensym(arena: &Arena, args: &[PoolPtr]) -> Result { 213 | check_len(args, Some(0), Some(1))?; 214 | let base_name = if let Some(v) = args.get(0) { 215 | Some( 216 | v.try_get_string() 217 | .map(|s| s.borrow().clone()) 218 | .ok_or_else(|| format!("not a string: {}", v.pretty_print()))?, 219 | ) 220 | } else { 221 | None 222 | }; 223 | Ok(arena.gensym(base_name.as_deref())) 224 | } 225 | -------------------------------------------------------------------------------- /src/primitives/vector.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | // TODO: deduplicate code between here and string.rs 16 | 17 | use std::cell::RefCell; 18 | 19 | use arena::Arena; 20 | use heap::PoolPtr; 21 | use num_bigint::BigInt; 22 | use num_traits::ToPrimitive; 23 | use util::check_len; 24 | use value::Value; 25 | 26 | pub fn vector_p(arena: &Arena, args: &[PoolPtr]) -> Result { 27 | check_len(args, Some(1), Some(1))?; 28 | Ok(match &*args[0] { 29 | Value::Vector(_) => arena.t, 30 | _ => arena.f, 31 | }) 32 | } 33 | 34 | pub fn make_vector(arena: &Arena, args: &[PoolPtr]) -> Result { 35 | check_len(args, Some(1), Some(2))?; 36 | let fill = *args.get(1).unwrap_or(&arena.f); 37 | let l = args[0] 38 | .try_get_integer() 39 | .ok_or_else(|| format!("make-vector: invalid length: {}", args[0].pretty_print()))?; 40 | let l = l 41 | .to_usize() 42 | .ok_or_else(|| format!("make-vector: vector cannot have negative length: {}", l))?; 43 | let v: Vec = std::iter::repeat(fill).take(l as usize).collect(); 44 | Ok(arena.insert(Value::Vector(RefCell::new(v)))) 45 | } 46 | 47 | pub fn vector_length(arena: &Arena, args: &[PoolPtr]) -> Result { 48 | check_len(args, Some(1), Some(1))?; 49 | let l = args[0] 50 | .try_get_vector() 51 | .ok_or_else(|| format!("vector-length: not a vector: {}", args[0].pretty_print()))? 52 | .borrow() 53 | .len(); 54 | Ok(arena.insert(Value::Integer(BigInt::from(l)))) 55 | } 56 | 57 | pub fn vector_set_b(arena: &Arena, args: &[PoolPtr]) -> Result { 58 | check_len(args, Some(3), Some(3))?; 59 | let mut borrowed_vec = args[0] 60 | .try_get_vector() 61 | .ok_or_else(|| format!("vector-set!: Not a vector: {}.", args[0].pretty_print()))? 62 | .borrow_mut(); 63 | let idx = args[1] 64 | .try_get_integer() 65 | .ok_or_else(|| format!("vector-set: Invalid index: {}.", args[1].pretty_print()))?; 66 | let idx = idx 67 | .to_usize() 68 | .ok_or_else(|| format!("vector-set!: Invalid index: {}.", idx))?; 69 | if idx >= borrowed_vec.len() { 70 | return Err(format!("vector-set!: Invalid index: {}.", idx)); 71 | } 72 | borrowed_vec[idx] = args[2]; 73 | Ok(arena.unspecific) 74 | } 75 | 76 | pub fn vector_ref(_arena: &Arena, args: &[PoolPtr]) -> Result { 77 | check_len(args, Some(2), Some(2))?; 78 | let borrowed_vec = args[0] 79 | .try_get_vector() 80 | .ok_or_else(|| format!("vector-ref: Not a vector: {}.", args[0].pretty_print()))? 81 | .borrow(); 82 | let idx = args[1] 83 | .try_get_integer() 84 | .ok_or_else(|| format!("vector-ref: Invalid index: {}.", args[1].pretty_print()))?; 85 | let idx = idx 86 | .to_usize() 87 | .ok_or_else(|| format!("vector-set!: Invalid index: {}.", idx))?; 88 | borrowed_vec 89 | .get(idx) 90 | .copied() 91 | .ok_or_else(|| format!("vector-set!: Invalid index: {}.", idx)) 92 | } 93 | -------------------------------------------------------------------------------- /src/read.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::{Cell, RefCell}; 16 | use std::iter::Peekable; 17 | 18 | use arena::Arena; 19 | use heap::RootPtr; 20 | use lex; 21 | use lex::{NumValue, Token}; 22 | use num_complex::Complex; 23 | use num_traits::cast::ToPrimitive; 24 | use util::simplify_numeric; 25 | use value::Value; 26 | 27 | #[derive(Debug)] 28 | pub enum ParseResult { 29 | Nothing, 30 | ParseError(String), 31 | } 32 | 33 | pub fn read_tokens(arena: &Arena, tokens: &[Token]) -> Result { 34 | if tokens.is_empty() { 35 | return Err(ParseResult::Nothing); 36 | } 37 | 38 | let mut it = tokens.iter().peekable(); 39 | let res = do_read(arena, &mut it)?; 40 | if let Some(s) = it.peek() { 41 | Err(ParseResult::ParseError(format!("Unexpected token {:?}", s))) 42 | } else { 43 | Ok(res) 44 | } 45 | } 46 | 47 | pub fn read(arena: &Arena, input: &str) -> Result { 48 | let tokens = lex::lex(input)?; 49 | read_tokens(arena, &tokens).map_err(|e| format!("{:?}", e)) 50 | } 51 | 52 | pub fn read_many(arena: &Arena, code: &str) -> Result, String> { 53 | let tokens = lex::lex(code)?; 54 | let segments = lex::segment(tokens)?; 55 | if !segments.remainder.is_empty() { 56 | return Err(format!( 57 | "Unterminated expression: dangling tokens {:?}", 58 | segments.remainder 59 | )); 60 | } 61 | segments 62 | .segments 63 | .iter() 64 | .map(|s| read_tokens(arena, s)) 65 | .collect::, _>>() 66 | .map_err(|e| format!("{:?}", e)) 67 | } 68 | 69 | fn do_read<'a, 'b, I>(arena: &Arena, it: &'a mut Peekable) -> Result 70 | where 71 | I: Iterator, 72 | { 73 | if let Some(t) = it.next() { 74 | match t { 75 | Token::Num(x) => Ok(arena.insert_rooted(read_num_token(x))), 76 | Token::Boolean(b) => Ok(arena.insert_rooted(Value::Boolean(*b))), 77 | Token::Character(c) => Ok(arena.insert_rooted(Value::Character(*c))), 78 | Token::String(s) => Ok(arena.insert_rooted(Value::String(RefCell::new(s.to_string())))), 79 | Token::Symbol(s) => Ok(arena.insert_rooted(Value::Symbol(s.to_ascii_lowercase()))), 80 | Token::OpenParen => read_list(arena, it), 81 | Token::OpenByteVector => read_bytevec(arena, it), 82 | Token::OpenVector => read_vec(arena, it), 83 | Token::Quote => read_quote(arena, it, "quote"), 84 | Token::QuasiQuote => read_quote(arena, it, "quasiquote"), 85 | Token::Unquote => read_quote(arena, it, "unquote"), 86 | Token::UnquoteSplicing => read_quote(arena, it, "unquote-splicing"), 87 | _ => Err(ParseResult::ParseError(format!( 88 | "Unexpected token {:?}.", 89 | t 90 | ))), 91 | } 92 | } else { 93 | panic!("do_parse called with no tokens."); 94 | } 95 | } 96 | 97 | pub fn read_num_token(t: &NumValue) -> Value { 98 | let equalized = match t { 99 | NumValue::Real(r) => Value::Real(*r), 100 | NumValue::Integer(i) => Value::Integer(i.clone()), 101 | NumValue::Rational(br) => Value::Rational(Box::new(br.clone())), 102 | NumValue::Polar(magnitude, phase) => { 103 | // TODO if phase or magnitude are exact zeros we can do better things 104 | let magnitude = magnitude.coerce_real(); 105 | let phase = phase.coerce_real(); 106 | Value::ComplexReal(Complex::from_polar(magnitude, phase)) 107 | } 108 | NumValue::Rectangular(real, imag) => match (real.as_ref(), imag.as_ref()) { 109 | (NumValue::Real(_), _) | (_, NumValue::Real(_)) => { 110 | Value::ComplexReal(Complex::new(real.coerce_real(), imag.coerce_real())) 111 | } 112 | (NumValue::Rational(_), _) | (_, NumValue::Rational(_)) => Value::ComplexRational( 113 | Box::new(Complex::new(real.coerce_rational(), imag.coerce_rational())), 114 | ), 115 | (NumValue::Integer(real), NumValue::Integer(imag)) => { 116 | Value::ComplexInteger(Box::new(Complex::new(real.clone(), imag.clone()))) 117 | } 118 | _ => panic!("Complex numbers in rectangular NumValue"), 119 | }, 120 | }; 121 | simplify_numeric(equalized) 122 | } 123 | 124 | fn read_list<'a, 'b, I>(arena: &Arena, it: &'a mut Peekable) -> Result 125 | where 126 | I: Iterator, 127 | { 128 | if let Some(&t) = it.peek() { 129 | match t { 130 | Token::ClosingParen => { 131 | it.next(); 132 | Ok(arena.insert_rooted(Value::EmptyList)) 133 | } 134 | _ => { 135 | let first = do_read(arena, it)?; 136 | let second = if it.peek() == Some(&&Token::Dot) { 137 | it.next(); 138 | let ret = do_read(arena, it); 139 | let next = it.next(); 140 | if next != Some(&Token::ClosingParen) { 141 | Err(ParseResult::ParseError(format!( 142 | "Unexpected token {:?} after dot.", 143 | next 144 | ))) 145 | } else { 146 | ret 147 | } 148 | } else { 149 | read_list(arena, it) 150 | }?; 151 | Ok(arena.insert_rooted(Value::Pair(Cell::new(first.pp()), Cell::new(second.pp())))) 152 | } 153 | } 154 | } else { 155 | Err(ParseResult::ParseError( 156 | "Unexpected end of list.".to_string(), 157 | )) 158 | } 159 | } 160 | 161 | fn read_bytevec<'a, 'b, I>(arena: &Arena, it: &'a mut Peekable) -> Result 162 | where 163 | I: Iterator, 164 | { 165 | let mut result: Vec = Vec::new(); 166 | 167 | if None == it.peek() { 168 | return Err(ParseResult::ParseError( 169 | "Unexpected end of vector.".to_string(), 170 | )); 171 | } 172 | 173 | while let Some(&t) = it.peek() { 174 | match t { 175 | Token::ClosingParen => { 176 | it.next(); 177 | break; 178 | } 179 | Token::Num(NumValue::Integer(i)) => { 180 | it.next(); 181 | let b = i.to_u8().ok_or_else(|| { 182 | ParseResult::ParseError(format!("Invalid byte value: {}.", i)) 183 | })?; 184 | result.push(b); 185 | } 186 | v => { 187 | return Err(ParseResult::ParseError(format!( 188 | "Non-byte in bytevector literal: {:?}", 189 | v 190 | ))); 191 | } 192 | } 193 | } 194 | 195 | Ok(arena.insert_rooted(Value::ByteVector(RefCell::new(result)))) 196 | } 197 | 198 | fn read_vec<'a, 'b, I>(arena: &Arena, it: &'a mut Peekable) -> Result 199 | where 200 | I: Iterator, 201 | { 202 | let mut roots = Vec::new(); 203 | let mut result = Vec::new(); 204 | 205 | if None == it.peek() { 206 | return Err(ParseResult::ParseError( 207 | "Unexpected end of vector.".to_string(), 208 | )); 209 | } 210 | 211 | while let Some(&t) = it.peek() { 212 | match t { 213 | Token::ClosingParen => { 214 | it.next(); 215 | break; 216 | } 217 | _ => { 218 | let elem = do_read(arena, it)?; 219 | result.push(elem.pp()); 220 | roots.push(elem); 221 | } 222 | } 223 | } 224 | 225 | Ok(arena.insert_rooted(Value::Vector(RefCell::new(result)))) 226 | } 227 | 228 | fn read_quote<'a, 'b, I>( 229 | arena: &Arena, 230 | it: &'a mut Peekable, 231 | prefix: &'static str, 232 | ) -> Result 233 | where 234 | I: Iterator, 235 | { 236 | let quoted = do_read(arena, it)?; 237 | let quoted_list_ptr = arena.insert_rooted(Value::Pair( 238 | Cell::new(quoted.pp()), 239 | Cell::new(arena.empty_list), 240 | )); 241 | let quote_sym_ptr = arena.insert_rooted(Value::Symbol(prefix.to_string())); 242 | Ok(arena.insert_rooted(Value::Pair( 243 | Cell::new(quote_sym_ptr.pp()), 244 | Cell::new(quoted_list_ptr.pp()), 245 | ))) 246 | } 247 | -------------------------------------------------------------------------------- /src/repl.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::fs::File; 16 | use std::io::{self, BufRead, BufReader, Write}; 17 | 18 | use rustyline::error::ReadlineError; 19 | use rustyline::Editor; 20 | 21 | #[derive(Debug)] 22 | pub enum GetLineError { 23 | Eof, 24 | Interrupted, 25 | Err(String), 26 | } 27 | 28 | pub trait Repl { 29 | fn get_line(&mut self, prompt: &str, prefill: &str) -> Result; 30 | fn add_to_history(&mut self, data: &str); 31 | fn save_history(&mut self); 32 | } 33 | 34 | pub struct ReadlineRepl { 35 | editor: Editor<()>, 36 | history_location: Option, 37 | } 38 | 39 | impl ReadlineRepl { 40 | pub fn new(history_location: Option) -> ReadlineRepl { 41 | let mut ed = ReadlineRepl { 42 | editor: Editor::<()>::new(), 43 | history_location, 44 | }; 45 | 46 | if ed.editor.load_history("history.txt").is_err() { 47 | println!("No previous history."); 48 | } 49 | 50 | ed 51 | } 52 | } 53 | 54 | impl Repl for ReadlineRepl { 55 | fn get_line(&mut self, prompt: &str, prefill: &str) -> Result { 56 | self.editor 57 | .readline_with_initial(prompt, (prefill, "")) 58 | .map_err(|e| match e { 59 | ReadlineError::Eof => GetLineError::Eof, 60 | ReadlineError::Interrupted => GetLineError::Interrupted, 61 | _ => GetLineError::Err(e.to_string()), 62 | }) 63 | } 64 | 65 | fn add_to_history(&mut self, data: &str) { 66 | self.editor.add_history_entry(data); 67 | } 68 | 69 | fn save_history(&mut self) { 70 | self.history_location 71 | .clone() 72 | .map(|hl| self.editor.save_history(&hl)); 73 | } 74 | } 75 | 76 | pub struct StdIoRepl {} 77 | 78 | impl Repl for StdIoRepl { 79 | fn get_line(&mut self, prompt: &str, _prefill: &str) -> Result { 80 | print!("{}", prompt); 81 | io::stdout() 82 | .flush() 83 | .map_err(|e| GetLineError::Err(e.to_string()))?; 84 | 85 | let mut buf = String::new(); 86 | match io::stdin().read_line(&mut buf) { 87 | Ok(0) => Err(GetLineError::Eof), 88 | Ok(_) => Ok(buf), 89 | Err(e) => Err(GetLineError::Err(e.to_string())), 90 | } 91 | } 92 | 93 | fn add_to_history(&mut self, _data: &str) {} 94 | 95 | fn save_history(&mut self) {} 96 | } 97 | 98 | pub struct FileRepl { 99 | reader: BufReader, 100 | } 101 | 102 | impl FileRepl { 103 | pub fn new(file_name: &str) -> Result { 104 | let f = File::open(file_name).map_err(|e| e.to_string())?; 105 | Ok(FileRepl { 106 | reader: BufReader::new(f), 107 | }) 108 | } 109 | } 110 | 111 | impl Repl for FileRepl { 112 | fn get_line(&mut self, _prompt: &str, _prefill: &str) -> Result { 113 | let mut line = String::new(); 114 | let len = self 115 | .reader 116 | .read_line(&mut line) 117 | .map_err(|e| GetLineError::Err(e.to_string()))?; 118 | match len { 119 | 0 => Err(GetLineError::Eof), 120 | _ => Ok(line), 121 | } 122 | } 123 | 124 | fn add_to_history(&mut self, _data: &str) {} 125 | 126 | fn save_history(&mut self) {} 127 | } 128 | -------------------------------------------------------------------------------- /src/util.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use num_bigint::BigInt; 16 | use num_complex::Complex; 17 | use num_rational::BigRational; 18 | use num_traits::{Signed, ToPrimitive, Zero}; 19 | use value::Value; 20 | 21 | /// Checks that a vector has at least `min`, at most `max` entries. 22 | // TODO this is not really idiomatic and should probably be made to return a boolean 23 | pub fn check_len(v: &[T], min: Option, max: Option) -> Result<(), String> { 24 | if let Some(m) = min { 25 | if v.len() < m { 26 | return Err(format!("too few values, expecting at least {}", m)); 27 | } 28 | }; 29 | if let Some(m) = max { 30 | if v.len() > m { 31 | return Err(format!("too many values, expecting at most {}", m)); 32 | } 33 | }; 34 | Ok(()) 35 | } 36 | 37 | pub fn parse_num(s: &str, base: u32) -> Result { 38 | if base > 36 { 39 | panic!("Invalid base {}.", base); 40 | } 41 | 42 | let mut r = 0_i64; 43 | let mut it = s.chars().peekable(); 44 | let reverse = it.peek() == Some(&'-'); 45 | if reverse { 46 | it.next(); 47 | } 48 | 49 | for d in it { 50 | let n = d.to_digit(base); 51 | if let Some(n) = n { 52 | r = r * i64::from(base) + i64::from(n); 53 | } else { 54 | return Err(format!("Invalid digit for base {}: {}", base, d)); 55 | } 56 | } 57 | 58 | if reverse { 59 | r = -r; 60 | } 61 | Ok(r) 62 | } 63 | 64 | pub fn str_to_char_vec(s: &str) -> Vec { 65 | s.chars().collect() 66 | } 67 | 68 | pub fn char_vec_to_str(v: &[char]) -> String { 69 | v.iter().collect() 70 | } 71 | 72 | pub fn escape_char(c: char) -> String { 73 | match c { 74 | '\x07' => "alarm".into(), 75 | '\x08' => "backspace".into(), 76 | '\x7F' => "delete".into(), 77 | '\x1B' => "escape".into(), 78 | '\n' => "newline".into(), 79 | '\0' => "null".into(), 80 | '\r' => "return".into(), 81 | ' ' => "space".into(), 82 | '\t' => "tab".into(), 83 | c => c.to_string(), 84 | } 85 | } 86 | 87 | pub fn escape_string(s: &str) -> String { 88 | let mut output = String::with_capacity(s.len()); 89 | for c in s.chars() { 90 | match c { 91 | '\x07' => output.push_str("\\a"), 92 | '\x08' => output.push_str("\\b"), 93 | '\t' => output.push_str("\\t"), 94 | '\n' => output.push_str("\\n"), 95 | '\r' => output.push_str("\\r"), 96 | '\"' => output.push_str("\\\""), 97 | '\\' => output.push_str("\\\\"), 98 | '|' => output.push_str("\\|"), 99 | _ => output.push(c), 100 | } 101 | } 102 | output 103 | } 104 | 105 | pub fn escape_symbol(s: &str) -> String { 106 | if s.is_ascii() { 107 | s.into() 108 | } else { 109 | format!("|{}|", s) 110 | } 111 | } 112 | 113 | pub fn rational_to_f64(v: &BigRational) -> f64 { 114 | v.to_f64().unwrap() 115 | } 116 | 117 | pub fn integer_to_float(v: &BigInt) -> f64 { 118 | v.to_f64().unwrap_or_else(|| { 119 | if v.is_positive() { 120 | std::f64::INFINITY 121 | } else { 122 | std::f64::NEG_INFINITY 123 | } 124 | }) 125 | } 126 | 127 | pub fn bigint_to_i64(b: &BigInt) -> i64 { 128 | let min_i64: BigInt = std::i64::MIN.into(); 129 | let max_i64: BigInt = std::i64::MAX.into(); 130 | let clamped = std::cmp::max(std::cmp::min(b, &max_i64), &min_i64); 131 | clamped.to_i64().unwrap() 132 | } 133 | 134 | /// Turns complex value with an exact zero imaginary part into reals, and integer rationals into 135 | /// proper integers. 136 | pub fn simplify_numeric(v: Value) -> Value { 137 | if !is_numeric(&v) { 138 | panic!("simplify_numeric called on non-numeric"); 139 | } 140 | 141 | let realified = match &v { 142 | Value::ComplexRational(x) if x.im.is_zero() => { 143 | Some(Value::Rational(Box::new(x.re.clone()))) 144 | } 145 | Value::ComplexInteger(x) if x.im.is_zero() => Some(Value::Integer(x.re.clone())), 146 | _ => None, 147 | } 148 | .unwrap_or(v); 149 | match &realified { 150 | Value::Rational(x) if x.is_integer() => Some(Value::Integer(x.to_integer())), 151 | Value::ComplexRational(x) => { 152 | if x.re.is_integer() && x.im.is_integer() { 153 | Some(Value::ComplexInteger(Box::new(Complex::new( 154 | x.re.to_integer(), 155 | x.im.to_integer(), 156 | )))) 157 | } else { 158 | None 159 | } 160 | } 161 | _ => None, 162 | } 163 | .unwrap_or(realified) 164 | } 165 | 166 | /// Checks that a value is numeric 167 | pub fn is_numeric(a: &Value) -> bool { 168 | matches!( 169 | a, 170 | Value::Integer(_) 171 | | Value::Rational(_) 172 | | Value::Real(_) 173 | | Value::ComplexInteger(_) 174 | | Value::ComplexRational(_) 175 | | Value::ComplexReal(_) 176 | ) 177 | } 178 | 179 | #[cfg(test)] 180 | mod tests { 181 | use super::*; 182 | 183 | #[test] 184 | fn test_parse_num() { 185 | assert_eq!(42, parse_num("101010", 2).unwrap()); 186 | assert_eq!(42, parse_num("2a", 16).unwrap()); 187 | assert_eq!(42, parse_num("42", 10).unwrap()); 188 | assert_eq!(-15, parse_num("-F", 16).unwrap()); 189 | } 190 | } 191 | -------------------------------------------------------------------------------- /src/value.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | use std::cell::{Cell, RefCell}; 16 | use std::fmt; 17 | 18 | use arena::Arena; 19 | use compile::CodeBlock; 20 | use environment::{ActivationFrame, RcEnv}; 21 | use heap::PoolPtr; 22 | use num_bigint::BigInt; 23 | use num_complex::Complex; 24 | use num_rational::BigRational; 25 | use primitives::{Port, Primitive, SyntacticClosure}; 26 | use vm::Continuation; 27 | use {heap, util}; 28 | 29 | // TODO box some of these, values are currently 56 bytes long oh no 30 | // TODO remove PartialEq and Clone. Clone should only be used in the numeric primitives library. 31 | // PartialEq is used in a number of unit / integ tests, but could be replaced with equal_p 32 | // from this file. 33 | #[derive(Debug, Clone, PartialEq)] 34 | pub enum Value { 35 | Undefined, 36 | Unspecific, 37 | EofObject, 38 | EmptyList, 39 | Real(f64), 40 | Integer(BigInt), 41 | Rational(Box), 42 | ComplexReal(Complex), 43 | ComplexInteger(Box>), 44 | ComplexRational(Box>), 45 | Boolean(bool), 46 | Character(char), 47 | Symbol(String), 48 | String(RefCell), 49 | Pair(Cell, Cell), 50 | ByteVector(RefCell>), 51 | Vector(RefCell>), 52 | Lambda { code: PoolPtr, frame: PoolPtr }, 53 | Port(Box), 54 | Primitive(&'static Primitive), 55 | ActivationFrame(RefCell), 56 | Environment(RcEnv), 57 | SyntacticClosure(SyntacticClosure), 58 | Continuation(Continuation), 59 | CodeBlock(Box), 60 | } 61 | 62 | impl fmt::Display for Value { 63 | fn fmt(&self, f: &mut fmt::Formatter) -> fmt::Result { 64 | match self { 65 | Value::Undefined => write!(f, "#undefined"), 66 | Value::Unspecific => write!(f, "#unspecific"), 67 | Value::EofObject => write!(f, "#eof-object"), 68 | Value::EmptyList => write!(f, "()"), 69 | Value::Real(r) => write!(f, "{}", r), 70 | Value::Integer(i) => write!(f, "{}", i), 71 | Value::Rational(r) => write!(f, "{}", r), 72 | Value::ComplexReal(c) => write!(f, "{}", c), 73 | Value::ComplexInteger(c) => write!(f, "{}", c), 74 | Value::ComplexRational(c) => write!(f, "{}", c), 75 | Value::Boolean(true) => write!(f, "#t"), 76 | Value::Boolean(false) => write!(f, "#f"), 77 | Value::Character('\n') => write!(f, "#\\newline"), 78 | Value::Character(c) => write!(f, "#\\{}", util::escape_char(*c)), 79 | Value::Symbol(s) => write!(f, "{}", util::escape_symbol(s)), 80 | Value::String(s) => write!(f, "\"{}\"", util::escape_string(&s.borrow())), 81 | Value::Pair(a, b) => write!(f, "({} . {})", &*a.get(), &*b.get()), 82 | Value::ByteVector(bv) => { 83 | let contents = bv 84 | .borrow() 85 | .iter() 86 | .map(|v| format!("{}", v)) 87 | .collect::>() 88 | .join(" "); 89 | write!(f, "#u8({})", contents) 90 | } 91 | Value::Vector(values) => { 92 | let contents = values 93 | .borrow() 94 | .iter() 95 | .map(|v| format!("=>{:?}", v)) 96 | .collect::>() 97 | .join(" "); 98 | write!(f, "#({})", contents) 99 | } 100 | Value::Environment(rce) => write!(f, "{:?}", rce.borrow()), 101 | e => write!(f, "{:?}", e), 102 | } 103 | } 104 | } 105 | 106 | impl heap::Inventory for Value { 107 | fn inventory(&self, v: &mut heap::PtrVec) { 108 | match self { 109 | Value::Pair(car, cdr) => { 110 | v.push(car.get()); 111 | v.push(cdr.get()); 112 | } 113 | Value::Vector(vals) => { 114 | for val in vals.borrow().iter() { 115 | v.push(*val); 116 | } 117 | } 118 | Value::Lambda { code, frame } => { 119 | v.push(*code); 120 | v.push(*frame); 121 | } 122 | Value::ActivationFrame(af) => { 123 | let f = af.borrow(); 124 | if let Some(p) = f.parent { 125 | v.push(p) 126 | }; 127 | for val in f.values.iter() { 128 | v.push(*val) 129 | } 130 | } 131 | Value::SyntacticClosure(sc) => { 132 | v.push(sc.expr); 133 | v.push(*sc.closed_env.borrow()); 134 | } 135 | Value::Port(p) => p.inventory(v), 136 | Value::Continuation(c) => c.inventory(v), 137 | Value::CodeBlock(c) => c.inventory(v), 138 | _ => (), 139 | } 140 | } 141 | } 142 | 143 | impl Value { 144 | pub fn pretty_print(&self) -> String { 145 | match self { 146 | Value::Pair(_, _) => self.print_pair(), 147 | Value::Vector(_) => self.print_vector(), 148 | Value::SyntacticClosure(SyntacticClosure { 149 | closed_env, 150 | free_variables, 151 | expr, 152 | }) => format!( 153 | "#sc[{} {:?} {}]", 154 | closed_env.borrow().pretty_print(), 155 | free_variables, 156 | expr.pretty_print() 157 | ), 158 | Value::Continuation(_) => "#".to_string(), 159 | Value::Lambda { code, .. } => match &code.get_code_block().name { 160 | Some(n) => format!("#", n), 161 | None => "#".to_string(), 162 | }, 163 | Value::Primitive(p) => format!("#", p.name), 164 | _ => format!("{}", self), 165 | } 166 | } 167 | 168 | fn print_pair(&self) -> String { 169 | fn _print_pair(p: &Value, s: &mut String) { 170 | match p { 171 | Value::Pair(a, b) => { 172 | s.push_str(&a.get().pretty_print()[..]); 173 | if let Value::EmptyList = &*b.get() { 174 | s.push(')'); 175 | } else { 176 | s.push(' '); 177 | _print_pair(&*b.get(), s); 178 | } 179 | } 180 | Value::EmptyList => { 181 | s.push(')'); 182 | } 183 | _ => { 184 | s.push_str(&format!(". {})", p)[..]); 185 | } 186 | } 187 | } 188 | 189 | match self { 190 | Value::Pair(_, _) | Value::EmptyList => { 191 | let mut s = "(".to_string(); 192 | _print_pair(self, &mut s); 193 | s 194 | } 195 | _ => panic!( 196 | "print_pair called on a value that is not a pair: {:?}.", 197 | self 198 | ), 199 | } 200 | } 201 | 202 | fn print_vector(&self) -> String { 203 | if let Value::Vector(vals) = self { 204 | let contents = vals 205 | .borrow() 206 | .iter() 207 | .map(|e| e.pretty_print()) 208 | .collect::>() 209 | .join(" "); 210 | format!("#({})", contents) 211 | } else { 212 | panic!( 213 | "print_vector called on a value that is not a vector: {:?}.", 214 | self 215 | ) 216 | } 217 | } 218 | 219 | pub fn list_to_vec(&self) -> Result, String> { 220 | let mut p = self; 221 | let mut result: Vec = Vec::new(); 222 | loop { 223 | match p { 224 | Value::Pair(car_r, cdr_r) => { 225 | result.push(car_r.get()); 226 | p = cdr_r.get().long_lived(); 227 | } 228 | Value::EmptyList => break, 229 | _ => { 230 | return Err(format!( 231 | "Converting list to vec: {} is not a proper list", 232 | self.pretty_print() 233 | )); 234 | } 235 | } 236 | } 237 | Ok(result) 238 | } 239 | 240 | pub fn truthy(&self) -> bool { 241 | if let Value::Boolean(b) = self { 242 | *b 243 | } else { 244 | true 245 | } 246 | } 247 | 248 | pub fn get_activation_frame(&self) -> &RefCell { 249 | match self { 250 | Value::ActivationFrame(af) => af, 251 | _ => panic!("value is not an activation frame"), 252 | } 253 | } 254 | 255 | pub fn get_code_block(&self) -> &CodeBlock { 256 | match self { 257 | Value::CodeBlock(c) => c, 258 | _ => panic!("value is not a code block"), 259 | } 260 | } 261 | 262 | // TODO make this less verbose with a macro? 263 | pub fn try_get_integer(&self) -> Option<&BigInt> { 264 | match self { 265 | Value::Integer(i) => Some(i), 266 | _ => None, 267 | } 268 | } 269 | 270 | pub fn try_get_character(&self) -> Option { 271 | match self { 272 | Value::Character(c) => Some(*c), 273 | _ => None, 274 | } 275 | } 276 | 277 | pub fn try_get_string(&self) -> Option<&RefCell> { 278 | match self { 279 | Value::String(s) => Some(s), 280 | _ => None, 281 | } 282 | } 283 | 284 | pub fn try_get_vector(&self) -> Option<&RefCell>> { 285 | match self { 286 | Value::Vector(v) => Some(v), 287 | _ => None, 288 | } 289 | } 290 | 291 | pub fn try_get_symbol(&self) -> Option<&str> { 292 | match self { 293 | Value::Symbol(s) => Some(s), 294 | _ => None, 295 | } 296 | } 297 | 298 | pub fn try_get_pair(&self) -> Option<(&Cell, &Cell)> { 299 | match self { 300 | Value::Pair(car, cdr) => Some((car, cdr)), 301 | _ => None, 302 | } 303 | } 304 | 305 | pub fn try_get_environment(&self) -> Option<&RcEnv> { 306 | match self { 307 | Value::Environment(r) => Some(r), 308 | _ => None, 309 | } 310 | } 311 | 312 | pub fn try_get_syntactic_closure(&self) -> Option<&SyntacticClosure> { 313 | match self { 314 | Value::SyntacticClosure(sc) => Some(sc), 315 | _ => None, 316 | } 317 | } 318 | 319 | pub fn try_get_port(&self) -> Option<&Port> { 320 | match self { 321 | Value::Port(p) => Some(p), 322 | _ => None, 323 | } 324 | } 325 | } 326 | 327 | pub fn list_from_vec(arena: &Arena, vals: &[PoolPtr]) -> PoolPtr { 328 | if vals.is_empty() { 329 | arena.empty_list 330 | } else { 331 | let rest = arena.root(list_from_vec(arena, &vals[1..])); 332 | arena.insert(Value::Pair(Cell::new(vals[0]), Cell::new(rest.pp()))) 333 | } 334 | } 335 | 336 | pub fn eqv(left: PoolPtr, right: PoolPtr) -> bool { 337 | match (&*left, &*right) { 338 | // This comparison is in the same order as the R5RS one for ease of 339 | // verification. 340 | (Value::Boolean(a), Value::Boolean(b)) => a == b, 341 | (Value::Symbol(a), Value::Symbol(b)) => a == b, 342 | (Value::Integer(a), Value::Integer(b)) => a == b, 343 | (Value::Real(a), Value::Real(b)) => (a - b).abs() < std::f64::EPSILON, 344 | (Value::Character(a), Value::Character(b)) => a == b, 345 | (Value::EmptyList, Value::EmptyList) => true, 346 | (Value::Pair(_, _), Value::Pair(_, _)) => left == right, 347 | (Value::Vector(_), Value::Vector(_)) => left == right, 348 | (Value::String(_), Value::String(_)) => left == right, 349 | (Value::Lambda { .. }, Value::Lambda { .. }) => left == right, 350 | _ => false, 351 | } 352 | } 353 | 354 | //TODO should not loop on recursive data (R7RS) 355 | pub fn equal(left: PoolPtr, right: PoolPtr) -> bool { 356 | match (&*left, &*right) { 357 | (Value::Pair(left_car, left_cdr), Value::Pair(right_car, right_cdr)) => { 358 | equal(left_car.get(), right_car.get()) && equal(left_cdr.get(), right_cdr.get()) 359 | } 360 | (Value::Vector(left_vec), Value::Vector(right_vec)) => left_vec 361 | .borrow() 362 | .iter() 363 | .zip(right_vec.borrow().iter()) 364 | .all(|(l, r)| equal(*l, *r)), 365 | (Value::String(left_string), Value::String(right_string)) => left_string == right_string, 366 | _ => eqv(left, right), 367 | } 368 | } 369 | 370 | #[cfg(test)] 371 | mod tests { 372 | use super::*; 373 | 374 | #[test] 375 | fn format_atoms() { 376 | assert_eq!("3.45", &format!("{}", Value::Real(3.45))); 377 | assert_eq!("69105", &format!("{}", Value::Integer(69105.into()))); 378 | assert_eq!("#f", &format!("{}", Value::Boolean(false))); 379 | assert_eq!("#t", &format!("{}", Value::Boolean(true))); 380 | assert_eq!("#\\newline", &format!("{}", Value::Character('\n'))); 381 | assert_eq!("#\\x", &format!("{}", Value::Character('x'))); 382 | assert_eq!("abc", &format!("{}", Value::Symbol("abc".to_string()))); 383 | assert_eq!( 384 | "\"abc\"", 385 | &format!("{}", Value::String(RefCell::new("abc".to_string()))) 386 | ); 387 | } 388 | } 389 | -------------------------------------------------------------------------------- /tests/integration_tests.rs: -------------------------------------------------------------------------------- 1 | // Copyright 2018-2020 Matthieu Felix 2 | // 3 | // Licensed under the Apache License, Version 2.0 (the "License"); 4 | // you may not use this file except in compliance with the License. 5 | // You may obtain a copy of the License at 6 | // 7 | // https://www.apache.org/licenses/LICENSE-2.0 8 | // 9 | // Unless required by applicable law or agreed to in writing, software 10 | // distributed under the License is distributed on an "AS IS" BASIS, 11 | // WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | // See the License for the specific language governing permissions and 13 | // limitations under the License. 14 | 15 | extern crate peroxide; 16 | 17 | use peroxide::heap::{GcMode, RootPtr}; 18 | use peroxide::read::read_many; 19 | use peroxide::value::Value; 20 | use peroxide::Interpreter; 21 | 22 | fn execute(vm_state: &Interpreter, code: &str) -> Result { 23 | execute_rooted(vm_state, code).map(|e| (*e.pp()).clone()) 24 | } 25 | 26 | fn execute_rooted(vm_state: &Interpreter, code: &str) -> Result { 27 | let mut results: Vec<_> = read_many(&vm_state.arena, code)? 28 | .into_iter() 29 | .map(|read| vm_state.parse_compile_run(read)) 30 | .collect::, _>>()?; 31 | results.pop().ok_or("no expressions".into()) 32 | } 33 | 34 | fn execute_to_vec(vm_state: &Interpreter, code: &str) -> Result, String> { 35 | let val = execute_rooted(vm_state, code)?; 36 | let vec = val.pp().list_to_vec()?; 37 | Ok(vec.iter().map(|&iv| (*iv).clone()).collect()) 38 | } 39 | 40 | fn magic_execute(code: &str, init: bool) -> Result { 41 | let interpreter = make_interpreter(init); 42 | // execute(&interpreter.arena, &mut vms, code) 43 | execute(&interpreter, code) 44 | } 45 | 46 | fn magic_execute_to_vec(code: &str, init: bool) -> Result, String> { 47 | let interpreter = make_interpreter(init); 48 | execute_to_vec(&interpreter, code) 49 | } 50 | 51 | fn make_interpreter(init: bool) -> Interpreter { 52 | let interpreter = Interpreter::new(GcMode::Normal); 53 | if init { 54 | interpreter.initialize("src/scheme-lib/init.scm").unwrap(); 55 | } 56 | interpreter 57 | } 58 | 59 | #[test] 60 | fn it_adds_two() { 61 | assert_eq!( 62 | Value::Integer(4.into()), 63 | magic_execute("(+ 2 2)", false).unwrap() 64 | ); 65 | } 66 | 67 | #[test] 68 | fn nested_add() { 69 | assert_eq!( 70 | Value::Integer(2.into()), 71 | magic_execute("(+ (+ 1 1 1) (- 1 2))", false).unwrap() 72 | ); 73 | } 74 | 75 | #[test] 76 | fn immediate_lambda_args() { 77 | assert_eq!( 78 | Value::Integer(1.into()), 79 | magic_execute("((lambda (x) x) 1)", false).unwrap() 80 | ); 81 | } 82 | 83 | #[test] 84 | fn immediate_lambda_noargs() { 85 | assert_eq!( 86 | Value::Integer(1.into()), 87 | magic_execute("((lambda () 1))", false).unwrap() 88 | ); 89 | } 90 | 91 | #[test] 92 | fn shadow() { 93 | assert_eq!( 94 | Value::Symbol("inner".into()), 95 | magic_execute("((lambda (x) ((lambda (x) x) 'inner)) 'outer)", false).unwrap() 96 | ); 97 | } 98 | 99 | #[test] 100 | fn several_args() { 101 | assert_eq!( 102 | vec![ 103 | Value::Integer(1.into()), 104 | Value::Integer(2.into()), 105 | Value::Integer(3.into()) 106 | ], 107 | magic_execute_to_vec( 108 | "(define (list . vals) vals)\ 109 | ((lambda (x y z) (list x y z)) 1 2 3)", 110 | false 111 | ) 112 | .unwrap() 113 | ); 114 | } 115 | 116 | #[test] 117 | fn dotted() { 118 | assert_eq!( 119 | vec![ 120 | Value::Integer(1.into()), 121 | Value::Integer(2.into()), 122 | Value::Integer(3.into()) 123 | ], 124 | magic_execute_to_vec( 125 | "(define (list . vals) vals)\ 126 | ((lambda (x y z) (list x y z)) 1 2 3)", 127 | false 128 | ) 129 | .unwrap() 130 | ); 131 | } 132 | 133 | #[test] 134 | fn global_reference() { 135 | assert_eq!( 136 | Value::Boolean(true), 137 | magic_execute("(define x #t) x", false).unwrap() 138 | ); 139 | } 140 | 141 | #[test] 142 | fn replace_global_reference() { 143 | assert_eq!( 144 | Value::Boolean(false), 145 | magic_execute("(define x #t) (define x #f) x", false).unwrap() 146 | ); 147 | } 148 | 149 | #[test] 150 | fn set_global_reference() { 151 | assert_eq!( 152 | Value::Boolean(false), 153 | magic_execute("(define x #t) (set! x #f) x", false).unwrap() 154 | ); 155 | } 156 | 157 | #[test] 158 | fn forward_global_reference() { 159 | assert_eq!( 160 | Value::Integer(5.into()), 161 | magic_execute( 162 | "(define (print-x) x)\ 163 | (define x 5)\ 164 | (print-x)", 165 | false 166 | ) 167 | .unwrap() 168 | ); 169 | } 170 | 171 | #[test] 172 | fn mut_rec() { 173 | assert_eq!( 174 | Value::Boolean(true), 175 | magic_execute( 176 | "(define (odd? x) (if (= x 0) #f (even? (- x 1))))\ 177 | (define (even? x) (if (= x 0) #t (odd? (- x 1))))\ 178 | (odd? 10001)", 179 | false 180 | ) 181 | .unwrap() 182 | ); 183 | } 184 | 185 | #[test] 186 | fn set_local() { 187 | assert_eq!( 188 | Value::Integer(2.into()), 189 | magic_execute( 190 | "(define x 2)\ 191 | ((lambda (x)\ 192 | (set! x 3)\ 193 | x) 1)\ 194 | x", 195 | false 196 | ) 197 | .unwrap() 198 | ); 199 | } 200 | 201 | #[test] 202 | fn set_local2() { 203 | assert_eq!( 204 | Value::Integer(3.into()), 205 | magic_execute( 206 | "(define x 2)\ 207 | ((lambda (x)\ 208 | (set! x 3)\ 209 | x) 1)", 210 | false 211 | ) 212 | .unwrap() 213 | ); 214 | } 215 | 216 | #[test] 217 | fn close_env() { 218 | assert_eq!( 219 | vec![Value::Integer(26.into()), Value::Integer((-5).into())], 220 | magic_execute_to_vec( 221 | "(define (list . args) args)\ 222 | (define (make-counter init-value)\ 223 | ((lambda (counter-value)\ 224 | (lambda (increment)\ 225 | (set! counter-value (+ counter-value increment))\ 226 | counter-value))\ 227 | init-value))\ 228 | (define counter1 (make-counter 5))\ 229 | (define counter2 (make-counter -5)) 230 | (counter1 3)\ 231 | (counter1 18)\ 232 | (list (counter1 0) (counter2 0))", 233 | false 234 | ) 235 | .unwrap() 236 | ); 237 | } 238 | 239 | #[test] 240 | fn rename_keyword() { 241 | assert_eq!( 242 | Value::Boolean(false), 243 | magic_execute("(define (set!) #f) (set!)", false).unwrap() 244 | ); 245 | } 246 | 247 | #[test] 248 | fn internal_define() { 249 | assert_eq!( 250 | Value::Integer(5.into()), 251 | magic_execute( 252 | "((lambda ()\ 253 | (define x 5)\ 254 | x))", 255 | false 256 | ) 257 | .unwrap() 258 | ); 259 | } 260 | 261 | #[test] 262 | fn apply() { 263 | assert_eq!( 264 | Value::Integer(5.into()), 265 | magic_execute("(apply + (apply - '(2 3)) '(6))", false).unwrap() 266 | ); 267 | } 268 | 269 | #[test] 270 | fn syntactic_closure() { 271 | assert_eq!( 272 | Value::Symbol("outer".into()), 273 | magic_execute( 274 | "(define x 'outer)\ 275 | (define-syntax tst\ 276 | (lambda (form usage-env def-env)\ 277 | (define outer-x (make-syntactic-closure def-env '() 'x))\ 278 | outer-x))\ 279 | ((lambda (x)\ 280 | (tst)) 'inner)", 281 | true 282 | ) 283 | .unwrap() 284 | ); 285 | } 286 | 287 | #[test] 288 | fn let_syntax() { 289 | assert_eq!( 290 | Value::Symbol("outer".into()), 291 | magic_execute( 292 | "(define x 'outer)\ 293 | (let-syntax ((tst\ 294 | (lambda (form usage-env def-env)\ 295 | (define outer-x (make-syntactic-closure def-env '() 'x))\ 296 | outer-x)))\ 297 | ((lambda (x)\ 298 | (tst)) 'inner))", 299 | true 300 | ) 301 | .unwrap() 302 | ); 303 | } 304 | 305 | #[test] 306 | fn cond1() { 307 | assert_eq!( 308 | Value::Symbol("greater".into()), 309 | magic_execute( 310 | "(cond ((> 3 2) 'greater) 311 | ((< 3 2) 'less))", 312 | true 313 | ) 314 | .unwrap() 315 | ); 316 | } 317 | 318 | #[test] 319 | fn cond2() { 320 | assert_eq!( 321 | Value::Symbol("equal".into()), 322 | magic_execute( 323 | "(cond ((> 3 3) 'greater) 324 | ((< 3 3) 'less) 325 | (else 'equal))", 326 | true 327 | ) 328 | .unwrap() 329 | ); 330 | } 331 | 332 | #[test] 333 | fn cond3() { 334 | assert_eq!( 335 | Value::Integer(2.into()), 336 | magic_execute( 337 | "(cond ((assv 'b '((a 1) (b 2))) => cadr)\ 338 | (else #f))", 339 | true 340 | ) 341 | .unwrap() 342 | ); 343 | } 344 | 345 | #[test] 346 | fn cond4() { 347 | assert_eq!( 348 | Value::Symbol("not-one".into()), 349 | magic_execute( 350 | "((lambda (x) (cond ((= x 1) 'one) (else 'not-one))) 2)", 351 | true 352 | ) 353 | .unwrap() 354 | ); 355 | } 356 | 357 | #[test] 358 | fn and() { 359 | assert_eq!( 360 | vec![ 361 | Value::Boolean(true), 362 | Value::Boolean(false), 363 | Value::Integer(4.into()), 364 | Value::Boolean(true) 365 | ], 366 | magic_execute_to_vec( 367 | "(list\ 368 | (and (= 2 2) (> 2 1))\ 369 | (and (= 2 2) (< 2 1))\ 370 | (and 1 2 3 4)\ 371 | (and))", 372 | true 373 | ) 374 | .unwrap() 375 | ); 376 | } 377 | 378 | #[test] 379 | fn or() { 380 | assert_eq!( 381 | vec![ 382 | Value::Boolean(true), 383 | Value::Boolean(false), 384 | Value::Integer(1.into()), 385 | Value::Boolean(false) 386 | ], 387 | magic_execute_to_vec( 388 | "(list\ 389 | (or (= 2 2) (< 2 1))\ 390 | (or (= 3 2) (< 2 1))\ 391 | (or 1 2 3 4)\ 392 | (or))", 393 | true 394 | ) 395 | .unwrap() 396 | ); 397 | } 398 | 399 | #[test] 400 | fn call_cc() { 401 | assert_eq!( 402 | Value::Integer((-4).into()), 403 | magic_execute( 404 | "(call/cc (lambda (exit)\ 405 | (for-each (lambda (x) (if (< x 0) (exit x))) '(1 2 3 -4 5 6))))", 406 | true 407 | ) 408 | .unwrap() 409 | ); 410 | } 411 | 412 | #[test] 413 | fn do_macro() { 414 | assert_eq!( 415 | Value::Integer(5.into()), 416 | magic_execute( 417 | "(do ((i 0 (+ i 1))) 418 | ((= i 5) i) 419 | (display i))", 420 | true 421 | ) 422 | .unwrap() 423 | ); 424 | } 425 | 426 | #[test] 427 | fn eval() { 428 | assert_eq!( 429 | Value::Integer(20.into()), 430 | magic_execute( 431 | "(let ((f (eval '(lambda (f x) (f x x)) (null-environment 5)))) (f + 10))", 432 | true 433 | ) 434 | .unwrap() 435 | ); 436 | } 437 | 438 | #[test] 439 | fn check_arity() { 440 | assert!(magic_execute("((lambda (x) x))", false).is_err()); 441 | assert!(magic_execute("(call/cc)", true).is_err()); 442 | assert!(magic_execute("((syntax-rules -1))", true).is_err()); 443 | } 444 | -------------------------------------------------------------------------------- /tests/scheme/r5rs-tests.scm: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009-2018 Alex Shinn 2 | ;; All rights reserved. 3 | ;; 4 | ;; Redistribution and use in source and binary forms, with or without 5 | ;; modification, are permitted provided that the following conditions 6 | ;; are met: 7 | ;; 1. Redistributions of source code must retain the above copyright 8 | ;; notice, this list of conditions and the following disclaimer. 9 | ;; 2. Redistributions in binary form must reproduce the above copyright 10 | ;; notice, this list of conditions and the following disclaimer in the 11 | ;; documentation and/or other materials provided with the distribution. 12 | ;; 3. The name of the author may not be used to endorse or promote products 13 | ;; derived from this software without specific prior written permission. 14 | ;; 15 | ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | ;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | 27 | (define *tests-run* 0) 28 | (define *tests-passed* 0) 29 | 30 | (define-syntax test 31 | (syntax-rules () 32 | ((test name expect expr) 33 | (test expect expr)) 34 | ((test expect expr) 35 | (begin 36 | (set! *tests-run* (+ *tests-run* 1)) 37 | (let ((res expr)) 38 | (display *tests-run* ". " 'expr) 39 | (cond 40 | ((equal? res expect) 41 | (set! *tests-passed* (+ *tests-passed* 1)) 42 | (display " [PASS]\n")) 43 | (else 44 | (display " [FAIL]\n") 45 | (display " expected " expect) 46 | (display " but got " res "\n")))))))) 47 | 48 | (define-syntax test-assert 49 | (syntax-rules () 50 | ((test-assert expr) (test #t expr)))) 51 | 52 | (define (test-begin . name) 53 | #f) 54 | 55 | (define (test-end) 56 | (write *tests-passed*) 57 | (display " out of ") 58 | (write *tests-run*) 59 | (display " passed (") 60 | (write (* (/ *tests-passed* *tests-run*) 100.0)) 61 | (display "%)") 62 | (newline)) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | 66 | (test-begin "r5rs") 67 | 68 | (test 8 ((lambda (x) (+ x x)) 4)) 69 | 70 | (test '(3 4 5 6) ((lambda x x) 3 4 5 6)) 71 | 72 | (test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) 73 | 74 | (test 'yes (if (> 3 2) 'yes 'no)) 75 | 76 | (test 'no (if (> 2 3) 'yes 'no)) 77 | 78 | (test 1 (if (> 3 2) (- 3 2) (+ 3 2))) 79 | 80 | (test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) 81 | 82 | (test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) 83 | 84 | (test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) 85 | 86 | (test 'consonant 87 | (case (car '(c d)) 88 | ((a e i o u) 'vowel) 89 | ((w y) 'semivowel) 90 | (else 'consonant))) 91 | 92 | (test #t (and (= 2 2) (> 2 1))) 93 | 94 | (test #f (and (= 2 2) (< 2 1))) 95 | 96 | (test '(f g) (and 1 2 'c '(f g))) 97 | 98 | (test #t (and)) 99 | 100 | (test #t (or (= 2 2) (> 2 1))) 101 | 102 | (test #t (or (= 2 2) (< 2 1))) 103 | 104 | (test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) 105 | 106 | (test 6 (let ((x 2) (y 3)) (* x y))) 107 | 108 | (test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) 109 | 110 | (test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) 111 | 112 | (test -2 (let () 113 | (define x 2) 114 | (define f (lambda () (- x))) 115 | (f))) 116 | 117 | (define let*-def 1) 118 | (let* () (define let*-def 2) #f) 119 | (test 1 let*-def) 120 | 121 | (test '#(0 1 2 3 4) 122 | (do ((vec (make-vector 5)) 123 | (i 0 (+ i 1))) 124 | ((= i 5) vec) 125 | (vector-set! vec i i))) 126 | 127 | (test 25 128 | (let ((x '(1 3 5 7 9))) 129 | (do ((x x (cdr x)) 130 | (sum 0 (+ sum (car x)))) 131 | ((null? x) 132 | sum)))) 133 | 134 | (test '((6 1 3) (-5 -2)) 135 | (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) 136 | (cond 137 | ((null? numbers) 138 | (list nonneg neg)) 139 | ((>= (car numbers) 0) 140 | (loop (cdr numbers) (cons (car numbers) nonneg) neg)) 141 | ((< (car numbers) 0) 142 | (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) 143 | 144 | (test '(list 3 4) `(list ,(+ 1 2) 4)) 145 | 146 | (test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) 147 | 148 | (test '(a 3 4 5 6 b) 149 | `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) 150 | 151 | (test '(10 5 4 16 9 8) 152 | `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8)) 153 | 154 | (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) 155 | `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) 156 | 157 | (test '(a `(b ,x ,'y d) e) 158 | (let ((name1 'x) 159 | (name2 'y)) 160 | `(a `(b ,,name1 ,',name2 d) e))) 161 | 162 | (test '(list 3 4) 163 | (quasiquote (list (unquote (+ 1 2)) 4))) 164 | 165 | (test #t (eqv? 'a 'a)) 166 | 167 | (test #f (eqv? 'a 'b)) 168 | 169 | (test #t (eqv? '() '())) 170 | 171 | (test #f (eqv? (cons 1 2) (cons 1 2))) 172 | 173 | (test #f (eqv? (lambda () 1) (lambda () 2))) 174 | 175 | (test #t (let ((p (lambda (x) x))) (eqv? p p))) 176 | 177 | (test #t (eq? 'a 'a)) 178 | 179 | (test #f (eq? (list 'a) (list 'a))) 180 | 181 | (test #t (eq? '() '())) 182 | 183 | (test #t (eq? car car)) 184 | 185 | (test #t (let ((x '(a))) (eq? x x))) 186 | 187 | (test #t (let ((p (lambda (x) x))) (eq? p p))) 188 | 189 | (test #t (equal? 'a 'a)) 190 | 191 | (test #t (equal? '(a) '(a))) 192 | 193 | (test #t (equal? '(a (b) c) '(a (b) c))) 194 | 195 | (test #t (equal? "abc" "abc")) 196 | 197 | (test #f (equal? "abc" "abcd")) 198 | 199 | (test #f (equal? "a" "b")) 200 | 201 | (test #t (equal? 2 2)) 202 | 203 | ;;(test #f (eqv? 2 2.0)) 204 | 205 | ;;(test #f (equal? 2.0 2)) 206 | 207 | (test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) 208 | 209 | (test 4 (max 3 4)) 210 | 211 | ;;(test 4 (max 3.9 4)) 212 | 213 | (test 7 (+ 3 4)) 214 | 215 | (test 3 (+ 3)) 216 | 217 | (test 0 (+)) 218 | 219 | (test 4 (* 4)) 220 | 221 | (test 1 (*)) 222 | 223 | (test -1 (- 3 4)) 224 | 225 | (test -6 (- 3 4 5)) 226 | 227 | (test -3 (- 3)) 228 | 229 | (test -1.0 (- 3.0 4)) 230 | 231 | (test 7 (abs -7)) 232 | 233 | (test 1 (modulo 13 4)) 234 | 235 | (test 1 (remainder 13 4)) 236 | 237 | (test 3 (modulo -13 4)) 238 | 239 | (test -1 (remainder -13 4)) 240 | 241 | (test -3 (modulo 13 -4)) 242 | 243 | (test 1 (remainder 13 -4)) 244 | 245 | (test -1 (modulo -13 -4)) 246 | 247 | (test -1 (remainder -13 -4)) 248 | 249 | (test 4 (gcd 32 -36)) 250 | 251 | (test 288 (lcm 32 -36)) 252 | 253 | (test 100 (string->number "100")) 254 | 255 | (test 255 (string->number "FF" 16)) 256 | 257 | (test 255 (string->number "ff" 16)) 258 | 259 | (test 256 (string->number "100" 16)) 260 | 261 | (test 127 (string->number "177" 8)) 262 | 263 | (test 5 (string->number "101" 2)) 264 | 265 | (test 100.0 (string->number "1e2")) 266 | 267 | (test "100" (number->string 100)) 268 | 269 | (test "100" (number->string 256 16)) 270 | 271 | (test "ff" (number->string 255 16)) 272 | 273 | (test "177" (number->string 127 8)) 274 | 275 | (test "101" (number->string 5 2)) 276 | 277 | (test #f (not 3)) 278 | 279 | (test #f (not (list 3))) 280 | 281 | (test #f (not '())) 282 | 283 | (test #f (not (list))) 284 | 285 | (test #f (not '())) 286 | 287 | (test #f (boolean? 0)) 288 | 289 | (test #f (boolean? '())) 290 | 291 | (test #t (pair? '(a . b))) 292 | 293 | (test #t (pair? '(a b c))) 294 | 295 | (test '(a) (cons 'a '())) 296 | 297 | (test '((a) b c d) (cons '(a) '(b c d))) 298 | 299 | (test '("a" b c) (cons "a" '(b c))) 300 | 301 | (test '(a . 3) (cons 'a 3)) 302 | 303 | (test '((a b) . c) (cons '(a b) 'c)) 304 | 305 | (test 'a (car '(a b c))) 306 | 307 | (test '(a) (car '((a) b c d))) 308 | 309 | (test 1 (car '(1 . 2))) 310 | 311 | (test '(b c d) (cdr '((a) b c d))) 312 | 313 | (test 2 (cdr '(1 . 2))) 314 | 315 | (test #t (list? '(a b c))) 316 | 317 | (test #t (list? '())) 318 | 319 | (test #f (list? '(a . b))) 320 | 321 | ;(test #f 322 | ; (let ((x (list 'a))) 323 | ; (set-cdr! x x) 324 | ; (list? x))) 325 | 326 | (test '(a 7 c) (list 'a (+ 3 4) 'c)) 327 | 328 | (test '() (list)) 329 | 330 | (test 3 (length '(a b c))) 331 | 332 | (test 3 (length '(a (b) (c d e)))) 333 | 334 | (test 0 (length '())) 335 | 336 | (test '(x y) (append '(x) '(y))) 337 | 338 | (test '(a b c d) (append '(a) '(b c d))) 339 | 340 | (test '(a (b) (c)) (append '(a (b)) '((c)))) 341 | 342 | (test '(a b c . d) (append '(a b) '(c . d))) 343 | 344 | (test 'a (append '() 'a)) 345 | 346 | (test '(c b a) (reverse '(a b c))) 347 | 348 | (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) 349 | 350 | (test 'c (list-ref '(a b c d) 2)) 351 | 352 | (test '(a b c) (memq 'a '(a b c))) 353 | 354 | (test '(b c) (memq 'b '(a b c))) 355 | 356 | (test #f (memq 'a '(b c d))) 357 | 358 | (test #f (memq (list 'a) '(b (a) c))) 359 | 360 | (test '((a) c) (member (list 'a) '(b (a) c))) 361 | 362 | (test '(101 102) (memv 101 '(100 101 102))) 363 | 364 | (test #f (assq (list 'a) '(((a)) ((b)) ((c))))) 365 | 366 | (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) 367 | 368 | (test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) 369 | 370 | (test #t (symbol? 'foo)) 371 | 372 | (test #t (symbol? (car '(a b)))) 373 | 374 | (test #f (symbol? "bar")) 375 | 376 | (test #t (symbol? 'nil)) 377 | 378 | (test #f (symbol? '())) 379 | 380 | (test "flying-fish" (symbol->string 'flying-fish)) 381 | 382 | (test "martin" (symbol->string 'Martin)) 383 | 384 | (test "Malvina" (symbol->string (string->symbol "Malvina"))) 385 | 386 | (test #t (string? "a")) 387 | 388 | (test #f (string? 'a)) 389 | 390 | (test 0 (string-length "")) 391 | 392 | (test 3 (string-length "abc")) 393 | 394 | (test #\a (string-ref "abc" 0)) 395 | 396 | (test #\c (string-ref "abc" 2)) 397 | 398 | (test #t (string=? "a" (string #\a))) 399 | 400 | (test #f (string=? "a" (string #\b))) 401 | 402 | (test #t (stringlist '#(dah dah didah))) 434 | 435 | (test '#(dididit dah) (list->vector '(dididit dah))) 436 | 437 | (test #t (procedure? car)) 438 | 439 | (test #f (procedure? 'car)) 440 | 441 | (test #t (procedure? (lambda (x) (* x x)))) 442 | 443 | (test #f (procedure? '(lambda (x) (* x x)))) 444 | 445 | (test #t (call-with-current-continuation procedure?)) 446 | 447 | (test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) 448 | 449 | (test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) 450 | 451 | (test 7 (apply + (list 3 4))) 452 | 453 | (test '(b e h) (map cadr '((a b) (d e) (g h)))) 454 | 455 | (test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) 456 | 457 | (test '(5 7 9) (map + '(1 2 3) '(4 5 6))) 458 | 459 | (test '#(0 1 4 9 16) 460 | (let ((v (make-vector 5))) 461 | (for-each 462 | (lambda (i) (vector-set! v i (* i i))) 463 | '(0 1 2 3 4)) 464 | v)) 465 | 466 | (test 3 (force (delay (+ 1 2)))) 467 | 468 | (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) 469 | 470 | (test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) 471 | 472 | (test 'ok (let ((=> 1)) (cond (#t => 'ok)))) 473 | 474 | (test '(,foo) (let ((unquote 1)) `(,foo))) 475 | 476 | (test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) 477 | 478 | (test 'ok 479 | (let ((... 2)) 480 | (let-syntax ((s (syntax-rules () 481 | ((_ x ...) 'bad) 482 | ((_ . r) 'ok)))) 483 | (s a b c)))) 484 | 485 | 486 | ;; The following two tests seem to be incorrect according to the letter of R5RS (and R7RS, I believe). 487 | ;; See also the last example and comments in http://sisc-scheme.org/r5rs_pitfall.scm 488 | ;(test 'ok (let () 489 | ; (let-syntax () 490 | ; (define internal-def 'ok)) 491 | ; internal-def)) 492 | 493 | ;(test 'ok (let () 494 | ; (letrec-syntax () 495 | ; (define internal-def 'ok)) 496 | ; internal-def)) 497 | 498 | (test '(2 1) 499 | ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) 500 | 501 | (test '(2 2) 502 | ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) 503 | 504 | (test '(1 2) 505 | ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) 506 | 507 | (test '(2 3) 508 | ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) 509 | 510 | (test '(a b c) 511 | (let* ((path '()) 512 | (add (lambda (s) (set! path (cons s path))))) 513 | (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) 514 | (reverse path))) 515 | 516 | (test '(connect talk1 disconnect connect talk2 disconnect) 517 | (let ((path '()) 518 | (c #f)) 519 | (let ((add (lambda (s) 520 | (set! path (cons s path))))) 521 | (dynamic-wind 522 | (lambda () (add 'connect)) 523 | (lambda () 524 | (add (call-with-current-continuation 525 | (lambda (c0) 526 | (set! c c0) 527 | 'talk1)))) 528 | (lambda () (add 'disconnect))) 529 | (if (< (length path) 4) 530 | (c 'talk2) 531 | (reverse path))))) 532 | 533 | (test 2 (let-syntax 534 | ((foo (syntax-rules ::: () 535 | ((foo ... args :::) 536 | (args ::: ...))))) 537 | (foo 3 - 5))) 538 | 539 | (test '(5 4 1 2 3) 540 | (let-syntax 541 | ((foo (syntax-rules () 542 | ((foo args ... penultimate ultimate) 543 | (list ultimate penultimate args ...))))) 544 | (foo 1 2 3 4 5))) 545 | 546 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 547 | 548 | (test-end) 549 | -------------------------------------------------------------------------------- /tests/scheme/r5rs-tests.scm.orig: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009-2018 Alex Shinn 2 | ;; All rights reserved. 3 | ;; 4 | ;; Redistribution and use in source and binary forms, with or without 5 | ;; modification, are permitted provided that the following conditions 6 | ;; are met: 7 | ;; 1. Redistributions of source code must retain the above copyright 8 | ;; notice, this list of conditions and the following disclaimer. 9 | ;; 2. Redistributions in binary form must reproduce the above copyright 10 | ;; notice, this list of conditions and the following disclaimer in the 11 | ;; documentation and/or other materials provided with the distribution. 12 | ;; 3. The name of the author may not be used to endorse or promote products 13 | ;; derived from this software without specific prior written permission. 14 | ;; 15 | ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | ;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | 27 | (define *tests-run* 0) 28 | (define *tests-passed* 0) 29 | 30 | (define-syntax test 31 | (syntax-rules () 32 | ((test name expect expr) 33 | (test expect expr)) 34 | ((test expect expr) 35 | (begin 36 | (set! *tests-run* (+ *tests-run* 1)) 37 | (let ((str (call-with-output-string 38 | (lambda (out) 39 | (write *tests-run*) 40 | (display ". ") 41 | (display 'expr out)))) 42 | (res expr)) 43 | (display str) 44 | (write-char #\space) 45 | (display (make-string (max 0 (- 72 (string-length str))) #\.)) 46 | (flush-output) 47 | (cond 48 | ((equal? res expect) 49 | (set! *tests-passed* (+ *tests-passed* 1)) 50 | (display " [PASS]\n")) 51 | (else 52 | (display " [FAIL]\n") 53 | (display " expected ") (write expect) 54 | (display " but got ") (write res) (newline)))))))) 55 | 56 | (define-syntax test-assert 57 | (syntax-rules () 58 | ((test-assert expr) (test #t expr)))) 59 | 60 | (define (test-begin . name) 61 | #f) 62 | 63 | (define (test-end) 64 | (write *tests-passed*) 65 | (display " out of ") 66 | (write *tests-run*) 67 | (display " passed (") 68 | (write (* (/ *tests-passed* *tests-run*) 100)) 69 | (display "%)") 70 | (newline)) 71 | 72 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 73 | 74 | (test-begin "r5rs") 75 | 76 | (test 8 ((lambda (x) (+ x x)) 4)) 77 | 78 | (test '(3 4 5 6) ((lambda x x) 3 4 5 6)) 79 | 80 | (test '(5 6) ((lambda (x y . z) z) 3 4 5 6)) 81 | 82 | (test 'yes (if (> 3 2) 'yes 'no)) 83 | 84 | (test 'no (if (> 2 3) 'yes 'no)) 85 | 86 | (test 1 (if (> 3 2) (- 3 2) (+ 3 2))) 87 | 88 | (test 'greater (cond ((> 3 2) 'greater) ((< 3 2) 'less))) 89 | 90 | (test 'equal (cond ((> 3 3) 'greater) ((< 3 3) 'less) (else 'equal))) 91 | 92 | (test 'composite (case (* 2 3) ((2 3 5 7) 'prime) ((1 4 6 8 9) 'composite))) 93 | 94 | (test 'consonant 95 | (case (car '(c d)) 96 | ((a e i o u) 'vowel) 97 | ((w y) 'semivowel) 98 | (else 'consonant))) 99 | 100 | (test #t (and (= 2 2) (> 2 1))) 101 | 102 | (test #f (and (= 2 2) (< 2 1))) 103 | 104 | (test '(f g) (and 1 2 'c '(f g))) 105 | 106 | (test #t (and)) 107 | 108 | (test #t (or (= 2 2) (> 2 1))) 109 | 110 | (test #t (or (= 2 2) (< 2 1))) 111 | 112 | (test '(b c) (or (memq 'b '(a b c)) (/ 3 0))) 113 | 114 | (test 6 (let ((x 2) (y 3)) (* x y))) 115 | 116 | (test 35 (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) 117 | 118 | (test 70 (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) 119 | 120 | (test -2 (let () 121 | (define x 2) 122 | (define f (lambda () (- x))) 123 | (f))) 124 | 125 | (define let*-def 1) 126 | (let* () (define let*-def 2) #f) 127 | (test 1 let*-def) 128 | 129 | (test '#(0 1 2 3 4) 130 | (do ((vec (make-vector 5)) 131 | (i 0 (+ i 1))) 132 | ((= i 5) vec) 133 | (vector-set! vec i i))) 134 | 135 | (test 25 136 | (let ((x '(1 3 5 7 9))) 137 | (do ((x x (cdr x)) 138 | (sum 0 (+ sum (car x)))) 139 | ((null? x) 140 | sum)))) 141 | 142 | (test '((6 1 3) (-5 -2)) 143 | (let loop ((numbers '(3 -2 1 6 -5)) (nonneg '()) (neg '())) 144 | (cond 145 | ((null? numbers) 146 | (list nonneg neg)) 147 | ((>= (car numbers) 0) 148 | (loop (cdr numbers) (cons (car numbers) nonneg) neg)) 149 | ((< (car numbers) 0) 150 | (loop (cdr numbers) nonneg (cons (car numbers) neg)))))) 151 | 152 | (test '(list 3 4) `(list ,(+ 1 2) 4)) 153 | 154 | (test '(list a 'a) (let ((name 'a)) `(list ,name ',name))) 155 | 156 | (test '(a 3 4 5 6 b) 157 | `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) 158 | 159 | (test '(10 5 4 16 9 8) 160 | `(10 5 ,(expt 2 2) ,@(map (lambda (n) (expt n 2)) '(4 3)) 8)) 161 | 162 | (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) 163 | `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) 164 | 165 | (test '(a `(b ,x ,'y d) e) 166 | (let ((name1 'x) 167 | (name2 'y)) 168 | `(a `(b ,,name1 ,',name2 d) e))) 169 | 170 | (test '(list 3 4) 171 | (quasiquote (list (unquote (+ 1 2)) 4))) 172 | 173 | (test #t (eqv? 'a 'a)) 174 | 175 | (test #f (eqv? 'a 'b)) 176 | 177 | (test #t (eqv? '() '())) 178 | 179 | (test #f (eqv? (cons 1 2) (cons 1 2))) 180 | 181 | (test #f (eqv? (lambda () 1) (lambda () 2))) 182 | 183 | (test #t (let ((p (lambda (x) x))) (eqv? p p))) 184 | 185 | (test #t (eq? 'a 'a)) 186 | 187 | (test #f (eq? (list 'a) (list 'a))) 188 | 189 | (test #t (eq? '() '())) 190 | 191 | (test #t (eq? car car)) 192 | 193 | (test #t (let ((x '(a))) (eq? x x))) 194 | 195 | (test #t (let ((p (lambda (x) x))) (eq? p p))) 196 | 197 | (test #t (equal? 'a 'a)) 198 | 199 | (test #t (equal? '(a) '(a))) 200 | 201 | (test #t (equal? '(a (b) c) '(a (b) c))) 202 | 203 | (test #t (equal? "abc" "abc")) 204 | 205 | (test #f (equal? "abc" "abcd")) 206 | 207 | (test #f (equal? "a" "b")) 208 | 209 | (test #t (equal? 2 2)) 210 | 211 | ;;(test #f (eqv? 2 2.0)) 212 | 213 | ;;(test #f (equal? 2.0 2)) 214 | 215 | (test #t (equal? (make-vector 5 'a) (make-vector 5 'a))) 216 | 217 | (test 4 (max 3 4)) 218 | 219 | ;;(test 4 (max 3.9 4)) 220 | 221 | (test 7 (+ 3 4)) 222 | 223 | (test 3 (+ 3)) 224 | 225 | (test 0 (+)) 226 | 227 | (test 4 (* 4)) 228 | 229 | (test 1 (*)) 230 | 231 | (test -1 (- 3 4)) 232 | 233 | (test -6 (- 3 4 5)) 234 | 235 | (test -3 (- 3)) 236 | 237 | (test -1.0 (- 3.0 4)) 238 | 239 | (test 7 (abs -7)) 240 | 241 | (test 1 (modulo 13 4)) 242 | 243 | (test 1 (remainder 13 4)) 244 | 245 | (test 3 (modulo -13 4)) 246 | 247 | (test -1 (remainder -13 4)) 248 | 249 | (test -3 (modulo 13 -4)) 250 | 251 | (test 1 (remainder 13 -4)) 252 | 253 | (test -1 (modulo -13 -4)) 254 | 255 | (test -1 (remainder -13 -4)) 256 | 257 | (test 4 (gcd 32 -36)) 258 | 259 | (test 288 (lcm 32 -36)) 260 | 261 | (test 100 (string->number "100")) 262 | 263 | (test 256 (string->number "100" 16)) 264 | 265 | (test 127 (string->number "177" 8)) 266 | 267 | (test 5 (string->number "101" 2)) 268 | 269 | (test 100.0 (string->number "1e2")) 270 | 271 | (test "100" (number->string 100)) 272 | 273 | (test "100" (number->string 256 16)) 274 | 275 | (test "ff" (number->string 255 16)) 276 | 277 | (test "177" (number->string 127 8)) 278 | 279 | (test "101" (number->string 5 2)) 280 | 281 | (test #f (not 3)) 282 | 283 | (test #f (not (list 3))) 284 | 285 | (test #f (not '())) 286 | 287 | (test #f (not (list))) 288 | 289 | (test #f (not '())) 290 | 291 | (test #f (boolean? 0)) 292 | 293 | (test #f (boolean? '())) 294 | 295 | (test #t (pair? '(a . b))) 296 | 297 | (test #t (pair? '(a b c))) 298 | 299 | (test '(a) (cons 'a '())) 300 | 301 | (test '((a) b c d) (cons '(a) '(b c d))) 302 | 303 | (test '("a" b c) (cons "a" '(b c))) 304 | 305 | (test '(a . 3) (cons 'a 3)) 306 | 307 | (test '((a b) . c) (cons '(a b) 'c)) 308 | 309 | (test 'a (car '(a b c))) 310 | 311 | (test '(a) (car '((a) b c d))) 312 | 313 | (test 1 (car '(1 . 2))) 314 | 315 | (test '(b c d) (cdr '((a) b c d))) 316 | 317 | (test 2 (cdr '(1 . 2))) 318 | 319 | (test #t (list? '(a b c))) 320 | 321 | (test #t (list? '())) 322 | 323 | (test #f (list? '(a . b))) 324 | 325 | (test #f 326 | (let ((x (list 'a))) 327 | (set-cdr! x x) 328 | (list? x))) 329 | 330 | (test '(a 7 c) (list 'a (+ 3 4) 'c)) 331 | 332 | (test '() (list)) 333 | 334 | (test 3 (length '(a b c))) 335 | 336 | (test 3 (length '(a (b) (c d e)))) 337 | 338 | (test 0 (length '())) 339 | 340 | (test '(x y) (append '(x) '(y))) 341 | 342 | (test '(a b c d) (append '(a) '(b c d))) 343 | 344 | (test '(a (b) (c)) (append '(a (b)) '((c)))) 345 | 346 | (test '(a b c . d) (append '(a b) '(c . d))) 347 | 348 | (test 'a (append '() 'a)) 349 | 350 | (test '(c b a) (reverse '(a b c))) 351 | 352 | (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f))))) 353 | 354 | (test 'c (list-ref '(a b c d) 2)) 355 | 356 | (test '(a b c) (memq 'a '(a b c))) 357 | 358 | (test '(b c) (memq 'b '(a b c))) 359 | 360 | (test #f (memq 'a '(b c d))) 361 | 362 | (test #f (memq (list 'a) '(b (a) c))) 363 | 364 | (test '((a) c) (member (list 'a) '(b (a) c))) 365 | 366 | (test '(101 102) (memv 101 '(100 101 102))) 367 | 368 | (test #f (assq (list 'a) '(((a)) ((b)) ((c))))) 369 | 370 | (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c))))) 371 | 372 | (test '(5 7) (assv 5 '((2 3) (5 7) (11 13)))) 373 | 374 | (test #t (symbol? 'foo)) 375 | 376 | (test #t (symbol? (car '(a b)))) 377 | 378 | (test #f (symbol? "bar")) 379 | 380 | (test #t (symbol? 'nil)) 381 | 382 | (test #f (symbol? '())) 383 | 384 | (test "flying-fish" (symbol->string 'flying-fish)) 385 | 386 | (test "Martin" (symbol->string 'Martin)) 387 | 388 | (test "Malvina" (symbol->string (string->symbol "Malvina"))) 389 | 390 | (test #t (string? "a")) 391 | 392 | (test #f (string? 'a)) 393 | 394 | (test 0 (string-length "")) 395 | 396 | (test 3 (string-length "abc")) 397 | 398 | (test #\a (string-ref "abc" 0)) 399 | 400 | (test #\c (string-ref "abc" 2)) 401 | 402 | (test #t (string=? "a" (string #\a))) 403 | 404 | (test #f (string=? "a" (string #\b))) 405 | 406 | (test #t (stringlist '#(dah dah didah))) 438 | 439 | (test '#(dididit dah) (list->vector '(dididit dah))) 440 | 441 | (test #t (procedure? car)) 442 | 443 | (test #f (procedure? 'car)) 444 | 445 | (test #t (procedure? (lambda (x) (* x x)))) 446 | 447 | (test #f (procedure? '(lambda (x) (* x x)))) 448 | 449 | (test #t (call-with-current-continuation procedure?)) 450 | 451 | (test 7 (call-with-current-continuation (lambda (k) (+ 2 5)))) 452 | 453 | (test 3 (call-with-current-continuation (lambda (k) (+ 2 5 (k 3))))) 454 | 455 | (test 7 (apply + (list 3 4))) 456 | 457 | (test '(b e h) (map cadr '((a b) (d e) (g h)))) 458 | 459 | (test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) 460 | 461 | (test '(5 7 9) (map + '(1 2 3) '(4 5 6))) 462 | 463 | (test '#(0 1 4 9 16) 464 | (let ((v (make-vector 5))) 465 | (for-each 466 | (lambda (i) (vector-set! v i (* i i))) 467 | '(0 1 2 3 4)) 468 | v)) 469 | 470 | (test 3 (force (delay (+ 1 2)))) 471 | 472 | (test '(3 3) (let ((p (delay (+ 1 2)))) (list (force p) (force p)))) 473 | 474 | (test 'ok (let ((else 1)) (cond (else 'ok) (#t 'bad)))) 475 | 476 | (test 'ok (let ((=> 1)) (cond (#t => 'ok)))) 477 | 478 | (test '(,foo) (let ((unquote 1)) `(,foo))) 479 | 480 | (test '(,@foo) (let ((unquote-splicing 1)) `(,@foo))) 481 | 482 | (test 'ok 483 | (let ((... 2)) 484 | (let-syntax ((s (syntax-rules () 485 | ((_ x ...) 'bad) 486 | ((_ . r) 'ok)))) 487 | (s a b c)))) 488 | 489 | (test 'ok (let () 490 | (let-syntax () 491 | (define internal-def 'ok)) 492 | internal-def)) 493 | 494 | (test 'ok (let () 495 | (letrec-syntax () 496 | (define internal-def 'ok)) 497 | internal-def)) 498 | 499 | (test '(2 1) 500 | ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (list x y)))))) 501 | 502 | (test '(2 2) 503 | ((lambda () (let ((x 1)) (set! x 2) (let ((y x)) (list x y)))))) 504 | 505 | (test '(1 2) 506 | ((lambda () (let ((x 1)) (let ((y x)) (set! y 2) (list x y)))))) 507 | 508 | (test '(2 3) 509 | ((lambda () (let ((x 1)) (let ((y x)) (set! x 2) (set! y 3) (list x y)))))) 510 | 511 | (test '(a b c) 512 | (let* ((path '()) 513 | (add (lambda (s) (set! path (cons s path))))) 514 | (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c))) 515 | (reverse path))) 516 | 517 | (test '(connect talk1 disconnect connect talk2 disconnect) 518 | (let ((path '()) 519 | (c #f)) 520 | (let ((add (lambda (s) 521 | (set! path (cons s path))))) 522 | (dynamic-wind 523 | (lambda () (add 'connect)) 524 | (lambda () 525 | (add (call-with-current-continuation 526 | (lambda (c0) 527 | (set! c c0) 528 | 'talk1)))) 529 | (lambda () (add 'disconnect))) 530 | (if (< (length path) 4) 531 | (c 'talk2) 532 | (reverse path))))) 533 | 534 | (test 2 (let-syntax 535 | ((foo (syntax-rules ::: () 536 | ((foo ... args :::) 537 | (args ::: ...))))) 538 | (foo 3 - 5))) 539 | 540 | (test '(5 4 1 2 3) 541 | (let-syntax 542 | ((foo (syntax-rules () 543 | ((foo args ... penultimate ultimate) 544 | (list ultimate penultimate args ...))))) 545 | (foo 1 2 3 4 5))) 546 | 547 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 548 | 549 | (test-end) 550 | -------------------------------------------------------------------------------- /tests/scheme/r5rs_pitfall.scm: -------------------------------------------------------------------------------- 1 | ;; r5rs_pitfalls.scm 2 | ;; 3 | ;; This program attempts to test a Scheme implementation's conformance 4 | ;; to various subtle edge-cases and consequences of the R5RS Scheme standard. 5 | ;; Code was collected from public forums, and is hereby placed in the public domain. 6 | ;; 7 | ;; 8 | (define-syntax should-be 9 | (syntax-rules () 10 | ((_ test-id value expression) 11 | (let ((return-value expression)) 12 | (if (not (equal? return-value value)) 13 | (for-each (lambda (v) (display v)) 14 | `("Failure: " test-id ", expected '" 15 | value "', got '" ,return-value "'." #\newline)) 16 | (for-each (lambda (v) (display v)) 17 | '("Passed: " test-id #\newline))))))) 18 | 19 | (define call/cc call-with-current-continuation) 20 | 21 | ;; Section 1: Proper letrec implementation 22 | 23 | ;;Credits to Al Petrofsky 24 | ;; In thread: 25 | ;; defines in letrec body 26 | ;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com 27 | (should-be 1.1 0 28 | (let ((cont #f)) 29 | (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0))) 30 | (y (call-with-current-continuation (lambda (c) (set! cont c) 0)))) 31 | (if cont 32 | (let ((c cont)) 33 | (set! cont #f) 34 | (set! x 1) 35 | (set! y 1) 36 | (c 0)) 37 | (+ x y))))) 38 | 39 | ;;Credits to Al Petrofsky 40 | ;; In thread: 41 | ;; Widespread bug (arguably) in letrec when an initializer returns twice 42 | ;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com 43 | (should-be 1.2 #t 44 | (letrec ((x (call/cc list)) (y (call/cc list))) 45 | (cond ((procedure? x) (x (pair? y))) 46 | ((procedure? y) (y (pair? x)))) 47 | (let ((x (car x)) (y (car y))) 48 | (and (call/cc x) (call/cc y) (call/cc x))))) 49 | 50 | ;;Credits to Alan Bawden 51 | ;; In thread: 52 | ;; LETREC + CALL/CC = SET! even in a limited setting 53 | ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU 54 | (should-be 1.3 #t 55 | (letrec ((x (call-with-current-continuation 56 | (lambda (c) 57 | (list #T c))))) 58 | (if (car x) 59 | ((cadr x) (list #F (lambda () x))) 60 | (eq? x ((cadr x)))))) 61 | 62 | ;; Section 2: Proper call/cc and procedure application 63 | 64 | ;;Credits to Al Petrofsky, (and a wink to Matthias Blume) 65 | ;; In thread: 66 | ;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1 67 | ;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org 68 | (should-be 2.1 1 69 | (call/cc (lambda (c) (0 (c 1))))) 70 | 71 | ;; Section 3: Hygienic macros 72 | 73 | ;; Eli Barzilay 74 | ;; In thread: 75 | ;; R5RS macros... 76 | ;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu 77 | (should-be 3.1 4 78 | (let-syntax ((foo 79 | (syntax-rules () 80 | ((_ expr) (+ expr 1))))) 81 | (let ((+ *)) 82 | (foo 3)))) 83 | 84 | 85 | ;; Al Petrofsky again 86 | ;; In thread: 87 | ;; Buggy use of begin in r5rs cond and case macros. 88 | ;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org 89 | (should-be 3.2 2 90 | (let-syntax ((foo (syntax-rules () 91 | ((_ var) (define var 1))))) 92 | (let ((x 2)) 93 | (begin (define foo +)) 94 | (cond (else (foo x))) 95 | x))) 96 | 97 | ;;Al Petrofsky 98 | ;; In thread: 99 | ;; An Advanced syntax-rules Primer for the Mildly Insane 100 | ;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org 101 | 102 | (should-be 3.3 1 103 | (let ((x 1)) 104 | (let-syntax 105 | ((foo (syntax-rules () 106 | ((_ y) (let-syntax 107 | ((bar (syntax-rules () 108 | ((_) (let ((x 2)) y))))) 109 | (bar)))))) 110 | (foo x)))) 111 | 112 | ;; Al Petrofsky 113 | ;; Contributed directly 114 | (should-be 3.4 1 115 | (let-syntax ((x (syntax-rules ()))) 1)) 116 | 117 | ;; Setion 4: No identifiers are reserved 118 | 119 | ;;(Brian M. Moore) 120 | ;; In thread: 121 | ;; shadowing syntatic keywords, bug in MIT Scheme? 122 | ;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu 123 | (should-be 4.1 '(x) 124 | ((lambda lambda lambda) 'x)) 125 | 126 | (should-be 4.2 '(1 2 3) 127 | ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda))) 128 | 129 | (should-be 4.3 #f 130 | (let ((quote -)) (eqv? '1 1))) 131 | ;; Section 5: #f/() distinctness 132 | 133 | ;; Scott Miller 134 | (should-be 5.1 #f 135 | (eq? #f '())) 136 | (should-be 5.2 #f 137 | (eqv? #f '())) 138 | (should-be 5.3 #f 139 | (equal? #f '())) 140 | 141 | ;; Section 6: string->symbol case sensitivity 142 | 143 | ;; Jens Axel S?gaard 144 | ;; In thread: 145 | ;; Symbols in DrScheme - bug? 146 | ;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk 147 | (should-be 6.1 #f 148 | (eq? (string->symbol "f") (string->symbol "F"))) 149 | 150 | ;; Section 7: First class continuations 151 | 152 | ;; Scott Miller 153 | ;; No newsgroup posting associated. The gist of this test and 7.2 154 | ;; is that once captured, a continuation should be unmodified by the 155 | ;; invocation of other continuations. This test determines that this is 156 | ;; the case by capturing a continuation and setting it aside in a temporary 157 | ;; variable while it invokes that and another continuation, trying to 158 | ;; side effect the first continuation. This test case was developed when 159 | ;; testing SISC 1.7's lazy CallFrame unzipping code. 160 | (define r #f) 161 | (define a #f) 162 | (define b #f) 163 | (define c #f) 164 | (define i 0) 165 | (should-be 7.1 28 166 | (let () 167 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) 168 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) 169 | (if (not c) 170 | (set! c a)) 171 | (set! i (+ i 1)) 172 | (case i 173 | ((1) (a 5)) 174 | ((2) (b 8)) 175 | ((3) (a 6)) 176 | ((4) (c 4))) 177 | r)) 178 | 179 | ;; Same test, but in reverse order 180 | (define r #f) 181 | (define a #f) 182 | (define b #f) 183 | (define c #f) 184 | (define i 0) 185 | (should-be 7.2 28 186 | (let () 187 | (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4)))) 188 | (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7)))))) 189 | (if (not c) 190 | (set! c a)) 191 | (set! i (+ i 1)) 192 | (case i 193 | ((1) (b 8)) 194 | ((2) (a 5)) 195 | ((3) (b 7)) 196 | ((4) (c 4))) 197 | r)) 198 | 199 | ;; Credits to Matthias Radestock 200 | ;; Another test case used to test SISC's lazy CallFrame routines. 201 | (should-be 7.3 '((-1 4 5 3) 202 | (4 -1 5 3) 203 | (-1 5 4 3) 204 | (5 -1 4 3) 205 | (4 5 -1 3) 206 | (5 4 -1 3)) 207 | (let ((k1 #f) 208 | (k2 #f) 209 | (k3 #f) 210 | (state 0)) 211 | (define (identity x) x) 212 | (define (fn) 213 | ((identity (if (= state 0) 214 | (call/cc (lambda (k) (set! k1 k) +)) 215 | +)) 216 | (identity (if (= state 0) 217 | (call/cc (lambda (k) (set! k2 k) 1)) 218 | 1)) 219 | (identity (if (= state 0) 220 | (call/cc (lambda (k) (set! k3 k) 2)) 221 | 2)))) 222 | (define (check states) 223 | (set! state 0) 224 | (let* ((res '()) 225 | (r (fn))) 226 | (set! res (cons r res)) 227 | (if (null? states) 228 | res 229 | (begin (set! state (car states)) 230 | (set! states (cdr states)) 231 | (case state 232 | ((1) (k3 4)) 233 | ((2) (k2 2)) 234 | ((3) (k1 -))))))) 235 | (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1))))) 236 | 237 | ;; Modification of the yin-yang puzzle so that it terminates and produces 238 | ;; a value as a result. (Scott G. Miller) 239 | (should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0) 240 | (let ((x '()) 241 | (y 0)) 242 | (call/cc 243 | (lambda (escape) 244 | (let* ((yin ((lambda (foo) 245 | (set! x (cons y x)) 246 | (if (= y 10) 247 | (escape x) 248 | (begin 249 | (set! y 0) 250 | foo))) 251 | (call/cc (lambda (bar) bar)))) 252 | (yang ((lambda (foo) 253 | (set! y (+ y 1)) 254 | foo) 255 | (call/cc (lambda (baz) baz))))) 256 | (yin yang)))))) 257 | 258 | ;; Miscellaneous 259 | 260 | ;;Al Petrofsky 261 | ;; In thread: 262 | ;; R5RS Implementors Pitfalls 263 | ;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com 264 | (should-be 8.1 -1 265 | (let - ((n (- 1))) n)) 266 | 267 | (should-be 8.2 '(1 2 3 4 1 2 3 4 5) 268 | (let ((ls (list 1 2 3 4))) 269 | (append ls ls '(5)))) 270 | 271 | ;; This example actually illustrates a bug in R5RS. If a Scheme system 272 | ;; follows the letter of the standard, 1 should be returned, but 273 | ;; the general agreement is that 2 should instead be returned. 274 | ;; The reason is that in R5RS, let-syntax always introduces new scope, thus 275 | ;; in the following test, the let-syntax breaks the definition section 276 | ;; and begins the expression section of the let. 277 | ;; 278 | ;; The general agreement by the implementors in 1998 was that the following 279 | ;; should be possible, but isn't: 280 | ;; 281 | ;; (define ---) 282 | ;; (let-syntax (---) 283 | ;; (define ---) 284 | ;; (define ---)) 285 | ;; (define ---) 286 | ;; 287 | ;; Scheme systems based on the Portable syntax-case expander by Dybvig 288 | ;; and Waddell do allow the above, and thus often violate the letter of 289 | ;; R5RS. In such systems, the following will produce a local scope: 290 | ;; 291 | ;; (define ---) 292 | ;; (let-syntax ((a ---)) 293 | ;; (let () 294 | ;; (define ---) 295 | ;; (define ---))) 296 | ;; (define ---) 297 | ;; 298 | ;; Credits to Matthias Radestock and thanks to R. Kent Dybvig for the 299 | ;; explanation and background 300 | (should-be 8.3 1 301 | (let ((x 1)) 302 | (let-syntax ((foo (syntax-rules () ((_) 2)))) 303 | (define x (foo)) 304 | 3) 305 | x)) 306 | 307 | ;;Not really an error to fail this (Matthias Radestock) 308 | ;;If this returns (0 1 0), your map isn't call/cc safe, but is probably 309 | ;;tail-recursive. If its (0 0 0), the opposite is true. 310 | (let ((result 311 | (let () 312 | (define executed-k #f) 313 | (define cont #f) 314 | (define res1 #f) 315 | (define res2 #f) 316 | (set! res1 (map (lambda (x) 317 | (if (= x 0) 318 | (call/cc (lambda (k) (set! cont k) 0)) 319 | 0)) 320 | '(1 0 2))) 321 | (if (not executed-k) 322 | (begin (set! executed-k #t) 323 | (set! res2 res1) 324 | (cont 1))) 325 | res2))) 326 | (if (equal? result '(0 0 0)) 327 | (display "Map is call/cc safe, but probably not tail recursive or inefficient.") 328 | (display "Map is not call/cc safe, but probably tail recursive and efficient.")) 329 | (newline)) 330 | 331 | -------------------------------------------------------------------------------- /tests/scheme/run-scheme.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | mkfifo /tmp/peroxide-output 4 | cargo run -- tests/scheme/r5rs-tests.scm | tee /tmp/peroxide-output & 5 | tail -n 1 /tmp/peroxide-output | grep -q 100% 6 | --------------------------------------------------------------------------------