├── .github └── workflows │ └── rust.yml ├── .gitignore ├── Cargo.toml ├── LICENSE ├── README.md ├── benches ├── fib.rs └── fib.scm ├── build.rs ├── build ├── lexer.rs └── parser.rs ├── logo-dark.png ├── logo-dark.svg ├── logo-light.png ├── logo.svg ├── proc-macros ├── Cargo.toml └── src │ └── lib.rs ├── src ├── ast.rs ├── character.rs ├── character │ └── unicode.rs ├── cps │ ├── analysis.rs │ ├── codegen.rs │ ├── compile.rs │ ├── mod.rs │ └── reduce.rs ├── env.rs ├── exception.rs ├── expand.rs ├── futures.rs ├── gc │ ├── collection.rs │ └── mod.rs ├── lex.rs ├── lib.rs ├── lists.rs ├── main.rs ├── num.rs ├── parse.rs ├── proc.rs ├── records.rs ├── registry.rs ├── runtime.rs ├── stdlib.scm ├── strings.rs ├── syntax.rs ├── value.rs └── vectors.rs ├── tests ├── common │ └── mod.rs ├── r6rs.rs ├── r6rs.scm ├── r7rs.rs └── r7rs.scm └── unicode ├── case_folding.txt ├── fetch.sh └── numeric_types.txt /.github/workflows/rust.yml: -------------------------------------------------------------------------------- 1 | name: Rust 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | env: 10 | CARGO_TERM_COLOR: always 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | - uses: dtolnay/rust-toolchain@stable 20 | with: 21 | components: clippy, rustfmt 22 | - name: Install packages 23 | run: sudo apt-get install libllvm18 llvm-18 llvm-18-dev libpolly-18-dev 24 | - name: Build 25 | run: cargo build 26 | - name: Check formatting 27 | run: cargo fmt -- --check 28 | - name: Clippy 29 | run: cargo clippy --all-targets -- -Dclippy::all -D warnings 30 | - name: Test 31 | run: cargo test 32 | - name: Bench 33 | run: cargo bench -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /target 2 | /Cargo.lock 3 | -------------------------------------------------------------------------------- /Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "scheme-rs" 3 | version = "0.1.0-alpha.1" 4 | edition = "2021" 5 | authors = ["Matthew Plant "] 6 | description = "Embedded scheme for the async-rust ecosystem" 7 | license = "MPL-2.0" 8 | 9 | documentation = "https://docs.rs/crate/scheme-rs" 10 | homepage = "https://github.com/maplant/scheme-rs" 11 | repository = "https://github.com/maplant/scheme-rs" 12 | 13 | [dependencies] 14 | async-trait = "0.1" 15 | derive_more = { version = "1.0", features = ["debug", "from"]} 16 | dyn-clone = "1.0.13" 17 | either = "1" 18 | futures = "0.3" 19 | indexmap = "2" 20 | inventory = "0.3" 21 | inkwell = { version = "0.6", features = ["llvm18-1"] } 22 | nom = "7" 23 | nom_locate = "4" 24 | num = "0.4" 25 | ordered-float = "5" 26 | scheme-rs-macros = { version = "0.1.0-alpha.1", path = "proc-macros" } 27 | rand = "0.8" 28 | thiserror = "1" 29 | tokio = { version = "1.41", features = ["full"] } 30 | unicode_categories = "0.1" 31 | # TODO: Get rid of this dependency 32 | derivative = "2" 33 | malachite = { version = "0.5.1", features = ["floats"] } 34 | rustyline = { version = "15.0.0", features = ["derive"] } 35 | 36 | [profile.release] 37 | lto = true 38 | 39 | [build-dependencies] 40 | nom = "7" 41 | 42 | [dev-dependencies] 43 | criterion = { version = "0.5", features = ["html_reports", "async_tokio"] } 44 | 45 | [[bench]] 46 | name = "fib" 47 | harness = false 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Mozilla Public License Version 2.0 2 | ================================== 3 | 4 | 1. Definitions 5 | -------------- 6 | 7 | 1.1. "Contributor" 8 | means each individual or legal entity that creates, contributes to 9 | the creation of, or owns Covered Software. 10 | 11 | 1.2. "Contributor Version" 12 | means the combination of the Contributions of others (if any) used 13 | by a Contributor and that particular Contributor's Contribution. 14 | 15 | 1.3. "Contribution" 16 | means Covered Software of a particular Contributor. 17 | 18 | 1.4. "Covered Software" 19 | means Source Code Form to which the initial Contributor has attached 20 | the notice in Exhibit A, the Executable Form of such Source Code 21 | Form, and Modifications of such Source Code Form, in each case 22 | including portions thereof. 23 | 24 | 1.5. "Incompatible With Secondary Licenses" 25 | means 26 | 27 | (a) that the initial Contributor has attached the notice described 28 | in Exhibit B to the Covered Software; or 29 | 30 | (b) that the Covered Software was made available under the terms of 31 | version 1.1 or earlier of the License, but not also under the 32 | terms of a Secondary License. 33 | 34 | 1.6. "Executable Form" 35 | means any form of the work other than Source Code Form. 36 | 37 | 1.7. "Larger Work" 38 | means a work that combines Covered Software with other material, in 39 | a separate file or files, that is not Covered Software. 40 | 41 | 1.8. "License" 42 | means this document. 43 | 44 | 1.9. "Licensable" 45 | means having the right to grant, to the maximum extent possible, 46 | whether at the time of the initial grant or subsequently, any and 47 | all of the rights conveyed by this License. 48 | 49 | 1.10. "Modifications" 50 | means any of the following: 51 | 52 | (a) any file in Source Code Form that results from an addition to, 53 | deletion from, or modification of the contents of Covered 54 | Software; or 55 | 56 | (b) any new file in Source Code Form that contains any Covered 57 | Software. 58 | 59 | 1.11. "Patent Claims" of a Contributor 60 | means any patent claim(s), including without limitation, method, 61 | process, and apparatus claims, in any patent Licensable by such 62 | Contributor that would be infringed, but for the grant of the 63 | License, by the making, using, selling, offering for sale, having 64 | made, import, or transfer of either its Contributions or its 65 | Contributor Version. 66 | 67 | 1.12. "Secondary License" 68 | means either the GNU General Public License, Version 2.0, the GNU 69 | Lesser General Public License, Version 2.1, the GNU Affero General 70 | Public License, Version 3.0, or any later versions of those 71 | licenses. 72 | 73 | 1.13. "Source Code Form" 74 | means the form of the work preferred for making modifications. 75 | 76 | 1.14. "You" (or "Your") 77 | means an individual or a legal entity exercising rights under this 78 | License. For legal entities, "You" includes any entity that 79 | controls, is controlled by, or is under common control with You. For 80 | purposes of this definition, "control" means (a) the power, direct 81 | or indirect, to cause the direction or management of such entity, 82 | whether by contract or otherwise, or (b) ownership of more than 83 | fifty percent (50%) of the outstanding shares or beneficial 84 | ownership of such entity. 85 | 86 | 2. License Grants and Conditions 87 | -------------------------------- 88 | 89 | 2.1. Grants 90 | 91 | Each Contributor hereby grants You a world-wide, royalty-free, 92 | non-exclusive license: 93 | 94 | (a) under intellectual property rights (other than patent or trademark) 95 | Licensable by such Contributor to use, reproduce, make available, 96 | modify, display, perform, distribute, and otherwise exploit its 97 | Contributions, either on an unmodified basis, with Modifications, or 98 | as part of a Larger Work; and 99 | 100 | (b) under Patent Claims of such Contributor to make, use, sell, offer 101 | for sale, have made, import, and otherwise transfer either its 102 | Contributions or its Contributor Version. 103 | 104 | 2.2. Effective Date 105 | 106 | The licenses granted in Section 2.1 with respect to any Contribution 107 | become effective for each Contribution on the date the Contributor first 108 | distributes such Contribution. 109 | 110 | 2.3. Limitations on Grant Scope 111 | 112 | The licenses granted in this Section 2 are the only rights granted under 113 | this License. No additional rights or licenses will be implied from the 114 | distribution or licensing of Covered Software under this License. 115 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 116 | Contributor: 117 | 118 | (a) for any code that a Contributor has removed from Covered Software; 119 | or 120 | 121 | (b) for infringements caused by: (i) Your and any other third party's 122 | modifications of Covered Software, or (ii) the combination of its 123 | Contributions with other software (except as part of its Contributor 124 | Version); or 125 | 126 | (c) under Patent Claims infringed by Covered Software in the absence of 127 | its Contributions. 128 | 129 | This License does not grant any rights in the trademarks, service marks, 130 | or logos of any Contributor (except as may be necessary to comply with 131 | the notice requirements in Section 3.4). 132 | 133 | 2.4. Subsequent Licenses 134 | 135 | No Contributor makes additional grants as a result of Your choice to 136 | distribute the Covered Software under a subsequent version of this 137 | License (see Section 10.2) or under the terms of a Secondary License (if 138 | permitted under the terms of Section 3.3). 139 | 140 | 2.5. Representation 141 | 142 | Each Contributor represents that the Contributor believes its 143 | Contributions are its original creation(s) or it has sufficient rights 144 | to grant the rights to its Contributions conveyed by this License. 145 | 146 | 2.6. Fair Use 147 | 148 | This License is not intended to limit any rights You have under 149 | applicable copyright doctrines of fair use, fair dealing, or other 150 | equivalents. 151 | 152 | 2.7. Conditions 153 | 154 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 155 | in Section 2.1. 156 | 157 | 3. Responsibilities 158 | ------------------- 159 | 160 | 3.1. Distribution of Source Form 161 | 162 | All distribution of Covered Software in Source Code Form, including any 163 | Modifications that You create or to which You contribute, must be under 164 | the terms of this License. You must inform recipients that the Source 165 | Code Form of the Covered Software is governed by the terms of this 166 | License, and how they can obtain a copy of this License. You may not 167 | attempt to alter or restrict the recipients' rights in the Source Code 168 | Form. 169 | 170 | 3.2. Distribution of Executable Form 171 | 172 | If You distribute Covered Software in Executable Form then: 173 | 174 | (a) such Covered Software must also be made available in Source Code 175 | Form, as described in Section 3.1, and You must inform recipients of 176 | the Executable Form how they can obtain a copy of such Source Code 177 | Form by reasonable means in a timely manner, at a charge no more 178 | than the cost of distribution to the recipient; and 179 | 180 | (b) You may distribute such Executable Form under the terms of this 181 | License, or sublicense it under different terms, provided that the 182 | license for the Executable Form does not attempt to limit or alter 183 | the recipients' rights in the Source Code Form under this License. 184 | 185 | 3.3. Distribution of a Larger Work 186 | 187 | You may create and distribute a Larger Work under terms of Your choice, 188 | provided that You also comply with the requirements of this License for 189 | the Covered Software. If the Larger Work is a combination of Covered 190 | Software with a work governed by one or more Secondary Licenses, and the 191 | Covered Software is not Incompatible With Secondary Licenses, this 192 | License permits You to additionally distribute such Covered Software 193 | under the terms of such Secondary License(s), so that the recipient of 194 | the Larger Work may, at their option, further distribute the Covered 195 | Software under the terms of either this License or such Secondary 196 | License(s). 197 | 198 | 3.4. Notices 199 | 200 | You may not remove or alter the substance of any license notices 201 | (including copyright notices, patent notices, disclaimers of warranty, 202 | or limitations of liability) contained within the Source Code Form of 203 | the Covered Software, except that You may alter any license notices to 204 | the extent required to remedy known factual inaccuracies. 205 | 206 | 3.5. Application of Additional Terms 207 | 208 | You may choose to offer, and to charge a fee for, warranty, support, 209 | indemnity or liability obligations to one or more recipients of Covered 210 | Software. However, You may do so only on Your own behalf, and not on 211 | behalf of any Contributor. You must make it absolutely clear that any 212 | such warranty, support, indemnity, or liability obligation is offered by 213 | You alone, and You hereby agree to indemnify every Contributor for any 214 | liability incurred by such Contributor as a result of warranty, support, 215 | indemnity or liability terms You offer. You may include additional 216 | disclaimers of warranty and limitations of liability specific to any 217 | jurisdiction. 218 | 219 | 4. Inability to Comply Due to Statute or Regulation 220 | --------------------------------------------------- 221 | 222 | If it is impossible for You to comply with any of the terms of this 223 | License with respect to some or all of the Covered Software due to 224 | statute, judicial order, or regulation then You must: (a) comply with 225 | the terms of this License to the maximum extent possible; and (b) 226 | describe the limitations and the code they affect. Such description must 227 | be placed in a text file included with all distributions of the Covered 228 | Software under this License. Except to the extent prohibited by statute 229 | or regulation, such description must be sufficiently detailed for a 230 | recipient of ordinary skill to be able to understand it. 231 | 232 | 5. Termination 233 | -------------- 234 | 235 | 5.1. The rights granted under this License will terminate automatically 236 | if You fail to comply with any of its terms. However, if You become 237 | compliant, then the rights granted under this License from a particular 238 | Contributor are reinstated (a) provisionally, unless and until such 239 | Contributor explicitly and finally terminates Your grants, and (b) on an 240 | ongoing basis, if such Contributor fails to notify You of the 241 | non-compliance by some reasonable means prior to 60 days after You have 242 | come back into compliance. Moreover, Your grants from a particular 243 | Contributor are reinstated on an ongoing basis if such Contributor 244 | notifies You of the non-compliance by some reasonable means, this is the 245 | first time You have received notice of non-compliance with this License 246 | from such Contributor, and You become compliant prior to 30 days after 247 | Your receipt of the notice. 248 | 249 | 5.2. If You initiate litigation against any entity by asserting a patent 250 | infringement claim (excluding declaratory judgment actions, 251 | counter-claims, and cross-claims) alleging that a Contributor Version 252 | directly or indirectly infringes any patent, then the rights granted to 253 | You by any and all Contributors for the Covered Software under Section 254 | 2.1 of this License shall terminate. 255 | 256 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 257 | end user license agreements (excluding distributors and resellers) which 258 | have been validly granted by You or Your distributors under this License 259 | prior to termination shall survive termination. 260 | 261 | ************************************************************************ 262 | * * 263 | * 6. Disclaimer of Warranty * 264 | * ------------------------- * 265 | * * 266 | * Covered Software is provided under this License on an "as is" * 267 | * basis, without warranty of any kind, either expressed, implied, or * 268 | * statutory, including, without limitation, warranties that the * 269 | * Covered Software is free of defects, merchantable, fit for a * 270 | * particular purpose or non-infringing. The entire risk as to the * 271 | * quality and performance of the Covered Software is with You. * 272 | * Should any Covered Software prove defective in any respect, You * 273 | * (not any Contributor) assume the cost of any necessary servicing, * 274 | * repair, or correction. This disclaimer of warranty constitutes an * 275 | * essential part of this License. No use of any Covered Software is * 276 | * authorized under this License except under this disclaimer. * 277 | * * 278 | ************************************************************************ 279 | 280 | ************************************************************************ 281 | * * 282 | * 7. Limitation of Liability * 283 | * -------------------------- * 284 | * * 285 | * Under no circumstances and under no legal theory, whether tort * 286 | * (including negligence), contract, or otherwise, shall any * 287 | * Contributor, or anyone who distributes Covered Software as * 288 | * permitted above, be liable to You for any direct, indirect, * 289 | * special, incidental, or consequential damages of any character * 290 | * including, without limitation, damages for lost profits, loss of * 291 | * goodwill, work stoppage, computer failure or malfunction, or any * 292 | * and all other commercial damages or losses, even if such party * 293 | * shall have been informed of the possibility of such damages. This * 294 | * limitation of liability shall not apply to liability for death or * 295 | * personal injury resulting from such party's negligence to the * 296 | * extent applicable law prohibits such limitation. Some * 297 | * jurisdictions do not allow the exclusion or limitation of * 298 | * incidental or consequential damages, so this exclusion and * 299 | * limitation may not apply to You. * 300 | * * 301 | ************************************************************************ 302 | 303 | 8. Litigation 304 | ------------- 305 | 306 | Any litigation relating to this License may be brought only in the 307 | courts of a jurisdiction where the defendant maintains its principal 308 | place of business and such litigation shall be governed by laws of that 309 | jurisdiction, without reference to its conflict-of-law provisions. 310 | Nothing in this Section shall prevent a party's ability to bring 311 | cross-claims or counter-claims. 312 | 313 | 9. Miscellaneous 314 | ---------------- 315 | 316 | This License represents the complete agreement concerning the subject 317 | matter hereof. If any provision of this License is held to be 318 | unenforceable, such provision shall be reformed only to the extent 319 | necessary to make it enforceable. Any law or regulation which provides 320 | that the language of a contract shall be construed against the drafter 321 | shall not be used to construe this License against a Contributor. 322 | 323 | 10. Versions of the License 324 | --------------------------- 325 | 326 | 10.1. New Versions 327 | 328 | Mozilla Foundation is the license steward. Except as provided in Section 329 | 10.3, no one other than the license steward has the right to modify or 330 | publish new versions of this License. Each version will be given a 331 | distinguishing version number. 332 | 333 | 10.2. Effect of New Versions 334 | 335 | You may distribute the Covered Software under the terms of the version 336 | of the License under which You originally received the Covered Software, 337 | or under the terms of any subsequent version published by the license 338 | steward. 339 | 340 | 10.3. Modified Versions 341 | 342 | If you create software not governed by this License, and you want to 343 | create a new license for such software, you may create and use a 344 | modified version of this License if you rename the license and remove 345 | any references to the name of the license steward (except to note that 346 | such modified license differs from this License). 347 | 348 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 349 | Licenses 350 | 351 | If You choose to distribute Source Code Form that is Incompatible With 352 | Secondary Licenses under the terms of this version of the License, the 353 | notice described in Exhibit B of this License must be attached. 354 | 355 | Exhibit A - Source Code Form License Notice 356 | ------------------------------------------- 357 | 358 | This Source Code Form is subject to the terms of the Mozilla Public 359 | License, v. 2.0. If a copy of the MPL was not distributed with this 360 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 361 | 362 | If it is not possible or desirable to put the notice in a particular 363 | file, then You may include the notice in a location (such as a LICENSE 364 | file in a relevant directory) where a recipient would be likely to look 365 | for such a notice. 366 | 367 | You may add additional accurate notices of copyright ownership. 368 | 369 | Exhibit B - "Incompatible With Secondary Licenses" Notice 370 | --------------------------------------------------------- 371 | 372 | This Source Code Form is "Incompatible With Secondary Licenses", as 373 | defined by the Mozilla Public License, v. 2.0. 374 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Scheme-rs: Embedded Scheme for the Async Rust Ecosystem 2 | 3 | Scheme-rs is a work-in-progress implementation of the [R6RS](https://www.r6rs.org/final/r6rs.pdf) specification 4 | of the scheme programming language that is designed to work with async Rust runtimes like [tokio](https://tokio.rs/). 5 | In essence, it is a embedded scripting language for the async Rust ecosystem. 6 | 7 | Scheme-rs is intended to be fully compliant with R6RS, and R7RS large when it is eventually released. To that end 8 | the bones are mostly there but some key issues remain. 9 | 10 | Eventually, I would like scheme-rs to be more opinionated in the extras it provides, and include a package manager. 11 | That is obviously a long way away. 12 | 13 | ## Features currently supported by scheme-rs: 14 | 15 | - Tail-call optimizations are fully supported 16 | - Garbage Collected via [Bacon-Rajan Concurrent Cycle Collection](https://pages.cs.wisc.edu/~cymen/misc/interests/Bacon01Concurrent.pdf) 17 | - Most key forms (let/let*/letrec/lambda/define etc) 18 | - Call by current continuation 19 | - Hygienic macros and syntax transformers (`define-syntax`, `syntax-case`, `datum->syntax` and `syntax->datum`) 20 | - Spawning tasks and awaiting futures 21 | - Exceptions and error handling (`raise`, `raise-continuable`, `with-exception-handler`) 22 | - `dynamic-wind` 23 | - Defining async bridge functions in Rust 24 | 25 | ## Features currently unsupported by scheme-rs: 26 | 27 | - Records and conditions 28 | - Ports and IO operations 29 | - Most API functions are not implemented 30 | - A large portion of lexical structures are missing; there's no way to specify recursive data structures 31 | - And many more that I cannot think of off the top of my head 32 | 33 | ## Implementation details: 34 | 35 | `scheme-rs` is JIT compiled, compiling the expanded Scheme code into a [CPS](https://en.wikipedia.org/wiki/Continuation-passing_style) 36 | mid-level IR, and then converting that into LLVM IR. 37 | 38 | At present the code produced by `scheme-rs` is of pretty poor quality. Very few optimizations are performed, all variables 39 | are boxed. Focus was spent on making this project as correct as possible, and to that end this is a JIT compiler for 40 | scheme that fully supports syntax-case, proper tail recursion, and interaction with async Rust. Contributions are more than 41 | welcome if you would like to add optimizations passes to the compiler. 42 | 43 | ## Usage: 44 | 45 | ### Running a REPL: 46 | 47 | A REPL is the default entry point for scheme-rs at the current moment. You can access it by running `cargo run` 48 | in the repo's root directory (examples taken from wikipedia): 49 | 50 | ``` 51 | ~/scheme-rs> cargo run 52 | Finished `dev` profile [unoptimized + debuginfo] target(s) in 0.03s 53 | Running `target/debug/scheme-rs` 54 | > (let loop ((n 1)) 55 | (if (> n 10) 56 | '() 57 | (cons n 58 | (loop (+ n 1))))) 59 | $1 = (1 2 3 4 5 6 7 8 9 10) 60 | > (let* ((yin 61 | ((lambda (cc) (display "@") cc) (call-with-current-continuation (lambda (c) c)))) 62 | (yang 63 | ((lambda (cc) (display "*") cc) (call-with-current-continuation (lambda (c) c))))) 64 | (yin yang)) 65 | @*@**@***@****@*****@******@*******@********@*********@**********@***********@**********...^C 66 | ``` 67 | 68 | ### Creating Builtin Functions: 69 | 70 | Scheme-rs provides a `bridge` function attribute macro to allow you to easily define builtins. Here is 71 | an example of a function that reads a file into a string using tokio's `read_to_string` function: 72 | 73 | ```rust 74 | #[bridge(name = "read-file-to-string", lib = "(base)")] 75 | pub async fn read_file(file: &Value) -> Result, Condition> { 76 | let file = file.to_string(); 77 | let contents = tokio::fs::read_to_string(&file) 78 | .await 79 | .map_err(|err| Condition::error(format!("failed to read file {file}: {err:?}")))?; 80 | Ok(vec![Value::from(contents)]) 81 | } 82 | ``` 83 | 84 | ## Contributing 85 | 86 | If you are an intrepid scheme compiler optimizer, this project is for you! Lots of work needs to be done 87 | to bring this project up to snuff. The initial focus was on correctness, so if you would like to take a 88 | stab at improving perf or add features anywhere in this project, feel free! 89 | 90 | If you have any questions or comments about the project, feel free to join [the scheme-rs discord server here](https://discord.gg/sR4TttzGv5). 91 | -------------------------------------------------------------------------------- /benches/fib.rs: -------------------------------------------------------------------------------- 1 | use scheme_rs::{ 2 | ast::DefinitionBody, 3 | cps::Compile, 4 | env::{Environment, Top}, 5 | gc::Gc, 6 | registry::Registry, 7 | runtime::Runtime, 8 | syntax::{Span, Syntax}, 9 | }; 10 | 11 | use criterion::*; 12 | 13 | async fn fib_fn() -> Gc { 14 | let runtime = Gc::new(Runtime::new()); 15 | let registry = Registry::new(&runtime).await; 16 | let base = registry.import("(base)").unwrap(); 17 | let mut test_top = Top::program(); 18 | { 19 | let base = base.read(); 20 | test_top.import(&base); 21 | } 22 | let test_top = Environment::from(Gc::new(test_top)); 23 | 24 | let sexprs = Syntax::from_str(include_str!("fib.scm"), Some("fib.scm")).unwrap(); 25 | let base = DefinitionBody::parse_program_body(&runtime, &sexprs, &test_top, &Span::default()) 26 | .await 27 | .unwrap(); 28 | let compiled = base.compile_top_level(); 29 | runtime.compile_expr(compiled).await.unwrap() 30 | } 31 | 32 | fn fib_benchmark(c: &mut Criterion) { 33 | // Set up and compile the closure 34 | let runtime = tokio::runtime::Runtime::new().unwrap(); 35 | let closure = runtime.block_on(async move { fib_fn().await }); 36 | 37 | c.bench_function("fib 10000", |b| { 38 | b.to_async(&runtime).iter(|| { 39 | let val = closure.clone(); 40 | async move { val.call(&[]).await } 41 | }) 42 | }); 43 | } 44 | 45 | criterion_group!(benches, fib_benchmark); 46 | criterion_main!(benches); 47 | -------------------------------------------------------------------------------- /benches/fib.scm: -------------------------------------------------------------------------------- 1 | (define (fib n) 2 | (define (iter a b count) 3 | (if (<= count 0) 4 | a 5 | (iter b (+ a b) (- count 1)))) 6 | (iter 0 1 n)) 7 | 8 | (fib 10000) 9 | -------------------------------------------------------------------------------- /build.rs: -------------------------------------------------------------------------------- 1 | use std::{ 2 | env, 3 | error::Error, 4 | fs::{self, File}, 5 | io::Write, 6 | path::Path, 7 | }; 8 | 9 | #[path = "build/lexer.rs"] 10 | mod lexer; 11 | 12 | #[path = "build/parser.rs"] 13 | mod parser; 14 | 15 | fn main() -> Result<(), Box> { 16 | let manifest_dir = env::var("CARGO_MANIFEST_DIR")?; 17 | let manifest_dir = Path::new(&manifest_dir); 18 | 19 | let src = ["case_folding", "numeric_types"] 20 | .into_iter() 21 | .map(|p| format!("unicode/{}.txt", p)) 22 | .map(|p| manifest_dir.join(p)) 23 | .map(fs::read_to_string) 24 | .collect::>()?; 25 | 26 | let output = parser::File::try_from(lexer::lex(&src).map_err(|e| e.to_string())?.1)?; 27 | 28 | let output_dir = env::var("OUT_DIR")?; 29 | let output_dir = Path::new(&output_dir); 30 | let mut output_file = File::create(output_dir.join("unicode.rs"))?; 31 | writeln!(output_file, "{}", output)?; 32 | 33 | Ok(()) 34 | } 35 | -------------------------------------------------------------------------------- /build/lexer.rs: -------------------------------------------------------------------------------- 1 | use nom::{ 2 | branch::alt, 3 | bytes::complete::{tag, take_while}, 4 | character::complete::{digit1, hex_digit1, line_ending, not_line_ending, space0}, 5 | combinator::{map, opt}, 6 | sequence::{delimited, preceded, terminated, tuple}, 7 | IResult, 8 | }; 9 | 10 | pub fn lex(src: &str) -> IResult<&str, Vec>> { 11 | let mut lines = Vec::new(); 12 | let mut src_p: &str = src; 13 | while !src_p.is_empty() { 14 | let out = Line::lex(src_p)?; 15 | src_p = out.0; 16 | lines.push(out.1); 17 | } 18 | 19 | Ok((src_p, lines)) 20 | } 21 | 22 | #[derive(Debug)] 23 | pub enum Line<'a> { 24 | Empty, 25 | CaseFolding(CaseFolding<'a>), 26 | NumericType(NumericType<'a>), 27 | } 28 | impl<'a> Line<'a> { 29 | pub fn lex(l: &'a str) -> IResult<&'a str, Self> { 30 | terminated( 31 | alt(( 32 | map(CaseFolding::lex, Self::CaseFolding), 33 | map(NumericType::lex, Self::NumericType), 34 | map( 35 | alt(( 36 | preceded(tag("#"), preceded(space0, not_line_ending)), 37 | space0, 38 | )), 39 | |_| Self::Empty, 40 | ), 41 | )), 42 | line_ending, 43 | )(l) 44 | } 45 | } 46 | 47 | #[derive(Debug)] 48 | pub struct CaseFolding<'a> { 49 | pub from: &'a str, 50 | pub _status: CaseFoldingStatus, 51 | pub into: &'a str, 52 | pub name: &'a str, 53 | } 54 | impl<'a> CaseFolding<'a> { 55 | pub fn lex(l: &'a str) -> IResult<&'a str, Self> { 56 | map( 57 | tuple(( 58 | terminated(terminated(hex_digit1, tag(";")), space0), 59 | terminated(terminated(CaseFoldingStatus::lex, tag(";")), space0), 60 | terminated( 61 | terminated( 62 | take_while(|c: char| c.is_whitespace() || c.is_ascii_hexdigit()), 63 | tag(";"), 64 | ), 65 | space0, 66 | ), 67 | preceded(tag("#"), preceded(space0, not_line_ending)), 68 | )), 69 | |(from, status, into, name)| Self { 70 | from, 71 | _status: status, 72 | into, 73 | name, 74 | }, 75 | )(l) 76 | } 77 | } 78 | 79 | #[derive(Debug)] 80 | pub enum CaseFoldingStatus { 81 | Common, 82 | Full, 83 | Simple, 84 | Turkic, 85 | } 86 | impl CaseFoldingStatus { 87 | pub fn lex(l: &str) -> IResult<&str, Self> { 88 | alt(( 89 | map(tag("C"), |_| Self::Common), 90 | map(tag("F"), |_| Self::Full), 91 | map(tag("S"), |_| Self::Simple), 92 | map(tag("T"), |_| Self::Turkic), 93 | ))(l) 94 | } 95 | } 96 | 97 | #[derive(Debug)] 98 | pub struct NumericType<'a> { 99 | pub lower_bound: &'a str, 100 | pub upper_bound: Option<&'a str>, 101 | pub num_group: NumberGroup, 102 | pub _char_group: CharGroup, 103 | pub len: Option<&'a str>, 104 | pub name: &'a str, 105 | } 106 | impl<'a> NumericType<'a> { 107 | pub fn lex(l: &'a str) -> IResult<&'a str, Self> { 108 | map( 109 | tuple(( 110 | terminated(hex_digit1, space0), 111 | opt(terminated(preceded(tag(".."), hex_digit1), space0)), 112 | terminated( 113 | preceded(preceded(tag(";"), space0), NumberGroup::lex), 114 | space0, 115 | ), 116 | terminated(preceded(preceded(tag("#"), space0), CharGroup::lex), space0), 117 | terminated(opt(delimited(tag("["), digit1, tag("]"))), space0), 118 | not_line_ending, 119 | )), 120 | |(lower_bound, upper_bound, num_group, char_group, len, name)| Self { 121 | lower_bound, 122 | upper_bound, 123 | num_group, 124 | _char_group: char_group, 125 | len, 126 | name, 127 | }, 128 | )(l) 129 | } 130 | } 131 | 132 | #[derive(Debug)] 133 | pub enum NumberGroup { 134 | Decimal, 135 | Digit, 136 | Numeric, 137 | } 138 | impl NumberGroup { 139 | pub fn lex(l: &str) -> IResult<&str, Self> { 140 | alt(( 141 | map(tag("Decimal"), |_| Self::Decimal), 142 | map(tag("Digit"), |_| Self::Digit), 143 | map(tag("Numeric"), |_| Self::Numeric), 144 | ))(l) 145 | } 146 | } 147 | 148 | #[derive(Debug)] 149 | pub enum CharGroup { 150 | // number decimal 151 | Nd, 152 | /// number letter 153 | Nl, 154 | /// number other 155 | No, 156 | /// letter other 157 | Lo, 158 | } 159 | impl CharGroup { 160 | pub fn lex(l: &str) -> IResult<&str, Self> { 161 | alt(( 162 | map(tag("Lo"), |_| Self::Lo), 163 | map(tag("Nd"), |_| Self::Nd), 164 | map(tag("Nl"), |_| Self::Nl), 165 | map(tag("No"), |_| Self::No), 166 | ))(l) 167 | } 168 | } 169 | -------------------------------------------------------------------------------- /build/parser.rs: -------------------------------------------------------------------------------- 1 | use crate::lexer::{Line, NumberGroup}; 2 | use std::{ 3 | collections::{hash_map, HashMap}, 4 | fmt::{Display, Formatter}, 5 | num::ParseIntError, 6 | ops::Range, 7 | str::FromStr, 8 | }; 9 | 10 | #[derive(Default)] 11 | pub struct File<'a> { 12 | case_foldings: HashMap, &'a str)>, 13 | numeric_types: HashMap, &'a str>, 14 | } 15 | impl<'a> TryFrom>> for File<'a> { 16 | type Error = ParseIntError; 17 | fn try_from(lines: Vec>) -> Result { 18 | let mut out = Self::default(); 19 | 20 | let (case_foldings, numeric_types): (Vec<_>, Vec<_>) = lines 21 | .into_iter() 22 | .filter(|line| matches!(line, Line::CaseFolding(_) | Line::NumericType(_))) 23 | .partition(|line| matches!(line, Line::CaseFolding(_))); 24 | 25 | case_foldings 26 | .into_iter() 27 | .map(|line| { 28 | let Line::CaseFolding(line) = line else { 29 | unreachable!() 30 | }; 31 | line 32 | }) 33 | .map(|case_folding| { 34 | Ok(( 35 | u32::from_str_radix(case_folding.from, 16)?, 36 | case_folding 37 | .into 38 | .split(' ') 39 | .map(|c| u32::from_str_radix(c, 16)) 40 | .collect::, ParseIntError>>()?, 41 | case_folding.name, 42 | )) 43 | }) 44 | .collect::, ParseIntError>>()? 45 | .into_iter() 46 | // insert if the we have less characters in order to allow more conversions 47 | .for_each(|(from, into, name)| match out.case_foldings.entry(from) { 48 | hash_map::Entry::Occupied(mut e) => { 49 | if e.get().0.len() <= into.len() { 50 | return; 51 | } 52 | e.insert((into, name)); 53 | } 54 | hash_map::Entry::Vacant(e) => { 55 | e.insert((into, name)); 56 | } 57 | }); 58 | out.numeric_types.extend( 59 | numeric_types 60 | .into_iter() 61 | .map(|line| { 62 | let Line::NumericType(line) = line else { 63 | unreachable!() 64 | }; 65 | line 66 | }) 67 | .filter(|line| matches!(line.num_group, NumberGroup::Decimal)) 68 | // all the decimals are complete 69 | .filter_map(|line| { 70 | Some((line.lower_bound, line.upper_bound?, line.len?, line.name)) 71 | }) 72 | .map(|(lower_bound, upper_bound, len, name)| { 73 | Ok(( 74 | u32::from_str_radix(lower_bound, 16)?, 75 | u32::from_str_radix(upper_bound, 16)?, 76 | usize::from_str(len)?, 77 | name, 78 | )) 79 | }) 80 | .collect::, ParseIntError>>()? 81 | .into_iter() 82 | // split the decimals into ranges of 10 83 | .flat_map(|(mut lower_bound, mut upper_bound, mut len, name)| { 84 | debug_assert!(len % 10 == 0, "all decimals should be a multiple of 10"); 85 | 86 | if len == 10 { 87 | vec![(lower_bound..upper_bound, name)] 88 | } else { 89 | upper_bound = lower_bound + 10; 90 | let mut ranges = Vec::with_capacity(len / 10); 91 | 92 | while len >= 10 { 93 | ranges.push((lower_bound..upper_bound, name)); 94 | lower_bound = upper_bound + 1; 95 | upper_bound = lower_bound + 10; 96 | len -= 10; 97 | } 98 | 99 | ranges 100 | } 101 | }), 102 | ); 103 | 104 | Ok(out) 105 | } 106 | } 107 | impl Display for File<'_> { 108 | fn fmt(&self, f: &mut Formatter<'_>) -> Result<(), std::fmt::Error> { 109 | writeln!( 110 | f, 111 | "pub fn digit_to_num(ch: char) -> Option {{ 112 | match ch {{" 113 | )?; 114 | self.numeric_types.iter().try_for_each(|(r, name)| { 115 | writeln!( 116 | f, 117 | " '\\u{{{:x}}}'..'\\u{{{:x}}}' => Some(ch as u32 - {0}), // {}", 118 | r.start, 119 | r.end + 1, 120 | name 121 | ) 122 | })?; 123 | writeln!( 124 | f, 125 | " _ => None, 126 | }} 127 | }}" 128 | )?; 129 | 130 | writeln!( 131 | f, 132 | "enum FoldcaseChars {{ 133 | Unary(char), 134 | Variadic(&'static [char]), 135 | }} 136 | impl FoldcaseChars {{ 137 | pub fn get(&self, index: usize) -> Option {{ 138 | match self {{ 139 | Self::Unary(i) => if index == 0 {{ Some(*i) }} else {{ None }}, 140 | Self::Variadic(i) => i.get(index).copied(), 141 | }} 142 | }} 143 | 144 | pub const fn len(&self) -> usize {{ 145 | match self {{ 146 | Self::Unary(_) => 1, 147 | Self::Variadic(i) => i.len(), 148 | }} 149 | }} 150 | }} 151 | 152 | pub struct ToFoldcase {{ 153 | chars: FoldcaseChars, 154 | i: u8, 155 | }} 156 | impl Iterator for ToFoldcase {{ 157 | type Item = char; 158 | fn next(&mut self) -> Option {{ 159 | let c = self.chars.get(self.i.into()); 160 | self.i = self.i.saturating_add(1); 161 | c 162 | }} 163 | }} 164 | impl ExactSizeIterator for ToFoldcase {{ 165 | fn len(&self) -> usize {{ 166 | self.chars.len().saturating_sub(self.i.into()) 167 | }} 168 | }} 169 | pub fn to_foldcase(ch: char) -> ToFoldcase {{ 170 | let chars = match ch {{" 171 | )?; 172 | self.case_foldings 173 | .iter() 174 | .try_for_each(|(from, (to, name))| { 175 | debug_assert!(!to.is_empty()); 176 | 177 | write!(f, " '\\u{{{:x}}}' => ", from)?; 178 | if to.len() == 1 { 179 | write!( 180 | f, 181 | "FoldcaseChars::Unary('\\u{{{:x}}}'),", 182 | to.first().unwrap() 183 | )?; 184 | } else { 185 | write!(f, "FoldcaseChars::Variadic(&[ ")?; 186 | to.iter() 187 | .try_for_each(|t| write!(f, "'\\u{{{:x}}}', ", t))?; 188 | write!(f, "]),")?; 189 | } 190 | writeln!(f, " // {}", name)?; 191 | 192 | Ok(()) 193 | })?; 194 | writeln!( 195 | f, 196 | " _ => FoldcaseChars::Unary(ch), 197 | }}; 198 | 199 | ToFoldcase {{ 200 | chars, 201 | i: 0, 202 | }} 203 | }}" 204 | )?; 205 | 206 | Ok(()) 207 | } 208 | } 209 | -------------------------------------------------------------------------------- /logo-dark.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maplant/scheme-rs/fb89f648144313039984bafcc70e968efb58d66f/logo-dark.png -------------------------------------------------------------------------------- /logo-light.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maplant/scheme-rs/fb89f648144313039984bafcc70e968efb58d66f/logo-light.png -------------------------------------------------------------------------------- /proc-macros/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "scheme-rs-macros" 3 | version = "0.1.0-alpha.1" 4 | edition = "2021" 5 | authors = ["Matthew Plant "] 6 | description = "Embedded scheme for the async-rust ecosystem (macros)" 7 | license = "MPL-2.0" 8 | 9 | documentation = "https://docs.rs/crate/scheme-rs" 10 | homepage = "https://github.com/maplant/scheme-rs" 11 | repository = "https://github.com/maplant/scheme-rs" 12 | 13 | [lib] 14 | proc-macro = true 15 | 16 | [dependencies] 17 | syn = { version = "2", features = ["full"] } 18 | quote = "1" 19 | proc-macro2 = "1" 20 | -------------------------------------------------------------------------------- /proc-macros/src/lib.rs: -------------------------------------------------------------------------------- 1 | use proc_macro::{self, TokenStream}; 2 | use proc_macro2::Span; 3 | use quote::quote; 4 | use syn::{ 5 | parse_macro_input, parse_quote, punctuated::Punctuated, DataEnum, DataStruct, DeriveInput, 6 | Fields, FnArg, GenericParam, Generics, Ident, ItemFn, LitStr, Member, Pat, PatIdent, PatType, 7 | Token, Type, TypeReference, 8 | }; 9 | 10 | #[proc_macro_attribute] 11 | pub fn bridge(args: TokenStream, item: TokenStream) -> TokenStream { 12 | let mut name: Option = None; 13 | let mut lib: Option = None; 14 | let bridge_attr_parser = syn::meta::parser(|meta| { 15 | if meta.path.is_ident("name") { 16 | name = Some(meta.value()?.parse()?); 17 | Ok(()) 18 | } else if meta.path.is_ident("lib") { 19 | lib = Some(meta.value()?.parse()?); 20 | Ok(()) 21 | } else { 22 | Err(meta.error("unsupported bridge property")) 23 | } 24 | }); 25 | 26 | parse_macro_input!(args with bridge_attr_parser); 27 | 28 | let name = name.unwrap().value(); 29 | let lib = lib.unwrap().value(); 30 | let bridge = parse_macro_input!(item as ItemFn); 31 | 32 | let impl_name = bridge.sig.ident.clone(); 33 | let wrapper_name = impl_name.to_string(); 34 | let wrapper_name = Ident::new(&wrapper_name, Span::call_site()); 35 | 36 | let is_variadic = if let Some(last_arg) = bridge.sig.inputs.last() { 37 | is_slice(last_arg) 38 | } else { 39 | false 40 | }; 41 | 42 | let num_args = if is_variadic { 43 | bridge.sig.inputs.len().saturating_sub(1) 44 | } else { 45 | bridge.sig.inputs.len() 46 | }; 47 | 48 | let arg_names: Vec<_> = bridge 49 | .sig 50 | .inputs 51 | .iter() 52 | .enumerate() 53 | .map(|(i, arg)| { 54 | if let FnArg::Typed(PatType { pat, .. }) = arg { 55 | if let Pat::Ident(PatIdent { ref ident, .. }) = pat.as_ref() { 56 | return ident.to_string(); 57 | } 58 | } 59 | format!("arg{i}") 60 | }) 61 | .collect(); 62 | 63 | let wrapper: ItemFn = if !is_variadic { 64 | let arg_indices: Vec<_> = (0..num_args).collect(); 65 | parse_quote! { 66 | pub(crate) fn #wrapper_name<'a>( 67 | args: &'a [::scheme_rs::value::Value], 68 | rest_args: &'a [::scheme_rs::value::Value], 69 | cont: &'a ::scheme_rs::value::Value, 70 | _env: &'a [::scheme_rs::gc::Gc<::scheme_rs::value::Value>], 71 | exception_handler: &'a Option<::scheme_rs::gc::Gc<::scheme_rs::exception::ExceptionHandler>>, 72 | dynamic_wind: &'a ::scheme_rs::proc::DynamicWind, 73 | ) -> futures::future::BoxFuture<'a, Result> { 74 | #bridge 75 | 76 | Box::pin( 77 | async move { 78 | let cont = cont.clone().try_into()?; 79 | Ok(::scheme_rs::proc::Application::new( 80 | cont, 81 | #impl_name( 82 | #( &args[#arg_indices], )* 83 | ).await?, 84 | exception_handler.clone(), 85 | dynamic_wind.clone(), 86 | None // TODO 87 | )) 88 | } 89 | ) 90 | } 91 | } 92 | } else { 93 | let arg_indices: Vec<_> = (0..num_args).collect(); 94 | parse_quote! { 95 | pub(crate) fn #wrapper_name<'a>( 96 | args: &'a [::scheme_rs::value::Value], 97 | rest_args: &'a [::scheme_rs::value::Value], 98 | cont: &'a ::scheme_rs::value::Value, 99 | _env: &'a [::scheme_rs::gc::Gc<::scheme_rs::value::Value>], 100 | exception_handler: &'a Option<::scheme_rs::gc::Gc<::scheme_rs::exception::ExceptionHandler>>, 101 | dynamic_wind: &'a ::scheme_rs::proc::DynamicWind, 102 | ) -> futures::future::BoxFuture<'a, Result> { 103 | #bridge 104 | 105 | Box::pin( 106 | async move { 107 | let cont = cont.clone().try_into()?; 108 | Ok(::scheme_rs::proc::Application::new( 109 | cont, 110 | #impl_name( 111 | #( &args[#arg_indices], )* 112 | rest_args 113 | ).await?, 114 | exception_handler.clone(), 115 | dynamic_wind.clone(), 116 | None // TODO 117 | )) 118 | } 119 | ) 120 | } 121 | } 122 | }; 123 | quote! { 124 | #wrapper 125 | 126 | inventory::submit! { 127 | ::scheme_rs::registry::BridgeFn::new( 128 | #name, 129 | #lib, 130 | #num_args, 131 | #is_variadic, 132 | #wrapper_name, 133 | ::scheme_rs::registry::BridgeFnDebugInfo::new( 134 | ::std::file!(), 135 | ::std::line!(), 136 | ::std::column!(), 137 | 0, 138 | &[ #( #arg_names, )* ], 139 | ) 140 | ) 141 | } 142 | } 143 | .into() 144 | } 145 | 146 | fn is_slice(arg: &FnArg) -> bool { 147 | matches!(arg, FnArg::Typed(PatType { ty, ..}) if matches!(ty.as_ref(), Type::Reference(TypeReference { elem, .. }) if matches!(elem.as_ref(), Type::Slice(_)))) 148 | } 149 | 150 | #[proc_macro_derive(Trace)] 151 | pub fn derive_trace(input: TokenStream) -> TokenStream { 152 | let DeriveInput { 153 | ident, 154 | data, 155 | generics, 156 | .. 157 | } = parse_macro_input!(input); 158 | 159 | match data { 160 | syn::Data::Struct(data_struct) => derive_trace_struct(ident, data_struct, generics).into(), 161 | syn::Data::Enum(data_enum) => derive_trace_enum(ident, data_enum, generics).into(), 162 | _ => panic!("Union types are not supported."), 163 | } 164 | } 165 | 166 | fn derive_trace_struct( 167 | name: Ident, 168 | record: DataStruct, 169 | generics: Generics, 170 | ) -> proc_macro2::TokenStream { 171 | let fields = match record.fields { 172 | Fields::Named(fields) => fields.named, 173 | Fields::Unnamed(fields) => fields.unnamed, 174 | _ => { 175 | return quote! { 176 | unsafe impl ::scheme_rs::gc::Trace for #name { 177 | unsafe fn visit_children(&self, visitor: unsafe fn(::scheme_rs::gc::OpaqueGcPtr)) {} 178 | } 179 | } 180 | } 181 | }; 182 | 183 | let Generics { 184 | mut params, 185 | where_clause, 186 | .. 187 | } = generics; 188 | 189 | let mut unbound_params = Punctuated::::new(); 190 | 191 | for param in params.iter_mut() { 192 | match param { 193 | GenericParam::Type(ref mut ty) => { 194 | ty.bounds.push(syn::TypeParamBound::Verbatim( 195 | quote! { ::scheme_rs::gc::Trace }, 196 | )); 197 | unbound_params.push(GenericParam::Type(syn::TypeParam::from(ty.ident.clone()))); 198 | } 199 | param => unbound_params.push(param.clone()), 200 | } 201 | } 202 | 203 | let field_visits = fields 204 | .iter() 205 | .enumerate() 206 | .map(|(i, f)| { 207 | let ident = f.ident.clone().map_or_else( 208 | || { 209 | Member::Unnamed(syn::Index { 210 | index: i as u32, 211 | span: Span::call_site(), 212 | }) 213 | }, 214 | Member::Named, 215 | ); 216 | if is_gc(&f.ty) { 217 | quote! { 218 | visitor(self.#ident.as_opaque()); 219 | } 220 | } else { 221 | quote! { 222 | self. #ident .visit_children(visitor); 223 | } 224 | } 225 | }) 226 | .collect::>(); 227 | 228 | let field_drops = fields 229 | .iter() 230 | .enumerate() 231 | .flat_map(|(i, f)| { 232 | let ident = f.ident.clone().map_or_else( 233 | || { 234 | Member::Unnamed(syn::Index { 235 | index: i as u32, 236 | span: Span::call_site(), 237 | }) 238 | }, 239 | Member::Named, 240 | ); 241 | if !is_gc(&f.ty) { 242 | Some(quote! { 243 | self.#ident.finalize(); 244 | }) 245 | } else { 246 | None 247 | } 248 | }) 249 | .collect::>(); 250 | 251 | quote! { 252 | #[automatically_derived] 253 | unsafe impl<#params> ::scheme_rs::gc::Trace for #name <#unbound_params> 254 | #where_clause 255 | { 256 | unsafe fn visit_children(&self, visitor: unsafe fn(::scheme_rs::gc::OpaqueGcPtr)) { 257 | #( 258 | #field_visits 259 | )* 260 | } 261 | 262 | unsafe fn finalize(&mut self) { 263 | #( 264 | #field_drops 265 | )* 266 | } 267 | } 268 | } 269 | } 270 | 271 | // TODO: Add generics here 272 | fn derive_trace_enum( 273 | name: Ident, 274 | data_enum: DataEnum, 275 | generics: Generics, 276 | ) -> proc_macro2::TokenStream { 277 | let (visit_match_clauses, finalize_match_clauses): (Vec<_>, Vec<_>) = data_enum 278 | .variants 279 | .into_iter() 280 | .flat_map(|variant| { 281 | let fields: Vec<_> = match variant.fields { 282 | Fields::Named(ref named) => named 283 | .named 284 | .iter() 285 | .map(|field| (field.ty.clone(), field.ident.as_ref().unwrap().clone())) 286 | .collect(), 287 | Fields::Unnamed(ref unnamed) => unnamed 288 | .unnamed 289 | .iter() 290 | .enumerate() 291 | .map(|(i, field)| { 292 | let ident = Ident::new(&format!("t{i}"), Span::call_site()); 293 | (field.ty.clone(), ident) 294 | }) 295 | .collect(), 296 | _ => return None, 297 | }; 298 | let visits: Vec<_> = fields 299 | .iter() 300 | .map(|(ty, accessor)| { 301 | if is_gc(ty) { 302 | quote! { 303 | visitor(#accessor.as_opaque()) 304 | } 305 | } else { 306 | quote! { 307 | #accessor.visit_children(visitor) 308 | } 309 | } 310 | }) 311 | .collect(); 312 | let drops: Vec<_> = fields 313 | .iter() 314 | .filter(|(ty, _)| !is_gc(ty)) 315 | .map(|(_, accessor)| { 316 | quote! { 317 | #accessor.finalize(); 318 | } 319 | }) 320 | .collect(); 321 | let field_name = fields.iter().map(|(_, field)| field); 322 | let fields_destructured = match variant.fields { 323 | Fields::Named(..) => quote! { { #( ref #field_name, )* .. } }, 324 | _ => quote! { ( #( ref #field_name ),* ) }, 325 | }; 326 | let field_name = fields.iter().map(|(_, field)| field); 327 | let fields_destructured_mut = match variant.fields { 328 | Fields::Named(..) => quote! { { #( ref mut #field_name, )* .. } }, 329 | _ => quote! { ( #( ref mut #field_name ),* ) }, 330 | }; 331 | let variant_name = variant.ident; 332 | Some(( 333 | quote! { 334 | Self::#variant_name #fields_destructured => { 335 | #( 336 | #visits; 337 | )* 338 | } 339 | }, 340 | quote! { 341 | Self::#variant_name #fields_destructured_mut => { 342 | #( 343 | #drops 344 | )* 345 | } 346 | }, 347 | )) 348 | }) 349 | .unzip(); 350 | 351 | let Generics { 352 | mut params, 353 | where_clause, 354 | .. 355 | } = generics; 356 | 357 | let mut unbound_params = Punctuated::::new(); 358 | 359 | for param in params.iter_mut() { 360 | match param { 361 | GenericParam::Type(ref mut ty) => { 362 | ty.bounds.push(syn::TypeParamBound::Verbatim( 363 | quote! { ::scheme_rs::gc::Trace }, 364 | )); 365 | unbound_params.push(GenericParam::Type(syn::TypeParam::from(ty.ident.clone()))); 366 | } 367 | param => unbound_params.push(param.clone()), 368 | } 369 | } 370 | 371 | quote! { 372 | unsafe impl<#params> ::scheme_rs::gc::Trace for #name <#unbound_params> 373 | #where_clause 374 | { 375 | unsafe fn visit_children(&self, visitor: unsafe fn(::scheme_rs::gc::OpaqueGcPtr)) { 376 | match self { 377 | #( #visit_match_clauses, )* 378 | _ => (), 379 | } 380 | } 381 | 382 | unsafe fn finalize(&mut self) { 383 | match self { 384 | #( #finalize_match_clauses, )* 385 | _ => (), 386 | } 387 | } 388 | } 389 | } 390 | } 391 | 392 | fn is_gc(arg: &Type) -> bool { 393 | if let Type::Path(ref path) = arg { 394 | return path 395 | .path 396 | .segments 397 | .last() 398 | .map(|p| p.ident.to_string()) 399 | .as_deref() 400 | == Some("Gc"); 401 | } 402 | false 403 | } 404 | -------------------------------------------------------------------------------- /src/character.rs: -------------------------------------------------------------------------------- 1 | use std::sync::Arc; 2 | 3 | use crate::{exception::Condition, num::Number, registry::bridge, value::Value}; 4 | use unicode_categories::UnicodeCategories; 5 | 6 | mod unicode; 7 | use unicode::*; 8 | 9 | fn char_switch_case + ExactSizeIterator>( 10 | ch: char, 11 | operation: fn(char) -> I, 12 | ) -> Result { 13 | let mut ch = operation(ch); 14 | let len = ch.len(); 15 | if len == 1 { 16 | Ok(ch.next().unwrap()) 17 | } else { 18 | Err(Condition::wrong_num_of_unicode_chars(1, len)) 19 | } 20 | } 21 | 22 | #[bridge(name = "char->integer", lib = "(base)")] 23 | pub async fn char_to_integer(ch: &Value) -> Result, Condition> { 24 | let ch: char = ch.clone().try_into()?; 25 | 26 | Ok(vec![Value::from(Number::FixedInteger( 27 | >::into(ch).into(), 28 | ))]) 29 | } 30 | 31 | #[bridge(name = "integer->char", lib = "(base)")] 32 | pub async fn integer_to_char(int: &Value) -> Result, Condition> { 33 | let int: Arc = int.clone().try_into()?; 34 | let int: usize = int.as_ref().try_into()?; 35 | if let Ok(int) = >::try_into(int) { 36 | if let Some(ch) = char::from_u32(int) { 37 | return Ok(vec![Value::from(ch)]); 38 | } 39 | } 40 | 41 | // char->integer returns a number larger than 0x10FFFF if integer is not an unicode scalar 42 | Ok(vec![Value::from(Number::FixedInteger(0x10FFFF + 1))]) 43 | } 44 | 45 | macro_rules! impl_char_operator { 46 | ( 47 | $(($bridge_name:literal, 48 | $function_name:ident, 49 | $cmp_function:ident)),* $(,)? 50 | ) => { 51 | $(#[bridge(name = $bridge_name, lib = "(base)")] 52 | pub async fn $function_name(req_lhs: &Value, req_rhs: &Value, opt_chars: &[Value]) -> Result, Condition> { 53 | for window in [req_lhs, req_rhs] 54 | .into_iter() 55 | .chain(opt_chars) 56 | .map(|ch| { 57 | ch.clone().try_into() 58 | }) 59 | .collect::, Condition>>()? 60 | .windows(2) { 61 | 62 | if !window.first() 63 | .and_then(|lhs| Some((lhs, window.get(1)?))) 64 | .map(|(lhs, rhs)| lhs.$cmp_function(rhs)) 65 | .unwrap_or(true) { 66 | return Ok(vec![Value::from(false)]); 67 | } 68 | } 69 | 70 | Ok(vec![Value::from(true)]) 71 | })* 72 | } 73 | } 74 | 75 | impl_char_operator![ 76 | ("char=?", char_eq, eq), 77 | ("char?", char_gt, gt), 79 | ("char>=?", char_ge, ge), 80 | ("char<=?", char_le, le), 81 | ]; 82 | 83 | macro_rules! impl_char_ci_operator { 84 | ( 85 | $(($bridge_name:literal, 86 | $function_name:ident, 87 | $cmp_function:ident)),* $(,)? 88 | ) => { 89 | $(#[bridge(name = $bridge_name, lib = "(base)")] 90 | pub async fn $function_name(req_lhs: &Value, req_rhs: &Value, opt_chars: &[Value]) -> Result, Condition> { 91 | for window in [req_lhs, req_rhs] 92 | .into_iter() 93 | .chain(opt_chars) 94 | .map(|ch| { 95 | let ch: char = ch.clone().try_into()?; 96 | char_switch_case(ch, to_foldcase) 97 | }) 98 | .collect::, Condition>>()? 99 | .windows(2) { 100 | 101 | if !window.first() 102 | .and_then(|lhs| Some((lhs, window.get(1)?))) 103 | .map(|(lhs, rhs)| lhs.$cmp_function(rhs)) 104 | .unwrap_or(true) { 105 | return Ok(vec![Value::from(false)]); 106 | } 107 | } 108 | 109 | Ok(vec![Value::from(true)]) 110 | })* 111 | } 112 | } 113 | 114 | impl_char_ci_operator![ 115 | ("char-ci-=?", char_ci_eq, eq), 116 | ("char-ci-?", char_ci_gt, gt), 118 | ("char-ci->=?", char_ci_ge, ge), 119 | ("char-ci-<=?", char_ci_le, le), 120 | ]; 121 | 122 | macro_rules! impl_char_predicate { 123 | ($(($bridge_name:literal, $function_name:ident, $predicate:ident)),* $(,)?) => { 124 | $(#[bridge(name = $bridge_name, lib = "(base)")] 125 | pub async fn $function_name(ch: &Value) -> Result, Condition> { 126 | let ch: char = ch.clone().try_into()?; 127 | Ok(vec![Value::from(ch.$predicate())]) 128 | })* 129 | } 130 | } 131 | 132 | impl_char_predicate![ 133 | ("char-alphabetic?", char_is_alphabetic, is_ascii_alphabetic), 134 | ("char-numeric?", char_is_numeric, is_number_decimal_digit), 135 | ("char-whitespace?", char_is_whitespace, is_whitespace), 136 | ("char-upper?", char_is_uppercase, is_uppercase), 137 | ("char-lower?", char_is_lowercase, is_lowercase), 138 | ]; 139 | 140 | #[bridge(name = "digit-value", lib = "(base)")] 141 | pub async fn digit_value(ch: &Value) -> Result, Condition> { 142 | let ch: char = ch.clone().try_into()?; 143 | 144 | Ok(vec![digit_to_num(ch) 145 | .map(>::into) 146 | .map(Number::FixedInteger) 147 | .map(Value::from) 148 | .unwrap_or(Value::from(false))]) 149 | } 150 | 151 | macro_rules! impl_char_case_converter { 152 | ($(($bridge_name:literal, $function_name:ident, $converter:expr)),* $(,)?) => { 153 | $(#[bridge(name = $bridge_name, lib = "(base)")] 154 | pub async fn $function_name(ch: &Value) -> Result, Condition> { 155 | let ch: char = ch.clone().try_into()?; 156 | Ok(vec![Value::from(char_switch_case(ch, $converter)?)]) 157 | })* 158 | } 159 | } 160 | 161 | impl_char_case_converter![ 162 | ("char-upcase", char_upcase, char::to_uppercase), 163 | ("char-downcase", char_downcase, char::to_lowercase), 164 | ]; 165 | 166 | #[bridge(name = "char-foldcase", lib = "(base)")] 167 | pub async fn char_foldcase(ch: &Value) -> Result, Condition> { 168 | let ch: char = ch.clone().try_into()?; 169 | Ok(vec![Value::from(char_switch_case(ch, to_foldcase)?)]) 170 | } 171 | 172 | #[cfg(test)] 173 | mod tests { 174 | use super::*; 175 | 176 | #[test] 177 | fn test_digit_to_num() { 178 | (char::MIN..char::MAX) 179 | .filter(|c| c.is_number_decimal_digit()) 180 | .map(digit_to_num) 181 | .for_each(|d| assert!(d.is_some())); 182 | } 183 | } 184 | -------------------------------------------------------------------------------- /src/character/unicode.rs: -------------------------------------------------------------------------------- 1 | include!(concat!(env!("OUT_DIR"), "/unicode.rs")); 2 | -------------------------------------------------------------------------------- /src/cps/analysis.rs: -------------------------------------------------------------------------------- 1 | //! Basic analysis stuff that we need. 2 | //! 3 | //! ## Free Variables: 4 | //! 5 | //! The free variables of a function are essentially the variables that we need 6 | //! to store in the environment for the closure we create for that function. 7 | //! Functions with no free variables do not escape and thus do not need a 8 | //! closure. 9 | //! 10 | //! To begin, we are converting all functions to closures, regardless of whether 11 | //! or not they escape. In this case, the free variables of a function f is 12 | //! simply F(f) = V(f) - B(f), where V(f) is the variables in the body of f and 13 | //! B(f) are the variables introduced in a binding in f. 14 | //! 15 | //! The function name itself does not count as a bound variable, and thus is a 16 | //! free variable in the context of the function's body. Also, _globals_ do not 17 | //! count as free variables, because we already have a different way for 18 | //! accessing those. 19 | 20 | use super::*; 21 | 22 | impl Cps { 23 | // TODO: Have this function return a Cow<'_, HashSet> 24 | pub(super) fn free_variables(&self) -> HashSet { 25 | match self { 26 | Cps::PrimOp(PrimOp::AllocCell, _, ref bind, cexpr) => { 27 | let mut free = cexpr.free_variables(); 28 | free.remove(bind); 29 | free 30 | } 31 | Cps::PrimOp(_, args, bind, cexpr) => { 32 | let mut free = cexpr.free_variables(); 33 | free.remove(bind); 34 | free.union(&values_to_locals(args)).copied().collect() 35 | } 36 | Cps::If(cond, success, failure) => { 37 | let mut free: HashSet<_> = success 38 | .free_variables() 39 | .union(&failure.free_variables()) 40 | .copied() 41 | .collect(); 42 | free.extend(cond.to_local()); 43 | free 44 | } 45 | Cps::App(op, vals, _) => { 46 | let mut free = values_to_locals(vals); 47 | free.extend(op.to_local()); 48 | free 49 | } 50 | Cps::Forward(op, arg) => vec![op.to_local(), arg.to_local()] 51 | .into_iter() 52 | .flatten() 53 | .collect(), 54 | Cps::Closure { 55 | args, 56 | body, 57 | val, 58 | cexp, 59 | .. 60 | } => { 61 | let mut free_body = body.free_variables(); 62 | for arg in args.to_vec() { 63 | free_body.remove(&arg); 64 | } 65 | let mut free_variables: HashSet<_> = 66 | free_body.union(&cexp.free_variables()).copied().collect(); 67 | free_variables.remove(val); 68 | free_variables 69 | } 70 | Cps::Halt(val) => val.to_local().into_iter().collect(), 71 | } 72 | } 73 | 74 | // TODO: Have this function return a Cow<'_, HashSet> 75 | pub(super) fn globals(&self) -> HashSet { 76 | match self { 77 | Cps::PrimOp(PrimOp::AllocCell, _, _, cexpr) => cexpr.globals(), 78 | Cps::PrimOp(_, args, _, cexpr) => cexpr 79 | .globals() 80 | .union(&values_to_globals(args)) 81 | .cloned() 82 | .collect(), 83 | Cps::If(cond, success, failure) => { 84 | let mut globals: HashSet<_> = success 85 | .globals() 86 | .union(&failure.globals()) 87 | .cloned() 88 | .collect(); 89 | globals.extend(cond.to_global()); 90 | globals 91 | } 92 | Cps::App(op, vals, _) => { 93 | let mut globals = values_to_globals(vals); 94 | globals.extend(op.to_global()); 95 | globals 96 | } 97 | Cps::Forward(op, arg) => vec![op.to_global(), arg.to_global()] 98 | .into_iter() 99 | .flatten() 100 | .collect(), 101 | Cps::Closure { body, cexp, .. } => { 102 | body.globals().union(&cexp.globals()).cloned().collect() 103 | } 104 | Cps::Halt(val) => val.to_global().into_iter().collect(), 105 | } 106 | } 107 | 108 | // TODO: Have this function return a Cow 109 | pub(super) fn uses( 110 | &self, 111 | uses_cache: &mut HashMap>, 112 | ) -> HashMap { 113 | match self { 114 | // Cps::AllocCell(_, cexpr) => cexpr.uses(uses_cache).clone(), 115 | Cps::PrimOp(_, args, _, cexpr) => { 116 | merge_uses(values_to_uses(args), cexpr.uses(uses_cache)) 117 | } 118 | Cps::If(cond, success, failure) => { 119 | let uses = merge_uses(success.uses(uses_cache).clone(), failure.uses(uses_cache)); 120 | add_value_use(uses, cond) 121 | } 122 | Cps::App(op, vals, _) => { 123 | let uses = values_to_uses(vals); 124 | add_value_use(uses, op) 125 | } 126 | Cps::Forward(op, arg) => add_value_use(add_value_use(HashMap::new(), op), arg), 127 | Cps::Closure { 128 | body, val, cexp, .. 129 | } => { 130 | if !uses_cache.contains_key(val) { 131 | let uses = merge_uses(body.uses(uses_cache).clone(), cexp.uses(uses_cache)); 132 | uses_cache.insert(*val, uses); 133 | } 134 | uses_cache.get(val).unwrap().clone() 135 | } 136 | Cps::Halt(value) => add_value_use(HashMap::new(), value), 137 | } 138 | } 139 | 140 | // TODO: Clean up this function! 141 | pub(super) fn need_cells( 142 | &self, 143 | local_args: &HashSet, 144 | escaping_arg_cache: &mut HashMap>, 145 | ) -> HashSet { 146 | match self { 147 | Cps::PrimOp(PrimOp::GetCallTransformerFn, args, _, cexp) => { 148 | // The GetCallTransformerFn requires that all arguments to it are 149 | // cells. We should fix this at some point. 150 | cexp.need_cells(local_args, escaping_arg_cache) 151 | .union(&values_to_locals(args)) 152 | .copied() 153 | .collect() 154 | } 155 | Cps::PrimOp(PrimOp::Set, args, _, cexp) => { 156 | let [to, from] = args.as_slice() else { 157 | unreachable!() 158 | }; 159 | // From should always escape so that it can be set. This is 160 | // really stretching the definition of "escaping", but it's easy 161 | // to put in here for now. 162 | let mut escaping_args = cexp.need_cells(local_args, escaping_arg_cache); 163 | match from.to_local() { 164 | Some(local) if !local_args.contains(&local) => { 165 | escaping_args.insert(local); 166 | } 167 | _ => (), 168 | } 169 | escaping_args.extend(to.to_local()); 170 | escaping_args 171 | } 172 | Cps::PrimOp(_, args, _, cexp) => values_to_locals(args) 173 | .difference(local_args) 174 | .copied() 175 | .collect::>() 176 | .union(&cexp.need_cells(local_args, escaping_arg_cache)) 177 | .copied() 178 | .collect::>(), 179 | Cps::If(cond, success, failure) => { 180 | let mut escaping_args: HashSet<_> = success 181 | .need_cells(local_args, escaping_arg_cache) 182 | .union(&failure.need_cells(local_args, escaping_arg_cache)) 183 | .copied() 184 | .collect(); 185 | match cond.to_local() { 186 | Some(local) if !local_args.contains(&local) => { 187 | escaping_args.insert(local); 188 | } 189 | _ => (), 190 | } 191 | escaping_args 192 | } 193 | Cps::App(op, vals, _) => { 194 | let mut escaping_args: HashSet<_> = values_to_locals(vals) 195 | .difference(local_args) 196 | .copied() 197 | .collect(); 198 | match op.to_local() { 199 | Some(local) if !local_args.contains(&local) => { 200 | escaping_args.insert(local); 201 | } 202 | _ => (), 203 | } 204 | escaping_args 205 | } 206 | Cps::Forward(op, val) => { 207 | let mut escaping_args = HashSet::new(); 208 | match val.to_local() { 209 | Some(local) if !local_args.contains(&local) => { 210 | escaping_args.insert(local); 211 | } 212 | _ => (), 213 | } 214 | match op.to_local() { 215 | Some(local) if !local_args.contains(&local) => { 216 | escaping_args.insert(local); 217 | } 218 | _ => (), 219 | } 220 | escaping_args 221 | } 222 | Cps::Halt(val) => { 223 | let mut escaping_args = HashSet::new(); 224 | match val.to_local() { 225 | Some(local) if !local_args.contains(&local) => { 226 | escaping_args.insert(local); 227 | } 228 | _ => (), 229 | } 230 | escaping_args 231 | } 232 | Cps::Closure { 233 | args, 234 | body, 235 | val, 236 | cexp, 237 | .. 238 | } => { 239 | if !escaping_arg_cache.contains_key(val) { 240 | let new_local_args: HashSet<_> = args.to_vec().into_iter().collect(); 241 | let escaping_args = body 242 | .need_cells(&new_local_args, escaping_arg_cache) 243 | .union(&cexp.need_cells(local_args, escaping_arg_cache)) 244 | .copied() 245 | .collect(); 246 | 247 | escaping_arg_cache.insert(*val, escaping_args); 248 | } 249 | escaping_arg_cache.get(val).unwrap().clone() 250 | } 251 | } 252 | } 253 | } 254 | 255 | fn values_to_locals(vals: &[Value]) -> HashSet { 256 | vals.iter().flat_map(|val| val.to_local()).collect() 257 | } 258 | 259 | fn values_to_uses(vals: &[Value]) -> HashMap { 260 | let mut uses = HashMap::new(); 261 | for local in vals.iter().flat_map(|val| val.to_local()) { 262 | *uses.entry(local).or_default() += 1; 263 | } 264 | uses 265 | } 266 | 267 | fn values_to_globals(vals: &[Value]) -> HashSet { 268 | vals.iter().flat_map(|val| val.to_global()).collect() 269 | } 270 | 271 | fn merge_uses(mut l: HashMap, r: HashMap) -> HashMap { 272 | for (local, uses) in r.into_iter() { 273 | *l.entry(local).or_default() += uses; 274 | } 275 | l 276 | } 277 | fn add_value_use(mut uses: HashMap, value: &Value) -> HashMap { 278 | if let Some(local) = value.to_local() { 279 | *uses.entry(local).or_default() += 1; 280 | } 281 | uses 282 | } 283 | -------------------------------------------------------------------------------- /src/cps/mod.rs: -------------------------------------------------------------------------------- 1 | //! Continuation-Passing Style 2 | //! 3 | //! Our mid-level representation for scheme code that ultimately gets translated 4 | //! into LLVM SSA for JIT compilation. This representation is the ultimate 5 | //! result of our parsing and compilation steps and the final step before JIT 6 | //! compilation. 7 | //! 8 | //! There are two main reasons we choose this IR: 9 | //! - Continuation-Passing Style lets use build our continuations mechanically 10 | //! once, as opposed to creating them at runtime by hand in a process that is 11 | //! slow and error prone. 12 | //! - Continuation-Passing Style maps well to SSA, allowing us to compile functions 13 | //! directly to machine code. 14 | 15 | use crate::{ 16 | env::{Global, Local, Var}, 17 | gc::Trace, 18 | runtime::{CallSiteId, FunctionDebugInfoId}, 19 | value::Value as RuntimeValue, 20 | }; 21 | use std::{ 22 | collections::{HashMap, HashSet}, 23 | fmt, 24 | str::FromStr, 25 | }; 26 | 27 | mod analysis; 28 | mod codegen; 29 | mod compile; 30 | mod reduce; 31 | 32 | pub use compile::Compile; 33 | 34 | #[derive(Clone, PartialEq)] 35 | pub enum Value { 36 | Var(Var), 37 | Const(RuntimeValue), 38 | } 39 | 40 | impl Value { 41 | fn to_local(&self) -> Option { 42 | if let Self::Var(Var::Local(local)) = self { 43 | Some(*local) 44 | } else { 45 | None 46 | } 47 | } 48 | 49 | fn to_global(&self) -> Option { 50 | if let Self::Var(Var::Global(global)) = self { 51 | Some(global.clone()) 52 | } else { 53 | None 54 | } 55 | } 56 | } 57 | 58 | impl From for Value { 59 | fn from(v: RuntimeValue) -> Self { 60 | Self::Const(v) 61 | } 62 | } 63 | 64 | impl From for Value { 65 | fn from(var: Var) -> Self { 66 | Self::Var(var) 67 | } 68 | } 69 | 70 | impl From for Value { 71 | fn from(local: Local) -> Self { 72 | Self::Var(Var::Local(local)) 73 | } 74 | } 75 | 76 | impl From for Value { 77 | fn from(global: Global) -> Self { 78 | Self::Var(Var::Global(global)) 79 | } 80 | } 81 | 82 | impl fmt::Debug for Value { 83 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 84 | match self { 85 | Self::Var(var) => var.fmt(f), 86 | Self::Const(val) => val.fmt(f), 87 | } 88 | } 89 | } 90 | 91 | #[derive(Copy, Clone, Debug, Trace)] 92 | pub enum PrimOp { 93 | /// Set cell value: 94 | Set, 95 | 96 | // Cell operations: 97 | /// Allocate a cell, returning a Gc. 98 | AllocCell, 99 | 100 | // List operators: 101 | Cons, 102 | 103 | // Math primitive operators: 104 | Add, 105 | Sub, 106 | Mul, 107 | Div, 108 | Equal, 109 | Greater, 110 | GreaterEqual, 111 | Lesser, 112 | LesserEqual, 113 | 114 | // Macro expansion primitive operators: 115 | CaptureEnvironment, 116 | GetCallTransformerFn, 117 | 118 | // Continuation primitive operators: 119 | CallWithCurrentContinuation, 120 | /// Converts a continuation to a callable user function 121 | PrepareContinuation, 122 | /// Extract the current winders from the environment into a value 123 | ExtractWinders, 124 | } 125 | 126 | impl FromStr for PrimOp { 127 | type Err = (); 128 | 129 | fn from_str(s: &str) -> Result { 130 | match s { 131 | "&call/cc" => Ok(Self::CallWithCurrentContinuation), 132 | _ => Err(()), 133 | } 134 | } 135 | } 136 | 137 | #[derive(Debug, Clone)] 138 | pub struct ClosureArgs { 139 | args: Vec, 140 | variadic: bool, 141 | continuation: Option, 142 | } 143 | 144 | impl ClosureArgs { 145 | fn new(args: Vec, variadic: bool, continuation: Option) -> Self { 146 | Self { 147 | args, 148 | variadic, 149 | continuation, 150 | } 151 | } 152 | 153 | fn iter_mut(&mut self) -> impl Iterator { 154 | self.args.iter_mut().chain(self.continuation.as_mut()) 155 | } 156 | 157 | fn to_vec(&self) -> Vec { 158 | self.args 159 | .clone() 160 | .into_iter() 161 | .chain(self.continuation) 162 | .collect() 163 | } 164 | 165 | fn num_required(&self) -> usize { 166 | self.args.len().saturating_sub(self.variadic as usize) 167 | } 168 | } 169 | 170 | #[derive(derive_more::Debug, Clone)] 171 | pub enum Cps { 172 | /// Call to a primitive operator. 173 | PrimOp(PrimOp, Vec, Local, Box), 174 | 175 | /// Function application. 176 | App(Value, Vec, Option), 177 | 178 | /// Forward a list of values into an application. 179 | // TODO: I think we can get rid of this with better primitive operators, maybe. 180 | Forward(Value, Value), 181 | 182 | /// Branching. 183 | If(Value, Box, Box), 184 | 185 | /// Closure generation. The result of this operation is a *const Value::Closure 186 | Closure { 187 | args: ClosureArgs, 188 | body: Box, 189 | val: Local, 190 | cexp: Box, 191 | debug: Option, 192 | }, 193 | 194 | /// Halt execution and return the values 195 | Halt(Value), 196 | } 197 | 198 | impl Cps { 199 | /// Perform substitutions on local variables. 200 | fn substitute(&mut self, substitutions: &HashMap) { 201 | match self { 202 | Self::PrimOp(_, args, _, cexp) => { 203 | substitute_values(args, substitutions); 204 | cexp.substitute(substitutions); 205 | } 206 | Self::App(value, values, _) => { 207 | substitute_value(value, substitutions); 208 | substitute_values(values, substitutions); 209 | } 210 | Self::Forward(op, arg) => { 211 | substitute_value(op, substitutions); 212 | substitute_value(arg, substitutions); 213 | } 214 | Self::If(cond, success, failure) => { 215 | substitute_value(cond, substitutions); 216 | success.substitute(substitutions); 217 | failure.substitute(substitutions); 218 | } 219 | Self::Closure { body, cexp, .. } => { 220 | body.substitute(substitutions); 221 | cexp.substitute(substitutions); 222 | } 223 | Self::Halt(value) => { 224 | substitute_value(value, substitutions); 225 | } 226 | } 227 | } 228 | } 229 | 230 | fn substitute_value(value: &mut Value, substitutions: &HashMap) { 231 | if let Value::Var(Var::Local(local)) = value { 232 | if let Some(substitution) = substitutions.get(local) { 233 | *value = substitution.clone(); 234 | } 235 | } 236 | } 237 | 238 | fn substitute_values(values: &mut [Value], substitutions: &HashMap) { 239 | values 240 | .iter_mut() 241 | .for_each(|value| substitute_value(value, substitutions)) 242 | } 243 | -------------------------------------------------------------------------------- /src/cps/reduce.rs: -------------------------------------------------------------------------------- 1 | //! Optimization passes that reduce the amount of CPS code, therefore reducing 2 | //! the amount of LLVM code that needs to be optimized. 3 | 4 | use super::*; 5 | 6 | impl Cps { 7 | pub(super) fn reduce(self) -> Self { 8 | // Perform beta reduction twice. This seems like the sweet spot for now 9 | self.beta_reduction(&mut HashMap::default()) 10 | .beta_reduction(&mut HashMap::default()) 11 | .dead_code_elimination(&mut HashMap::default()) 12 | } 13 | 14 | /// Beta-reduction optimization step. This function replaces applications to 15 | /// functions with the body of the function with arguments substituted. 16 | /// 17 | /// Our initial heuristic is rather simple: if a function is non-recursive and 18 | /// is applied to exactly once in its continuation expression, its body is 19 | /// substituted for the application. 20 | /// 21 | /// The uses analysis cache is absolutely demolished and dangerous to use by 22 | /// the end of this function. 23 | fn beta_reduction(self, uses_cache: &mut HashMap>) -> Self { 24 | match self { 25 | Cps::PrimOp(prim_op, values, result, cexp) => Cps::PrimOp( 26 | prim_op, 27 | values, 28 | result, 29 | Box::new(cexp.beta_reduction(uses_cache)), 30 | ), 31 | Cps::If(cond, success, failure) => Cps::If( 32 | cond, 33 | Box::new(success.beta_reduction(uses_cache)), 34 | Box::new(failure.beta_reduction(uses_cache)), 35 | ), 36 | Cps::Closure { 37 | args, 38 | body, 39 | val, 40 | cexp, 41 | debug, 42 | } => { 43 | let body = body.beta_reduction(uses_cache); 44 | let mut cexp = cexp.beta_reduction(uses_cache); 45 | 46 | let is_recursive = body.uses(uses_cache).contains_key(&val); 47 | let uses = cexp.uses(uses_cache).get(&val).copied().unwrap_or(0); 48 | 49 | // TODO: When we get more list primops, allow for variadic substitutions 50 | if !args.variadic && !is_recursive && uses == 1 { 51 | let reduced = cexp.reduce_function(val, &args, &body, uses_cache); 52 | if reduced { 53 | uses_cache.remove(&val); 54 | return cexp; 55 | } 56 | } 57 | 58 | Cps::Closure { 59 | args, 60 | body: Box::new(body), 61 | val, 62 | cexp: Box::new(cexp), 63 | debug, 64 | } 65 | } 66 | cexp => cexp, 67 | } 68 | } 69 | 70 | fn reduce_function( 71 | &mut self, 72 | func: Local, 73 | args: &ClosureArgs, 74 | func_body: &Cps, 75 | uses_cache: &mut HashMap>, 76 | ) -> bool { 77 | let new = match self { 78 | Cps::PrimOp(_, _, _, cexp) => { 79 | return cexp.reduce_function(func, args, func_body, uses_cache) 80 | } 81 | Cps::If(_, succ, fail) => { 82 | return succ.reduce_function(func, args, func_body, uses_cache) 83 | || fail.reduce_function(func, args, func_body, uses_cache) 84 | } 85 | Cps::Closure { 86 | val, body, cexp, .. 87 | } => { 88 | let reduced = body.reduce_function(func, args, func_body, uses_cache) 89 | || cexp.reduce_function(func, args, func_body, uses_cache); 90 | if reduced { 91 | uses_cache.remove(val); 92 | } 93 | return reduced; 94 | } 95 | Cps::App(Value::Var(Var::Local(operator)), applied, _) if *operator == func => { 96 | let substitutions: HashMap<_, _> = args 97 | .to_vec() 98 | .into_iter() 99 | .zip(applied.iter().cloned()) 100 | .collect(); 101 | let mut body = func_body.clone(); 102 | body.substitute(&substitutions); 103 | body 104 | } 105 | Cps::App(_, _, _) | Cps::Forward(_, _) | Cps::Halt(_) => return false, 106 | }; 107 | *self = new; 108 | true 109 | } 110 | 111 | /// Removes any closures and allocated cells that are left unused. 112 | #[allow(dead_code)] 113 | fn dead_code_elimination(self, uses_cache: &mut HashMap>) -> Self { 114 | match self { 115 | Cps::Closure { val, cexp, .. } if !cexp.uses(uses_cache).contains_key(&val) => { 116 | // Unused closure can be eliminated 117 | cexp.dead_code_elimination(uses_cache) 118 | } 119 | Cps::PrimOp(PrimOp::AllocCell, _, result, cexp) 120 | if !cexp.uses(uses_cache).contains_key(&result) => 121 | { 122 | cexp.dead_code_elimination(uses_cache) 123 | } 124 | Cps::PrimOp(prim_op, values, result, cexp) => Cps::PrimOp( 125 | prim_op, 126 | values, 127 | result, 128 | Box::new(cexp.dead_code_elimination(uses_cache)), 129 | ), 130 | Cps::If(cond, success, failure) => Cps::If( 131 | cond, 132 | Box::new(success.dead_code_elimination(uses_cache)), 133 | Box::new(failure.dead_code_elimination(uses_cache)), 134 | ), 135 | Cps::Closure { 136 | args, 137 | body, 138 | val, 139 | cexp, 140 | debug, 141 | } => Cps::Closure { 142 | args, 143 | body: Box::new(body.dead_code_elimination(uses_cache)), 144 | val, 145 | cexp: Box::new(cexp.dead_code_elimination(uses_cache)), 146 | debug, 147 | }, 148 | cexp => cexp, 149 | } 150 | } 151 | } 152 | -------------------------------------------------------------------------------- /src/env.rs: -------------------------------------------------------------------------------- 1 | use std::{ 2 | collections::{hash_map::Entry, HashMap}, 3 | fmt, 4 | hash::{Hash, Hasher}, 5 | sync::atomic::{AtomicUsize, Ordering}, 6 | }; 7 | 8 | use crate::{ 9 | gc::{Gc, Trace}, 10 | proc::Closure, 11 | syntax::{Identifier, Mark}, 12 | value::Value, 13 | }; 14 | 15 | /// A Top level environment 16 | #[derive(Trace)] 17 | pub struct Top { 18 | kind: TopLevelEnvKind, 19 | vars: HashMap>, 20 | macros: HashMap, 21 | } 22 | 23 | #[derive(Trace)] 24 | pub enum TopLevelEnvKind { 25 | Library, 26 | Program, 27 | Repl, 28 | } 29 | 30 | impl Top { 31 | pub fn library() -> Self { 32 | Self { 33 | kind: TopLevelEnvKind::Library, 34 | vars: HashMap::new(), 35 | macros: HashMap::new(), 36 | } 37 | } 38 | 39 | pub fn program() -> Self { 40 | Self { 41 | kind: TopLevelEnvKind::Program, 42 | vars: HashMap::new(), 43 | macros: HashMap::new(), 44 | } 45 | } 46 | 47 | pub fn repl() -> Self { 48 | Self { 49 | kind: TopLevelEnvKind::Repl, 50 | vars: HashMap::new(), 51 | macros: HashMap::new(), 52 | } 53 | } 54 | 55 | pub fn is_repl(&self) -> bool { 56 | matches!(self.kind, TopLevelEnvKind::Repl) 57 | } 58 | 59 | pub fn import(&mut self, lib: &Top) { 60 | for (name, val) in lib.vars.iter() { 61 | self.vars.insert(name.clone(), val.clone()); 62 | } 63 | for (name, mac) in lib.macros.iter() { 64 | self.macros.insert(name.clone(), mac.clone()); 65 | } 66 | } 67 | 68 | pub fn def_var(&mut self, name: Identifier, value: Value) -> Global { 69 | let global = Gc::new(value); 70 | match self.vars.entry(name.clone()) { 71 | Entry::Occupied(occup) => Global::new(name, occup.get().clone()), 72 | Entry::Vacant(vacant) => Global::new(name, vacant.insert(global).clone()), 73 | } 74 | } 75 | 76 | pub fn def_macro(&mut self, name: Identifier, mac: Macro) { 77 | self.macros.insert(name, mac); 78 | } 79 | 80 | pub fn fetch_var(&mut self, name: &Identifier) -> Option { 81 | self.vars 82 | .get(name) 83 | .map(|val| Global::new(name.clone(), val.clone())) 84 | } 85 | 86 | pub fn fetch_macro(&self, name: &Identifier) -> Option { 87 | self.macros.get(name).cloned() 88 | } 89 | } 90 | 91 | impl fmt::Debug for Top { 92 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 93 | write!(f, "Top") 94 | } 95 | } 96 | 97 | #[derive(Debug, Trace)] 98 | pub struct LexicalContour { 99 | up: Environment, 100 | vars: HashMap, 101 | macros: HashMap>, 102 | } 103 | 104 | impl LexicalContour { 105 | fn new(env: &Environment) -> Self { 106 | Self { 107 | up: env.clone(), 108 | vars: Default::default(), 109 | macros: Default::default(), 110 | } 111 | } 112 | } 113 | 114 | impl LexicalContour { 115 | pub fn def_var(&mut self, name: Identifier) -> Local { 116 | let local = Local::gensym(); 117 | self.vars.insert(name, local); 118 | local 119 | } 120 | 121 | pub fn def_macro(&mut self, name: Identifier, closure: Gc) { 122 | self.macros.insert(name, closure); 123 | } 124 | 125 | pub fn fetch_var(&self, name: &Identifier) -> Option { 126 | if let Some(local) = self.vars.get(name) { 127 | return Some(Var::Local(*local)); 128 | } 129 | self.up.fetch_var(name) 130 | } 131 | 132 | pub fn fetch_local(&self, name: &Identifier) -> Option { 133 | if let Some(local) = self.vars.get(name) { 134 | return Some(*local); 135 | } 136 | self.up.fetch_local(name) 137 | } 138 | 139 | pub fn fetch_top(&self) -> Gc { 140 | self.up.fetch_top() 141 | } 142 | } 143 | 144 | impl Gc { 145 | pub fn fetch_macro(&self, name: &Identifier) -> Option { 146 | if let Some(trans) = self.read().macros.get(name) { 147 | return Some(Macro::new( 148 | Environment::LexicalContour(self.clone()), 149 | trans.clone(), 150 | )); 151 | } 152 | self.read().up.fetch_macro(name) 153 | } 154 | } 155 | 156 | #[derive(Debug, Trace)] 157 | pub struct LetSyntaxContour { 158 | up: Environment, 159 | macros: HashMap>, 160 | recursive: bool, 161 | } 162 | 163 | impl LetSyntaxContour { 164 | fn new(env: &Environment, recursive: bool) -> Self { 165 | Self { 166 | up: env.clone(), 167 | macros: Default::default(), 168 | recursive, 169 | } 170 | } 171 | } 172 | 173 | impl LetSyntaxContour { 174 | pub fn def_var(&self, name: Identifier) -> Var { 175 | self.up.def_var(name) 176 | } 177 | 178 | pub fn def_macro(&mut self, name: Identifier, closure: Gc) { 179 | self.macros.insert(name, closure); 180 | } 181 | 182 | pub fn fetch_var(&self, name: &Identifier) -> Option { 183 | self.up.fetch_var(name) 184 | } 185 | 186 | pub fn fetch_local(&self, name: &Identifier) -> Option { 187 | self.up.fetch_local(name) 188 | } 189 | 190 | pub fn fetch_top(&self) -> Gc { 191 | self.up.fetch_top() 192 | } 193 | } 194 | 195 | impl Gc { 196 | pub fn fetch_macro(&self, name: &Identifier) -> Option { 197 | if let Some(trans) = self.read().macros.get(name) { 198 | return Some(Macro::new( 199 | if self.read().recursive { 200 | Environment::LetSyntaxContour(self.clone()) 201 | } else { 202 | self.read().up.clone() 203 | }, 204 | trans.clone(), 205 | )); 206 | } 207 | self.read().up.fetch_macro(name) 208 | } 209 | } 210 | 211 | #[derive(Debug, Trace)] 212 | pub struct MacroExpansion { 213 | up: Environment, 214 | mark: Mark, 215 | source: Environment, 216 | } 217 | 218 | impl MacroExpansion { 219 | pub fn new(env: &Environment, mark: Mark, source: Environment) -> Self { 220 | Self { 221 | up: env.clone(), 222 | mark, 223 | source, 224 | } 225 | } 226 | } 227 | 228 | impl MacroExpansion { 229 | pub fn def_var(&self, name: Identifier) -> Var { 230 | // In the case of defining variables produced from macro expansions, pass them 231 | // on to the next environment up. 232 | self.up.def_var(name) 233 | } 234 | 235 | pub fn def_macro(&self, name: Identifier, closure: Gc) { 236 | self.up.def_macro(name, closure); 237 | } 238 | 239 | pub fn fetch_var(&self, name: &Identifier) -> Option { 240 | // Attempt to check the up scope first: 241 | let var = self.up.fetch_var(name); 242 | if var.is_some() { 243 | return var; 244 | } 245 | // If the current expansion context contains the mark, remove it and check the 246 | // expansion source scope. 247 | name.marks 248 | .contains(&self.mark) 249 | .then(|| { 250 | let mut unmarked = name.clone(); 251 | unmarked.mark(self.mark); 252 | self.source.fetch_var(&unmarked) 253 | }) 254 | .flatten() 255 | } 256 | 257 | pub fn fetch_local(&self, name: &Identifier) -> Option { 258 | // Attempt to check the up scope first: 259 | let var = self.up.fetch_local(name); 260 | if var.is_some() { 261 | return var; 262 | } 263 | // If the current expansion context contains the mark, remove it and check the 264 | // expansion source scope. 265 | name.marks 266 | .contains(&self.mark) 267 | .then(|| { 268 | let mut unmarked = name.clone(); 269 | unmarked.mark(self.mark); 270 | self.source.fetch_local(&unmarked) 271 | }) 272 | .flatten() 273 | } 274 | 275 | pub fn fetch_macro(&self, name: &Identifier) -> Option { 276 | // Attempt to check the up scope first: 277 | let mac = self.up.fetch_macro(name); 278 | if mac.is_some() { 279 | return mac; 280 | } 281 | // If the current expansion context contains the mark, remove it and check the 282 | // expansion source scope. 283 | name.marks 284 | .contains(&self.mark) 285 | .then(|| { 286 | let mut unmarked = name.clone(); 287 | unmarked.mark(self.mark); 288 | self.source.fetch_macro(&unmarked) 289 | }) 290 | .flatten() 291 | } 292 | 293 | pub fn fetch_top(&self) -> Gc { 294 | self.up.fetch_top() 295 | } 296 | } 297 | 298 | #[derive(Debug, Trace)] 299 | pub enum Environment { 300 | Top(Gc), 301 | LexicalContour(Gc), 302 | LetSyntaxContour(Gc), 303 | MacroExpansion(Gc), 304 | } 305 | 306 | impl Environment { 307 | pub fn fetch_top(&self) -> Gc { 308 | match self { 309 | Self::Top(top) => top.clone(), 310 | Self::LexicalContour(lex) => lex.read().fetch_top(), 311 | Self::LetSyntaxContour(ls) => ls.read().fetch_top(), 312 | Self::MacroExpansion(me) => me.read().fetch_top(), 313 | } 314 | } 315 | 316 | pub fn def_var(&self, name: Identifier) -> Var { 317 | match self { 318 | Self::Top(top) => Var::Global(top.write().def_var(name, Value::undefined())), 319 | Self::LexicalContour(lex) => Var::Local(lex.write().def_var(name)), 320 | Self::LetSyntaxContour(ls) => ls.read().def_var(name), 321 | Self::MacroExpansion(me) => me.read().def_var(name), 322 | } 323 | } 324 | 325 | pub fn def_macro(&self, name: Identifier, val: Gc) { 326 | match self { 327 | Self::Top(top) => top.write().def_macro(name, Macro::new(self.clone(), val)), 328 | Self::LexicalContour(lex) => lex.write().def_macro(name, val), 329 | Self::LetSyntaxContour(ls) => ls.write().def_macro(name, val), 330 | Self::MacroExpansion(me) => me.read().def_macro(name, val), 331 | } 332 | } 333 | 334 | pub fn fetch_var(&self, name: &Identifier) -> Option { 335 | match self { 336 | Self::Top(top) => top.write().fetch_var(name).map(Var::Global), 337 | Self::LexicalContour(lex) => lex.read().fetch_var(name), 338 | Self::LetSyntaxContour(ls) => ls.read().fetch_var(name), 339 | Self::MacroExpansion(me) => me.read().fetch_var(name), 340 | } 341 | } 342 | 343 | pub fn fetch_local(&self, name: &Identifier) -> Option { 344 | match self { 345 | Self::Top(_) => None, 346 | Self::LexicalContour(lex) => lex.read().fetch_local(name), 347 | Self::LetSyntaxContour(ls) => ls.read().fetch_local(name), 348 | Self::MacroExpansion(me) => me.read().fetch_local(name), 349 | } 350 | } 351 | 352 | pub fn fetch_macro(&self, name: &Identifier) -> Option { 353 | match self { 354 | Self::Top(top) => top.read().fetch_macro(name), 355 | Self::LexicalContour(lex) => lex.fetch_macro(name), 356 | Self::LetSyntaxContour(ls) => ls.fetch_macro(name), 357 | Self::MacroExpansion(me) => me.read().fetch_macro(name), 358 | } 359 | } 360 | 361 | pub fn is_bound(&self, name: &Identifier) -> bool { 362 | self.fetch_var(name).is_some() 363 | } 364 | 365 | pub fn new_lexical_contour(&self) -> Self { 366 | let new_lexical_contour = LexicalContour::new(self); 367 | Self::LexicalContour(Gc::new(new_lexical_contour)) 368 | } 369 | 370 | pub fn new_let_syntax_contour(&self, recursive: bool) -> Self { 371 | let new_let_syntax_contour = LetSyntaxContour::new(self, recursive); 372 | Self::LetSyntaxContour(Gc::new(new_let_syntax_contour)) 373 | } 374 | 375 | pub fn new_macro_expansion(&self, mark: Mark, source: Environment) -> Self { 376 | let new_macro_expansion = MacroExpansion::new(self, mark, source); 377 | Self::MacroExpansion(Gc::new(new_macro_expansion)) 378 | } 379 | } 380 | 381 | impl From> for Environment { 382 | fn from(top: Gc) -> Self { 383 | Self::Top(top) 384 | } 385 | } 386 | 387 | impl Clone for Environment { 388 | fn clone(&self) -> Self { 389 | match self { 390 | Self::Top(top) => Self::Top(top.clone()), 391 | Self::LexicalContour(lex) => Self::LexicalContour(lex.clone()), 392 | Self::LetSyntaxContour(ls) => Self::LetSyntaxContour(ls.clone()), 393 | Self::MacroExpansion(mac) => Self::MacroExpansion(mac.clone()), 394 | } 395 | } 396 | } 397 | 398 | #[derive(Copy, Clone, Trace, Hash, PartialEq, Eq, PartialOrd, Ord)] 399 | pub struct Local(usize); 400 | 401 | impl Local { 402 | /// Create a new temporary value. 403 | pub fn gensym() -> Self { 404 | static NEXT_SYM: AtomicUsize = AtomicUsize::new(0); 405 | Self(NEXT_SYM.fetch_add(1, Ordering::Relaxed)) 406 | } 407 | 408 | pub fn to_func_name(&self) -> String { 409 | format!("f{}", self.0) 410 | } 411 | } 412 | 413 | impl fmt::Display for Local { 414 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 415 | write!(f, "%{}", self.0) 416 | } 417 | } 418 | 419 | impl fmt::Debug for Local { 420 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 421 | write!(f, "%{}", self.0) 422 | } 423 | } 424 | 425 | // TODO: Do we need to make this pointer eq? 426 | #[derive(Clone, Trace)] 427 | pub struct Global { 428 | name: Identifier, 429 | val: Gc, 430 | } 431 | 432 | impl Global { 433 | pub fn new(name: Identifier, val: Gc) -> Self { 434 | Global { name, val } 435 | } 436 | 437 | pub fn value(self) -> Gc { 438 | self.val 439 | } 440 | 441 | pub fn value_ref(&self) -> &Gc { 442 | &self.val 443 | } 444 | } 445 | 446 | impl fmt::Debug for Global { 447 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 448 | write!(f, "${}", self.name.name) 449 | } 450 | } 451 | 452 | impl PartialEq for Global { 453 | fn eq(&self, rhs: &Self) -> bool { 454 | self.name == rhs.name && Gc::ptr_eq(&self.val, &rhs.val) 455 | } 456 | } 457 | 458 | impl Hash for Global { 459 | fn hash(&self, state: &mut H) 460 | where 461 | H: Hasher, 462 | { 463 | self.name.hash(state); 464 | Gc::as_ptr(&self.val).hash(state); 465 | } 466 | } 467 | 468 | impl Eq for Global {} 469 | 470 | #[derive(Clone, Trace, Hash, PartialEq, Eq)] 471 | pub enum Var { 472 | Global(Global), 473 | Local(Local), 474 | } 475 | 476 | impl fmt::Debug for Var { 477 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 478 | match self { 479 | Self::Global(global) => global.fmt(f), 480 | Self::Local(local) => local.fmt(f), 481 | } 482 | } 483 | } 484 | 485 | #[derive(Clone, Trace)] 486 | pub struct Macro { 487 | pub source_env: Environment, 488 | pub transformer: Gc, 489 | } 490 | 491 | impl Macro { 492 | pub fn new(source_env: Environment, transformer: Gc) -> Self { 493 | Self { 494 | source_env, 495 | transformer, 496 | } 497 | } 498 | } 499 | 500 | #[derive(Clone, Trace)] 501 | #[repr(align(16))] 502 | pub struct CapturedEnv { 503 | pub env: Environment, 504 | pub captured: Vec, 505 | } 506 | 507 | impl CapturedEnv { 508 | pub fn new(env: Environment, captured: Vec) -> Self { 509 | Self { env, captured } 510 | } 511 | } 512 | -------------------------------------------------------------------------------- /src/exception.rs: -------------------------------------------------------------------------------- 1 | //! Exceptional situations and conditions 2 | 3 | use futures::future::BoxFuture; 4 | 5 | use crate::{ 6 | gc::{Gc, GcInner, Trace}, 7 | proc::{Application, Closure, DynamicWind, FuncPtr}, 8 | registry::{BridgeFn, BridgeFnDebugInfo}, 9 | runtime::{Runtime, IGNORE_FUNCTION}, 10 | syntax::{Identifier, Span}, 11 | value::Value, 12 | }; 13 | use std::{error::Error as StdError, fmt, ops::Range}; 14 | 15 | #[derive(Debug, Clone, Trace)] 16 | pub struct Exception { 17 | pub backtrace: Vec, 18 | pub obj: Value, 19 | } 20 | 21 | impl Exception { 22 | pub fn new(backtrace: Vec, obj: Value) -> Self { 23 | Self { backtrace, obj } 24 | } 25 | } 26 | 27 | // TODO: This shouldn't be the display impl for Exception, I don' t think. 28 | impl fmt::Display for Exception { 29 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 30 | const MAX_BACKTRACE_LEN: usize = 20; 31 | writeln!(f, "Uncaught exception: {}", self.obj)?; 32 | if !self.backtrace.is_empty() { 33 | writeln!(f, "Stack trace:")?; 34 | for (i, frame) in self.backtrace.iter().rev().enumerate() { 35 | if i >= MAX_BACKTRACE_LEN { 36 | writeln!(f, "(backtrace truncated)")?; 37 | break; 38 | } 39 | writeln!(f, "{i}: {frame}")?; 40 | } 41 | } 42 | Ok(()) 43 | } 44 | } 45 | 46 | impl StdError for Exception {} 47 | 48 | #[derive(Debug, Clone, Trace)] 49 | pub enum Condition { 50 | Condition, 51 | Message { message: String }, 52 | Warning, 53 | Serious, 54 | Error, 55 | Violation, 56 | Assertion, 57 | NonContinuable, 58 | ImplementationRestriction, 59 | Lexical, 60 | Syntax { form: Value, subform: Value }, 61 | Undefined, 62 | Irritants { irritants: Value }, 63 | Who { who: Value }, 64 | CompoundCondition { simple_conditions: Vec }, 65 | } 66 | 67 | impl Condition { 68 | pub fn error(message: String) -> Self { 69 | Self::Message { message } 70 | } 71 | 72 | pub fn syntax_error() -> Self { 73 | // TODO: Expand on these 74 | Self::Syntax { 75 | form: Value::null(), 76 | subform: Value::from(false), 77 | } 78 | } 79 | 80 | pub fn assert_eq_failed(expected: &str, actual: &str) -> Self { 81 | Self::error(format!( 82 | "Assertion failed, expected: {expected}, actual: {actual}" 83 | )) 84 | } 85 | 86 | pub fn undefined_variable(ident: Identifier) -> Self { 87 | Self::error(format!("Undefined variable {}", ident.name)) 88 | } 89 | 90 | pub fn invalid_type(expected: &str, provided: &str) -> Self { 91 | // panic!(); 92 | Self::error(format!( 93 | "Expected value of type {expected}, provided {provided}" 94 | )) 95 | } 96 | 97 | pub fn invalid_operator_type(provided: &str) -> Self { 98 | Self::error(format!( 99 | "Invalid operator, expected procedure, provided {provided}" 100 | )) 101 | } 102 | 103 | pub fn invalid_index(index: usize, len: usize) -> Self { 104 | Self::error(format!( 105 | "Invalid index of {index} into collection of size {len}" 106 | )) 107 | } 108 | pub fn invalid_range(range: Range, len: usize) -> Self { 109 | Self::error(format!( 110 | "Invalid range of {range:?} into collection of size {len}" 111 | )) 112 | } 113 | 114 | pub fn wrong_num_of_unicode_chars(expected: usize, provided: usize) -> Self { 115 | Self::error(format!( 116 | "Expected to receive {expected} unicode characters from transform, received {provided}" 117 | )) 118 | } 119 | 120 | pub fn wrong_num_of_args(expected: usize, provided: usize) -> Self { 121 | Self::error(format!( 122 | "Expected {expected} arguments, provided {provided}" 123 | )) 124 | } 125 | pub fn wrong_num_of_variadic_args(expected: Range, provided: usize) -> Self { 126 | Self::error(format!( 127 | "Expected {expected:?} arguments, provided {provided}" 128 | )) 129 | } 130 | } 131 | 132 | macro_rules! impl_into_condition_for { 133 | ($for:ty) => { 134 | impl From<$for> for Condition { 135 | fn from(e: $for) -> Self { 136 | Self::error(e.to_string()) 137 | } 138 | } 139 | }; 140 | } 141 | 142 | impl_into_condition_for!(Box); 143 | impl_into_condition_for!(crate::num::NumberToUsizeError); 144 | impl_into_condition_for!(std::num::TryFromIntError); 145 | 146 | #[derive(Debug, Clone, Trace)] 147 | pub struct Frame { 148 | pub proc: String, 149 | pub call_site_span: Option, 150 | // pub repeated: usize, 151 | } 152 | 153 | impl Frame { 154 | pub fn new(proc: String, call_site_span: Option) -> Self { 155 | Self { 156 | proc, 157 | call_site_span, 158 | // repeated: 0, 159 | } 160 | } 161 | } 162 | 163 | impl fmt::Display for Frame { 164 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 165 | if let Some(ref call_site) = self.call_site_span { 166 | write!(f, "{} at {call_site}", self.proc) 167 | } else { 168 | write!(f, "{} at (unknown)", self.proc) 169 | } 170 | } 171 | } 172 | 173 | /// An exception handler includes the current handler - a function to call with 174 | /// any condition that is raised - and the previous handler. 175 | // TODO: We need to determine include the dynamic extent with the exception handler 176 | // so that we can call the proper winders. 177 | #[derive(Clone, Debug, Trace)] 178 | pub struct ExceptionHandler { 179 | /// The previously installed handler. If the previously installed handler is 180 | /// None, we return the condition as an Error. 181 | prev_handler: Option>, 182 | /// The currently installed handler. 183 | curr_handler: Gc, 184 | /// The dynamic extent of the exception handler. 185 | dynamic_extent: DynamicWind, 186 | } 187 | 188 | impl ExceptionHandler { 189 | /// # Safety 190 | /// Exception handler must point to a valid Gc'd object. 191 | pub unsafe fn from_ptr(ptr: *mut GcInner) -> Option> { 192 | use std::ops::Not; 193 | ptr.is_null() 194 | .not() 195 | .then(|| unsafe { Gc::from_raw_inc_rc(ptr) }) 196 | } 197 | } 198 | 199 | pub fn with_exception_handler<'a>( 200 | args: &'a [Value], 201 | _rest_args: &'a [Value], 202 | cont: &'a Value, 203 | _env: &'a [Gc], 204 | exception_handler: &'a Option>, 205 | dynamic_wind: &'a DynamicWind, 206 | ) -> BoxFuture<'a, Result> { 207 | Box::pin(async move { 208 | let [handler, thunk] = args else { 209 | return Err(Condition::wrong_num_of_args(2, args.len()).into()); 210 | }; 211 | 212 | let handler: Gc = handler.clone().try_into()?; 213 | 214 | let thunk: Gc = thunk.clone().try_into()?; 215 | 216 | let exception_handler = ExceptionHandler { 217 | prev_handler: exception_handler.clone(), 218 | curr_handler: handler.clone(), 219 | dynamic_extent: dynamic_wind.clone(), 220 | }; 221 | 222 | Ok(Application::new( 223 | thunk.clone(), 224 | vec![cont.clone()], 225 | Some(Gc::new(exception_handler)), 226 | dynamic_wind.clone(), 227 | None, 228 | )) 229 | }) 230 | } 231 | 232 | inventory::submit! { 233 | BridgeFn::new( 234 | "with-exception-handler", 235 | "(base)", 236 | 2, 237 | false, 238 | with_exception_handler, 239 | BridgeFnDebugInfo::new( 240 | "exception.rs", 241 | 182, 242 | 7, 243 | 0, 244 | &[ "handler", "thunk" ], 245 | ) 246 | ) 247 | } 248 | 249 | /// Raises a non-continuable exception to the current exception handler. 250 | pub fn raise<'a>( 251 | args: &'a [Value], 252 | _rest_args: &'a [Value], 253 | cont: &'a Value, 254 | _env: &'a [Gc], 255 | exception_handler: &'a Option>, 256 | dynamic_wind: &'a DynamicWind, 257 | ) -> BoxFuture<'a, Result> { 258 | Box::pin(async move { 259 | let [condition] = args else { 260 | return Err(Condition::wrong_num_of_args(1, args.len()).into()); 261 | }; 262 | 263 | // TODO: Make condition non-continuable when it is re-raised 264 | 265 | let Some(ref handler) = exception_handler else { 266 | return Err(condition.clone()); 267 | }; 268 | 269 | let handler = handler.read(); 270 | let runtime = { 271 | let curr_handler = handler.curr_handler.read(); 272 | curr_handler.runtime.clone() 273 | }; 274 | 275 | Ok(Application::new( 276 | handler.curr_handler.clone(), 277 | vec![ 278 | condition.clone(), 279 | Value::from(Closure::new( 280 | runtime, 281 | vec![Gc::new(condition.clone()), Gc::new(cont.clone())], 282 | Vec::new(), 283 | FuncPtr::Continuation(reraise_exception), 284 | 0, 285 | true, 286 | Some(IGNORE_FUNCTION), 287 | )), 288 | ], 289 | handler.prev_handler.clone(), 290 | dynamic_wind.clone(), 291 | None, 292 | )) 293 | }) 294 | } 295 | 296 | inventory::submit! { 297 | BridgeFn::new( 298 | "raise", 299 | "(base)", 300 | 1, 301 | false, 302 | raise, 303 | BridgeFnDebugInfo::new( 304 | "exception.rs", 305 | 231, 306 | 7, 307 | 0, 308 | &["condition"], 309 | ) 310 | ) 311 | } 312 | 313 | unsafe extern "C" fn reraise_exception( 314 | runtime: *mut GcInner, 315 | env: *const *mut GcInner, 316 | _globals: *const *mut GcInner, 317 | _args: *const Value, 318 | exception_handler: *mut GcInner, 319 | dynamic_wind: *const DynamicWind, 320 | ) -> *mut Result { 321 | let runtime = Gc::from_raw_inc_rc(runtime); 322 | 323 | // env[0] is the exception 324 | let exception = Gc::from_raw_inc_rc(env.read()); 325 | let exception = exception.read().clone(); 326 | 327 | // env[1] is the continuation 328 | let cont = Gc::from_raw_inc_rc(env.add(1).read()); 329 | let cont = cont.read().clone(); 330 | 331 | Box::into_raw(Box::new(Ok(Application::new( 332 | Gc::new(Closure::new( 333 | runtime, 334 | Vec::new(), 335 | Vec::new(), 336 | FuncPtr::Bridge(raise), 337 | 1, 338 | false, 339 | Some(IGNORE_FUNCTION), 340 | )), 341 | vec![exception, cont], 342 | ExceptionHandler::from_ptr(exception_handler), 343 | dynamic_wind.as_ref().unwrap().clone(), 344 | None, 345 | )))) 346 | } 347 | 348 | /// Raises an exception to the current exception handler and coninues with the 349 | /// value returned by the handler. 350 | pub fn raise_continuable<'a>( 351 | args: &'a [Value], 352 | _rest_args: &'a [Value], 353 | cont: &'a Value, 354 | _env: &'a [Gc], 355 | exception_handler: &'a Option>, 356 | dynamic_wind: &'a DynamicWind, 357 | ) -> BoxFuture<'a, Result> { 358 | Box::pin(async move { 359 | let [condition] = args else { 360 | return Err(Condition::wrong_num_of_args(1, args.len()).into()); 361 | }; 362 | 363 | let Some(ref handler) = exception_handler else { 364 | return Err(condition.clone()); 365 | }; 366 | 367 | let handler = handler.read().clone(); 368 | 369 | Ok(Application::new( 370 | handler.curr_handler, 371 | vec![condition.clone(), cont.clone()], 372 | handler.prev_handler, 373 | dynamic_wind.clone(), 374 | None, 375 | )) 376 | }) 377 | } 378 | 379 | inventory::submit! { 380 | BridgeFn::new( 381 | "raise-continuable", 382 | "(base)", 383 | 1, 384 | false, 385 | raise_continuable, 386 | BridgeFnDebugInfo::new( 387 | "exception.rs", 388 | 326, 389 | 7, 390 | 0, 391 | &["condition"], 392 | ) 393 | ) 394 | } 395 | 396 | /* 397 | pub fn winders(from_extent: &DynamicWind, to_extent: &DynamicWind) -> Gc { 398 | let len = from_extent.winders.len().min(to_extent.winders.len()); 399 | 400 | let mut split_point = 0; 401 | for i in 0..len { 402 | if from_extent.winders[i].0 == to_extent.winders[i].0 { 403 | split_point = i + 1; 404 | } else { 405 | break; 406 | } 407 | } 408 | 409 | let (_, to_extent) = to_extent.winders.split_at(split_point); 410 | 411 | let mut thunks = Gc::new(Value::Null); 412 | for thunk in to_extent 413 | .iter() 414 | .map(|to_extent| { 415 | to_extent.1.clone() 416 | }) 417 | .rev() 418 | { 419 | thunks = Gc::new(Value::Pair(Gc::new(Value::Closure(thunk)), thunks)); 420 | } 421 | 422 | thunks 423 | } 424 | */ 425 | -------------------------------------------------------------------------------- /src/futures.rs: -------------------------------------------------------------------------------- 1 | use crate::{continuation::Continuation, error::RuntimeError, gc::Gc, num::Number, value::Value}; 2 | use futures::{future::try_join_all, FutureExt}; 3 | use proc_macros::builtin; 4 | use std::{sync::Arc, time::Duration}; 5 | 6 | #[builtin("spawn")] 7 | pub async fn spawn( 8 | _cont: &Option>, 9 | arg: &Gc, 10 | ) -> Result>, RuntimeError> { 11 | let value = arg.read(); 12 | let callable = value 13 | .as_callable() 14 | .ok_or_else(|| RuntimeError::invalid_type("callable", value.type_name()))?; 15 | /* 16 | let Some(0) = callable.max_args() else { 17 | todo!(); 18 | }; 19 | */ 20 | let task = tokio::task::spawn(async move { 21 | let val = callable.call(Vec::new(), &None).await?; 22 | val.eval(&None).await 23 | }); 24 | let future = async move { task.await.unwrap() }.boxed().shared(); 25 | Ok(vec![Gc::new(Value::Future(future))]) 26 | } 27 | 28 | #[builtin("sleep")] 29 | pub async fn sleep( 30 | _cont: &Option>, 31 | arg: &Gc, 32 | ) -> Result>, RuntimeError> { 33 | let value = arg.read(); 34 | let time: &Number = value.as_ref().try_into()?; 35 | let millis = time.to_u64(); 36 | let future = async move { 37 | tokio::time::sleep(Duration::from_millis(millis)).await; 38 | Ok(vec![Gc::new(Value::Null)]) 39 | } 40 | .boxed() 41 | .shared(); 42 | Ok(vec![Gc::new(Value::Future(future))]) 43 | } 44 | 45 | #[builtin("await")] 46 | pub async fn await_value( 47 | _cont: &Option>, 48 | arg: &Gc, 49 | ) -> Result>, RuntimeError> { 50 | let future = { 51 | let value = arg.read(); 52 | match &*value { 53 | Value::Future(fut) => fut.clone(), 54 | _ => return Ok(vec![arg.clone()]), 55 | } 56 | }; 57 | future.await 58 | } 59 | 60 | #[builtin("join")] 61 | pub async fn join( 62 | _cont: &Option>, 63 | args: Vec>, 64 | ) -> Result>, RuntimeError> { 65 | let mut futs = Vec::new(); 66 | for arg in args.into_iter() { 67 | let value = arg.read(); 68 | let fut = match &*value { 69 | Value::Future(fut) => fut.clone(), 70 | _ => { 71 | // I can't figure out a way to get rid of this clone 72 | // at the current moment without writing annoying code 73 | let arg = arg.clone(); 74 | async move { Ok(vec![arg]) }.boxed().shared() 75 | } 76 | }; 77 | futs.push(fut); 78 | } 79 | let future = async move { 80 | let results = try_join_all(futs) 81 | .await? 82 | .into_iter() 83 | .flatten() 84 | .collect::>(); 85 | Ok(vec![Gc::new(Value::from(results))]) 86 | } 87 | .boxed() 88 | .shared(); 89 | Ok(vec![Gc::new(Value::Future(future))]) 90 | } 91 | -------------------------------------------------------------------------------- /src/gc/collection.rs: -------------------------------------------------------------------------------- 1 | //! An implementation of the algorithm described in the paper Concurrent 2 | //! Cycle Collection in Reference Counted Systems by David F. Bacon and 3 | //! V.T. Rajan. 4 | 5 | use std::{ 6 | ptr::NonNull, 7 | sync::{Mutex, OnceLock}, 8 | time::{Duration, Instant}, 9 | }; 10 | use tokio::{ 11 | sync::mpsc::{unbounded_channel, UnboundedReceiver, UnboundedSender}, 12 | task::JoinHandle, 13 | }; 14 | 15 | use super::{Color, GcInner, OpaqueGcPtr}; 16 | 17 | #[derive(Copy, Clone)] 18 | pub struct Mutation { 19 | kind: MutationKind, 20 | gc: OpaqueGcPtr, 21 | } 22 | 23 | impl Mutation { 24 | fn new(kind: MutationKind, gc: OpaqueGcPtr) -> Self { 25 | Self { kind, gc } 26 | } 27 | } 28 | 29 | unsafe impl Send for Mutation {} 30 | unsafe impl Sync for Mutation {} 31 | 32 | #[derive(Copy, Clone, Debug)] 33 | pub enum MutationKind { 34 | Inc, 35 | Dec, 36 | } 37 | 38 | /// Instead of mutations being atomic (via an atomic variable), they're buffered into 39 | /// "epochs", and handled by precisely one thread. 40 | struct MutationBuffer { 41 | mutation_buffer_tx: UnboundedSender, 42 | mutation_buffer_rx: Mutex>>, 43 | } 44 | 45 | unsafe impl Sync for MutationBuffer {} 46 | 47 | impl Default for MutationBuffer { 48 | fn default() -> Self { 49 | let (mutation_buffer_tx, mutation_buffer_rx) = unbounded_channel(); 50 | Self { 51 | mutation_buffer_tx, 52 | mutation_buffer_rx: Mutex::new(Some(mutation_buffer_rx)), 53 | } 54 | } 55 | } 56 | 57 | static MUTATION_BUFFER: OnceLock = OnceLock::new(); 58 | 59 | pub(super) fn inc_rc(gc: NonNull>) { 60 | // Disregard any send errors. If the receiver was dropped then the process 61 | // is exiting and we don't care if we leak. 62 | let _ = MUTATION_BUFFER 63 | .get_or_init(MutationBuffer::default) 64 | .mutation_buffer_tx 65 | .send(Mutation::new(MutationKind::Inc, OpaqueGcPtr::from(gc))); 66 | } 67 | 68 | pub(super) fn dec_rc(gc: NonNull>) { 69 | // Disregard any send errors. If the receiver was dropped then the process 70 | // is exiting and we don't care if we leak. 71 | let _ = MUTATION_BUFFER 72 | .get_or_init(MutationBuffer::default) 73 | .mutation_buffer_tx 74 | .send(Mutation::new(MutationKind::Dec, OpaqueGcPtr::from(gc))); 75 | } 76 | 77 | static COLLECTOR_TASK: OnceLock> = OnceLock::new(); 78 | 79 | pub fn init_gc() { 80 | // SAFETY: We DO NOT mutate MUTATION_BUFFER, we mutate the _interior once lock_. 81 | let _ = MUTATION_BUFFER.get_or_init(MutationBuffer::default); 82 | let _ = COLLECTOR_TASK 83 | .get_or_init(|| tokio::task::spawn(async { unsafe { run_garbage_collector().await } })); 84 | } 85 | 86 | const MIN_MUTATIONS_PER_EPOCH: usize = 10; 87 | const MAX_MUTATIONS_PER_EPOCH: usize = 10_000; // No idea what a good value is here. 88 | 89 | async unsafe fn run_garbage_collector() { 90 | let mut last_epoch = Instant::now(); 91 | let mut mutation_buffer: Vec<_> = Vec::with_capacity(MAX_MUTATIONS_PER_EPOCH); 92 | let mut mutation_buffer_rx = MUTATION_BUFFER 93 | .get_or_init(MutationBuffer::default) 94 | .mutation_buffer_rx 95 | .lock() 96 | .unwrap() 97 | .take() 98 | .unwrap(); 99 | while epoch( 100 | &mut last_epoch, 101 | &mut mutation_buffer_rx, 102 | &mut mutation_buffer, 103 | ) 104 | .await 105 | {} 106 | } 107 | 108 | // Run a collection epoch. Returns false if we've been cancelled and should exit. 109 | async unsafe fn epoch( 110 | last_epoch: &mut Instant, 111 | mutation_buffer_rx: &mut UnboundedReceiver, 112 | mutation_buffer: &mut Vec, 113 | ) -> bool { 114 | process_mutation_buffer(mutation_buffer_rx, mutation_buffer).await; 115 | let duration_since_last_epoch = Instant::now() - *last_epoch; 116 | if duration_since_last_epoch > Duration::from_millis(100) { 117 | if tokio::task::spawn_blocking(|| unsafe { process_cycles() }) 118 | .await 119 | .is_err() 120 | { 121 | return false; 122 | } 123 | 124 | *last_epoch = Instant::now(); 125 | } 126 | true 127 | } 128 | 129 | /// SAFETY: this function is _not reentrant_, may only be called by once per epoch, 130 | /// and must _complete_ before the next epoch. 131 | async unsafe fn process_mutation_buffer( 132 | mutation_buffer_rx: &mut UnboundedReceiver, 133 | mutation_buffer: &mut Vec, 134 | ) { 135 | // It is very important that we do not delay any mutations that 136 | // have occurred at this point by an extra epoch. 137 | let to_recv = mutation_buffer_rx.len().max(MIN_MUTATIONS_PER_EPOCH); 138 | 139 | mutation_buffer_rx.recv_many(mutation_buffer, to_recv).await; 140 | for mutation in mutation_buffer.drain(..) { 141 | match mutation.kind { 142 | MutationKind::Inc => increment(mutation.gc), 143 | MutationKind::Dec => decrement(mutation.gc), 144 | } 145 | } 146 | } 147 | 148 | // SAFETY: These values can only be accessed by one thread at once. 149 | static mut ROOTS: Vec = Vec::new(); 150 | static mut CYCLE_BUFFER: Vec> = Vec::new(); 151 | static mut CURRENT_CYCLE: Vec = Vec::new(); 152 | 153 | unsafe fn increment(s: OpaqueGcPtr) { 154 | s.set_rc(s.rc() + 1); 155 | scan_black(s); 156 | } 157 | 158 | unsafe fn decrement(s: OpaqueGcPtr) { 159 | s.set_rc(s.rc() - 1); 160 | if s.rc() == 0 { 161 | release(s); 162 | } else { 163 | possible_root(s); 164 | } 165 | } 166 | 167 | unsafe fn release(s: OpaqueGcPtr) { 168 | for_each_child(s, decrement); 169 | s.set_color(Color::Black); 170 | if !s.buffered() { 171 | free(s); 172 | } 173 | } 174 | 175 | unsafe fn possible_root(s: OpaqueGcPtr) { 176 | scan_black(s); 177 | s.set_color(Color::Purple); 178 | if !s.buffered() { 179 | s.set_buffered(true); 180 | (&raw mut ROOTS).as_mut().unwrap().push(s); 181 | } 182 | } 183 | 184 | unsafe fn process_cycles() { 185 | free_cycles(); 186 | collect_cycles(); 187 | sigma_preparation(); 188 | } 189 | 190 | unsafe fn collect_cycles() { 191 | mark_roots(); 192 | scan_roots(); 193 | collect_roots(); 194 | } 195 | 196 | // SAFETY: No function called by mark_roots may access ROOTS 197 | unsafe fn mark_roots() { 198 | let mut new_roots = Vec::new(); 199 | for s in (&raw const ROOTS).as_ref().unwrap().iter() { 200 | if s.color() == Color::Purple && s.rc() > 0 { 201 | mark_gray(*s); 202 | new_roots.push(*s); 203 | } else { 204 | s.set_buffered(false); 205 | if s.rc() == 0 { 206 | free(*s); 207 | } 208 | } 209 | } 210 | ROOTS = new_roots; 211 | } 212 | 213 | unsafe fn scan_roots() { 214 | for s in (&raw const ROOTS).as_ref().unwrap().iter() { 215 | scan(*s) 216 | } 217 | } 218 | 219 | unsafe fn collect_roots() { 220 | for s in std::mem::take((&raw mut ROOTS).as_mut().unwrap()) { 221 | if s.color() == Color::White { 222 | collect_white(s); 223 | let current_cycle = std::mem::take((&raw mut CURRENT_CYCLE).as_mut().unwrap()); 224 | (&raw mut CYCLE_BUFFER) 225 | .as_mut() 226 | .unwrap() 227 | .push(current_cycle); 228 | } else { 229 | s.set_buffered(false); 230 | } 231 | } 232 | } 233 | 234 | unsafe fn mark_gray(s: OpaqueGcPtr) { 235 | if s.color() != Color::Gray { 236 | s.set_color(Color::Gray); 237 | s.set_crc(s.rc() as isize); 238 | for_each_child(s, |t| { 239 | mark_gray(t); 240 | let t_crc = t.crc(); 241 | if t_crc > 0 { 242 | t.set_crc(t_crc - 1); 243 | } 244 | }); 245 | } 246 | } 247 | 248 | unsafe fn scan(s: OpaqueGcPtr) { 249 | if s.color() == Color::Gray { 250 | if s.crc() == 0 { 251 | s.set_color(Color::White); 252 | for_each_child(s, scan); 253 | } else { 254 | scan_black(s); 255 | } 256 | } 257 | } 258 | 259 | unsafe fn scan_black(s: OpaqueGcPtr) { 260 | if s.color() != Color::Black { 261 | s.set_color(Color::Black); 262 | for_each_child(s, scan_black); 263 | } 264 | } 265 | 266 | unsafe fn collect_white(s: OpaqueGcPtr) { 267 | if s.color() == Color::White { 268 | s.set_color(Color::Orange); 269 | s.set_buffered(true); 270 | (&raw mut CURRENT_CYCLE).as_mut().unwrap().push(s); 271 | for_each_child(s, collect_white); 272 | } 273 | } 274 | 275 | unsafe fn sigma_preparation() { 276 | for c in (&raw const CYCLE_BUFFER).as_ref().unwrap() { 277 | for n in c { 278 | n.set_color(Color::Red); 279 | n.set_crc(n.rc() as isize); 280 | } 281 | for n in c { 282 | for_each_child(*n, |m| { 283 | if m.color() == Color::Red && m.crc() > 0 { 284 | m.set_crc(m.crc() - 1); 285 | } 286 | }); 287 | } 288 | for n in c { 289 | n.set_color(Color::Orange); 290 | } 291 | } 292 | } 293 | 294 | unsafe fn free_cycles() { 295 | for c in std::mem::take((&raw mut CYCLE_BUFFER).as_mut().unwrap()) 296 | .into_iter() 297 | .rev() 298 | { 299 | if delta_test(&c) && sigma_test(&c) { 300 | free_cycle(&c); 301 | } else { 302 | refurbish(&c); 303 | } 304 | } 305 | } 306 | 307 | unsafe fn delta_test(c: &[OpaqueGcPtr]) -> bool { 308 | for n in c { 309 | if n.color() != Color::Orange { 310 | return false; 311 | } 312 | } 313 | true 314 | } 315 | 316 | unsafe fn sigma_test(c: &[OpaqueGcPtr]) -> bool { 317 | let mut sum = 0; 318 | for n in c { 319 | sum += n.crc(); 320 | } 321 | sum == 0 322 | // TODO: I think this is still correct. Make CRC a usize and uncomment 323 | // out this code. 324 | /* 325 | // NOTE: This is the only function so far that I have not implemented 326 | // _exactly_ as the text reads. I do not understand why I would have to 327 | // continue iterating if I see a CRC > 0, as CRCs cannot be negative. 328 | for n in c { 329 | if *crc(*n) > 0 { 330 | return false; 331 | } 332 | } 333 | true 334 | */ 335 | } 336 | 337 | unsafe fn refurbish(c: &[OpaqueGcPtr]) { 338 | for (i, n) in c.iter().enumerate() { 339 | match (i, n.color()) { 340 | (0, Color::Orange) | (_, Color::Purple) => { 341 | n.set_color(Color::Purple); 342 | unsafe { 343 | (&raw mut ROOTS).as_mut().unwrap().push(*n); 344 | } 345 | } 346 | _ => { 347 | n.set_color(Color::Black); 348 | n.set_buffered(false); 349 | } 350 | } 351 | } 352 | } 353 | 354 | unsafe fn free_cycle(c: &[OpaqueGcPtr]) { 355 | for n in c { 356 | n.set_color(Color::Red); 357 | } 358 | for n in c { 359 | for_each_child(*n, cyclic_decrement); 360 | } 361 | for n in c { 362 | free(*n); 363 | } 364 | } 365 | 366 | unsafe fn cyclic_decrement(m: OpaqueGcPtr) { 367 | if m.color() != Color::Red { 368 | if m.color() == Color::Orange { 369 | m.set_rc(m.rc() - 1); 370 | m.set_crc(m.crc() - 1); 371 | } else { 372 | decrement(m); 373 | } 374 | } 375 | } 376 | 377 | unsafe fn for_each_child(s: OpaqueGcPtr, visitor: unsafe fn(OpaqueGcPtr)) { 378 | let lock = s.lock().read().unwrap(); 379 | (s.visit_children())(s.data(), visitor); 380 | drop(lock); 381 | } 382 | 383 | unsafe fn free(s: OpaqueGcPtr) { 384 | // Safety: No need to acquire a permit, s is guaranteed to be garbage. 385 | 386 | // Finalize the object: 387 | (s.finalize())(s.data_mut()); 388 | 389 | // Deallocate the object: 390 | std::alloc::dealloc(s.header.as_ptr() as *mut u8, s.layout()); 391 | } 392 | 393 | #[cfg(test)] 394 | mod test { 395 | use super::*; 396 | use crate::gc::*; 397 | use std::sync::Arc; 398 | 399 | #[tokio::test] 400 | async fn cycles() { 401 | #[derive(Default, Trace)] 402 | struct Cyclic { 403 | next: Option>, 404 | out: Option>, 405 | } 406 | 407 | let out_ptr = Arc::new(()); 408 | 409 | let a = Gc::new(Cyclic::default()); 410 | let b = Gc::new(Cyclic::default()); 411 | let c = Gc::new(Cyclic::default()); 412 | 413 | // a -> b -> c - 414 | // ^----------/ 415 | a.write().next = Some(b.clone()); 416 | b.write().next = Some(c.clone()); 417 | b.write().out = Some(out_ptr.clone()); 418 | c.write().next = Some(a.clone()); 419 | 420 | assert_eq!(Arc::strong_count(&out_ptr), 2); 421 | 422 | drop(a); 423 | drop(b); 424 | drop(c); 425 | let mut mutation_buffer_rx = MUTATION_BUFFER 426 | .get_or_init(MutationBuffer::default) 427 | .mutation_buffer_rx 428 | .lock() 429 | .unwrap() 430 | .take() 431 | .unwrap(); 432 | let mut mutation_buffer = Vec::new(); 433 | unsafe { 434 | process_mutation_buffer(&mut mutation_buffer_rx, &mut mutation_buffer).await; 435 | process_cycles(); 436 | process_cycles(); 437 | } 438 | 439 | assert_eq!(Arc::strong_count(&out_ptr), 1); 440 | } 441 | } 442 | -------------------------------------------------------------------------------- /src/lib.rs: -------------------------------------------------------------------------------- 1 | extern crate self as scheme_rs; 2 | 3 | pub mod ast; 4 | pub mod character; 5 | pub mod cps; 6 | pub mod env; 7 | pub mod exception; 8 | pub mod expand; 9 | pub mod registry; 10 | pub mod runtime; 11 | // pub mod futures; 12 | pub mod gc; 13 | pub mod lex; 14 | pub mod lists; 15 | pub mod num; 16 | pub mod parse; 17 | pub mod proc; 18 | pub mod records; 19 | pub mod strings; 20 | pub mod syntax; 21 | pub mod value; 22 | pub mod vectors; 23 | -------------------------------------------------------------------------------- /src/lists.rs: -------------------------------------------------------------------------------- 1 | use crate::{ 2 | exception::Condition, 3 | gc::{Gc, Trace}, 4 | num::Number, 5 | registry::bridge, 6 | value::{UnpackedValue, Value}, 7 | }; 8 | use std::fmt; 9 | 10 | /// A pair of scheme values. Has a head and tail. 11 | #[derive(Trace)] 12 | pub struct Pair(pub Value, pub Value); 13 | 14 | impl Pair { 15 | pub fn new(car: Value, cdr: Value) -> Self { 16 | Self(car, cdr) 17 | } 18 | } 19 | 20 | impl PartialEq for Pair { 21 | fn eq(&self, rhs: &Self) -> bool { 22 | // TODO: Avoid circular lists causing an infinite loop 23 | self.0 == rhs.0 && self.1 == rhs.1 24 | } 25 | } 26 | 27 | pub fn display_list(car: &Value, cdr: &Value, f: &mut fmt::Formatter<'_>) -> fmt::Result { 28 | // TODO(map): If the list is circular, DO NOT print infinitely! 29 | match &*cdr.unpacked_ref() { 30 | UnpackedValue::Pair(_) | UnpackedValue::Null => (), 31 | cdr => { 32 | // This is not a proper list 33 | return write!(f, "({car} . {cdr})"); 34 | } 35 | } 36 | 37 | write!(f, "({car}")?; 38 | 39 | let mut stack = vec![cdr.clone()]; 40 | 41 | while let Some(head) = stack.pop() { 42 | match &*head.unpacked_ref() { 43 | UnpackedValue::Null => { 44 | if !stack.is_empty() { 45 | write!(f, " ()")?; 46 | } 47 | } 48 | UnpackedValue::Pair(pair) => { 49 | let pair_read = pair.read(); 50 | let Pair(car, cdr) = pair_read.as_ref(); 51 | write!(f, " {car}")?; 52 | stack.push(cdr.clone()); 53 | } 54 | x => { 55 | write!(f, " {x}")?; 56 | } 57 | } 58 | } 59 | 60 | write!(f, ")") 61 | } 62 | 63 | pub fn debug_list(car: &Value, cdr: &Value, f: &mut fmt::Formatter<'_>) -> fmt::Result { 64 | // TODO(map): If the list is circular, DO NOT print infinitely! 65 | match &*cdr.unpacked_ref() { 66 | UnpackedValue::Pair(_) | UnpackedValue::Null => (), 67 | cdr => { 68 | // This is not a proper list 69 | return write!(f, "({car:?} . {cdr:?})"); 70 | } 71 | } 72 | 73 | write!(f, "({car:?}")?; 74 | 75 | let mut stack = vec![cdr.clone()]; 76 | 77 | while let Some(head) = stack.pop() { 78 | match &*head.unpacked_ref() { 79 | UnpackedValue::Null => { 80 | if !stack.is_empty() { 81 | write!(f, " ()")?; 82 | } 83 | } 84 | UnpackedValue::Pair(pair) => { 85 | let pair_read = pair.read(); 86 | let Pair(car, cdr) = pair_read.as_ref(); 87 | write!(f, " {car:?}")?; 88 | stack.push(cdr.clone()); 89 | } 90 | x => { 91 | write!(f, " {x:?}")?; 92 | } 93 | } 94 | } 95 | 96 | write!(f, ")") 97 | } 98 | 99 | pub fn slice_to_list(items: &[Value]) -> Value { 100 | match items { 101 | [] => Value::null(), 102 | [head, tail @ ..] => Value::from(Gc::new(Pair(head.clone(), slice_to_list(tail)))), 103 | } 104 | } 105 | 106 | pub fn list_to_vec(curr: &Value, out: &mut Vec) { 107 | match &*curr.unpacked_ref() { 108 | UnpackedValue::Pair(pair) => { 109 | let pair_read = pair.read(); 110 | let Pair(car, cdr) = pair_read.as_ref(); 111 | out.push(car.clone()); 112 | list_to_vec(cdr, out); 113 | } 114 | UnpackedValue::Null => (), 115 | _ => out.push(curr.clone()), 116 | } 117 | } 118 | 119 | pub fn list_to_vec_with_null(curr: &Value, out: &mut Vec) { 120 | match &*curr.unpacked_ref() { 121 | UnpackedValue::Pair(pair) => { 122 | let pair_read = pair.read(); 123 | let Pair(car, cdr) = pair_read.as_ref(); 124 | out.push(car.clone()); 125 | list_to_vec_with_null(cdr, out); 126 | } 127 | _ => out.push(curr.clone()), 128 | } 129 | } 130 | 131 | #[bridge(name = "list", lib = "(base)")] 132 | pub async fn list(args: &[Value]) -> Result, Condition> { 133 | // Construct the list in reverse 134 | let mut cdr = Value::null(); 135 | for arg in args.iter().rev() { 136 | cdr = Value::from(Gc::new(Pair(arg.clone(), cdr))); 137 | } 138 | Ok(vec![cdr]) 139 | } 140 | 141 | #[bridge(name = "cons", lib = "(base)")] 142 | pub async fn cons(car: &Value, cdr: &Value) -> Result, Condition> { 143 | Ok(vec![Value::from(Gc::new(Pair(car.clone(), cdr.clone())))]) 144 | } 145 | 146 | #[bridge(name = "car", lib = "(base)")] 147 | pub async fn car(val: &Value) -> Result, Condition> { 148 | let pair: Gc = val.clone().try_into()?; 149 | let pair_read = pair.read(); 150 | let Pair(car, _) = pair_read.as_ref(); 151 | Ok(vec![car.clone()]) 152 | } 153 | 154 | #[bridge(name = "cdr", lib = "(base)")] 155 | pub async fn cdr(val: &Value) -> Result, Condition> { 156 | let pair: Gc = val.clone().try_into()?; 157 | let pair_read = pair.read(); 158 | let Pair(_, cdr) = pair_read.as_ref(); 159 | Ok(vec![cdr.clone()]) 160 | } 161 | 162 | #[bridge(name = "set-car!", lib = "(base)")] 163 | pub async fn set_car(var: &Value, val: &Value) -> Result, Condition> { 164 | let pair: Gc = var.clone().try_into()?; 165 | let mut pair_write = pair.write(); 166 | let Pair(ref mut car, _) = pair_write.as_mut(); 167 | *car = val.clone(); 168 | Ok(Vec::new()) 169 | } 170 | 171 | #[bridge(name = "set-cdr!", lib = "(base)")] 172 | pub async fn set_cdr(var: &Value, val: &Value) -> Result, Condition> { 173 | let pair: Gc = var.clone().try_into()?; 174 | let mut pair_write = pair.write(); 175 | let Pair(_, ref mut cdr) = pair_write.as_mut(); 176 | *cdr = val.clone(); 177 | Ok(Vec::new()) 178 | } 179 | 180 | #[bridge(name = "length", lib = "(base)")] 181 | pub async fn length(arg: &Value) -> Result, Condition> { 182 | let mut length = 0; 183 | let mut arg = arg.clone(); 184 | loop { 185 | arg = { 186 | match &*arg.unpacked_ref() { 187 | UnpackedValue::Pair(pair) => { 188 | let pair_read = pair.read(); 189 | let Pair(_, cdr) = pair_read.as_ref(); 190 | cdr.clone() 191 | } 192 | _ => break, 193 | } 194 | }; 195 | length += 1; 196 | } 197 | Ok(vec![Value::from(Number::from(length))]) 198 | } 199 | 200 | #[bridge(name = "list->vector", lib = "(base)")] 201 | pub async fn list_to_vector(list: &Value) -> Result, Condition> { 202 | let mut vec = Vec::new(); 203 | list_to_vec(list, &mut vec); 204 | 205 | Ok(vec![Value::from(vec)]) 206 | } 207 | -------------------------------------------------------------------------------- /src/main.rs: -------------------------------------------------------------------------------- 1 | use rustyline::{ 2 | error::ReadlineError, 3 | highlight::MatchingBracketHighlighter, 4 | history::DefaultHistory, 5 | validate::{ValidationContext, ValidationResult, Validator}, 6 | Completer, Config, Editor, Helper, Highlighter, Hinter, Validator, 7 | }; 8 | use scheme_rs::{ 9 | ast::{DefinitionBody, ParseAstError}, 10 | cps::Compile, 11 | env::{Environment, Top}, 12 | exception::Exception, 13 | gc::Gc, 14 | lex::LexError, 15 | parse::ParseSyntaxError, 16 | proc::{Application, DynamicWind}, 17 | registry::Registry, 18 | runtime::Runtime, 19 | syntax::Syntax, 20 | value::Value, 21 | }; 22 | use std::process::ExitCode; 23 | 24 | #[derive(Default)] 25 | struct InputValidator; 26 | 27 | impl Validator for InputValidator { 28 | fn validate(&self, ctx: &mut ValidationContext<'_>) -> rustyline::Result { 29 | match Syntax::from_str(ctx.input(), None) { 30 | Err(ParseSyntaxError::UnclosedParen { .. }) => Ok(ValidationResult::Incomplete), 31 | _ => Ok(ValidationResult::Valid(None)), 32 | } 33 | } 34 | } 35 | 36 | #[derive(Completer, Helper, Highlighter, Hinter, Validator)] 37 | struct InputHelper { 38 | #[rustyline(Validator)] 39 | validator: InputValidator, 40 | #[rustyline(Highlighter)] 41 | highlighter: MatchingBracketHighlighter, 42 | } 43 | 44 | #[tokio::main] 45 | async fn main() -> ExitCode { 46 | let runtime = Gc::new(Runtime::new()); 47 | let registry = Registry::new(&runtime).await; 48 | let base = registry.import("(base)").unwrap(); 49 | 50 | let config = Config::builder().auto_add_history(true).build(); 51 | let mut editor = match Editor::with_history(config, DefaultHistory::new()) { 52 | Ok(e) => e, 53 | Err(err) => { 54 | eprintln!("Error creating line editor: {}", err); 55 | return ExitCode::FAILURE; 56 | } 57 | }; 58 | 59 | let helper = InputHelper { 60 | validator: InputValidator, 61 | highlighter: MatchingBracketHighlighter::new(), 62 | }; 63 | 64 | editor.set_helper(Some(helper)); 65 | 66 | let mut n_results = 1; 67 | let mut repl = Top::repl(); 68 | { 69 | let base = base.read(); 70 | repl.import(&base); 71 | } 72 | let top = Environment::from(Gc::new(repl)); 73 | 74 | loop { 75 | let input = match editor.readline("> ") { 76 | Ok(line) => line, 77 | Err(ReadlineError::Eof) => break, 78 | Err(err) => { 79 | eprintln!("Error while reading input: {}", err); 80 | return ExitCode::FAILURE; 81 | } 82 | }; 83 | 84 | //input.push('\n'); 85 | match compile_and_run_str(&runtime, &top, &input).await { 86 | Ok(results) => { 87 | for result in results.into_iter() { 88 | println!("${n_results} = {:?}", result); 89 | n_results += 1; 90 | } 91 | } 92 | Err(EvalError::Exception(exception)) => { 93 | print!("{exception}"); 94 | } 95 | Err(err) => { 96 | println!("Error: {err:?}"); 97 | } 98 | } 99 | } 100 | 101 | ExitCode::SUCCESS 102 | } 103 | 104 | #[derive(derive_more::From, Debug)] 105 | pub enum EvalError<'e> { 106 | LexError(LexError<'e>), 107 | ParseError(ParseSyntaxError<'e>), 108 | ParseAstError(ParseAstError), 109 | Exception(Exception), 110 | } 111 | 112 | async fn compile_and_run_str<'e>( 113 | runtime: &Gc, 114 | env: &Environment, 115 | input: &'e str, 116 | ) -> Result, EvalError<'e>> { 117 | let sexprs = Syntax::from_str(input, None)?; 118 | let mut output = Vec::new(); 119 | for sexpr in sexprs { 120 | let span = sexpr.span().clone(); 121 | let expr = DefinitionBody::parse(runtime, &[sexpr], env, &span).await?; 122 | 123 | // println!("Parsed: {expr:#?}"); 124 | let compiled = expr.compile_top_level(); 125 | // println!("Compiled: {compiled:#?}"); 126 | 127 | let closure = runtime.compile_expr(compiled).await.unwrap(); 128 | let result = Application::new(closure, Vec::new(), None, DynamicWind::default(), None) 129 | .eval() 130 | .await?; 131 | output.extend(result) 132 | } 133 | Ok(output) 134 | } 135 | -------------------------------------------------------------------------------- /src/parse.rs: -------------------------------------------------------------------------------- 1 | use crate::{ 2 | ast::Literal, 3 | lex::{ 4 | Character as LexCharacter, Fragment, InputSpan, LexError, Lexeme, Number as LexNumber, 5 | Token, TryFromNumberError, 6 | }, 7 | num::Number, 8 | syntax::Syntax, 9 | }; 10 | use malachite::{rational::Rational, Integer}; 11 | use std::{char::CharTryFromError, error::Error as StdError, fmt, num::TryFromIntError}; 12 | 13 | #[derive(Debug)] 14 | pub enum ParseSyntaxError<'a> { 15 | EmptyInput, 16 | UnexpectedEndOfFile, 17 | ExpectedClosingParen { span: InputSpan<'a> }, 18 | UnexpectedClosingParen { span: InputSpan<'a> }, 19 | InvalidHexValue { value: String, span: InputSpan<'a> }, 20 | InvalidPeriodLocation { span: InputSpan<'a> }, 21 | NonByte { span: InputSpan<'a> }, 22 | UnclosedParen { span: InputSpan<'a> }, 23 | CharTryFrom(CharTryFromError), 24 | Lex(LexError<'a>), 25 | TryFromInt(TryFromIntError), 26 | TryFromNumber(TryFromNumberError), 27 | UnexpectedToken { token: Token<'a> }, 28 | } 29 | 30 | impl fmt::Display for ParseSyntaxError<'_> { 31 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 32 | match self { 33 | Self::EmptyInput => write!(f, "cannot parse an empty list"), 34 | Self::UnexpectedEndOfFile => write!(f, "unexpected end of file"), 35 | Self::ExpectedClosingParen { span } => { 36 | write!(f, "closing parenthesis not found at `{}`", span) 37 | } 38 | Self::UnexpectedClosingParen { span } => { 39 | write!(f, "unexpected closing parenthesis found at `{}`", span) 40 | } 41 | Self::InvalidHexValue { value, span } => { 42 | write!(f, "invalid hex value `{}` found at `{}`", value, span) 43 | } 44 | Self::InvalidPeriodLocation { span } => { 45 | write!(f, "invalid period found at location `{}`", span) 46 | } 47 | Self::NonByte { span } => write!( 48 | f, 49 | "non byte value found in byte vector at location `{}`", 50 | span 51 | ), 52 | Self::UnclosedParen { span } => { 53 | write!(f, "unclosed parenthesis at location `{}`", span) 54 | } 55 | Self::CharTryFrom(e) => write!(f, "{}", e), 56 | Self::Lex(e) => write!(f, "{}", e), 57 | Self::TryFromInt(e) => write!(f, "{}", e), 58 | Self::TryFromNumber(e) => write!(f, "{}", e), 59 | Self::UnexpectedToken { token } => { 60 | write!( 61 | f, 62 | "unexpected token {:?} at location `{}`", 63 | token.lexeme, token.span 64 | ) 65 | } 66 | } 67 | } 68 | } 69 | impl StdError for ParseSyntaxError<'_> {} 70 | 71 | impl From for ParseSyntaxError<'_> { 72 | fn from(e: TryFromIntError) -> Self { 73 | Self::TryFromInt(e) 74 | } 75 | } 76 | impl<'a> From> for ParseSyntaxError<'a> { 77 | fn from(lex: LexError<'a>) -> Self { 78 | Self::Lex(lex) 79 | } 80 | } 81 | impl From for ParseSyntaxError<'_> { 82 | fn from(e: CharTryFromError) -> Self { 83 | Self::CharTryFrom(e) 84 | } 85 | } 86 | impl From for ParseSyntaxError<'_> { 87 | fn from(e: TryFromNumberError) -> Self { 88 | Self::TryFromNumber(e) 89 | } 90 | } 91 | 92 | impl<'a> ParseSyntaxError<'a> { 93 | fn try_parse_hex + ?Sized>(hex: &S, span: InputSpan<'a>) -> Result { 94 | u32::from_str_radix(hex.as_ref(), 16) 95 | .ok() 96 | .ok_or_else(|| Self::InvalidHexValue { 97 | value: hex.as_ref().to_string(), 98 | span, 99 | }) 100 | } 101 | 102 | fn invalid_period(token: &Token<'a>) -> Self { 103 | Self::InvalidPeriodLocation { 104 | span: token.span.clone(), 105 | } 106 | } 107 | 108 | fn unclosed_paren(token: &Token<'a>) -> Self { 109 | Self::UnclosedParen { 110 | span: token.span.clone(), 111 | } 112 | } 113 | 114 | fn unexpected_closing_paren(token: &Token<'a>) -> Self { 115 | Self::UnexpectedClosingParen { 116 | span: token.span.clone(), 117 | } 118 | } 119 | } 120 | 121 | macro_rules! token { 122 | ( $pattern:pat ) => { 123 | Token { 124 | lexeme: $pattern, 125 | .. 126 | } 127 | }; 128 | } 129 | 130 | pub fn expression<'a, 'b>( 131 | i: &'b [Token<'a>], 132 | ) -> Result<(&'b [Token<'a>], Syntax), ParseSyntaxError<'a>> { 133 | match i { 134 | // Calling expression with an empty list is an error 135 | [] => Err(ParseSyntaxError::EmptyInput), 136 | // Literals: 137 | [b @ token!(Lexeme::Boolean(_)), tail @ ..] => { 138 | Ok((tail, Syntax::new_literal(boolean(b)?, b.span.clone()))) 139 | } 140 | [c @ token!(Lexeme::Character(_)), tail @ ..] => { 141 | Ok((tail, Syntax::new_literal(character(c)?, c.span.clone()))) 142 | } 143 | [Token { 144 | lexeme: Lexeme::Number(n), 145 | span, 146 | }, tail @ ..] => Ok((tail, Syntax::new_literal(number(n)?, span.clone()))), 147 | [s @ token!(Lexeme::String(_)), tail @ ..] => { 148 | Ok((tail, Syntax::new_literal(string(s)?, s.span.clone()))) 149 | } 150 | // Identifiers: 151 | [i @ token!(Lexeme::Identifier(_)), tail @ ..] => Ok(( 152 | tail, 153 | Syntax::new_identifier(i.lexeme.to_ident(), i.span.clone()), 154 | )), 155 | // Lists: 156 | [n @ token!(Lexeme::LParen), token!(Lexeme::RParen), tail @ ..] => { 157 | Ok((tail, Syntax::new_null(n.span.clone()))) 158 | } 159 | [n @ token!(Lexeme::LBracket), token!(Lexeme::RBracket), tail @ ..] => { 160 | Ok((tail, Syntax::new_null(n.span.clone()))) 161 | } 162 | [p @ token!(Lexeme::LParen), tail @ ..] => match list(tail, p.span.clone(), Lexeme::RParen) 163 | { 164 | Err(ParseListError::UnclosedParen) => Err(ParseSyntaxError::unclosed_paren(p)), 165 | Err(ParseListError::ParseError(err)) => Err(err), 166 | Ok(ok) => Ok(ok), 167 | }, 168 | [p @ token!(Lexeme::LBracket), tail @ ..] => { 169 | match list(tail, p.span.clone(), Lexeme::RBracket) { 170 | Err(ParseListError::UnclosedParen) => Err(ParseSyntaxError::unclosed_paren(p)), 171 | Err(ParseListError::ParseError(err)) => Err(err), 172 | Ok(ok) => Ok(ok), 173 | } 174 | } 175 | // Vectors: 176 | [v @ token!(Lexeme::HashParen), tail @ ..] => match vector(tail, v.span.clone()) { 177 | Err(ParseVectorError::UnclosedParen) => Err(ParseSyntaxError::unclosed_paren(v)), 178 | Err(ParseVectorError::ParseError(err)) => Err(err), 179 | Ok(ok) => Ok(ok), 180 | }, 181 | // Byte vectors: 182 | [v @ token!(Lexeme::Vu8Paren), tail @ ..] => match byte_vector(tail, v.span.clone()) { 183 | Err(ParseVectorError::UnclosedParen) => Err(ParseSyntaxError::unclosed_paren(v)), 184 | Err(ParseVectorError::ParseError(err)) => Err(err), 185 | Ok(ok) => Ok(ok), 186 | }, 187 | // Quote: 188 | [q @ token!(Lexeme::Quote), tail @ ..] => { 189 | let (tail, expr) = expression(tail)?; 190 | let expr_span = expr.span().clone(); 191 | Ok(( 192 | tail, 193 | Syntax::new_list( 194 | vec![ 195 | Syntax::new_identifier("quote", q.span.clone()), 196 | expr, 197 | Syntax::new_null(expr_span), 198 | ], 199 | q.span.clone(), 200 | ), 201 | )) 202 | } 203 | // Syntax: 204 | [s @ token!(Lexeme::HashTick), tail @ ..] => { 205 | let (tail, expr) = expression(tail)?; 206 | let expr_span = expr.span().clone(); 207 | Ok(( 208 | tail, 209 | Syntax::new_list( 210 | vec![ 211 | Syntax::new_identifier("syntax", s.span.clone()), 212 | expr, 213 | Syntax::new_null(expr_span), 214 | ], 215 | s.span.clone(), 216 | ), 217 | )) 218 | } 219 | [paren @ token!(Lexeme::RParen), ..] => { 220 | Err(ParseSyntaxError::unexpected_closing_paren(paren)) 221 | } 222 | [paren @ token!(Lexeme::RBracket), ..] => { 223 | Err(ParseSyntaxError::unexpected_closing_paren(paren)) 224 | } 225 | // Invalid locations: 226 | [d @ token!(Lexeme::Period), ..] => Err(ParseSyntaxError::invalid_period(d)), 227 | // Unexpected token (perhaps not supported?): 228 | [token, ..] => Err(ParseSyntaxError::UnexpectedToken { 229 | token: token.clone(), 230 | }), 231 | } 232 | } 233 | 234 | #[derive(Debug)] 235 | enum ParseListError<'a> { 236 | UnclosedParen, 237 | ParseError(ParseSyntaxError<'a>), 238 | } 239 | 240 | impl<'a> From> for ParseListError<'a> { 241 | fn from(pe: ParseSyntaxError<'a>) -> Self { 242 | Self::ParseError(pe) 243 | } 244 | } 245 | 246 | fn list<'a, 'b>( 247 | mut i: &'b [Token<'a>], 248 | span: InputSpan<'a>, 249 | closing: Lexeme<'static>, 250 | ) -> Result<(&'b [Token<'a>], Syntax), ParseListError<'a>> { 251 | let mut output = Vec::new(); 252 | loop { 253 | if i.is_empty() { 254 | return Err(ParseListError::UnclosedParen); 255 | } 256 | 257 | let (remaining, expr) = expression(i)?; 258 | output.push(expr); 259 | 260 | match remaining { 261 | // Proper lists: 262 | [token, tail @ ..] if token.lexeme == closing => { 263 | output.push(Syntax::new_null(token.span.clone())); 264 | return Ok((tail, Syntax::new_list(output, span))); 265 | } 266 | [token!(Lexeme::Period), end @ token!(Lexeme::LParen), token!(Lexeme::RParen), token, tail @ ..] 267 | | [token!(Lexeme::Period), end @ token!(Lexeme::LBracket), token!(Lexeme::RBracket), token, tail @ ..] 268 | if token.lexeme == closing => 269 | { 270 | output.push(Syntax::new_null(end.span.clone())); 271 | return Ok((tail, Syntax::new_list(output, span))); 272 | } 273 | // Improper lists: 274 | [token!(Lexeme::Period), tail @ ..] => { 275 | let (remaining, expr) = expression(tail)?; 276 | output.push(expr); 277 | return match remaining { 278 | [] => Err(ParseListError::ParseError( 279 | ParseSyntaxError::UnexpectedEndOfFile, 280 | )), 281 | [token!(Lexeme::RParen), tail @ ..] => { 282 | Ok((tail, Syntax::new_list(output, span))) 283 | } 284 | [unexpected, ..] => Err(ParseListError::ParseError( 285 | ParseSyntaxError::ExpectedClosingParen { 286 | span: unexpected.span.clone(), 287 | }, 288 | )), 289 | }; 290 | } 291 | _ => (), 292 | } 293 | i = remaining; 294 | } 295 | } 296 | 297 | #[derive(Debug)] 298 | enum ParseVectorError<'a> { 299 | UnclosedParen, 300 | ParseError(ParseSyntaxError<'a>), 301 | } 302 | 303 | impl<'a> From> for ParseVectorError<'a> { 304 | fn from(pe: ParseSyntaxError<'a>) -> Self { 305 | Self::ParseError(pe) 306 | } 307 | } 308 | 309 | fn vector_shared<'a, 'b>( 310 | mut i: &'b [Token<'a>], 311 | ) -> Result<(&'b [Token<'a>], Vec), ParseVectorError<'a>> { 312 | let mut output = Vec::new(); 313 | loop { 314 | match i { 315 | [] => return Err(ParseVectorError::UnclosedParen), 316 | [token!(Lexeme::RParen), tail @ ..] => return Ok((tail, output)), 317 | _ => (), 318 | } 319 | 320 | let (remaining, expr) = expression(i)?; 321 | output.push(expr); 322 | i = remaining; 323 | } 324 | } 325 | fn vector<'a, 'b>( 326 | i: &'b [Token<'a>], 327 | span: InputSpan<'a>, 328 | ) -> Result<(&'b [Token<'a>], Syntax), ParseVectorError<'a>> { 329 | let (i, vec) = vector_shared(i)?; 330 | 331 | Ok((i, Syntax::new_vector(vec, span))) 332 | } 333 | 334 | fn byte_vector<'a, 'b>( 335 | i: &'b [Token<'a>], 336 | span: InputSpan<'a>, 337 | ) -> Result<(&'b [Token<'a>], Syntax), ParseVectorError<'a>> { 338 | let (i, vec) = vector_shared(i)?; 339 | let vec = vec 340 | .into_iter() 341 | .map(|i| { 342 | if let Syntax::Literal { 343 | literal: Literal::Number(Number::FixedInteger(i)), 344 | .. 345 | } = i 346 | { 347 | Ok(i) 348 | } else { 349 | Err(ParseSyntaxError::NonByte { span: span.clone() }) 350 | } 351 | }) 352 | .collect::, _>>()? 353 | .into_iter() 354 | .map(|i| u8::try_from(i).map_err(ParseSyntaxError::from)) 355 | .collect::, _>>()?; 356 | 357 | Ok((i, Syntax::new_byte_vector(vec, span))) 358 | } 359 | 360 | fn boolean<'a>(i: &Token<'a>) -> Result> { 361 | Ok(Literal::Boolean(i.lexeme.to_boolean())) 362 | } 363 | 364 | fn character<'a>(i: &Token<'a>) -> Result> { 365 | let char = i.lexeme.to_char(); 366 | match char { 367 | LexCharacter::Literal(c) => Ok(Literal::Character(*c)), 368 | LexCharacter::Escaped(e) => Ok(Literal::Character((*e).into())), 369 | LexCharacter::Unicode(u) => Ok(Literal::Character(char::try_from( 370 | ParseSyntaxError::try_parse_hex(u, i.span.clone())?, 371 | )?)), 372 | } 373 | } 374 | 375 | fn number<'a>(i: &LexNumber<'a>) -> Result> { 376 | >::try_into(*i) 377 | .map(Number::FixedInteger) 378 | .or_else(|_| >::try_into(*i).map(Number::BigInteger)) 379 | .or_else(|_| >::try_into(*i).map(Number::Rational)) 380 | .or_else(|_| >::try_into(*i).map(Number::Real)) 381 | .map(Literal::Number) 382 | .map_err(ParseSyntaxError::from) 383 | } 384 | 385 | fn string<'a>(i: &Token<'a>) -> Result> { 386 | let fragments = i.lexeme.to_string(); 387 | let mut output = String::new(); 388 | for fragment in fragments { 389 | match fragment { 390 | Fragment::Escaped(c) => output.push(*c), 391 | Fragment::Unescaped(s) => output.push_str(s), 392 | Fragment::HexValue(hex) => { 393 | let hex_value = ParseSyntaxError::try_parse_hex(hex, i.span.clone())?; 394 | let Some(c) = char::from_u32(hex_value) else { 395 | return Err(ParseSyntaxError::InvalidHexValue { 396 | value: hex.to_string(), 397 | span: i.span.clone(), 398 | }); 399 | }; 400 | output.push(c); 401 | } 402 | } 403 | } 404 | Ok(Literal::String(output)) 405 | } 406 | -------------------------------------------------------------------------------- /src/registry.rs: -------------------------------------------------------------------------------- 1 | //! A Registry is a collection of libraries. 2 | 3 | use crate::{ 4 | ast::{DefinitionBody, Literal, ParseAstError}, 5 | cps::Compile, 6 | env::{Environment, Top}, 7 | gc::Gc, 8 | parse::ParseSyntaxError, 9 | proc::{BridgePtr, Closure, FuncPtr}, 10 | runtime::Runtime, 11 | syntax::{Identifier, Span, Syntax}, 12 | value::Value, 13 | }; 14 | pub use scheme_rs_macros::bridge; 15 | use std::collections::HashMap; 16 | 17 | #[derive(Clone, Default, PartialEq, Eq, Hash)] 18 | pub struct LibraryName { 19 | name: Vec, 20 | version: Version, 21 | } 22 | 23 | impl LibraryName { 24 | fn parse(syn: &Syntax) -> Result { 25 | match syn.as_list() { 26 | Some( 27 | [name @ .., Syntax::List { 28 | list: version, 29 | span, 30 | }, Syntax::Null { .. }], 31 | ) => Ok(Self { 32 | name: list_to_name(name)?, 33 | version: Version::parse(version, span)?, 34 | }), 35 | Some([name @ .., Syntax::Null { .. }]) => Ok(Self { 36 | name: list_to_name(name)?, 37 | version: Version::default(), 38 | }), 39 | _ => Err(ParseAstError::BadForm(syn.span().clone())), 40 | } 41 | } 42 | 43 | fn from_str<'a>( 44 | s: &'a str, 45 | file_name: Option<&str>, 46 | ) -> Result> { 47 | let syn = Syntax::from_str(s, file_name)?; 48 | Ok(Self::parse(&syn[0])?) 49 | } 50 | } 51 | 52 | fn list_to_name(name: &[Syntax]) -> Result, ParseAstError> { 53 | name.iter() 54 | .map(|name| { 55 | if let Syntax::Identifier { ident, .. } = name { 56 | Ok(ident.name.clone()) 57 | } else { 58 | Err(ParseAstError::ExpectedIdentifier(name.span().clone())) 59 | } 60 | }) 61 | .collect() 62 | } 63 | 64 | #[derive(Debug)] 65 | pub enum ParseLibraryNameError<'a> { 66 | ParseSyntaxError(ParseSyntaxError<'a>), 67 | ParseAstError(ParseAstError), 68 | } 69 | 70 | impl<'a> From> for ParseLibraryNameError<'a> { 71 | fn from(pse: ParseSyntaxError<'a>) -> Self { 72 | Self::ParseSyntaxError(pse) 73 | } 74 | } 75 | 76 | impl From for ParseLibraryNameError<'_> { 77 | fn from(pae: ParseAstError) -> Self { 78 | Self::ParseAstError(pae) 79 | } 80 | } 81 | 82 | #[derive(Clone, PartialEq, PartialOrd, Eq, Ord, Hash, Default)] 83 | pub struct Version { 84 | version: Vec, 85 | } 86 | 87 | impl Version { 88 | fn parse(syn: &[Syntax], span: &Span) -> Result { 89 | match syn { 90 | [version @ .., Syntax::Null { .. }] => { 91 | let version: Result, _> = version 92 | .iter() 93 | .map(|subvers| { 94 | if let Syntax::Literal { 95 | literal: Literal::Number(num), 96 | .. 97 | } = subvers 98 | { 99 | num.try_into().map_err(ParseAstError::ExpectedInteger) 100 | } else { 101 | Err(ParseAstError::ExpectedNumber(subvers.span().clone())) 102 | } 103 | }) 104 | .collect(); 105 | Ok(Self { version: version? }) 106 | } 107 | _ => Err(ParseAstError::BadForm(span.clone())), 108 | } 109 | } 110 | } 111 | 112 | pub enum VersionReference { 113 | SubVersions(Vec), 114 | And(Vec), 115 | Or(Vec), 116 | Not(Box), 117 | } 118 | 119 | pub enum SubVersionReference { 120 | SubVersion(u32), 121 | Gte(Vec), 122 | Lte(Vec), 123 | And(Vec), 124 | Or(Vec), 125 | Not(Box), 126 | } 127 | 128 | pub struct BridgeFn { 129 | name: &'static str, 130 | lib_name: &'static str, 131 | num_args: usize, 132 | variadic: bool, 133 | wrapper: BridgePtr, 134 | debug_info: BridgeFnDebugInfo, 135 | } 136 | 137 | impl BridgeFn { 138 | pub const fn new( 139 | name: &'static str, 140 | lib_name: &'static str, 141 | num_args: usize, 142 | variadic: bool, 143 | wrapper: BridgePtr, 144 | debug_info: BridgeFnDebugInfo, 145 | ) -> Self { 146 | Self { 147 | name, 148 | lib_name, 149 | num_args, 150 | variadic, 151 | wrapper, 152 | debug_info, 153 | } 154 | } 155 | } 156 | 157 | #[derive(Copy, Clone)] 158 | pub struct BridgeFnDebugInfo { 159 | pub(crate) file: &'static str, 160 | pub(crate) line: u32, 161 | pub(crate) column: u32, 162 | pub(crate) offset: usize, 163 | pub(crate) args: &'static [&'static str], 164 | } 165 | 166 | impl BridgeFnDebugInfo { 167 | pub const fn new( 168 | file: &'static str, 169 | line: u32, 170 | column: u32, 171 | offset: usize, 172 | args: &'static [&'static str], 173 | ) -> Self { 174 | Self { 175 | file, 176 | line, 177 | column, 178 | offset, 179 | args, 180 | } 181 | } 182 | } 183 | 184 | inventory::collect!(BridgeFn); 185 | 186 | pub struct Registry { 187 | libs: HashMap>, 188 | } 189 | 190 | impl Registry { 191 | /// Construct a Registry with all of the available bridge functions present but no external libraries imported. 192 | pub async fn new(runtime: &Gc) -> Self { 193 | let mut libs = HashMap::>::default(); 194 | 195 | for bridge_fn in inventory::iter::() { 196 | let debug_info_id = runtime.write().debug_info.new_function_debug_info( 197 | crate::proc::FunctionDebugInfo::from_bridge_fn( 198 | bridge_fn.name, 199 | bridge_fn.debug_info, 200 | ), 201 | ); 202 | let lib_name = LibraryName::from_str(bridge_fn.lib_name, None).unwrap(); 203 | let lib = libs 204 | .entry(lib_name) 205 | .or_insert_with(|| Gc::new(Top::library())); 206 | let mut lib = lib.write(); 207 | lib.def_var( 208 | Identifier::new(bridge_fn.name.to_string()), 209 | Value::from(Closure::new( 210 | runtime.clone(), 211 | Vec::new(), 212 | Vec::new(), 213 | FuncPtr::Bridge(bridge_fn.wrapper), 214 | bridge_fn.num_args, 215 | bridge_fn.variadic, 216 | Some(debug_info_id), 217 | )), 218 | ); 219 | } 220 | 221 | // Import the stdlib: 222 | let base_lib = libs 223 | .entry(LibraryName::from_str("(base)", None).unwrap()) 224 | .or_insert_with(|| Gc::new(Top::library())); 225 | let base_env = Environment::Top(base_lib.clone()); 226 | let sexprs = Syntax::from_str(include_str!("stdlib.scm"), Some("stdlib.scm")).unwrap(); 227 | let base = DefinitionBody::parse(runtime, &sexprs, &base_env, &Span::default()) 228 | .await 229 | .unwrap(); 230 | let compiled = base.compile_top_level(); 231 | let closure = runtime.compile_expr(compiled).await.unwrap(); 232 | closure.call(&[]).await.unwrap(); 233 | 234 | Self { libs } 235 | } 236 | 237 | pub fn import(&self, lib: &str) -> Option> { 238 | let lib_name = LibraryName::from_str(lib, None).unwrap(); 239 | self.libs.get(&lib_name).cloned() 240 | } 241 | } 242 | -------------------------------------------------------------------------------- /src/stdlib.scm: -------------------------------------------------------------------------------- 1 | ;; Contains standard definitions for functions that can be easily defined in 2 | ;; terms of forms supported by the compiler. This allows us to provide a minimum 3 | ;; amount of core functionality while still supporting the entire r6rs spec. 4 | ;; 5 | ;; By and large, these macro definitions come from Appendix B of the R6RS 6 | ;; standard. This allows for use to test the correctness of the compiler. 7 | ;; 8 | ;; This code is for definitions only. Most builtins are not provided at this point. 9 | 10 | ;; 11 | ;; Syntax definitions: 12 | ;; 13 | 14 | ;; Define syntax-rules in terms of syntax-case: 15 | (define-syntax syntax-rules 16 | (lambda (x) 17 | (syntax-case x () 18 | ((_ (i ...) ((keyword . pattern) template) ...) 19 | (syntax (lambda (x) 20 | (syntax-case x (i ...) 21 | ((dummy . pattern) (syntax template)) 22 | ...))))))) 23 | 24 | (define-syntax with-syntax 25 | (lambda (x) 26 | (syntax-case x () 27 | ((_ ((p e0) ...) e1 e2 ...) 28 | (syntax (syntax-case (list e0 ...) () 29 | ((p ...) (let () e1 e2 ...)))))))) 30 | 31 | (define-syntax cond 32 | (syntax-rules (else =>) 33 | ((cond (else result1 result2 ...)) 34 | (begin result1 result2 ...)) 35 | ((cond (test => result)) 36 | (let ((temp test)) 37 | (if temp (result temp)))) 38 | ((cond (test => result) clause1 clause2 ...) 39 | (let ((temp test)) 40 | (if temp 41 | (result temp) 42 | (cond clause1 clause2 ...)))) 43 | ((cond (test)) test) 44 | ((cond (test) clause1 clause2 ...) 45 | (let ((temp test)) 46 | (if temp 47 | temp 48 | (cond clause1 clause2 ...)))) 49 | ((cond (test result1 result2 ...)) 50 | (if test (begin result1 result2 ...))) 51 | ((cond (test result1 result2 ...) 52 | clause1 clause2 ...) 53 | (if test 54 | (begin result1 result2 ...) 55 | (cond clause1 clause2 ...))))) 56 | 57 | (define-syntax case 58 | (syntax-rules (else) 59 | ((case expr0 60 | ((key ...) res1 res2 ...) 61 | ... 62 | (else else-res1 else-res2 ...)) 63 | (let ((tmp expr0)) 64 | (cond 65 | ((memv tmp '(key ...)) res1 res2 ...) 66 | ... 67 | (else else-res1 else-res2 ...)))) 68 | ((case expr0 69 | ((keya ...) res1a res2a ...) 70 | ((keyb ...) res1b res2b ...) 71 | ...) 72 | (let ((tmp expr0)) 73 | (cond 74 | ((memv tmp '(keya ...)) res1a res2a ...) 75 | ((memv tmp '(keyb ...)) res1b res2b ...) 76 | ...))))) 77 | 78 | (define-syntax let* 79 | (syntax-rules () 80 | ((let* () body1 body2 ...) 81 | (let () body1 body2 ...)) 82 | ((let* ((name1 expr1) (name2 expr2) ...) 83 | body1 body2 ...) 84 | (let ((name1 expr1)) 85 | (let* ((name2 expr2) ...) 86 | body1 body2 ...))))) 87 | 88 | (define-syntax letrec 89 | (syntax-rules () 90 | ((letrec () body1 body2 ...) 91 | (let () body1 body2 ...)) 92 | ((letrec ((var init) ...) body1 body2 ...) 93 | (letrec-helper 94 | (var ...) 95 | () 96 | ((var init) ...) 97 | body1 body2 ...)))) 98 | 99 | (define-syntax letrec-helper 100 | (syntax-rules () 101 | ((letrec-helper 102 | () 103 | (temp ...) 104 | ((var init) ...) 105 | body1 body2 ...) 106 | (let ((var ) ...) 107 | (let ((temp init) ...) 108 | (set! var temp) 109 | ...) 110 | (let () body1 body2 ...))) 111 | ((letrec-helper 112 | (x y ...) 113 | (temp ...) 114 | ((var init) ...) 115 | body1 body2 ...) 116 | (letrec-helper 117 | (y ...) 118 | (newtemp temp ...) 119 | ((var init) ...) 120 | body1 body2 ...)))) 121 | 122 | (define-syntax letrec* 123 | (syntax-rules () 124 | ((letrec* ((var1 init1) ...) body1 body2 ...) 125 | (let ((var1 ) ...) 126 | (set! var1 init1) ... 127 | (let () body1 body2 ...))))) 128 | 129 | (define (values . things) 130 | (call-with-current-continuation 131 | (lambda (cont) (apply cont things)))) 132 | 133 | (define-syntax let-values 134 | (syntax-rules () 135 | ((let-values (binding ...) body1 body2 ...) 136 | (let-values-helper1 137 | () 138 | (binding ...) 139 | body1 body2 ...)))) 140 | 141 | (define-syntax let-values-helper1 142 | ;; map over the bindings 143 | (syntax-rules () 144 | ((let-values 145 | ((id temp) ...) 146 | () 147 | body1 body2 ...) 148 | (let ((id temp) ...) body1 body2 ...)) 149 | ((let-values 150 | assocs 151 | ((formals1 expr1) (formals2 expr2) ...) 152 | body1 body2 ...) 153 | (let-values-helper2 154 | formals1 155 | () 156 | expr1 157 | assocs 158 | ((formals2 expr2) ...) 159 | body1 body2 ...)))) 160 | 161 | (define-syntax let-values-helper2 162 | ;; create temporaries for the formals 163 | (syntax-rules () 164 | ((let-values-helper2 165 | () 166 | temp-formals 167 | expr1 168 | assocs 169 | bindings 170 | body1 body2 ...) 171 | (call-with-values 172 | (lambda () expr1) 173 | (lambda temp-formals 174 | (let-values-helper1 175 | assocs 176 | bindings 177 | body1 body2 ...)))) 178 | ((let-values-helper2 179 | (first . rest) 180 | (temp ...) 181 | expr1 182 | (assoc ...) 183 | bindings 184 | body1 body2 ...) 185 | (let-values-helper2 186 | rest 187 | (temp ... newtemp) 188 | expr1 189 | (assoc ... (first newtemp)) 190 | bindings 191 | body1 body2 ...)) 192 | ((let-values-helper2 193 | rest-formal 194 | (temp ...) 195 | expr1 196 | (assoc ...) 197 | bindings 198 | body1 body2 ...) 199 | (call-with-values 200 | (lambda () expr1) 201 | (lambda (temp ... . newtemp) 202 | (let-values-helper1 203 | (assoc ... (rest-formal newtemp)) 204 | bindings 205 | body1 body2 ...)))))) 206 | 207 | (define-syntax let*-values 208 | (syntax-rules () 209 | ((let*-values () body1 body2 ...) 210 | (let-values () body1 body2 ...)) 211 | ((let*-values ((name1 expr1) (name2 expr2) ...) 212 | body1 body2 ...) 213 | (let-values ((name1 expr1)) 214 | (let*-values ((name2 expr2) ...) 215 | body1 body2 ...))))) 216 | 217 | (define-syntax when 218 | (syntax-rules () 219 | ((when test result1 result2 ...) 220 | (if test 221 | (begin result1 result2 ...))))) 222 | 223 | (define-syntax unless 224 | (syntax-rules () 225 | ((unless test result1 result2 ...) 226 | (if (not test) 227 | (begin result1 result2 ...))))) 228 | 229 | (define-syntax do 230 | (syntax-rules () 231 | ((do ((var init step ...) ...) 232 | (test expr ...) 233 | command ...) 234 | (letrec 235 | ((loop 236 | (lambda (var ...) 237 | (if test 238 | (begin 239 | #f ; avoid empty begin 240 | expr ...) 241 | (begin 242 | command 243 | ... 244 | (loop (do "step" var step ...) 245 | ...)))))) 246 | (loop init ...))) 247 | ((do "step" x) 248 | x) 249 | ((do "step" x y) 250 | y))) 251 | 252 | (define-syntax case-lambda 253 | (syntax-rules () 254 | ((_ (fmls b1 b2 ...)) 255 | (lambda fmls b1 b2 ...)) 256 | ((_ (fmls b1 b2 ...) ...) 257 | (lambda args 258 | (let ((n (length args))) 259 | (case-lambda-help args n 260 | (fmls b1 b2 ...) ...)))))) 261 | 262 | (define-syntax case-lambda-help 263 | (syntax-rules () 264 | ((_ args n) 265 | (assertion-violation #f "unexpected number of arguments")) 266 | ((_ args n ((x ...) b1 b2 ...) more ...) 267 | (if (= n (length '(x ...))) 268 | (apply (lambda (x ...) b1 b2 ...) args) 269 | (case-lambda-help args n more ...))) 270 | ((_ args n ((x1 x2 ... . r) b1 b2 ...) more ...) 271 | (if (>= n (length '(x1 x2 ...))) 272 | (apply (lambda (x1 x2 ... . r) b1 b2 ...) 273 | args) 274 | (case-lambda-help args n more ...))) 275 | ((_ args n (r b1 b2 ...) more ...) 276 | (apply (lambda r b1 b2 ...) args)))) 277 | 278 | ;; 279 | ;; Aliases and function definitions: 280 | ;; 281 | 282 | (define equal? eqv?) ;; TODO(map): This is INCORRECT, needs to be fixed! 283 | (define (member obj list) 284 | (memp (lambda (x) (equal? x obj)) list)) 285 | (define (memv obj list) 286 | (memp (lambda (x) (eqv? x obj)) list)) 287 | (define (memq obj list) 288 | (memp (lambda (x) (eq? x obj)) list)) 289 | 290 | ;; TODO: All of the car/cdr combinations 291 | (define caar (lambda (x) (car (car x)))) 292 | (define cadr (lambda (x) (car (cdr x)))) 293 | 294 | (define (memp proc list) 295 | (if (and (pair? list) 296 | (proc (car list))) 297 | list 298 | (if (null? list) #f (memp proc (cdr list))))) 299 | 300 | ;; Define call/cc and call-with-current-continuation in terms of its primitive 301 | (define (call/cc x) 302 | (&call/cc x)); 303 | 304 | (define (call-with-current-continuation x) 305 | (&call/cc x)) 306 | 307 | ;; TODO: a lot of these should be made into rust functions, as of right now 308 | ;; these are quite slow. 309 | 310 | (define (for-each func lst . remaining) 311 | (let loop ((rest lst)) 312 | (unless (null? rest) 313 | (func (car rest)) 314 | (loop (cdr rest)))) 315 | (if (not (null? remaining)) 316 | (begin 317 | (apply for-each (cons func remaining))))) 318 | 319 | (define (append l m) 320 | (if (null? l) m 321 | (cons (car l) (append (cdr l) m)))) 322 | 323 | (define (make-list n) 324 | (if (> n 0) 325 | (cons #f (make-list (- n 1))) 326 | '())) 327 | 328 | (define (list-copy lst) 329 | (if (null? lst) 330 | '() 331 | (cons (car lst) 332 | (list-copy (cdr lst))))) 333 | 334 | (define (list-tail lst n) 335 | (if (> n 0) 336 | (list-tail (cdr lst) (- n 1)) 337 | lst)) 338 | 339 | (define (list-ref lst n) 340 | (if (> n 0) 341 | (list-ref (cdr lst) (- n 1)) 342 | (car lst))) 343 | 344 | (define (assoc k lst) 345 | (if (null? lst) 346 | #f 347 | (let ((pair (car lst))) 348 | (if (equal? (car pair) k) 349 | pair 350 | (assoc k (cdr lst)))))) 351 | 352 | (define (map function list1 . more-lists) 353 | (define (some? function list) 354 | ;; returns #f if (function x) returns #t for 355 | ;; some x in the list 356 | (and (pair? list) 357 | (or (function (car list)) 358 | (some? function (cdr list))))) 359 | (define (map1 function list) 360 | ;; non-variadic map. Returns a list whose elements are 361 | ;; the result of calling function with corresponding 362 | ;; elements of list 363 | (if (null? list) 364 | '() 365 | (cons (function (car list)) 366 | (map1 function (cdr list))))) 367 | ;; Variadic map implementation terminates 368 | ;; when any of the argument lists is empty 369 | (let ((lists (cons list1 more-lists))) 370 | (if (some? null? lists) 371 | '() 372 | (cons (apply function (map1 car lists)) 373 | (apply map function (map1 cdr lists)))))) 374 | 375 | (define (reverse ls) 376 | (define (reverse ls acc) 377 | (if (null? ls) 378 | acc 379 | (reverse (cdr ls) (cons (car ls) acc)))) 380 | (reverse ls '())) 381 | 382 | ;; 6.2. Numbers 383 | 384 | (define (positive? x) (> x 0)) 385 | 386 | (define (negative? x) (< x 0)) 387 | 388 | (define (abs x) 389 | (if (< x 0) 390 | (- x) 391 | x)) 392 | 393 | (define (min x . xs) 394 | (let loop ((xs xs) (smallest x)) 395 | (if (null? xs) 396 | smallest 397 | (loop (cdr xs) 398 | (if (< (car xs) smallest) 399 | (car xs) 400 | smallest))))) 401 | 402 | (define (max x . xs) 403 | (let loop ((xs xs) (biggest x)) 404 | (if (null? xs) 405 | biggest 406 | (loop (cdr xs) 407 | (if (> (car xs) biggest) 408 | (car xs) 409 | biggest))))) 410 | -------------------------------------------------------------------------------- /src/strings.rs: -------------------------------------------------------------------------------- 1 | //! String builtins and data types 2 | 3 | use std::{ 4 | fmt, 5 | ops::{Deref, DerefMut}, 6 | }; 7 | 8 | #[repr(align(16))] 9 | pub struct AlignedString(pub String); 10 | 11 | impl AlignedString { 12 | pub fn new(str: String) -> Self { 13 | AlignedString(str) 14 | } 15 | } 16 | 17 | impl Deref for AlignedString { 18 | type Target = String; 19 | 20 | fn deref(&self) -> &Self::Target { 21 | &self.0 22 | } 23 | } 24 | 25 | impl DerefMut for AlignedString { 26 | fn deref_mut(&mut self) -> &mut Self::Target { 27 | &mut self.0 28 | } 29 | } 30 | 31 | impl PartialEq for AlignedString { 32 | fn eq(&self, rhs: &str) -> bool { 33 | self.0 == rhs 34 | } 35 | } 36 | 37 | impl PartialEq for AlignedString { 38 | fn eq(&self, rhs: &Self) -> bool { 39 | self.0 == rhs.0 40 | } 41 | } 42 | 43 | impl fmt::Display for AlignedString { 44 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 45 | self.0.fmt(f) 46 | } 47 | } 48 | 49 | impl fmt::Debug for AlignedString { 50 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 51 | self.0.fmt(f) 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /src/syntax.rs: -------------------------------------------------------------------------------- 1 | use crate::{ 2 | ast::Literal, 3 | env::{Environment, Macro}, 4 | exception::Condition, 5 | gc::Trace, 6 | lex::{InputSpan, Token}, 7 | lists::{self, list_to_vec_with_null}, 8 | parse::ParseSyntaxError, 9 | registry::bridge, 10 | value::{UnpackedValue, Value}, 11 | }; 12 | use futures::future::BoxFuture; 13 | use std::{ 14 | collections::{BTreeSet, HashSet}, 15 | fmt, 16 | sync::Arc, 17 | }; 18 | 19 | #[derive(Debug, Clone, PartialEq, Trace)] 20 | pub struct Span { 21 | pub line: u32, 22 | pub column: usize, 23 | pub offset: usize, 24 | pub file: Arc, 25 | } 26 | 27 | impl fmt::Display for Span { 28 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 29 | write!(f, "{}:{}:{}", self.file, self.line, self.column) 30 | } 31 | } 32 | 33 | impl Default for Span { 34 | fn default() -> Self { 35 | Self { 36 | line: 0, 37 | column: 0, 38 | offset: 0, 39 | file: Arc::new(String::new()), 40 | } 41 | } 42 | } 43 | 44 | impl From> for Span { 45 | fn from(span: InputSpan<'_>) -> Self { 46 | Span { 47 | line: span.location_line(), 48 | column: span.get_column(), 49 | offset: span.location_offset(), 50 | file: span.extra.clone(), 51 | } 52 | } 53 | } 54 | 55 | #[derive(Clone, derive_more::Debug, Trace, PartialEq)] 56 | #[repr(align(16))] 57 | // TODO: Make cloning this struct as fast as possible. 58 | pub enum Syntax { 59 | /// An empty list. 60 | Null { 61 | #[debug(skip)] 62 | span: Span, 63 | }, 64 | /// A nested grouping of pairs. If the expression is a proper list, then the 65 | /// last element of expression will be Null. This vector is guaranteed to contain 66 | /// at least two elements. 67 | List { 68 | list: Vec, 69 | #[debug(skip)] 70 | span: Span, 71 | }, 72 | Vector { 73 | vector: Vec, 74 | #[debug(skip)] 75 | span: Span, 76 | }, 77 | ByteVector { 78 | vector: Vec, 79 | #[debug(skip)] 80 | span: Span, 81 | }, 82 | Literal { 83 | literal: Literal, 84 | #[debug(skip)] 85 | span: Span, 86 | }, 87 | Identifier { 88 | ident: Identifier, 89 | #[debug(skip)] 90 | bound: bool, 91 | #[debug(skip)] 92 | span: Span, 93 | }, 94 | } 95 | 96 | impl Syntax { 97 | pub fn mark(&mut self, mark: Mark) { 98 | match self { 99 | Self::List { ref mut list, .. } => { 100 | for item in list { 101 | item.mark(mark); 102 | } 103 | } 104 | Self::Vector { ref mut vector, .. } => { 105 | for item in vector { 106 | item.mark(mark); 107 | } 108 | } 109 | Self::Identifier { ident, .. } => ident.mark(mark), 110 | _ => (), 111 | } 112 | } 113 | 114 | pub fn mark_many(&mut self, marks: &BTreeSet) { 115 | match self { 116 | Self::List { ref mut list, .. } => { 117 | for item in list { 118 | item.mark_many(marks); 119 | } 120 | } 121 | Self::Vector { ref mut vector, .. } => { 122 | for item in vector { 123 | item.mark_many(marks); 124 | } 125 | } 126 | Self::Identifier { ident, .. } => ident.mark_many(marks), 127 | _ => (), 128 | } 129 | } 130 | 131 | // I do not like the fact that this function exists. 132 | pub fn normalize(self) -> Self { 133 | match self { 134 | Self::List { mut list, span } => { 135 | if let [Syntax::Null { .. }] = list.as_slice() { 136 | list.pop().unwrap() 137 | } else if list.is_empty() { 138 | Syntax::Null { span } 139 | } else { 140 | Self::List { list, span } 141 | } 142 | } 143 | x => x, 144 | } 145 | } 146 | 147 | pub fn syntax_from_datum(marks: &BTreeSet, datum: Value) -> Self { 148 | // TODO: conjure up better values for Span 149 | match datum.unpack() { 150 | UnpackedValue::Null => Syntax::new_null(Span::default()), 151 | UnpackedValue::Pair(pair) => { 152 | let pair_read = pair.read(); 153 | let lists::Pair(lhs, rhs) = pair_read.as_ref(); 154 | let mut list = Vec::new(); 155 | list.push(lhs.clone()); 156 | list_to_vec_with_null(rhs, &mut list); 157 | // TODO: Use futures combinators 158 | let mut out_list = Vec::new(); 159 | for item in list.iter() { 160 | out_list.push(Syntax::syntax_from_datum(marks, item.clone())); 161 | } 162 | Syntax::new_list(out_list, Span::default()) 163 | } 164 | UnpackedValue::Syntax(syntax) => { 165 | let mut syntax = syntax.as_ref().clone(); 166 | syntax.mark_many(marks); 167 | syntax 168 | } 169 | UnpackedValue::Symbol(sym) => { 170 | let ident = Identifier { 171 | name: sym.0.clone(), 172 | marks: marks.clone(), 173 | }; 174 | Syntax::Identifier { 175 | ident, 176 | bound: false, 177 | span: Span::default(), 178 | } 179 | } 180 | _ => unimplemented!(), 181 | } 182 | } 183 | 184 | pub fn resolve_bindings(&mut self, env: &Environment) { 185 | match self { 186 | Self::List { ref mut list, .. } => { 187 | for item in list { 188 | item.resolve_bindings(env); 189 | } 190 | } 191 | Self::Vector { ref mut vector, .. } => { 192 | for item in vector { 193 | item.resolve_bindings(env); 194 | } 195 | } 196 | Self::Identifier { 197 | ref ident, 198 | ref mut bound, 199 | .. 200 | } => *bound = env.is_bound(ident), 201 | _ => (), 202 | } 203 | } 204 | 205 | #[allow(dead_code)] 206 | async fn apply_transformer( 207 | &self, 208 | env: &Environment, 209 | mac: Macro, 210 | // cont: &Closure, 211 | ) -> Result { 212 | // Create a new mark for the expansion context 213 | let new_mark = Mark::new(); 214 | 215 | // Apply the new mark to the input and resolve any bindings 216 | let mut input = self.clone(); 217 | input.resolve_bindings(env); 218 | input.mark(new_mark); 219 | 220 | // Call the transformer with the input: 221 | let transformer_output = mac.transformer.call(&[Value::from(input)]).await?; 222 | 223 | // Output must be syntax: 224 | let output: Arc = transformer_output[0].clone().try_into()?; 225 | 226 | // Apply the new mark to the output 227 | let mut output = output.as_ref().clone(); 228 | output.mark(new_mark); 229 | 230 | let new_env = env.new_macro_expansion(new_mark, mac.source_env.clone()); 231 | 232 | Ok(Expansion::new_expanded(new_env, output)) 233 | } 234 | 235 | fn expand_once<'a>( 236 | &'a self, 237 | env: &'a Environment, 238 | // cont: &Closure, 239 | ) -> BoxFuture<'a, Result> { 240 | Box::pin(async move { 241 | match self { 242 | Self::List { list, .. } => { 243 | // TODO: If list head is a list, do we expand this in here or in proc call? 244 | 245 | let ident = match list.first() { 246 | Some(Self::Identifier { ident, .. }) => ident, 247 | _ => return Ok(Expansion::Unexpanded), 248 | }; 249 | if let Some(mac) = env.fetch_macro(ident) { 250 | return self.apply_transformer(env, mac).await; 251 | } 252 | 253 | // Check for set! macro 254 | match &list.as_slice()[1..] { 255 | [Syntax::Identifier { ident: var, .. }, ..] if ident.name == "set!" => { 256 | // Look for a variable transformer: 257 | if let Some(mac) = env.fetch_macro(var) { 258 | if !mac.transformer.read().is_variable_transformer { 259 | return Err(Condition::error(format!( 260 | "{} not a variable transformer", 261 | var.name 262 | )) 263 | .into()); 264 | } 265 | return self.apply_transformer(env, mac).await; 266 | } 267 | } 268 | _ => (), 269 | } 270 | } 271 | Self::Identifier { ident, .. } => { 272 | if let Some(mac) = env.fetch_macro(ident) { 273 | return self.apply_transformer(env, mac).await; 274 | } 275 | } 276 | _ => (), 277 | } 278 | Ok(Expansion::Unexpanded) 279 | }) 280 | } 281 | 282 | /// Fully expand the outermost syntax object. 283 | pub async fn expand( 284 | mut self, 285 | env: &Environment, 286 | // cont: &Closure, 287 | ) -> Result { 288 | let mut curr_env = env.clone(); 289 | loop { 290 | match self.expand_once(&curr_env).await? { 291 | Expansion::Unexpanded => { 292 | return Ok(FullyExpanded::new(curr_env, self)); 293 | } 294 | Expansion::Expanded { new_env, syntax } => { 295 | curr_env = new_env; 296 | self = syntax; 297 | } 298 | } 299 | } 300 | } 301 | 302 | fn parse_fragment<'a, 'b>( 303 | i: &'b [Token<'a>], 304 | ) -> Result<(&'b [Token<'a>], Self), ParseSyntaxError<'a>> { 305 | let (remaining, syntax) = crate::parse::expression(i)?; 306 | Ok((remaining, syntax)) 307 | } 308 | 309 | pub fn parse<'a>(mut i: &[Token<'a>]) -> Result, ParseSyntaxError<'a>> { 310 | let mut output = Vec::new(); 311 | while !i.is_empty() { 312 | let (remaining, expr) = Self::parse_fragment(i)?; 313 | output.push(expr); 314 | i = remaining 315 | } 316 | Ok(output) 317 | } 318 | 319 | pub fn from_str<'a>( 320 | s: &'a str, 321 | file_name: Option<&str>, 322 | ) -> Result, ParseSyntaxError<'a>> { 323 | let tokens = Token::tokenize(s, file_name)?; 324 | Self::parse(&tokens) 325 | } 326 | 327 | pub fn fetch_all_identifiers(&self, idents: &mut HashSet) { 328 | match self { 329 | Self::List { list: syns, .. } | Self::Vector { vector: syns, .. } => { 330 | for item in syns { 331 | item.fetch_all_identifiers(idents); 332 | } 333 | } 334 | Self::Identifier { ident, .. } => { 335 | idents.insert(ident.clone()); 336 | } 337 | _ => (), 338 | } 339 | } 340 | } 341 | 342 | // #[derive(derive_more::Debug)] 343 | pub enum Expansion { 344 | /// Syntax remained unchanged after expansion 345 | Unexpanded, 346 | /// Syntax was expanded, producing a new expansion context 347 | Expanded { 348 | new_env: Environment, 349 | syntax: Syntax, 350 | }, 351 | } 352 | 353 | impl Expansion { 354 | fn new_expanded(new_env: Environment, syntax: Syntax) -> Self { 355 | Self::Expanded { new_env, syntax } 356 | } 357 | } 358 | 359 | pub struct FullyExpanded { 360 | pub expansion_env: Environment, 361 | pub expanded: Syntax, 362 | } 363 | 364 | impl FullyExpanded { 365 | pub fn new(expansion_env: Environment, expanded: Syntax) -> Self { 366 | Self { 367 | expansion_env, 368 | expanded, 369 | } 370 | } 371 | } 372 | 373 | #[derive(Debug)] 374 | pub struct ParsedSyntax { 375 | pub doc_comment: Option, 376 | pub syntax: Syntax, 377 | } 378 | 379 | impl ParsedSyntax {} 380 | 381 | #[derive(Copy, Clone, Debug, Hash, PartialEq, Eq, PartialOrd, Ord, Trace)] 382 | pub struct Mark(usize); 383 | 384 | impl Mark { 385 | pub fn new() -> Self { 386 | Self(rand::random()) 387 | } 388 | } 389 | 390 | impl Default for Mark { 391 | fn default() -> Self { 392 | Self::new() 393 | } 394 | } 395 | 396 | #[derive(Clone, Hash, PartialEq, Eq, Trace)] 397 | pub struct Identifier { 398 | pub name: String, 399 | pub marks: BTreeSet, 400 | } 401 | 402 | impl fmt::Debug for Identifier { 403 | fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { 404 | write!( 405 | f, 406 | "{} ({})", 407 | self.name, 408 | self.marks 409 | .iter() 410 | .map(|m| m.0.to_string() + " ") 411 | .collect::() 412 | ) 413 | } 414 | } 415 | 416 | impl Identifier { 417 | pub fn new(name: String) -> Self { 418 | Self { 419 | name, 420 | marks: BTreeSet::default(), 421 | } 422 | } 423 | 424 | pub fn mark(&mut self, mark: Mark) { 425 | if self.marks.contains(&mark) { 426 | self.marks.remove(&mark); 427 | } else { 428 | self.marks.insert(mark); 429 | } 430 | } 431 | 432 | pub fn mark_many(&mut self, marks: &BTreeSet) { 433 | self.marks = self.marks.symmetric_difference(marks).cloned().collect(); 434 | } 435 | } 436 | 437 | impl PartialEq for Identifier { 438 | fn eq(&self, rhs: &str) -> bool { 439 | self.name == rhs 440 | } 441 | } 442 | 443 | impl Syntax { 444 | pub fn span(&self) -> &Span { 445 | match self { 446 | Self::Null { span } => span, 447 | Self::List { span, .. } => span, 448 | Self::Vector { span, .. } => span, 449 | Self::ByteVector { span, .. } => span, 450 | Self::Literal { span, .. } => span, 451 | Self::Identifier { span, .. } => span, 452 | } 453 | } 454 | 455 | // There's got to be a better way: 456 | 457 | pub fn new_null(span: impl Into) -> Self { 458 | Self::Null { span: span.into() } 459 | } 460 | 461 | pub fn is_null(&self) -> bool { 462 | matches!(self, Self::Null { .. }) 463 | } 464 | 465 | pub fn as_ident(&self) -> Option<&Identifier> { 466 | if let Syntax::Identifier { ident, .. } = self { 467 | Some(ident) 468 | } else { 469 | None 470 | } 471 | } 472 | 473 | pub fn new_list(list: Vec, span: impl Into) -> Self { 474 | Self::List { 475 | list, 476 | span: span.into(), 477 | } 478 | } 479 | 480 | pub fn as_list(&self) -> Option<&[Syntax]> { 481 | if let Syntax::List { list, .. } = self { 482 | Some(list) 483 | } else { 484 | None 485 | } 486 | } 487 | 488 | pub fn is_list(&self) -> bool { 489 | matches!(self, Self::List { .. }) 490 | } 491 | 492 | pub fn new_vector(vector: Vec, span: impl Into) -> Self { 493 | Self::Vector { 494 | vector, 495 | span: span.into(), 496 | } 497 | } 498 | 499 | pub fn new_byte_vector(vector: Vec, span: impl Into) -> Self { 500 | Self::ByteVector { 501 | vector, 502 | span: span.into(), 503 | } 504 | } 505 | 506 | pub fn is_vector(&self) -> bool { 507 | matches!(self, Self::Vector { .. }) 508 | } 509 | 510 | pub fn new_literal(literal: Literal, span: impl Into) -> Self { 511 | Self::Literal { 512 | literal, 513 | span: span.into(), 514 | } 515 | } 516 | 517 | pub fn is_literal(&self) -> bool { 518 | matches!(self, Self::Literal { .. }) 519 | } 520 | 521 | pub fn new_identifier(name: &str, span: impl Into) -> Self { 522 | Self::Identifier { 523 | ident: Identifier::new(name.to_string()), 524 | span: span.into(), 525 | bound: false, 526 | } 527 | } 528 | 529 | pub fn is_identifier(&self) -> bool { 530 | matches!(self, Self::Identifier { .. }) 531 | } 532 | } 533 | 534 | #[bridge(name = "syntax->datum", lib = "(base)")] 535 | pub async fn syntax_to_datum(syn: &Value) -> Result, Condition> { 536 | let syn: Arc = syn.clone().try_into()?; 537 | Ok(vec![Value::datum_from_syntax(syn.as_ref())]) 538 | } 539 | 540 | #[bridge(name = "datum->syntax", lib = "(base)")] 541 | pub async fn datum_to_syntax(template_id: &Value, datum: &Value) -> Result, Condition> { 542 | let syntax: Arc = template_id.clone().try_into()?; 543 | let Syntax::Identifier { 544 | ident: template_id, .. 545 | } = syntax.as_ref() 546 | else { 547 | return Err(Condition::invalid_type("template_id", "syntax")); 548 | }; 549 | Ok(vec![Value::from(Syntax::syntax_from_datum( 550 | &template_id.marks, 551 | datum.clone(), 552 | ))]) 553 | } 554 | -------------------------------------------------------------------------------- /src/vectors.rs: -------------------------------------------------------------------------------- 1 | use crate::{ 2 | exception::Condition, 3 | gc::{Gc, Trace}, 4 | lists::slice_to_list, 5 | num::{Number, NumberToUsizeError}, 6 | registry::bridge, 7 | strings, 8 | value::Value, 9 | }; 10 | use malachite::Integer; 11 | use std::{ 12 | clone::Clone, 13 | fmt, 14 | ops::{Deref, DerefMut, Range}, 15 | sync::Arc, 16 | }; 17 | 18 | /// A vector aligned to 16 bytes. 19 | #[derive(Trace)] 20 | #[repr(align(16))] 21 | pub struct AlignedVector(pub Vec); 22 | 23 | impl AlignedVector { 24 | pub fn new(v: Vec) -> Self { 25 | Self(v) 26 | } 27 | } 28 | 29 | impl Deref for AlignedVector { 30 | type Target = Vec; 31 | 32 | fn deref(&self) -> &Self::Target { 33 | &self.0 34 | } 35 | } 36 | 37 | impl DerefMut for AlignedVector { 38 | fn deref_mut(&mut self) -> &mut Self::Target { 39 | &mut self.0 40 | } 41 | } 42 | 43 | impl PartialEq for AlignedVector { 44 | fn eq(&self, rhs: &Self) -> bool { 45 | self.0 == rhs.0 46 | } 47 | } 48 | 49 | pub fn display_vec( 50 | head: &str, 51 | v: &[T], 52 | f: &mut fmt::Formatter<'_>, 53 | ) -> Result<(), fmt::Error> { 54 | write!(f, "{}", head)?; 55 | 56 | let mut iter = v.iter().peekable(); 57 | while let Some(next) = iter.next() { 58 | write!(f, "{}", next)?; 59 | if iter.peek().is_some() { 60 | write!(f, " ")?; 61 | } 62 | } 63 | 64 | write!(f, ")") 65 | } 66 | 67 | fn try_make_range(start: usize, end: usize) -> Result, Condition> { 68 | if end < start { 69 | Err(Condition::error(format!( 70 | "Range end {} cannot be less than start {}", 71 | end, start 72 | ))) 73 | } else { 74 | Ok(start..end) 75 | } 76 | } 77 | 78 | fn try_to_usize(n: &Value) -> Result { 79 | n.clone().try_into().and_then(|n: Arc| { 80 | n.as_ref() 81 | .try_into() 82 | .map_err(>::into) 83 | }) 84 | } 85 | 86 | trait Indexer { 87 | type Collection; 88 | 89 | fn get_len(_: &Self::Collection) -> usize; 90 | 91 | fn get_range(_: &Self::Collection, _: Range) -> Self::Collection; 92 | 93 | fn try_get(_: &Value) -> Result; 94 | 95 | fn index(from: &Value, range: &[Value]) -> Result { 96 | let collection = Self::try_get(from)?; 97 | let len = Self::get_len(&collection); 98 | 99 | let start: usize = range.first().map(try_to_usize).transpose()?.unwrap_or(0); 100 | let end: usize = range.get(1).map(try_to_usize).transpose()?.unwrap_or(len); 101 | 102 | let range = try_make_range(start, end)?; 103 | if range.end > len { 104 | return Err(Condition::invalid_range(range, len)); 105 | } 106 | 107 | Ok(Self::get_range(&collection, range)) 108 | } 109 | } 110 | 111 | struct StringIndexer; 112 | 113 | impl Indexer for StringIndexer { 114 | type Collection = Arc; 115 | 116 | fn get_len(string: &Self::Collection) -> usize { 117 | string.chars().count() 118 | } 119 | 120 | fn get_range(string: &Self::Collection, range: Range) -> Self::Collection { 121 | let substr: String = string 122 | .chars() 123 | .skip(range.start) 124 | .take(range.end - range.start) 125 | .collect(); 126 | Arc::new(strings::AlignedString::new(substr)) 127 | } 128 | 129 | fn try_get(val: &Value) -> Result { 130 | val.clone().try_into() 131 | } 132 | } 133 | 134 | struct VectorIndexer; 135 | 136 | impl Indexer for VectorIndexer { 137 | type Collection = Gc>; 138 | 139 | fn get_len(vec: &Self::Collection) -> usize { 140 | vec.read().len() 141 | } 142 | 143 | fn get_range(vec: &Self::Collection, range: Range) -> Self::Collection { 144 | let subvec: Vec = vec 145 | .read() 146 | .iter() 147 | .skip(range.start) 148 | .take(range.end - range.start) 149 | .cloned() 150 | .collect(); 151 | Gc::new(AlignedVector::new(subvec)) 152 | } 153 | 154 | fn try_get(val: &Value) -> Result { 155 | val.clone().try_into() 156 | } 157 | } 158 | 159 | #[bridge(name = "make-vector", lib = "(base)")] 160 | pub async fn make_vector(n: &Value, with: &[Value]) -> Result, Condition> { 161 | let n: Arc = n.clone().try_into()?; 162 | let n: usize = n.as_ref().try_into()?; 163 | 164 | Ok(vec![Value::from( 165 | (0..n) 166 | .map(|_| with.first().cloned().unwrap_or_else(Value::null)) 167 | .collect::>(), 168 | )]) 169 | } 170 | 171 | #[bridge(name = "vector", lib = "(base)")] 172 | pub async fn vector(args: &[Value]) -> Result, Condition> { 173 | Ok(vec![Value::from(args.to_vec())]) 174 | } 175 | 176 | #[bridge(name = "vector-ref", lib = "(base)")] 177 | pub async fn vector_ref(vec: &Value, index: &Value) -> Result, Condition> { 178 | let vec: Gc> = vec.clone().try_into()?; 179 | let index: usize = try_to_usize(index)?; 180 | let vec_read = vec.read(); 181 | 182 | Ok(vec![vec_read 183 | .get(index) 184 | .ok_or_else(|| Condition::invalid_index(index, vec_read.len()))? 185 | .clone()]) 186 | } 187 | 188 | #[bridge(name = "vector-length", lib = "(base)")] 189 | pub async fn vector_len(vec: &Value) -> Result, Condition> { 190 | let vec: Gc> = vec.clone().try_into()?; 191 | let len = vec.read().len(); 192 | 193 | Ok(vec![Value::from(match i64::try_from(len) { 194 | Ok(len) => Number::FixedInteger(len), 195 | Err(_) => Number::BigInteger(Integer::from(len)), 196 | })]) 197 | } 198 | 199 | #[bridge(name = "vector-set!", lib = "(base)")] 200 | pub async fn vector_set(vec: &Value, index: &Value, with: &Value) -> Result, Condition> { 201 | let vec: Gc> = vec.clone().try_into()?; 202 | let vec_len = vec.read().len(); 203 | 204 | let index: usize = try_to_usize(index)?; 205 | 206 | *vec.write() 207 | .get_mut(index) 208 | .ok_or_else(|| Condition::invalid_index(index, vec_len))? = with.clone(); 209 | 210 | Ok(vec![]) 211 | } 212 | 213 | #[bridge(name = "vector->list", lib = "(base)")] 214 | pub async fn vector_to_list(from: &Value, range: &[Value]) -> Result, Condition> { 215 | let vec = VectorIndexer::index(from, range)?; 216 | let vec_read = vec.read(); 217 | Ok(vec![slice_to_list(&vec_read)]) 218 | } 219 | 220 | #[bridge(name = "vector->string", lib = "(base)")] 221 | pub async fn vector_to_string(from: &Value, range: &[Value]) -> Result, Condition> { 222 | let vec = VectorIndexer::index(from, range)?; 223 | let vec_read = vec.read(); 224 | Ok(vec![Value::from( 225 | vec_read 226 | .iter() 227 | .cloned() 228 | .map(>::try_into) 229 | .collect::>()?, 230 | )]) 231 | } 232 | 233 | #[bridge(name = "string->vector", lib = "(base)")] 234 | pub async fn string_to_vector(from: &Value, range: &[Value]) -> Result, Condition> { 235 | let str = StringIndexer::index(from, range)?; 236 | Ok(vec![Value::from( 237 | str.chars().map(Value::from).collect::>(), 238 | )]) 239 | } 240 | 241 | #[bridge(name = "vector-copy", lib = "(base)")] 242 | pub async fn vector_copy(from: &Value, range: &[Value]) -> Result, Condition> { 243 | Ok(vec![Value::from(VectorIndexer::index(from, range)?)]) 244 | } 245 | 246 | #[bridge(name = "vector-copy!", lib = "(base)")] 247 | pub async fn vector_copy_to( 248 | to: &Value, 249 | at: &Value, 250 | from: &Value, 251 | range: &[Value], 252 | ) -> Result, Condition> { 253 | let to: Gc> = to.clone().try_into()?; 254 | let mut to = to.write(); 255 | 256 | let at: usize = try_to_usize(at)?; 257 | 258 | if at >= to.len() { 259 | return Err(Condition::invalid_index(at, to.len())); 260 | } 261 | 262 | let copies = VectorIndexer::index(from, range)?; 263 | let copies = copies.read(); 264 | if copies.len() + at >= to.len() { 265 | return Err(Condition::invalid_range(at..at + copies.len(), to.len())); 266 | } 267 | 268 | copies 269 | .iter() 270 | .enumerate() 271 | .map(|(i, copy)| (i + at, copy)) 272 | .for_each(|(i, copy)| { 273 | if let Some(i) = to.get_mut(i) { 274 | *i = copy.clone(); 275 | } 276 | }); 277 | 278 | Ok(vec![]) 279 | } 280 | 281 | #[bridge(name = "vector-append", lib = "(base)")] 282 | pub async fn vector_append(args: &[Value]) -> Result, Condition> { 283 | if args.is_empty() { 284 | return Err(Condition::wrong_num_of_variadic_args(1..usize::MAX, 0)); 285 | } 286 | 287 | Ok(vec![Value::from( 288 | args.iter() 289 | .map(|arg| { 290 | let vec: Gc> = arg.clone().try_into()?; 291 | let vec_read = vec.read(); 292 | Ok(vec_read.iter().cloned().collect::>()) 293 | }) 294 | .collect::, Condition>>()? 295 | .into_iter() 296 | .flatten() 297 | .collect::>(), 298 | )]) 299 | } 300 | 301 | #[bridge(name = "vector-fill!", lib = "(base)")] 302 | pub async fn vector_fill( 303 | vector: &Value, 304 | with: &Value, 305 | start: &Value, 306 | end: &[Value], 307 | ) -> Result, Condition> { 308 | let vector: Gc> = vector.clone().try_into()?; 309 | let mut vector = vector.write(); 310 | 311 | let start: usize = try_to_usize(start)?; 312 | let end = match end.first() { 313 | Some(end) => try_to_usize(end)?, 314 | None => vector.len(), 315 | }; 316 | 317 | let range = try_make_range(start, end)?; 318 | if range.end > vector.len() { 319 | return Err(Condition::invalid_range(range, vector.len())); 320 | } 321 | 322 | range.for_each(|i| { 323 | if let Some(slot) = vector.get_mut(i) { 324 | *slot = with.clone() 325 | } 326 | }); 327 | 328 | Ok(vec![]) 329 | } 330 | -------------------------------------------------------------------------------- /tests/common/mod.rs: -------------------------------------------------------------------------------- 1 | #![allow(dead_code, unused_macros, unused_imports)] 2 | 3 | //! Test to see whether or not passes r*rs specifications 4 | 5 | use scheme_rs::{ 6 | ast::DefinitionBody, 7 | cps::Compile, 8 | env::{Environment, Top}, 9 | exception::Condition, 10 | gc::Gc, 11 | registry::{bridge, Registry}, 12 | runtime::Runtime, 13 | syntax::{Span, Syntax}, 14 | value::Value, 15 | }; 16 | use std::error::Error as StdError; 17 | 18 | pub struct TestRuntime { 19 | runtime: Gc, 20 | test_top: Environment, 21 | } 22 | impl TestRuntime { 23 | pub async fn new() -> Self { 24 | let runtime = Gc::new(Runtime::new()); 25 | let registry = Registry::new(&runtime).await; 26 | let base = registry.import("(base)").unwrap(); 27 | let mut test_top = Top::program(); 28 | { 29 | let base = base.read(); 30 | test_top.import(&base); 31 | } 32 | let test_top = Environment::from(Gc::new(test_top)); 33 | 34 | Self { runtime, test_top } 35 | } 36 | 37 | pub async fn exec_syn(&self, sexprs: &[Syntax]) -> Result<(), Box> { 38 | let base = DefinitionBody::parse_program_body( 39 | &self.runtime, 40 | sexprs, 41 | &self.test_top, 42 | &Span::default(), 43 | ) 44 | .await 45 | .unwrap(); 46 | let compiled = base.compile_top_level(); 47 | let closure = self 48 | .runtime 49 | .compile_expr(compiled) 50 | .await 51 | .map_err(Box::new)?; 52 | Ok(closure.call(&[]).await.map(drop).map_err(Box::new)?) 53 | } 54 | 55 | pub async fn exec_str<'a>(&self, src: &'a str) -> Result<(), Box> { 56 | let sexprs = Syntax::from_str(src, None).map_err(Box::new)?; 57 | self.exec_syn(&sexprs).await 58 | } 59 | } 60 | 61 | #[bridge(name = "assert-eq", lib = "(base)")] 62 | pub async fn test_assert(arg1: &Value, arg2: &Value) -> Result, Condition> { 63 | if arg1 != arg2 { 64 | let arg1 = format!("{arg1:?}"); 65 | let arg2 = format!("{arg2:?}"); 66 | Err(Condition::assert_eq_failed(&arg2, &arg1)) 67 | } else { 68 | Ok(vec![]) 69 | } 70 | } 71 | 72 | macro_rules! assert_file { 73 | ($name:ident) => { 74 | #[::tokio::test] 75 | async fn $name() { 76 | let rt = $crate::common::TestRuntime::new().await; 77 | let sexprs = scheme_rs::syntax::Syntax::from_str( 78 | include_str!(concat!(stringify!($name), ".scm")), 79 | Some(concat!(stringify!($name), ".scm")), 80 | ) 81 | .unwrap(); 82 | rt.exec_syn(&sexprs).await.unwrap(); 83 | } 84 | }; 85 | } 86 | 87 | macro_rules! assert_failure { 88 | ($name:ident, $expr:literal) => { 89 | #[::tokio::test] 90 | async fn $name() { 91 | let rt = $crate::common::TestRuntime::new().await; 92 | assert!(rt.exec_str($expr).await.is_err()) 93 | } 94 | }; 95 | } 96 | 97 | pub(crate) use assert_failure; 98 | pub(crate) use assert_file; 99 | -------------------------------------------------------------------------------- /tests/r6rs.rs: -------------------------------------------------------------------------------- 1 | mod common; 2 | 3 | common::assert_file!(r6rs); 4 | -------------------------------------------------------------------------------- /tests/r6rs.scm: -------------------------------------------------------------------------------- 1 | ;; r6rs.scm - Compatibility test for the R6RS implementation 2 | ;; 3 | ;; As of right now, this test simply takes all of the examples 4 | ;; given in the r6rs spec and runs them, asserting the values to 5 | ;; be the ones given in the spec. 6 | 7 | ;; 1.2. Expressions 8 | 9 | ;; The following are omitted because they don't really show anything: 10 | ;; (assert-eq #t #t) 11 | ;; (assert-eq 23 23) 12 | 13 | (assert-eq (+ 23 42) 65) 14 | (assert-eq (+ 14 (* 23 42)) 980) 15 | 16 | ;; 1.3. Variables and binding 17 | 18 | (assert-eq 19 | (let ((x 23) 20 | (y 42)) 21 | (+ x y)) 22 | 65) 23 | 24 | ;; 1.4. Definitions 25 | 26 | (define x 23) 27 | (define y 42) 28 | (assert-eq (+ x y) 65) 29 | 30 | (define x 23) 31 | (define y 42) 32 | 33 | (assert-eq (let ((y 43)) 34 | (+ x y)) 35 | 66) 36 | 37 | (assert-eq (let ((y 43)) 38 | (let ((y 44)) 39 | (+ x y))) 40 | 67) 41 | 42 | ;; 1.6 Procedures 43 | 44 | (define (f x) 45 | (+ x 42)) 46 | 47 | (assert-eq (f 23) 65) 48 | 49 | (define (f x) 50 | (+ x 42)) 51 | 52 | (define (g p x) 53 | (p x)) 54 | 55 | (assert-eq (g f 23) 65) 56 | 57 | (define (h op x y) 58 | (op x y)) 59 | 60 | (assert-eq (h + 23 42) 65) 61 | (assert-eq (h * 23 42) 966) 62 | 63 | ;; mark 64 | 65 | (assert-eq ((lambda (x) (+ x 42)) 23) 65) 66 | 67 | ;; 1.8 Assignments 68 | 69 | (assert-eq (let ((x 23)) 70 | (set! x 42) 71 | x) 72 | 42) 73 | 74 | ;; 1.11 Continuations 75 | (assert-eq (+ 1 (call-with-current-continuation 76 | (lambda (escape) 77 | (+ 2 (escape 3))))) 78 | 4) 79 | 80 | ;; ?? boolean=? 81 | 82 | (assert-eq (boolean=? #t #t #t) #t) 83 | (assert-eq (boolean=? #f #f #f) #t) 84 | (assert-eq (boolean=? #t #f #f) #f) 85 | (assert-eq (boolean=? #f #t #t) #f) 86 | (assert-eq (boolean=? 1 2) #f) 87 | (assert-eq (boolean=? #t 2) #f) 88 | (assert-eq (boolean=? #t) #t) 89 | (assert-eq (boolean=? #f) #t) 90 | 91 | ;; 6.4. list procedures 92 | 93 | (assert-eq (make-list 2) '(#f #f)) 94 | (assert-eq (make-list 5) '(#f #f #f #f #f)) 95 | 96 | (define xs '(1 2 3 4 5)) 97 | 98 | (assert-eq (eq? (list-copy xs) xs) #f) 99 | (assert-eq (eq? xs xs) #t) 100 | 101 | (assert-eq (list-ref xs 2) 3) 102 | (assert-eq (list-ref xs 3) 4) 103 | 104 | (assert-eq (list-tail xs 3) '(4 5)) 105 | 106 | (define alist '((a . 1) (b . 2))) 107 | 108 | (assert-eq (assoc 'a alist) '(a . 1)) 109 | (assert-eq (assoc 'b alist) '(b . 2)) 110 | (assert-eq (assoc 'c alist) #f) 111 | 112 | ;; 11.2.2. Syntax definitions 113 | 114 | (assert-eq (let () 115 | (define even? 116 | (lambda (x) 117 | (or (= x 0) (odd? (- x 1))))) 118 | (define-syntax odd? 119 | (syntax-rules () 120 | ((odd? x) (not (even? x))))) 121 | (even? 10)) 122 | #t) 123 | 124 | (assert-eq (let () 125 | (define-syntax bind-to-zero 126 | (syntax-rules () 127 | ((bind-to-zero id) (define id 0)))) 128 | (bind-to-zero x) 129 | x) 130 | 0) 131 | 132 | ;; 11.3 Bodies 133 | 134 | (assert-eq (let ((x 5)) 135 | (define foo (lambda (y) (bar x y))) 136 | (define bar (lambda (a b) (+ (* a b) a))) 137 | (foo (+ x 3))) 138 | 45) 139 | 140 | 141 | ;; 11.4.2. Procedures 142 | 143 | ;; (skipping a bunch of these because this stuff works) 144 | 145 | (assert-eq ((lambda (x) 146 | (define (p y) 147 | (+ y 1)) 148 | (+ (p x) x)) 149 | 5) 150 | 11) 151 | 152 | ;; 11.4.3 Conditionals 153 | 154 | (assert-eq (if (> 3 2) 'yes 'no) 'yes) 155 | (assert-eq (if (> 2 3) 'yes 'no) 'no) 156 | (assert-eq (if (> 3 2) 157 | (- 3 2) 158 | (+ 3 2)) 159 | 1) 160 | 161 | ;; 11.4.5 Derived conditionals 162 | 163 | (assert-eq (cond ((> 3 2) 'greater) 164 | ((< 3 2) 'less)) 165 | 'greater) 166 | (assert-eq (cond ((> 3 3) 'greater) 167 | ((< 3 3) 'less) 168 | (else 'equal)) 169 | 'equal) 170 | (assert-eq (cond ('(1 2 3) => cadr) 171 | (else #f)) 172 | 2) 173 | 174 | (assert-eq (case (* 2 3) 175 | ((2 3 5 7) 'prime) 176 | ((1 4 6 8 9) 'composite)) 177 | 'composite) 178 | (assert-eq (case (car '(c d)) 179 | ((a e i o u) 'vowel) 180 | ((w y) 'semivowel) 181 | (else 'consonant)) 182 | 'consonant) 183 | 184 | 185 | ;; 11.4.6. Binding constructs 186 | 187 | (assert-eq (let ((x 2) (y 3)) 188 | (let* ((x 7) 189 | (z (+ x y))) 190 | (* z x))) 191 | 70) 192 | 193 | (assert-eq (letrec ((even? 194 | (lambda (n) 195 | (if (zero? n) 196 | #t 197 | (odd? (- n 1))))) 198 | (odd? 199 | (lambda (n) 200 | (if (zero? n) 201 | #f 202 | (even? (- n 1)))))) 203 | (even? 88)) 204 | #t) 205 | 206 | (assert-eq (letrec* ((p 207 | (lambda (x) 208 | (+ 1 (q (- x 1))))) 209 | (q 210 | (lambda (y) 211 | (if (zero? y) 212 | 0 213 | (+ 1 (p (- y 1)))))) 214 | (x (p 5)) 215 | (y x)) 216 | y) 217 | 5) 218 | 219 | (assert-eq (let-values (((a b) (values 1 2)) 220 | ((c d) (values 3 4))) 221 | (list a b c d)) 222 | '(1 2 3 4)) 223 | 224 | (assert-eq (let-values (((a b . c) (values 1 2 3 4))) 225 | (list a b c)) 226 | '(1 2 (3 4))) 227 | 228 | (assert-eq (let ((a 'a) (b 'b) (x 'x) (y 'y)) 229 | (let-values (((a b) (values x y)) 230 | ((x y) (values a b))) 231 | (list a b x y))) 232 | '(x y a b)) 233 | 234 | (assert-eq (let ((a 'a) (b 'b) (x 'x) (y 'y)) 235 | (let*-values (((a b) (values x y)) 236 | ((x y) (values a b))) 237 | (list a b x y))) 238 | '(x y x y)) 239 | 240 | ;; 11.5. Equivalence predicates 241 | 242 | ;; Right now, constants have a new allocation per each instance. This is obviously 243 | ;; wrong, but a much deeper problem than one with the implementation of eq? 244 | 245 | (assert-eq (eq? (list 'a) (list 'a)) 246 | #f) 247 | 248 | (assert-eq (let ((x 1)) 249 | (eq? x x)) 250 | #t) 251 | 252 | (assert-eq (let loopv ((n 1)) 253 | (if (> n 10) 254 | '() 255 | (cons n (loopv (+ n 1))))) 256 | '(1 2 3 4 5 6 7 8 9 10)) 257 | 258 | (define-syntax loop 259 | (lambda (x) 260 | (syntax-case x () 261 | [(k e ...) 262 | (with-syntax 263 | ([break (datum->syntax #'k 'break)]) 264 | #'(call-with-current-continuation 265 | (lambda (break) 266 | (let f () e ... (f)))))]))) 267 | 268 | (assert-eq (let ((n 3) (ls '())) 269 | (loop 270 | (if (= n 0) (break ls)) 271 | (set! ls (cons 'a ls)) 272 | (set! n (- n 1)))) 273 | '(a a a)) 274 | 275 | ;; 11.7 Arithmetic 276 | 277 | (assert-eq (/ 5) 1/5) 278 | (assert-eq (/ 5 10) 1/2) 279 | 280 | ;; 11.15 Control features 281 | 282 | (assert-eq (let ((path '()) 283 | (c #f)) 284 | (let ((add (lambda (s) 285 | (set! path (cons s path))))) 286 | (dynamic-wind 287 | (lambda () (add 'connect)) 288 | (lambda () 289 | (add (call-with-current-continuation 290 | (lambda (c0) 291 | (set! c c0) 292 | 'talk1)))) 293 | (lambda () (add 'disconnect))) 294 | (if (< (length path) 4) 295 | (c 'talk2) 296 | (reverse path)))) 297 | '(connect talk1 disconnect connect talk2 disconnect)) 298 | 299 | (assert-eq (let ((n 0)) 300 | (call-with-current-continuation 301 | (lambda (k) 302 | (dynamic-wind 303 | (lambda () 304 | (set! n (+ n 1)) 305 | (k)) 306 | (lambda () 307 | (set! n (+ n 2))) 308 | (lambda () 309 | (set! n (+ n 4)))))) 310 | n) 311 | 1) 312 | 313 | ;; 11.18 Binding constructs for syntactic-keywords 314 | (assert-eq (let-syntax ((when (syntax-rules () 315 | ((when test stmt1 stmt2 ...) 316 | (if test 317 | (begin stmt1 318 | stmt2 ...)))))) 319 | (let ((if #t)) 320 | (when if (set! if 'now)) 321 | if)) 322 | 'now) 323 | 324 | (assert-eq (let () 325 | (let-syntax 326 | ((def (syntax-rules () 327 | ((def stuff ...) (define stuff ...))))) 328 | (def foo 42)) 329 | foo) 330 | 42) 331 | 332 | (assert-eq (let ((x 'outer)) 333 | (let-syntax ((m (syntax-rules () ((m) x)))) 334 | (let ((x 'inner)) 335 | (m)))) 336 | 'outer) 337 | 338 | ;; TODO: Fix parser for this, I guess. 339 | ;; (assert-eq (let () 340 | ;; (let-syntax ()) 341 | ;; 5) 342 | ;; 5) 343 | 344 | (assert-eq (letrec-syntax 345 | ((my-or (syntax-rules () 346 | ((my-or) #f) 347 | ((my-or e) e) 348 | ((my-or e1 e2 ...) 349 | (let ((temp e1)) 350 | (if temp 351 | temp 352 | (my-or e2 ...))))))) 353 | (let ((x #f) 354 | (y 7) 355 | (temp 8) 356 | ;; TODO: In the R6RS docs these are let and if and everything 357 | ;; works fine. Got to fix the parser 358 | (let odd?) 359 | (if even?)) 360 | (my-or x 361 | (let temp) 362 | (if y) 363 | y))) 364 | 7) 365 | 366 | (assert-eq (let ((f (lambda (x) (+ x 1)))) 367 | (let-syntax ((f (syntax-rules () 368 | ((f x) x))) 369 | (g (syntax-rules () 370 | ((g x) (f x))))) 371 | (list (f 1) (g 1)))) 372 | '(1 2)) 373 | 374 | (assert-eq (let ((f (lambda (x) (+ x 1)))) 375 | (letrec-syntax ((f (syntax-rules () 376 | ((f x) x))) 377 | (g (syntax-rules () 378 | ((g x) (f x))))) 379 | (list (f 1) (g 1)))) 380 | '(1 1)) 381 | 382 | ;; Extra stuff: 383 | 384 | (assert-eq (let ([x 1]) 385 | (syntax-case #'() () 386 | ([] x))) 387 | 1) 388 | 389 | ;; Guile hygiene example: 390 | 391 | (define-syntax defconst 392 | (lambda (x) 393 | (syntax-case x () 394 | [(_ name val) 395 | (syntax (begin 396 | (define t val) 397 | (define-syntax name 398 | (lambda (x) 399 | (syntax-case x () 400 | ([_] #'t))))))]))) 401 | 402 | ;; foo is already bound to a macro in this scope 403 | (defconst newfoo 42) 404 | (defconst newbar 70) 405 | 406 | (assert-eq (newfoo) 42) 407 | (assert-eq (newbar) 70) 408 | 409 | ;; Realized this was an issue when doing escape analysis: 410 | (define (test a) (set! a '())) 411 | -------------------------------------------------------------------------------- /tests/r7rs.rs: -------------------------------------------------------------------------------- 1 | mod common; 2 | 3 | use common::{assert_failure, assert_file}; 4 | 5 | assert_file!(r7rs); 6 | 7 | assert_failure!(byte_overflow, "#u8(9001)"); 8 | -------------------------------------------------------------------------------- /tests/r7rs.scm: -------------------------------------------------------------------------------- 1 | ;; r7rs.scm - Compatibility test for the R7RS small implementation 2 | 3 | ;; 6.2 Numbers 4 | 5 | (assert-eq (positive? 1) #t) 6 | (assert-eq (positive? 0) #f) 7 | (assert-eq (positive? (- 1)) #f) 8 | 9 | (assert-eq (negative? 1) #f) 10 | (assert-eq (negative? 0) #f) 11 | (assert-eq (negative? -1) #t) 12 | 13 | (assert-eq (abs 1) 1) 14 | (assert-eq (abs 0) 0) 15 | (assert-eq (abs -1) 1) 16 | 17 | (assert-eq (min 2 4 1 3) 1) 18 | (assert-eq (min 2 4 -1 3) -1) 19 | (assert-eq (min 2 4 3) 2) 20 | 21 | (assert-eq (max 2 4 1 3) 4) 22 | (assert-eq (max 2 4 3) 4) 23 | (assert-eq (max 3 2 1) 3) 24 | 25 | ;; 6.6 Characters 26 | (assert-eq (char->integer #\a) 97) 27 | (assert-eq (integer->char 97) #\a) 28 | 29 | ;; 6.8 Vectors 30 | 31 | (assert-eq (make-vector 10 'a) #(a a a a a a a a a a)) 32 | 33 | (assert-eq (vector 'a 'b 'c) #(a b c)) 34 | 35 | (assert-eq (vector-ref '#(1 1 2 3 5 8 13 21) 5) 8) 36 | 37 | (assert-eq 38 | (let ((vec (vector 0 '(2 2 2 2) "Anna"))) 39 | (vector-set! vec 1 '("Sue" "Sue")) 40 | vec) 41 | #(0 ("Sue" "Sue") "Anna")) 42 | 43 | (assert-eq 44 | (vector->list '#(dah dah didah)) 45 | '(dah dah didah)) 46 | (assert-eq 47 | (vector->list '#(dah dah didah) 1 2) 48 | '(dah)) 49 | (assert-eq 50 | (list->vector '(dididit dah)) 51 | #(dididit dah)) 52 | 53 | (assert-eq 54 | (string->vector "ABC") 55 | #(#\A #\B #\C)) 56 | (assert-eq (vector->string #(#\A #\B #\C)) "ABC") 57 | 58 | (let* ((a #(1 8 2 8)) 59 | (b (vector-copy a)) 60 | (c (vector-copy b 1 3))) 61 | 62 | (vector-set! b 0 3) 63 | 64 | (assert-eq b #(3 8 2 8)) 65 | (assert-eq c #(8 2))) 66 | 67 | (let ((a (vector 1 2 3 4 5)) 68 | (b (vector 10 20 30 40 50))) 69 | 70 | (vector-copy! b 1 a 0 2) 71 | (assert-eq b #(10 1 2 40 50))) 72 | 73 | (assert-eq (vector-append #(a b c) #(d e f)) 74 | #(a b c d e f)) 75 | 76 | (let ((v (vector 1 2 3 4 5))) 77 | (vector-fill! v 'smash 2 4) 78 | (assert-eq v #(1 2 smash smash 5))) 79 | -------------------------------------------------------------------------------- /unicode/fetch.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | curl -L https://www.unicode.org/Public/UCD/latest/ucd/CaseFolding.txt -o case_folding.txt 4 | curl -L https://www.unicode.org/Public/UCD/latest/ucd/extracted/DerivedNumericType.txt -o numeric_types.txt 5 | --------------------------------------------------------------------------------