├── .github
└── workflows
│ ├── codeql-analysis.yml
│ └── node.js.yml
├── .gitignore
├── LICENSE
├── README.md
├── package-lock.json
├── package.json
├── scheme.code-workspace
├── scheme.wasm.ui
├── about.html
├── assets
│ ├── icons.plain.svg
│ └── icons.svg
├── favicon
│ ├── scheme.wasm.logo.16.png
│ ├── scheme.wasm.logo.32.png
│ ├── scheme.wasm.logo.96.png
│ └── scheme.wasm.logo.svg
├── fonts
│ ├── roboto-v29-latin-500.woff
│ ├── roboto-v29-latin-500.woff2
│ ├── roboto-v29-latin-700.woff
│ ├── roboto-v29-latin-700.woff2
│ ├── roboto-v29-latin-regular.woff
│ ├── roboto-v29-latin-regular.woff2
│ ├── source-code-pro-v18-latin-regular.woff
│ └── source-code-pro-v18-latin-regular.woff2
├── index.html
├── package.json
├── src
│ ├── Jiffies.ts
│ ├── RuntimeWorker.ts
│ ├── SchemeRuntime.tsx
│ ├── SchemeType.tsx
│ ├── components
│ │ ├── About.tsx
│ │ ├── Burger.tsx
│ │ ├── Debugger.tsx
│ │ ├── Editor.tsx
│ │ ├── EmergencyStop.tsx
│ │ ├── Flyout.tsx
│ │ ├── FocusContext.tsx
│ │ ├── HeapInspector.tsx
│ │ ├── IconButton.tsx
│ │ ├── RuntimeStatus.tsx
│ │ ├── SchemeRuntimeProvider.tsx
│ │ ├── Settings.tsx
│ │ ├── SettingsMenu.tsx
│ │ ├── Terminal.tsx
│ │ ├── TerminalData.tsx
│ │ ├── TerminalEditor.tsx
│ │ ├── TerminalInput.tsx
│ │ ├── ThemeProvider.tsx
│ │ └── ToggleSwitch.tsx
│ ├── global.d.ts
│ ├── icons
│ │ ├── IconProps.tsx
│ │ ├── copy.tsx
│ │ ├── cut.tsx
│ │ ├── icons.ts
│ │ ├── logo.tsx
│ │ ├── open.tsx
│ │ ├── paste.tsx
│ │ ├── redo.tsx
│ │ ├── save.tsx
│ │ └── undo.tsx
│ ├── index.tsx
│ ├── monaco
│ │ ├── scheme.ts
│ │ ├── solarized-contrast.ts
│ │ ├── solarized.ts
│ │ └── theme.ts
│ ├── styles
│ │ ├── animations.module.css
│ │ └── page.module.css
│ ├── util.ts
│ └── worker
│ │ ├── messages.ts
│ │ └── worker.ts
├── tsconfig.json
└── webpack.config.js
└── scheme.wasm
├── buildwat.json
├── package.json
├── src
├── builtins.wat
├── conditionals.wat
├── continuations.wat
├── define.wat
├── display.wat
├── environment.wat
├── exceptions.wat
├── gc.wat
├── hashtable.wat
├── heap.wat
├── include.wat
├── index.ts
├── lambda.wat
├── let.wat
├── library
│ ├── boolean.wat
│ ├── bytevector.wat
│ ├── char.wat
│ ├── complex.wat
│ ├── equiv.wat
│ ├── grisu.wat
│ ├── mp.wat
│ ├── numerics-core.wat
│ ├── numerics.wat
│ ├── pair.wat
│ ├── procedures.wat
│ ├── process.wat
│ ├── real.wat
│ ├── string.wat
│ ├── symbol.wat
│ ├── time.wat
│ ├── trig.wat
│ └── vector.wat
├── macros.wat
├── malloc.wat
├── port.wat
├── print.wat
├── quote.wat
├── reader.wat
├── record.wat
├── runtime.wat
├── scheme
│ ├── guard.scm
│ ├── lazy.scm
│ ├── numerics.scm
│ ├── pair.scm
│ ├── port.scm
│ ├── prelude.scm
│ ├── procedures.scm
│ └── test
│ │ ├── boolean.spec.scm
│ │ ├── bytevector.spec.scm
│ │ ├── case-lambda.spec.scm
│ │ ├── char.spec.scm
│ │ ├── complex.spec.scm
│ │ ├── conditionals.spec.scm
│ │ ├── control.spec.scm
│ │ ├── cxr.spec.scm
│ │ ├── equivalence.spec.scm
│ │ ├── exceptions.spec.scm
│ │ ├── include-ci.spec.scm
│ │ ├── include-ci.test.scm
│ │ ├── lazy.spec.scm
│ │ ├── number.spec.scm
│ │ ├── pair.spec.scm
│ │ ├── port.spec.scm
│ │ ├── process.spec.scm
│ │ ├── sequence.spec.scm
│ │ ├── string.spec.scm
│ │ ├── symbol.spec.scm
│ │ ├── test.scm
│ │ ├── time.spec.scm
│ │ ├── trig.spec.scm
│ │ └── vector.spec.scm
├── scripts
│ ├── buildwat.ts
│ ├── fluent.ts
│ ├── parsedwat.ts
│ ├── tokens.ts
│ ├── unicodedata.ts
│ ├── validatewat.ts
│ └── watmacro.ts
├── start.wat
├── string.wat
├── syntax.wat
└── xxh3.wat
├── tests
├── buildwat.json
├── common.ts
├── environment.spec.ts
├── gc.spec.ts
├── hashtable.spec.ts
├── heap.spec.ts
├── malloc.spec.ts
├── mp.spec.ts
├── print.spec.ts
├── reader.spec.ts
├── runtime.spec.ts
├── scheme.spec.ts
├── string.spec.ts
└── xxh3.spec.ts
└── tsconfig.json
/.github/workflows/codeql-analysis.yml:
--------------------------------------------------------------------------------
1 | # For most projects, this workflow file will not need changing; you simply need
2 | # to commit it to your repository.
3 | #
4 | # You may wish to alter this file to override the set of languages analyzed,
5 | # or to provide custom queries or build logic.
6 | #
7 | # ******** NOTE ********
8 | # We have attempted to detect the languages in your repository. Please check
9 | # the `language` matrix defined below to confirm you have the correct set of
10 | # supported CodeQL languages.
11 | #
12 | name: "CodeQL"
13 |
14 | on:
15 | push:
16 | branches: [ main ]
17 | pull_request:
18 | # The branches below must be a subset of the branches above
19 | branches: [ main ]
20 | schedule:
21 | - cron: '17 13 * * 2'
22 |
23 | jobs:
24 | analyze:
25 | name: Analyze
26 | runs-on: ubuntu-latest
27 | permissions:
28 | actions: read
29 | contents: read
30 | security-events: write
31 |
32 | strategy:
33 | fail-fast: false
34 | matrix:
35 | language: [ 'javascript' ]
36 | # CodeQL supports [ 'cpp', 'csharp', 'go', 'java', 'javascript', 'python', 'ruby' ]
37 | # Learn more about CodeQL language support at https://git.io/codeql-language-support
38 |
39 | steps:
40 | - name: Checkout repository
41 | uses: actions/checkout@v2
42 |
43 | # Initializes the CodeQL tools for scanning.
44 | - name: Initialize CodeQL
45 | uses: github/codeql-action/init@v1
46 | with:
47 | languages: ${{ matrix.language }}
48 | # If you wish to specify custom queries, you can do so here or in a config file.
49 | # By default, queries listed here will override any specified in a config file.
50 | # Prefix the list here with "+" to use these queries and those in the config file.
51 | # queries: ./path/to/local/query, your-org/your-repo/queries@main
52 |
53 | # Autobuild attempts to build any compiled languages (C/C++, C#, or Java).
54 | # If this step fails, then you should remove it and run the build manually (see below)
55 | - name: Autobuild
56 | uses: github/codeql-action/autobuild@v1
57 |
58 | # ℹ️ Command-line programs to run using the OS shell.
59 | # 📚 https://git.io/JvXDl
60 |
61 | # ✏️ If the Autobuild fails above, remove it and uncomment the following three lines
62 | # and modify them (or add more) to build your code if your project
63 | # uses a compiled language
64 |
65 | #- run: |
66 | # make bootstrap
67 | # make release
68 |
69 | - name: Perform CodeQL Analysis
70 | uses: github/codeql-action/analyze@v1
71 |
--------------------------------------------------------------------------------
/.github/workflows/node.js.yml:
--------------------------------------------------------------------------------
1 | # This workflow will do a clean install of node dependencies, cache/restore them, build the source code and run tests across different versions of node
2 | # For more information see: https://help.github.com/actions/language-and-framework-guides/using-nodejs-with-github-actions
3 |
4 | name: Node.js CI
5 |
6 | on:
7 | push:
8 | branches: [ main ]
9 | pull_request:
10 | branches: [ main ]
11 |
12 | jobs:
13 | build:
14 |
15 | runs-on: ubuntu-latest
16 |
17 | strategy:
18 | matrix:
19 | # Only works on Node 16.x
20 | node-version: [ 16.x ]
21 | # See supported Node.js release schedule at https://nodejs.org/en/about/releases/
22 |
23 | steps:
24 | - uses: actions/checkout@v2
25 | - name: Fetch tags
26 | run: git fetch --unshallow --tags
27 | - name: Use Node.js ${{ matrix.node-version }}
28 | uses: actions/setup-node@v2
29 | with:
30 | node-version: ${{ matrix.node-version }}
31 | cache: 'npm'
32 | - run: npm ci
33 | - run: npm run build-prod --if-present
34 | - run: npm run build-dev --if-present
35 | - run: npm test
36 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.swp
3 | *.zip
4 |
5 | node_modules/
6 | bundle/
7 | dist/
8 | .VsCodeCounter/
9 | codeql/
10 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | MIT License
2 |
3 | Copyright (c) 2021 Paul C. Roberts
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | [](https://github.com/PollRobots/scheme/actions/workflows/node.js.yml)
6 | [](https://github.com/PollRobots/scheme/actions/workflows/codeql-analysis.yml)
7 | [](https://app.fossa.com/projects/custom%2B29853%2Fgithub.com%2FPollRobots%2Fscheme?ref=badge_shield)
8 |
9 | [](https://github.com/pollrobots/scheme/stargazers)
10 |
11 | # scheme.wasm
12 |
13 | An R7RS Scheme implemented in WebAssembly
14 |
15 | A partial implementation of [r7rs scheme](https://small.r7rs.org/), written
16 | entirely in WebAssembly using the WebAssembly Text format. The only external
17 | imports are for IO (`read`, `write`, and `readFile`), unicode (I have an
18 | import that reads information about 256 code-point blocks to enable case
19 | operations etc.), and process control (`exit`).
20 |
21 | You can try it out at [pollrobots.com/scheme/](https://pollrobots.com/scheme/)
22 |
23 | ## How Complete Is It?
24 |
25 | The aim is to write a spec complete version of `r7rs`, although I may skip
26 | some of the optional features.
27 |
28 | ### What is done so far
29 |
30 | - [x] Numerics
31 | - [x] Integers (arbitrary precision)
32 | - [x] Real numbers (double precision)
33 | - [x] Rationals
34 | - [x] Complex Numbers
35 | - [x] Booleans
36 | - [x] Strings
37 | - [x] Characters
38 | - [x] Pairs and Lists
39 | - [x] Vectors
40 | - [x] Bytevectors
41 | - [x] Values
42 | - [x] Records
43 | - [x] Tail call optimization — internally `eval` uses a continuation passing
44 | style, so TCO comes for free.
45 | - [x] `call/cc` and exceptions
46 | - [x] Macros
47 | - [x] `define-syntax`, `syntax-rules`, `syntax-error`
48 | - [x] Hygienic over `let`, `let*`, `letrec`, `letrec*`, and `lambda`
49 | - [ ] `let-syntax`, `letrec-syntax`
50 | - [ ] Modules
51 | - [ ] Ports
52 | - [ ] `dynamic-wind`
53 | - [ ] Everything else
54 |
55 | ## Credits
56 |
57 | Where practical everything has been implemented from scratch, but there
58 | are places where it either wasn't practical, or where I tried and failed
59 | to implement them myself, so credit is due to:
60 |
61 | - **xxHash**:
62 | It's probably overkill, but the hashing algorithm used for hashtables,
63 | which are in turn used for environments and interning symbols, is xxHash
64 | translated from the C++ implementation at
65 | [github.com/Cyan4973/xxHash](https://github.com/Cyan4973/xxHash)
66 | - **string->real**:
67 | Strings are converted to real numbers using _Algorithm M_ from
68 | "How to Read Floating Point Numbers Accurately",
69 | [William D Clinger](https://www.khoury.northeastern.edu/people/william-d-clinger/) 1990. Which is conveniently expressed in scheme in the original
70 | [paper](https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.45.4152&rep=rep1&type=pdf)
71 | - **real->string**:
72 | Real numbers are converted to strings using _Grisu 2_ by
73 | [Florian Loitsch](https://florian.loitsch.com/home).
74 | This was translated from C++ found at [github.com/romange/Grisu](https://github.com/romange/Grisu)
75 |
76 | Additionally inspiration came from a couple of places
77 |
78 | - **Lispy**: [Peter Norvig's](https://norvig.com) article
79 | [(How to Write a (Lisp) Interpreter (in Python))](https://norvig.com/lispy.html)
80 | was a critical source of inspiration.
81 | - **EPLAiP**: Nearly a decade ago a friend gave
82 | me a copy of
83 | [Exploring Programming Language Architecture in Perl](https://billhails.net/EPLAiP.pdf)
84 | by [Bill Hails](https://billhails.net). Definitely worth reading regardless of
85 | your language of choice (I haven't written PERL this millenium).
86 |
--------------------------------------------------------------------------------
/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "scheme",
3 | "version": "0.0.1",
4 | "workspaces": [
5 | "scheme.wasm",
6 | "scheme.wasm.ui"
7 | ],
8 | "scripts": {
9 | "build-prod": "npm run build -w scheme.wasm && npm run build-prod -w scheme.wasm.ui",
10 | "build-dev": "npm run build -w scheme.wasm && npm run build-dev -w scheme.wasm.ui",
11 | "start": "npm run build -w scheme.wasm && npm run start -w scheme.wasm.ui",
12 | "test": "npm run test -w scheme.wasm",
13 | "clean": "npm run clean -w scheme.wasm && npm run clean -w scheme.wasm.ui"
14 | },
15 | "author": "Paul C Roberts ",
16 | "homepage": "https://github.com/PollRobots/scheme#readme",
17 | "license": "MIT",
18 | "devDependencies": {
19 | "rimraf": "^3.0.2"
20 | }
21 | }
22 |
--------------------------------------------------------------------------------
/scheme.code-workspace:
--------------------------------------------------------------------------------
1 | {
2 | "folders": [
3 | {
4 | "path": ".",
5 | }
6 | ],
7 | "settings": {
8 | "editor.formatOnSave": true,
9 | "editor.tabSize": 2
10 | }
11 | }
12 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/about.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 | About scheme.wasm
6 |
41 |
42 |
43 |
44 | About scheme.wasm
45 |
46 | scheme.wasm is a partial implementation of
47 | r7rs scheme ,
48 | written entirely in WebAssembly using the WebAssembly Text
49 | format. The only external imports are for IO (read
,
50 | write
, and readFile
), unicode (I have an import that reads
51 | information about 256 code-point blocks, to enable case operations etc.),
52 | and process control (exit
)
53 |
54 | Where can I find the code
55 | The code is hosted at github.com/pollrobots/scheme .
56 | How Complete Is It?
57 | The aim is to write a spec complete version of r7rs
, although
58 | I may skip some of the optional features
59 | What is done so far
60 |
61 | Numerics
62 |
63 | Integer (arbitrary precision)
64 | Real numbers (double precision)
65 | Rationals
66 | Complex
67 |
68 |
69 | Booleans
70 | Strings
71 | Characters
72 | Pairs and Lists
73 | Vectors
74 | Bytevectors
75 | Values
76 | Records
77 |
78 | Tail call optimization — internally eval
uses a
79 | continuation passing style, so TCO comes for free.
80 |
81 | call/cc
and exceptions
82 | Macros
83 |
84 | define-syntax
, syntax-rules
, and
85 | syntax-error
86 | Hygienic over let
, let*
,
87 | letrec
, letrec*
, and lambda
88 |
89 |
90 |
91 | What is missing at the moment
92 |
93 | Macros
94 |
95 | let-syntax
and letrec-syntax
96 |
97 |
98 | Modules
99 | dynamic-wind
100 | Everything else
101 |
102 | Credits
103 |
104 | Where practical everything has been implemented from scratch, but there
105 | are places where it either wasn't practical, or where I tried and failed
106 | to implement them myself, so credit is due to:
107 |
108 |
109 | xxHash
110 | It's probably overkill, but the hashing algorithm used for hashtables,
111 | which are in turn used for environments and interning symbols, is xxHash
112 | translated from the C++ implementation at
113 | github.com/Cyan4973/xxHash
114 |
115 | string->real
116 | Strings are converted to real numbers using Algorithm M from
117 | "How to Read Floating Point Numbers Accurately",
118 | William D Clinger ,
119 | 1990. Which is conveniently expressed in scheme in the original
120 | paper .
121 |
122 | real->string
123 | Real numbers are converted to strings using Grisu 2 by
124 | Florian Loitsch .
125 | This was translated from C++ found at
126 | github.com/romange/Grisu
127 |
128 |
129 |
130 |
131 | Additionally inspiration came from a couple of places
132 |
133 |
134 | Lispy
135 | Peter Norvig's article
136 |
137 | (How to Write a (Lisp) Interpreter (in Python))
138 | was a critical source of inspiration.
139 |
140 | EPLAiP
141 | Nearly a decade ago a friend gave me a
142 | copy of
143 | Exploring Programming Language Architecture in Perl by
144 | Bill Hails .
145 | Definitely worth reading regardless of your language of choice (I haven't written PERL this millenium).
146 |
147 |
148 |
149 |
150 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/favicon/scheme.wasm.logo.16.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/favicon/scheme.wasm.logo.16.png
--------------------------------------------------------------------------------
/scheme.wasm.ui/favicon/scheme.wasm.logo.32.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/favicon/scheme.wasm.logo.32.png
--------------------------------------------------------------------------------
/scheme.wasm.ui/favicon/scheme.wasm.logo.96.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/favicon/scheme.wasm.logo.96.png
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-500.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-500.woff
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-500.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-500.woff2
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-700.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-700.woff
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-700.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-700.woff2
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-regular.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-regular.woff
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/roboto-v29-latin-regular.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/roboto-v29-latin-regular.woff2
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/source-code-pro-v18-latin-regular.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/source-code-pro-v18-latin-regular.woff
--------------------------------------------------------------------------------
/scheme.wasm.ui/fonts/source-code-pro-v18-latin-regular.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/PollRobots/scheme/1ad3ba04ef2674b0fa1f7ce60f443c10c5b23929/scheme.wasm.ui/fonts/source-code-pro-v18-latin-regular.woff2
--------------------------------------------------------------------------------
/scheme.wasm.ui/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 | scheme.wasm
8 |
9 |
10 |
11 |
37 |
80 |
81 |
82 |
83 |
84 |
85 |
102 |
103 |
104 |
105 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "scheme.wasm.ui",
3 | "version": "1.0.0",
4 | "description": "",
5 | "main": "index.js",
6 | "scripts": {
7 | "start": "webpack server --mode development --no-hot",
8 | "start-prod": "webpack server --mode production --no-hot",
9 | "build-prod": "webpack --mode production",
10 | "build-dev": "webpack --mode development",
11 | "clean": "rimraf -rf ./dist",
12 | "test": "echo \"Error: no test specified\" && exit 1"
13 | },
14 | "keywords": [],
15 | "author": "Paul C Roberts ",
16 | "license": "MIT",
17 | "devDependencies": {
18 | "@types/prismjs": "^1.16.6",
19 | "@types/react": "^17.0.37",
20 | "@types/react-dom": "^17.0.11",
21 | "@types/sanitize-html": "^2.6.0",
22 | "@types/ua-parser-js": "^0.7.36",
23 | "@types/wicg-file-system-access": "^2020.9.4",
24 | "clean-webpack-plugin": "^4.0.0",
25 | "copy-webpack-plugin": "^10.1.0",
26 | "css-loader": "^6.5.1",
27 | "fflate": "^0.7.3",
28 | "file-loader": "^6.2.0",
29 | "generate-file-webpack-plugin": "^1.0.1",
30 | "html-webpack-plugin": "^5.5.0",
31 | "monaco-editor": "^0.31.1",
32 | "prismjs": "^1.25.0",
33 | "react-contenteditable": "^3.3.6",
34 | "sanitize-html": "^2.6.1",
35 | "scheme.wasm": "file:../scheme.wasm",
36 | "source-map-loader": "^3.0.0",
37 | "style-loader": "^3.3.1",
38 | "terser-webpack-plugin": "^5.3.0",
39 | "ts-loader": "^9.2.6",
40 | "typescript": "^4.5.3",
41 | "ua-parser-js": "^1.0.2",
42 | "webpack": "^5.65.0",
43 | "webpack-bundle-analyzer": "^4.5.0",
44 | "webpack-cli": "^4.9.1",
45 | "webpack-dev-server": "^4.6.0",
46 | "webpack-subresource-integrity": "^5.1.0"
47 | },
48 | "dependencies": {
49 | "react": "^17.0.2",
50 | "react-dom": "^17.0.2"
51 | }
52 | }
53 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/Jiffies.ts:
--------------------------------------------------------------------------------
1 | export class Jiffies {
2 | private readonly epoch: number;
3 | private microsPerJiffy: number;
4 |
5 | private constructor(epoch: number, microsPerJiffy: number) {
6 | this.epoch = epoch;
7 | this.microsPerJiffy = microsPerJiffy;
8 | console.log(`One jiffy is ${microsPerJiffy}μs`);
9 | }
10 |
11 | get jiffiesPerSecond(): number {
12 | return 1000000 / this.microsPerJiffy;
13 | }
14 |
15 | get current(): number {
16 | return Math.round(
17 | (1000 * (performance.now() - this.epoch)) / this.microsPerJiffy
18 | );
19 | }
20 |
21 | static init(): Jiffies {
22 | const intervals = new Set();
23 |
24 | let last = performance.now();
25 | for (let i = 0; i < 100 && intervals.size < 2; i++) {
26 | const curr = performance.now();
27 | intervals.add(Math.round(1000 * (curr - last)));
28 | last = curr;
29 | }
30 |
31 | let smallest = Infinity;
32 | for (const interval of intervals) {
33 | if (interval > 0 && interval < smallest) {
34 | smallest = interval;
35 | }
36 | }
37 |
38 | return new Jiffies(performance.now(), smallest);
39 | }
40 | }
41 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/SchemeType.tsx:
--------------------------------------------------------------------------------
1 | export enum SchemeType {
2 | Empty = 0,
3 | Nil = 1,
4 | Boolean = 2,
5 | Cons = 3,
6 | I64 = 4,
7 | F64 = 5,
8 | Symbol = 6,
9 | Str = 7,
10 | Char = 8,
11 | Env = 9,
12 | Special = 10,
13 | Builtin = 11,
14 | Lambda = 12,
15 | Error = 13,
16 | Values = 14,
17 | Vector = 15,
18 | Bytevector = 16,
19 | Cont = 17,
20 | BigInt = 18,
21 | Except = 19,
22 | ContProc = 20,
23 | SyntaxRules = 21,
24 | Rational = 22,
25 | Complex = 23,
26 | Record = 24,
27 | RecordMeta = 25,
28 | RecordMethod = 26,
29 | CaseLambda = 27,
30 | Port = 28,
31 | Eof = 29,
32 | MaxHeap = 30,
33 | Mask = 0x1f,
34 | }
35 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/About.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "./ThemeProvider";
3 | import "../styles/animations.module.css";
4 | import { reference } from "../util";
5 | import animations from "../styles/animations.module.css";
6 |
7 | reference(animations);
8 |
9 | interface AboutState {
10 | loaded: boolean;
11 | }
12 |
13 | export const About: React.FunctionComponent = (props) => {
14 | const theme = React.useContext(ThemeContext);
15 | const [state, setState] = React.useState({ loaded: false });
16 |
17 | return (
18 |
33 |
39 | );
40 | };
41 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/Burger.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "./ThemeProvider";
3 | import { reference } from "../util";
4 | import animations from "../styles/animations.module.css";
5 |
6 | reference(animations);
7 |
8 | interface BurgerProps {
9 | open: boolean;
10 | visibleBack?: boolean;
11 | onClick?: () => void;
12 | }
13 |
14 | const kBurgerStyle: React.CSSProperties = {
15 | position: "absolute",
16 | top: "1rem",
17 | left: "1rem",
18 | display: "flex",
19 | flexDirection: "column",
20 | justifyContent: "space-around",
21 | width: "1.5rem",
22 | height: "1.5rem",
23 | background: "transparent",
24 | border: "none",
25 | outline: "none",
26 | cursor: "pointer",
27 | padding: 0,
28 | zIndex: 10,
29 | transformOrigin: "50% 50%",
30 | transition: "background 0.4s",
31 | };
32 |
33 | const kBurgerLineStyle: React.CSSProperties = {
34 | width: "1.5rem",
35 | height: "0.25rem",
36 | borderRadius: "0.125rem",
37 | position: "relative",
38 | transition: "background 0.4s",
39 | };
40 |
41 | export const Burger: React.FunctionComponent = (props) => {
42 | const theme = React.useContext(ThemeContext);
43 | const ref = React.useRef(null);
44 |
45 | const burgerStyle = props.visibleBack
46 | ? {
47 | ...kBurgerStyle,
48 | background: props.open ? "transparent" : `${theme.foreground}80`,
49 | padding: "0.25em",
50 | borderRadius: "0.25em",
51 | }
52 | : kBurgerStyle;
53 |
54 | const lineStyle = {
55 | ...kBurgerLineStyle,
56 | background: props.open ? theme.foreground : theme.boldBackground,
57 | };
58 | return (
59 | {
62 | if (ref.current) {
63 | ref.current.style.animation = "";
64 | }
65 | }}
66 | style={burgerStyle}
67 | onClick={() => {
68 | if (props.onClick) {
69 | props.onClick();
70 | if (ref.current) {
71 | ref.current.style.animation = "0.4s shake 0s";
72 | }
73 | }
74 | }}
75 | >
76 |
77 |
78 |
79 |
80 | );
81 | };
82 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/Editor.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import monaco from "monaco-editor";
3 | import { registerLanguage } from "../monaco/scheme";
4 | import * as solarized from "../monaco/solarized";
5 | import * as solarizedContrast from "../monaco/solarized-contrast";
6 |
7 | interface EditorProperties {
8 | height?: string | number;
9 | width?: string | number;
10 | maxHeight?: string | number;
11 | maxWidth?: string | number;
12 | theme?: string;
13 | defaultLanguage?: string;
14 | defaultValue?: string;
15 | onMount?: (editor: monaco.editor.IStandaloneCodeEditor) => void;
16 | }
17 |
18 | const Editor: React.FunctionComponent = (props) => {
19 | const ref = React.useRef(null);
20 | const editorRef = React.useRef();
21 |
22 | const resizeEditor = () => {
23 | if (editorRef.current && ref.current) {
24 | editorRef.current.layout({
25 | width: ref.current.offsetWidth,
26 | height: ref.current.offsetHeight,
27 | });
28 | }
29 | };
30 |
31 | React.useEffect(() => {
32 | let editor: monaco.editor.IStandaloneCodeEditor;
33 | if (ref.current) {
34 | registerLanguage();
35 | solarized.defineThemes();
36 | solarizedContrast.defineThemes();
37 | // @ts-ignore
38 | editor = window.monaco.editor.create(ref.current, {
39 | language: props.defaultLanguage,
40 | theme: props.theme,
41 | value: props.defaultValue,
42 | });
43 | editorRef.current = editor;
44 | window.addEventListener("resize", resizeEditor);
45 | if (props.onMount) {
46 | props.onMount(editor);
47 | }
48 | }
49 | return () => {
50 | window.removeEventListener("resize", resizeEditor);
51 | editorRef.current = undefined;
52 | editor.dispose();
53 | };
54 | }, []);
55 |
56 | return (
57 |
66 | );
67 | };
68 |
69 | export default Editor;
70 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/EmergencyStop.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 |
3 | interface EmergencyStopProps {
4 | msgs: string[];
5 | disabled?: boolean;
6 | title?: string;
7 | style?: React.CSSProperties;
8 | lastStyle?: React.CSSProperties;
9 | onAction: () => void;
10 | }
11 |
12 | export const EmergencyStop: React.FunctionComponent = (
13 | props
14 | ) => {
15 | const [count, setCount] = React.useState(0);
16 |
17 | const click = () => {
18 | const newCount = count + 1;
19 | if (newCount >= props.msgs.length) {
20 | setCount(0);
21 | props.onAction();
22 | } else {
23 | setCount(newCount);
24 | }
25 | };
26 |
27 | const style =
28 | count == props.msgs.length - 1
29 | ? { ...props.style, ...props.lastStyle }
30 | : props.style;
31 |
32 | return (
33 | setCount(0)}
38 | onClick={() => click()}
39 | >
40 | {props.msgs[count]}
41 |
42 | );
43 | };
44 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/Flyout.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { FocusContextProvider } from "./FocusContext";
3 | import { ThemeContext } from "./ThemeProvider";
4 |
5 | interface FlyoutProps {
6 | label?: string;
7 | fontSize?: number;
8 | offset?: number;
9 | }
10 |
11 | interface FlyoutState {
12 | expanded: boolean;
13 | }
14 |
15 | const kDefaultState: FlyoutState = {
16 | expanded: false,
17 | };
18 |
19 | const kFlyoutStyle: React.CSSProperties = {
20 | position: "absolute",
21 | top: "1rem",
22 | right: 0,
23 | };
24 |
25 | export const Flyout: React.FunctionComponent = (props) => {
26 | const [state, setState] = React.useState(kDefaultState);
27 | const theme = React.useContext(ThemeContext);
28 | const label = props.label || "flyout";
29 | const height = 15 * label.length;
30 | const labelHeight = `${label.length}em`;
31 |
32 | return (
33 |
40 |
50 |
setState({ ...state, expanded: !state.expanded })}
67 | >
68 |
75 |
76 |
83 | {props.label || "flyout"}
84 |
85 |
86 |
87 |
88 |
101 |
102 | {props.children}
103 |
104 |
105 |
106 |
107 | );
108 | };
109 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/FocusContext.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 |
3 | export const FocusContext = React.createContext(true);
4 | export const FocusContextProvider = FocusContext.Provider;
5 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/IconButton.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { EditorThemeContext, ThemeContext } from "./ThemeProvider";
3 |
4 | interface IconButtonProps {
5 | size: number;
6 | title?: string;
7 | disabled?: boolean;
8 | onClick?: () => void;
9 | }
10 |
11 | interface IconButtonState {
12 | down: boolean;
13 | in: boolean;
14 | }
15 |
16 | export const IconButton: React.FunctionComponent = (props) => {
17 | const theme = React.useContext(ThemeContext);
18 | const editorTheme = React.useContext(EditorThemeContext) || theme;
19 | const [state, setState] = React.useState({
20 | down: false,
21 | in: false,
22 | });
23 |
24 | const isDown = !props.disabled && state.down;
25 | return (
26 | {
46 | if (!props.disabled && props.onClick) {
47 | props.onClick();
48 | }
49 | }}
50 | onMouseDown={() => setState({ ...state, down: true })}
51 | onMouseUp={() => setState({ ...state, down: false })}
52 | onMouseEnter={() => setState({ ...state, in: true })}
53 | onMouseLeave={() => setState({ ...state, in: false, down: false })}
54 | >
55 | {props.children}
56 |
57 | );
58 | };
59 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/RuntimeStatus.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { EmergencyStop } from "./EmergencyStop";
3 | import { SchemeRuntimeContext } from "./SchemeRuntimeProvider";
4 | import { ThemeContext } from "./ThemeProvider";
5 |
6 | export const RuntimeStatus: React.FunctionComponent<{ disabled?: boolean }> = (
7 | props
8 | ) => {
9 | const theme = React.useContext(ThemeContext);
10 | const runtime = React.useContext(SchemeRuntimeContext);
11 |
12 | const status = () => {
13 | if (!runtime || !runtime.loaded) {
14 | return "not started";
15 | } else if (runtime.stopped) {
16 | return "stopped";
17 | } else if (runtime.waiting) {
18 | return "busy";
19 | } else if (runtime.partial) {
20 | return "incomplete input";
21 | } else {
22 | return "idle";
23 | }
24 | };
25 |
26 | const debugging = () => (runtime && runtime.debugging ? "(debugging)" : null);
27 |
28 | const memsize = (size: number) => {
29 | if (size < 1024) {
30 | return `${size} bytes`;
31 | } else if (size < 0x10_0000) {
32 | const sizeInKib = size / 1024;
33 | if (sizeInKib === (sizeInKib | 0)) {
34 | return `${sizeInKib} KiB`;
35 | }
36 | return `${sizeInKib.toFixed(1)} KiB`;
37 | } else {
38 | const sizeInMib = size / 0x10_0000;
39 | if (sizeInMib === (sizeInMib | 0)) {
40 | return `${sizeInMib} MiB`;
41 | }
42 | return `${sizeInMib.toFixed(1)} MiB`;
43 | }
44 | };
45 |
46 | const memory = () => {
47 | if (!runtime || !runtime.loaded) {
48 | return "n/a";
49 | } else {
50 | return `${runtime.memorySize / 0x10000} pages, ${memsize(
51 | runtime.memorySize
52 | )}`;
53 | }
54 | };
55 |
56 | return (
57 |
58 |
65 | Status: {status()}
66 | {debugging()}
67 | {
89 | if (runtime) {
90 | runtime.terminate();
91 | }
92 | }}
93 | />
94 |
95 |
Memory: {memory()}
96 |
97 | );
98 | };
99 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/SchemeRuntimeProvider.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { RuntimeWorker } from "../RuntimeWorker";
3 |
4 | export const SchemeRuntimeContext = React.createContext<
5 | RuntimeWorker | undefined
6 | >(undefined);
7 |
8 | export const SchemeRuntimeProvider = SchemeRuntimeContext.Provider;
9 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/Settings.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { Logo } from "../icons/logo";
3 | import { Theme } from "../monaco/theme";
4 | import { FocusContext } from "./FocusContext";
5 | import { RuntimeStatus } from "./RuntimeStatus";
6 | import { ThemeContext } from "./ThemeProvider";
7 | import { ToggleSwitch } from "./ToggleSwitch";
8 |
9 | export type ThemeDescriptor =
10 | | "Dark"
11 | | "Light"
12 | | "ContrastDark"
13 | | "ContrastLight";
14 | export type ExtendedThemeDescriptor = ThemeDescriptor | "Same";
15 |
16 | export interface SettingsBase {
17 | theme: ThemeDescriptor;
18 | editorTheme: ExtendedThemeDescriptor;
19 | highlighting: boolean;
20 | inspector: boolean;
21 | fontSize: number;
22 | persist: boolean;
23 | }
24 |
25 | interface SettingsProps extends SettingsBase {
26 | onChange?: (update: SettingsBase) => void;
27 | onAbout?: () => void;
28 | }
29 |
30 | const kSettingsSubHeading: React.CSSProperties = {
31 | fontWeight: 500,
32 | fontSize: "1.25em",
33 | lineHeight: "2em",
34 | marginTop: "1rem",
35 | };
36 |
37 | const kFontSizes: number[] = [
38 | 6, 7, 8, 9, 10, 11, 12, 14, 18, 24, 30, 36, 48, 60, 72, 96,
39 | ];
40 |
41 | function selectStyle(theme: Theme): React.CSSProperties {
42 | return {
43 | fontSize: "inherit",
44 | fontFamily: "inherit",
45 | width: "10em",
46 | height: "1.5em",
47 | borderRadius: "0.25em",
48 | appearance: "none",
49 | padding: "0 0.25em",
50 | background: theme.background,
51 | color: theme.foreground,
52 | };
53 | }
54 |
55 | export const Settings: React.FunctionComponent = (props) => {
56 | const theme = React.useContext(ThemeContext);
57 | const focus = React.useContext(FocusContext);
58 | return (
59 |
60 |
61 |
Appearance
62 |
63 | REPL Theme:{" "}
64 | {
69 | if (props.onChange) {
70 | props.onChange({
71 | ...props,
72 | theme: e.target.value as ThemeDescriptor,
73 | });
74 | }
75 | }}
76 | >
77 | Dark
78 | Light
79 | High Contrast Dark
80 | High Contrast Light
81 |
82 |
83 |
84 | Editor Theme:{" "}
85 | {
90 | if (props.onChange) {
91 | props.onChange({
92 | ...props,
93 | editorTheme: e.target.value as ExtendedThemeDescriptor,
94 | });
95 | }
96 | }}
97 | >
98 | Same as REPL
99 | Dark
100 | Light
101 | High Contrast Dark
102 | High Contrast Light
103 |
104 |
105 |
106 | Font Size:{" "}
107 | {
112 | if (props.onChange) {
113 | props.onChange({ ...props, fontSize: Number(e.target.value) });
114 | }
115 | }}
116 | >
117 | {kFontSizes.map((el) => (
118 |
119 | {el}pt
120 |
121 | ))}
122 |
123 |
124 |
125 | Syntax Highlighting
126 | {
130 | if (props.onChange) {
131 | props.onChange({ ...props, highlighting: on });
132 | }
133 | }}
134 | />
135 |
136 |
Debug
137 |
138 | Show inspector
139 | {
143 | if (props.onChange) {
144 | props.onChange({ ...props, inspector: on });
145 | }
146 | }}
147 | />
148 |
149 |
150 | Persist Settings
151 | {
155 | if (props.onChange) {
156 | props.onChange({ ...props, persist: on });
157 | }
158 | }}
159 | />
160 |
161 |
Runtime
162 |
163 |
{
170 | if (props.onAbout) {
171 | props.onAbout();
172 | }
173 | }}
174 | >
175 | About
176 |
177 |
178 | );
179 | };
180 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/SettingsMenu.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { FocusContextProvider } from "./FocusContext";
3 | import { ThemeContext } from "./ThemeProvider";
4 |
5 | interface SettingsMenuProps {
6 | open: boolean;
7 | }
8 |
9 | export const SettingsMenu: React.FunctionComponent = (
10 | props
11 | ) => {
12 | const theme = React.useContext(ThemeContext);
13 |
14 | return (
15 |
35 |
36 | {props.children}
37 |
38 |
39 | );
40 | };
41 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/TerminalData.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import Prism from "prismjs";
3 |
4 | export interface DataLine {
5 | type: "raw" | "datum" | "prompted";
6 | text: string;
7 | prompt?: string;
8 | first?: boolean;
9 | }
10 |
11 | interface TerminalDataProps {
12 | text: DataLine[];
13 | highlighting: boolean;
14 | }
15 |
16 | interface TerminalDataLineProps extends DataLine {
17 | highlighting: boolean;
18 | }
19 |
20 | export const TerminalData: React.FunctionComponent = (
21 | props
22 | ) => (
23 |
24 | {props.text.map((el, i) => {
25 | return (
26 |
31 | );
32 | })}
33 |
34 | );
35 |
36 | const TerminalDataLine: React.FunctionComponent = (
37 | props
38 | ) => {
39 | if (!props.text.length && props.type !== "prompted") {
40 | return (
41 |
42 |
49 | {" "}
50 |
51 |
52 | );
53 | }
54 |
55 | if (props.type === "prompted") {
56 | const prompt = props.prompt || "";
57 | return (
58 |
59 |
66 | {props.first ? prompt : "".padEnd(prompt?.length, " ")}
67 |
68 | {props.highlighting ? (
69 |
79 | ) : (
80 |
81 | {props.text}
82 |
83 | )}
84 |
85 | );
86 | }
87 |
88 | return (
89 |
90 |
91 | {AnsiEscaper(props.text)}
92 |
93 |
94 | );
95 | };
96 |
97 | const kColor: Record = {
98 | 30: "#073642", // 'black',
99 | 31: "#dc322f", // 'red',
100 | 32: "#859900", // 'green',
101 | 33: "#b58900", // 'yellow',
102 | 34: "#268bd2", // 'blue',
103 | 35: "#d33682", // 'magenta',
104 | 36: "#2aa198", // 'cyan',
105 | 37: "#eee8d5", // 'white'
106 | 40: "#073642", // 'black',
107 | 41: "#dc322f", // 'red',
108 | 42: "#859900", // 'green',
109 | 43: "#b58900", // 'yellow',
110 | 44: "#268bd2", // 'blue',
111 | 45: "#d33682", // 'magenta',
112 | 46: "#2aa198", // 'cyan',
113 | 47: "#eee8d5", // 'white'
114 | 90: "#002b36", // 'brblack',
115 | 91: "#cb4b16", // 'brred',
116 | 92: "#586e75", // 'brgreen',
117 | 93: "#657b83", // 'bryellow',
118 | 94: "#839496", // 'brblue',
119 | 95: "#6c71c4", // 'brmagenta',
120 | 96: "#93a1a1", // 'brcyan',
121 | 97: "#fdf6e3", // 'brwhite'
122 | 100: "#002b36", // 'brblack',
123 | 101: "#cb4b16", // 'brred',
124 | 102: "#586e75", // 'brgreen',
125 | 103: "#657b83", // 'bryellow',
126 | 104: "#839496", // 'brblue',
127 | 105: "#6c71c4", // 'brmagenta',
128 | 106: "#93a1a1", // 'brcyan',
129 | 107: "#fdf6e3", // 'brwhite'
130 | };
131 |
132 | function AnsiEscaper(str: string): React.ReactNode {
133 | const nodes: React.ReactNode[] = [];
134 | const chars = Array.from(str);
135 | let start = 0;
136 | let escapeCount = 0;
137 | let foreground: string | undefined;
138 | let background: string | undefined;
139 |
140 | for (let index = 0; index < chars.length; index++) {
141 | const cp = chars[index].codePointAt(0);
142 | if (cp !== 0x1b) {
143 | continue;
144 | }
145 | escapeCount++;
146 |
147 | // this is an escape sequence
148 | // add string so far (if any)
149 | if (index > start) {
150 | const partial = chars.slice(start, index).join("");
151 | nodes.push(
152 |
153 | {partial}
154 |
155 | );
156 | }
157 | index++;
158 | if (index == chars.length) {
159 | // orphan escape at the end of the string, simply break
160 | break;
161 | }
162 |
163 | const e1 = chars[index].codePointAt(0) || 0;
164 | if (e1 == 0x5b) {
165 | // this is a CSI
166 | // accumulate all chars up to terminating
167 | index++;
168 | const cmdBuf: string[] = [];
169 | let final = "";
170 | while (index < chars.length) {
171 | const e2 = chars[index].codePointAt(0) || 0;
172 | if (e2 >= 0x40 && e2 <= 0x7e) {
173 | final = chars[index];
174 | break;
175 | }
176 | cmdBuf.push(chars[index]);
177 | index++;
178 | }
179 | const cmd = cmdBuf.join("");
180 | if (final == "m") {
181 | const parts = cmd.split(";").map((el) => {
182 | const num = Number(el);
183 | return isNaN(num) ? 0 : num;
184 | });
185 | for (let pidx = 0; pidx < parts.length; pidx++) {
186 | const part = parts[pidx];
187 | if (part == 0) {
188 | foreground = undefined;
189 | background = undefined;
190 | } else if ((part >= 30 && part <= 37) || (part >= 90 && part <= 97)) {
191 | foreground = kColor[part];
192 | } else if (
193 | (part >= 40 && part <= 47) ||
194 | (part >= 100 && part <= 107)
195 | ) {
196 | background = kColor[part];
197 | } else {
198 | break;
199 | }
200 | }
201 | }
202 | } else if (e1 >= 0x40 && e1 <= 0x5f) {
203 | // This is an Fe sequence, which we don't support, simply skip
204 | }
205 | start = index + 1;
206 | }
207 |
208 | if (start > 0 && start < chars.length) {
209 | const partial = chars.slice(start).join("");
210 | nodes.push(
211 |
215 | {partial}
216 |
217 | );
218 | }
219 |
220 | if (escapeCount == 0) {
221 | return str;
222 | } else {
223 | return nodes;
224 | }
225 | }
226 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/ThemeProvider.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { kSolarizedDark } from "../monaco/solarized";
3 | import { Theme } from "../monaco/theme";
4 |
5 | const kDefaultTheme: Theme = kSolarizedDark;
6 |
7 | type EditorTheme = Theme | false;
8 |
9 | export const ThemeContext = React.createContext(kDefaultTheme);
10 |
11 | export const ThemeProvider = ThemeContext.Provider;
12 |
13 | export const EditorThemeContext = React.createContext(false);
14 |
15 | export const EditorThemeProvider = EditorThemeContext.Provider;
16 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/components/ToggleSwitch.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "./ThemeProvider";
3 |
4 | interface ToggleSwitchProps {
5 | on: boolean;
6 | disabled?: boolean;
7 | labelOn?: string;
8 | labelOff?: string;
9 | onChange?: (on: boolean) => void;
10 | }
11 |
12 | function generateId(): string {
13 | const array = new Uint8Array(12);
14 | window.crypto.getRandomValues(array);
15 | return btoa(
16 | Array.from(array)
17 | .map((el) => String.fromCodePoint(el))
18 | .join("")
19 | );
20 | }
21 |
22 | const kToggleSwitchStyle: React.CSSProperties = {
23 | position: "relative",
24 | display: "inline-block",
25 | verticalAlign: "text-bottom",
26 | userSelect: "none",
27 | };
28 |
29 | const kToggleSwitchDisabledStyle: React.CSSProperties = {
30 | ...kToggleSwitchStyle,
31 | opacity: 0.75,
32 | };
33 |
34 | const kToggleLabelStyle: React.CSSProperties = {
35 | display: "block",
36 | overflow: "hidden",
37 | cursor: "pointer",
38 | borderWidth: 1,
39 | borderStyle: "solid",
40 | borderRadius: "0.5em",
41 | width: "3em",
42 | height: "1em",
43 | margin: 0,
44 | transition: "background-color 0.1s 0.1s",
45 | };
46 |
47 | const kToggleInnerStyle: React.CSSProperties = {
48 | display: "block",
49 | transition: "all 0.3s",
50 | height: "1em",
51 | borderRadius: "0.5em",
52 | width: "1.5em",
53 | boxSizing: "border-box",
54 | position: "relative",
55 | };
56 |
57 | export const ToggleSwitch: React.FunctionComponent = (
58 | props
59 | ) => {
60 | const theme = React.useContext(ThemeContext);
61 | const id = React.useRef(generateId());
62 |
63 | const onChange = () => {
64 | if (props.onChange && !props.disabled) {
65 | props.onChange(!props.on);
66 | }
67 | };
68 | return (
69 |
72 | onChange()}
79 | />
80 | {
91 | if (e.code === "Space" || e.code === "Enter") {
92 | onChange();
93 | }
94 | }}
95 | >
96 |
108 | {props.on ? props.labelOn || "on" : props.labelOff || "off"}
109 |
110 |
117 |
118 |
119 | );
120 | };
121 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/global.d.ts:
--------------------------------------------------------------------------------
1 | declare module "*.module.css";
2 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/IconProps.tsx:
--------------------------------------------------------------------------------
1 | export interface IconProps {
2 | width?: string | number;
3 | height?: string | number;
4 | }
5 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/copy.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "../components/ThemeProvider";
3 | import { IconProps } from "./IconProps";
4 |
5 | export const Copy: React.FunctionComponent = (props) => {
6 | const theme = React.useContext(ThemeContext);
7 | return (
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 | );
23 | };
24 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/cut.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "../components/ThemeProvider";
3 | import { IconProps } from "./IconProps";
4 |
5 | export const Cut: React.FunctionComponent = (props) => {
6 | const theme = React.useContext(ThemeContext);
7 | return (
8 |
9 |
10 |
14 |
18 |
19 |
20 | );
21 | };
22 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/icons.ts:
--------------------------------------------------------------------------------
1 | export { Copy } from "./copy";
2 | export { Cut } from "./cut";
3 | export { Open } from "./open";
4 | export { Paste } from "./paste";
5 | export { Redo } from "./redo";
6 | export { Save } from "./save";
7 | export { Undo } from "./undo";
8 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/open.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "../components/ThemeProvider";
3 | import { IconProps } from "./IconProps";
4 |
5 | export const Open: React.FunctionComponent = (props) => {
6 | const theme = React.useContext(ThemeContext);
7 | return (
8 |
9 |
10 |
11 |
21 |
26 |
27 |
28 |
29 | );
30 | };
31 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/paste.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "../components/ThemeProvider";
3 | import { IconProps } from "./IconProps";
4 |
5 | export const Paste: React.FunctionComponent = (props) => {
6 | const theme = React.useContext(ThemeContext);
7 | return (
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
29 |
30 |
31 | );
32 | };
33 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/redo.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { IconProps } from "./IconProps";
3 |
4 | export const Redo: React.FunctionComponent = (props) => {
5 | return (
6 |
7 |
8 |
13 |
17 |
18 |
19 |
20 | );
21 | };
22 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/save.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { ThemeContext } from "../components/ThemeProvider";
3 | import { IconProps } from "./IconProps";
4 |
5 | export const Save: React.FunctionComponent = (props) => {
6 | const theme = React.useContext(ThemeContext);
7 | return (
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
20 |
21 |
25 |
26 |
27 | );
28 | };
29 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/icons/undo.tsx:
--------------------------------------------------------------------------------
1 | import React from "react";
2 | import { IconProps } from "./IconProps";
3 |
4 | export const Undo: React.FunctionComponent = (props) => {
5 | return (
6 |
7 |
8 |
12 |
13 |
14 | );
15 | };
16 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/monaco/solarized-contrast.ts:
--------------------------------------------------------------------------------
1 | import monaco from "monaco-editor";
2 | import { BaseColors, Theme } from "./theme";
3 |
4 | const kSolarizedContrastColors: BaseColors = {
5 | base03: "#001014", // 'brblack',
6 | base02: "#031b20", // 'black',
7 | base01: "#425257", // 'brgreen',
8 | base00: "#596c73", // 'bryellow',
9 | base0: "#91a0a1", // 'brblue',
10 | base1: "#adb8b8", // 'brcyan',
11 | base2: "#f5f1e6", // 'white'
12 | base3: "#fefaf1", // 'brwhite'
13 | yellow: "#b58900", // 'yellow',
14 | orange: "#cb4b16", // 'brred',
15 | red: "#dc322f", // 'red',
16 | magenta: "#d33682", // 'magenta',
17 | violet: "#6c71c4", // 'brmagenta',
18 | blue: "#268bd2", // 'blue',
19 | cyan: "#2aa198", // 'cyan',
20 | green: "#859900", // 'green',
21 | };
22 |
23 | export const kSolarizedContrastDark: Theme = {
24 | name: "SolarizedContrastDark",
25 | ...kSolarizedContrastColors,
26 | background: kSolarizedContrastColors.base02,
27 | foreground: kSolarizedContrastColors.base2,
28 | boldBackground: kSolarizedContrastColors.base03,
29 | boldForeground: kSolarizedContrastColors.base3,
30 | };
31 |
32 | export const kSolarizedContrastLight: Theme = {
33 | name: "SolarizedContrastLight",
34 | ...kSolarizedContrastColors,
35 | background: kSolarizedContrastColors.base2,
36 | foreground: kSolarizedContrastColors.base02,
37 | boldBackground: kSolarizedContrastColors.base3,
38 | boldForeground: kSolarizedContrastColors.base03,
39 | };
40 |
41 | export function defineThemes() {
42 | // @ts-ignore
43 | window.monaco.editor.defineTheme(kSolarizedContrastDark.name, {
44 | base: "vs-dark",
45 | inherit: false,
46 | rules: [
47 | { token: "keyword", foreground: kSolarizedContrastDark.green },
48 | { token: "constant", foreground: kSolarizedContrastDark.orange },
49 | { token: "identifier", foreground: kSolarizedContrastDark.yellow },
50 | { token: "delimiter.vector", foreground: kSolarizedContrastDark.yellow },
51 | { token: "string.character", foreground: kSolarizedContrastDark.cyan },
52 | { token: "string", foreground: kSolarizedContrastDark.cyan },
53 | { token: "number", foreground: kSolarizedContrastDark.blue },
54 | { token: "comment", foreground: kSolarizedContrastDark.base1 },
55 | { token: "operators", foreground: kSolarizedContrastDark.green },
56 | { token: "delimiter", foreground: kSolarizedContrastDark.base01 },
57 | { token: "variable", foreground: kSolarizedContrastDark.green },
58 | { token: "bracket", foreground: kSolarizedContrastDark.base01 },
59 | {
60 | token: "",
61 | foreground: kSolarizedContrastDark.foreground,
62 | background: kSolarizedContrastDark.background,
63 | },
64 | ],
65 | colors: {
66 | "editor.foreground": kSolarizedContrastDark.foreground,
67 | "editor.background": kSolarizedContrastDark.background,
68 | "editorLineNumber.foreground": kSolarizedContrastColors.base00,
69 | },
70 | });
71 | // @ts-ignore
72 | window.monaco.editor.defineTheme(kSolarizedContrastLight.name, {
73 | base: "vs",
74 | inherit: false,
75 | rules: [
76 | { token: "keyword", foreground: kSolarizedContrastLight.green },
77 | { token: "constant", foreground: kSolarizedContrastLight.orange },
78 | { token: "identifier", foreground: kSolarizedContrastLight.yellow },
79 | { token: "delimiter.vector", foreground: kSolarizedContrastLight.yellow },
80 | { token: "string.character", foreground: kSolarizedContrastLight.cyan },
81 | { token: "string", foreground: kSolarizedContrastLight.cyan },
82 | { token: "number", foreground: kSolarizedContrastLight.blue },
83 | { token: "comment", foreground: kSolarizedContrastLight.base1 },
84 | { token: "operators", foreground: kSolarizedContrastLight.green },
85 | { token: "delimiter", foreground: kSolarizedContrastLight.base01 },
86 | { token: "variable", foreground: kSolarizedContrastLight.green },
87 | { token: "bracket", foreground: kSolarizedContrastLight.base01 },
88 | {
89 | token: "",
90 | foreground: kSolarizedContrastLight.foreground,
91 | background: kSolarizedContrastLight.background,
92 | },
93 | ],
94 | colors: {
95 | "editor.foreground": kSolarizedContrastLight.foreground,
96 | "editor.background": kSolarizedContrastLight.background,
97 | "editorLineNumber.foreground": kSolarizedContrastColors.base00,
98 | },
99 | });
100 | }
101 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/monaco/solarized.ts:
--------------------------------------------------------------------------------
1 | import monaco from "monaco-editor";
2 | import { BaseColors, Theme } from "./theme";
3 |
4 | const kSolarizedColors: BaseColors = {
5 | base03: "#002b36", // 'brblack',
6 | base02: "#073642", // 'black',
7 | base01: "#586e75", // 'brgreen',
8 | base00: "#657b83", // 'bryellow',
9 | base0: "#839496", // 'brblue',
10 | base1: "#93a1a1", // 'brcyan',
11 | base2: "#eee8d5", // 'white'
12 | base3: "#fdf6e3", // 'brwhite'
13 | yellow: "#b58900", // 'yellow',
14 | orange: "#cb4b16", // 'brred',
15 | red: "#dc322f", // 'red',
16 | magenta: "#d33682", // 'magenta',
17 | violet: "#6c71c4", // 'brmagenta',
18 | blue: "#268bd2", // 'blue',
19 | cyan: "#2aa198", // 'cyan',
20 | green: "#859900", // 'green',
21 | };
22 |
23 | export const kSolarizedDark: Theme = {
24 | name: "SolarizedDark",
25 | ...kSolarizedColors,
26 | background: kSolarizedColors.base02,
27 | foreground: kSolarizedColors.base2,
28 | boldBackground: kSolarizedColors.base03,
29 | boldForeground: kSolarizedColors.base3,
30 | };
31 |
32 | export const kSolarizedLight: Theme = {
33 | name: "SolarizedLight",
34 | ...kSolarizedColors,
35 | background: kSolarizedColors.base2,
36 | foreground: kSolarizedColors.base02,
37 | boldBackground: kSolarizedColors.base3,
38 | boldForeground: kSolarizedColors.base03,
39 | };
40 |
41 | export function defineThemes() {
42 | // @ts-ignore
43 | window.monaco.editor.defineTheme(kSolarizedDark.name, {
44 | base: "vs-dark",
45 | inherit: false,
46 | rules: [
47 | { token: "keyword", foreground: kSolarizedDark.green },
48 | { token: "constant", foreground: kSolarizedDark.orange },
49 | { token: "identifier", foreground: kSolarizedDark.yellow },
50 | { token: "delimiter.vector", foreground: kSolarizedDark.yellow },
51 | { token: "string.character", foreground: kSolarizedDark.cyan },
52 | { token: "string", foreground: kSolarizedDark.cyan },
53 | { token: "number", foreground: kSolarizedDark.blue },
54 | { token: "comment", foreground: kSolarizedDark.base1 },
55 | { token: "operators", foreground: kSolarizedDark.green },
56 | { token: "delimiter", foreground: kSolarizedDark.base01 },
57 | { token: "variable", foreground: kSolarizedDark.green },
58 | { token: "bracket", foreground: kSolarizedDark.base01 },
59 | {
60 | token: "",
61 | foreground: kSolarizedDark.foreground,
62 | background: kSolarizedDark.background,
63 | },
64 | ],
65 | colors: {
66 | "editor.foreground": kSolarizedDark.foreground,
67 | "editor.background": kSolarizedDark.background,
68 | "editorLineNumber.foreground": kSolarizedColors.base00,
69 | },
70 | });
71 | // @ts-ignore
72 | window.monaco.editor.defineTheme(kSolarizedLight.name, {
73 | base: "vs",
74 | inherit: false,
75 | rules: [
76 | { token: "keyword", foreground: kSolarizedLight.green },
77 | { token: "constant", foreground: kSolarizedLight.orange },
78 | { token: "identifier", foreground: kSolarizedLight.yellow },
79 | { token: "delimiter.vector", foreground: kSolarizedLight.yellow },
80 | { token: "string.character", foreground: kSolarizedLight.cyan },
81 | { token: "string", foreground: kSolarizedLight.cyan },
82 | { token: "number", foreground: kSolarizedLight.blue },
83 | { token: "comment", foreground: kSolarizedLight.base1 },
84 | { token: "operators", foreground: kSolarizedLight.green },
85 | { token: "delimiter", foreground: kSolarizedLight.base01 },
86 | { token: "variable", foreground: kSolarizedLight.green },
87 | { token: "bracket", foreground: kSolarizedLight.base01 },
88 | {
89 | token: "",
90 | foreground: kSolarizedLight.foreground,
91 | background: kSolarizedLight.background,
92 | },
93 | ],
94 | colors: {
95 | "editor.foreground": kSolarizedLight.foreground,
96 | "editor.background": kSolarizedLight.background,
97 | "editorLineNumber.foreground": kSolarizedColors.base00,
98 | },
99 | });
100 | }
101 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/monaco/theme.ts:
--------------------------------------------------------------------------------
1 | export interface BaseColors {
2 | base03: string;
3 | base02: string;
4 | base01: string;
5 | base00: string;
6 | base0: string;
7 | base1: string;
8 | base2: string;
9 | base3: string;
10 | yellow: string;
11 | orange: string;
12 | red: string;
13 | magenta: string;
14 | violet: string;
15 | blue: string;
16 | cyan: string;
17 | green: string;
18 | }
19 |
20 | export interface Theme extends BaseColors {
21 | name: string;
22 | foreground: string;
23 | background: string;
24 | boldForeground: string;
25 | boldBackground: string;
26 | }
27 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/styles/animations.module.css:
--------------------------------------------------------------------------------
1 | @keyframes :global(shake) {
2 | 0% {
3 | transform: rotate(0deg);
4 | }
5 | 5% {
6 | transform: rotate(5deg);
7 | }
8 | 10% {
9 | transform: rotate(-5deg);
10 | }
11 | 15% {
12 | transform: rotate(10deg);
13 | }
14 | 20% {
15 | transform: rotate(-10deg);
16 | }
17 | 25% {
18 | transform: rotate(15deg);
19 | }
20 | 30% {
21 | transform: rotate(-15deg);
22 | }
23 | 35% {
24 | transform: rotate(15deg);
25 | }
26 | 40% {
27 | transform: rotate(-15deg);
28 | }
29 | 45% {
30 | transform: rotate(15deg);
31 | }
32 | 50% {
33 | transform: rotate(-15deg);
34 | }
35 | 55% {
36 | transform: rotate(15deg);
37 | }
38 | 60% {
39 | transform: rotate(-12.5deg);
40 | }
41 | 65% {
42 | transform: rotate(12.5deg);
43 | }
44 | 70% {
45 | transform: rotate(-10deg);
46 | }
47 | 75% {
48 | transform: rotate(10deg);
49 | }
50 | 80% {
51 | transform: rotate(-7.5deg);
52 | }
53 | 85% {
54 | transform: rotate(7.5deg);
55 | }
56 | 90% {
57 | transform: rotate(-5deg);
58 | }
59 | 95% {
60 | transform: rotate(5deg);
61 | }
62 | 100% {
63 | transform: rotate(0deg);
64 | }
65 | }
66 |
67 | @keyframes :global(zoom) {
68 | 0% {
69 | transform: scale(1, 0.25);
70 | }
71 | 100% {
72 | transform: scale(1);
73 | }
74 | }
75 |
76 | @keyframes :global(clockwise-spin) {
77 | from {
78 | transform: rotate(0deg);
79 | }
80 | to {
81 | transform: rotate(360deg);
82 | }
83 | }
84 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/styles/page.module.css:
--------------------------------------------------------------------------------
1 | body {
2 | font-family: Roboto, Arial, Helvetica, sans-serif;
3 | background: #93a1a1;
4 | margin: 0;
5 | padding: 0;
6 | overflow-x: hidden;
7 | }
8 |
9 | :global #app {
10 | overflow-x: hidden;
11 | position: relative;
12 | }
13 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/src/util.ts:
--------------------------------------------------------------------------------
1 | export function reference(...els: any[]) {}
2 |
3 | export async function saveFilePicker(text: string) {
4 | const blob = new Blob([text], {
5 | type: "text/plain",
6 | });
7 |
8 | if (!Reflect.has(window, "showSaveFilePicker")) {
9 | return saveFallback(blob);
10 | }
11 |
12 | const handle = await showSaveFilePicker({
13 | suggestedName: "untitled.scm",
14 | types: [
15 | {
16 | description: "Scheme files",
17 | accept: {
18 | "text/x-scheme": [".scm"],
19 | },
20 | },
21 | ],
22 | });
23 |
24 | const writable = await handle.createWritable();
25 | await writable.write(blob);
26 | await writable.close();
27 | }
28 |
29 | function saveFallback(blob: Blob) {
30 | const anchor = document.createElement("a");
31 | anchor.href = window.URL.createObjectURL(blob);
32 | anchor.download = "untitled.scm";
33 | anchor.click();
34 | }
35 |
36 | export async function openFilePicker(): Promise {
37 | let text = "";
38 | if (!Reflect.has(window, "showOpenFilePicker")) {
39 | return openFallback();
40 | }
41 |
42 | const [handle] = await showOpenFilePicker({
43 | types: [
44 | {
45 | description: "Scheme file",
46 | accept: {
47 | "text/x-scheme": [".scm"],
48 | },
49 | },
50 | ],
51 | multiple: false,
52 | });
53 |
54 | const file = await handle.getFile();
55 | return file.text();
56 | }
57 |
58 | function openFallback(): Promise {
59 | return new Promise((resolve, reject) => {
60 | const input = document.createElement("input");
61 | input.type = "file";
62 | input.multiple = false;
63 | input.accept = ".scm,text/plain,text/x-script.scheme,text/x-scheme";
64 | const timeout = window.setTimeout(
65 | () => reject(new Error("Timed out opening file")),
66 | 10 * 60 * 1000 // times out after 10 minutes
67 | );
68 | input.addEventListener("change", async () => {
69 | const files = input.files;
70 | if (!files || files.length == 0) {
71 | return reject(new Error("No files"));
72 | }
73 | const file = files.item(0);
74 | if (!file) {
75 | return reject(new Error("No File"));
76 | }
77 | window.clearTimeout(timeout);
78 | resolve(await file.text());
79 | });
80 |
81 | input.click();
82 | });
83 | }
84 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/tsconfig.json:
--------------------------------------------------------------------------------
1 | {
2 | "compilerOptions": {
3 | "outDir": "./dist/",
4 | "rootDirs": ["./src/", "./tests/"],
5 | "sourceMap": true,
6 | "noImplicitAny": true,
7 | "module": "ES2020",
8 | "target": "ES2021",
9 | "declaration": false,
10 | "strict": true,
11 | "jsx": "react",
12 | "lib": ["dom", "es2021"],
13 | "allowSyntheticDefaultImports": true,
14 | "moduleResolution": "node"
15 | }
16 | }
17 |
--------------------------------------------------------------------------------
/scheme.wasm.ui/webpack.config.js:
--------------------------------------------------------------------------------
1 | const path = require("path");
2 | const { CleanWebpackPlugin: CleanWebpack } = require("clean-webpack-plugin");
3 | const CopyWebpack = require("copy-webpack-plugin");
4 | const HtmlWebpack = require("html-webpack-plugin");
5 | const TerserWebpack = require("terser-webpack-plugin");
6 | const { SubresourceIntegrityPlugin } = require("webpack-subresource-integrity");
7 | const GenerateFileWebpack = require("generate-file-webpack-plugin");
8 |
9 | module.exports = (env, argv) => {
10 | // Selects a different template file for the start page based on whether
11 | // this is a "production" build or not
12 | const isProduction = argv.mode === "production";
13 |
14 | const defaultSources = ["self"];
15 | const scriptSources = isProduction
16 | ? [
17 | "self",
18 | // error handling inline script in index.html
19 | "sha256-TO1LBWpNZpKvSV7k/GXrQi3Dr3W6DM4HiyBZ34t9NZY=",
20 | // monaco loader inline script in index.html
21 | "sha256-L3Q56wz8wKAd/Sv4L0XQVvnS9NTbuc6bMFdjybWP7W0=",
22 | // required to allow wasm compilation
23 | "unsafe-eval",
24 | ]
25 | : [
26 | "self",
27 | // error handling inline script in index.html
28 | "sha256-CaJQ9XvDeqT1hFm5G9xK1m9KdzTb15u78m3/yqU3kI4=",
29 | // monaco loader inline script in index.html
30 | "sha256-mBDwcg6uDyAcx3h6QPxb9yGjK5ak26IXZ/9Xk/VsJM4=",
31 | // required to allow wasm compilation
32 | "unsafe-eval",
33 | ];
34 | const fontSources = ["self"];
35 | const imageSource = ["self"];
36 | const styleSources = [
37 | "self",
38 | // needed because of the way we handle css in general. This still won't allow
39 | // accessing external urls (i.e. no tracking images in inline styles)
40 | "unsafe-inline",
41 | ];
42 | // fflate useses a worker loaded from a blob, so worker sources needs to
43 | // include the blob: scheme
44 | const workerSources = ["self", "blob:"];
45 |
46 | const sourceMap = (sources, type) =>
47 | [type, ...sources.map((el) => (el.endsWith(":") ? el : `'${el}'`))].join(
48 | " "
49 | ) + ";";
50 | const cspHeader = [
51 | sourceMap(defaultSources, "default-src"),
52 | sourceMap(scriptSources, "script-src"),
53 | sourceMap(fontSources, "font-src"),
54 | sourceMap(imageSource, "img-src"),
55 | sourceMap(styleSources, "style-src"),
56 | sourceMap(workerSources, "worker-src"),
57 | ].join(" ");
58 | const cspHeaderFile = `add_header Content-Security-Policy "${cspHeader}" always;`;
59 |
60 | return {
61 | entry: "./src/index.tsx", // The entry point into the bundle
62 | output: {
63 | path: path.join(__dirname, "/dist"),
64 | filename: "[name].[contenthash].js",
65 | crossOriginLoading: "anonymous",
66 | },
67 | devServer: {
68 | port: 8080,
69 | host: "0.0.0.0",
70 | static: {
71 | publicPath: path.join(__dirname, "/dist"),
72 | },
73 | headers: {
74 | "Content-Security-Policy": cspHeader,
75 | "Cross-Origin-Opener-Policy": "same-origin",
76 | "Cross-Origin-Embedder-Policy": "require-corp",
77 | },
78 | },
79 | devtool: isProduction ? undefined : "source-map",
80 | resolve: {
81 | extensions: [".ts", ".tsx", ".js"],
82 | },
83 |
84 | module: {
85 | rules: [
86 | {
87 | test: /\.ts(x?)$/,
88 | exclude: /node_modules/,
89 | use: "ts-loader",
90 | },
91 | {
92 | enforce: "pre",
93 | test: /\.js$/,
94 | exclude: /node_modules/,
95 | loader: "source-map-loader",
96 | },
97 | {
98 | test: /\.css$/,
99 | exclude: /node-modules/,
100 | use: ["style-loader", "css-loader"],
101 | },
102 | {
103 | test: /\.ttf$/,
104 | use: ["file-loader"],
105 | },
106 | ],
107 | },
108 |
109 | externals: {
110 | "monaco-editor": [],
111 | },
112 |
113 | optimization: {
114 | minimize: isProduction,
115 | minimizer: [new TerserWebpack()],
116 | realContentHash: true,
117 | splitChunks: {
118 | chunks: "all",
119 | },
120 | },
121 |
122 | plugins: [
123 | new CleanWebpack(),
124 | new SubresourceIntegrityPlugin(),
125 | new HtmlWebpack({
126 | filename: "scheme.wasm.html", // The output name when built
127 | template: "./index.html",
128 | }),
129 | new CopyWebpack({
130 | patterns: [
131 | { from: "../scheme.wasm/dist/scheme.wasm", to: "wasm" },
132 | { from: "../scheme.wasm/dist/unicode/blocks.json.gz", to: "unicode" },
133 | { from: "../scheme.wasm/src/scheme", to: "scheme" },
134 | { from: "./about.html", to: "static" },
135 | { from: "./favicon", to: "static" },
136 | { from: "./fonts", to: "fonts" },
137 | {
138 | from: "../node_modules/monaco-editor/min/vs",
139 | to: "vs",
140 | globOptions: {
141 | ignore: ["**/basic-languages/**", "**/language/**"],
142 | },
143 | },
144 | {
145 | from: "../node_modules/monaco-editor/min-maps",
146 | to: "min-maps",
147 | },
148 | ],
149 | }),
150 | GenerateFileWebpack({
151 | file: "csp.conf",
152 | content: cspHeaderFile,
153 | }),
154 | ],
155 | };
156 | };
157 |
--------------------------------------------------------------------------------
/scheme.wasm/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "scheme.wasm",
3 | "version": "1.0.0",
4 | "description": "",
5 | "main": "./dist/src/index.js",
6 | "bin": {
7 | "scheme.wasm": "./dist/src/index.js",
8 | "buildwat": "./dist/src/scripts/buildwat.js",
9 | "unicodedata": "./dist/src/scripts/unicodedata.js"
10 | },
11 | "scripts": {
12 | "start-dev": "nodemon --watch src -e ts --exec \"npm run start\"",
13 | "start": "node .",
14 | "prestart": "npm run build",
15 | "build": "tsc --incremental -p . && npm run unicode && npm run assemble",
16 | "assemble": "node dist/src/scripts/buildwat.js ./buildwat.json --macros --validate --output dist/scheme.wasm --tempfile dist/scheme.wat",
17 | "pretest": "tsc --incremental -p . && npm run unicode && node dist/src/scripts/buildwat.js tests/buildwat.json --macros --validate --output dist/test.wasm --tempfile dist/test.wat",
18 | "unicode": "node dist/src/scripts/unicodedata.js",
19 | "test": "node ../node_modules/mocha/bin/_mocha -r ts-node/register --no-timeouts tests/**/*.spec.ts",
20 | "clean": "rimraf -rf ./dist"
21 | },
22 | "keywords": [],
23 | "author": "Paul C Roberts ",
24 | "license": "MIT",
25 | "devDependencies": {
26 | "@types/chai": "^4.2.22",
27 | "@types/mocha": "^9.0.0",
28 | "@types/node": "^16.11.6",
29 | "chai": "^4.3.4",
30 | "commander": "^8.3.0",
31 | "mocha": "^9.2.0",
32 | "nodemon": "^2.0.14",
33 | "ts-node": "^10.4.0",
34 | "typescript": "^4.4.4",
35 | "wabt": "^1.0.24"
36 | }
37 | }
38 |
--------------------------------------------------------------------------------
/scheme.wasm/src/continuations.wat:
--------------------------------------------------------------------------------
1 | (;
2 |
3 | Continuations.
4 |
5 | Continuations are stored in a separate slab.
6 |
7 | Continuation Block
8 | size: i32 -- Size of the block
9 | count: i32 -- number of continuations allocated in this block
10 | free: i32 ptr -- ptr to the free list (if any)
11 | next: i32 ptr -- ptr to the next continuation block (if any)
12 |
13 | Continuation:
14 | fn: i32 -- function index in the builtins-table,
15 | env: i32 env -- environment
16 | args: i32 list -- arguments to the continuation
17 |
18 | if cont.fn is 0 then it is an eval
19 |
20 | ;)
21 |
22 | (%define %continuation-block-count () (i32.const 256))
23 |
24 | (global $g-continuations (mut i32) (i32.const 0))
25 |
26 | (func $cont-init
27 | (global.set $g-continuations (call $cont-alloc-block)))
28 |
29 | (func $cont-cleanup
30 | (local $block i32)
31 | (local $next i32)
32 |
33 | (local.set $block (global.get $g-continuations))
34 |
35 | (block $b_end
36 | (loop $b_start
37 | (br_if $b_end (i32.eqz (local.get $block)))
38 |
39 | (local.set $next (i32.load offset=12 (local.get $block)))
40 | (call $malloc-free (local.get $block))
41 | (local.set $block (local.get $next))
42 | (br $b_start))))
43 |
44 | (func $cont-alloc-block (result i32)
45 | (local $block i32)
46 | (local $ptr i32)
47 | (local $next-ptr i32)
48 | (local $count i32)
49 |
50 | (local.set $count (%continuation-block-count))
51 | (local.set $block (call $malloc
52 | (i32.add
53 | (i32.const 16) ;; header
54 | (i32.mul (local.get $count) (i32.const 12))))) ;; number of continuations * 12
55 |
56 | (local.set $ptr (i32.add (local.get $block) (i32.const 16)))
57 |
58 | (i32.store offset=0 (local.get $block) (local.get $count)) ;; size
59 | (i32.store offset=4 (local.get $block) (i32.const 0)) ;; count
60 | (i32.store offset=8 (local.get $block) (local.get $ptr)) ;; free
61 | (i32.store offset=12 (local.get $block) (i32.const 0)) ;; next
62 |
63 | (block $b_end
64 | (loop $b_start
65 | (br_if $b_end (i32.eqz (local.get $count)))
66 |
67 | (local.set $next-ptr (i32.add (local.get $ptr) (i32.const 12)))
68 | (i32.store
69 | (local.get $ptr)
70 | (select
71 | (local.get $next-ptr)
72 | (i32.const 0)
73 | (i32.gt_u (local.get $count) (i32.const 1))))
74 |
75 | (%dec $count)
76 | (local.set $ptr (local.get $next-ptr))
77 | (br $b_start)))
78 |
79 | (return (local.get $block)))
80 |
81 | (func $cont-alloc (param $fn i32) (param $env i32) (param $args i32) (param $next i32) (result i32)
82 | (return (call $heap-alloc
83 | (global.get $g-heap)
84 | (%cont-type)
85 | (call $cont-alloc-inner
86 | (local.get $fn)
87 | (local.get $env)
88 | (local.get $args))
89 | (local.get $next))))
90 |
91 | (func $cont-alloc-inner (param $fn i32) (param $env i32) (param $args i32) (result i32)
92 | (local $block i32)
93 | (local $next-block i32)
94 | (local $ptr i32)
95 | (local $count i32)
96 | (local $size i32)
97 |
98 | (local.set $block (global.get $g-continuations))
99 |
100 | (block $b_end
101 | (loop $b_start
102 | (local.set $size (i32.load offset=0 (local.get $block)))
103 | (local.set $count (i32.load offset=4 (local.get $block)))
104 | (if (i32.lt_u (local.get $count) (local.get $size))
105 | (then
106 | (local.set $ptr (i32.load offset=8 (local.get $block)))
107 | ;; increment count
108 | (i32.store offset=4 (local.get $block) (i32.add (local.get $count) (i32.const 1)))
109 | ;; set free ptr to this continuations next ptr
110 | (i32.store offset=8 (local.get $block) (i32.load (local.get $ptr)))
111 |
112 | (i32.store offset=0 (local.get $ptr) (local.get $fn))
113 | (i32.store offset=4 (local.get $ptr) (local.get $env))
114 | (i32.store offset=8 (local.get $ptr) (local.get $args))
115 |
116 | (return (local.get $ptr))
117 | ))
118 |
119 | (local.set $next-block (i32.load offset=12 (local.get $block)))
120 | (if (i32.eqz (local.get $next-block))
121 | (then
122 | (i32.store offset=12
123 | (local.get $block)
124 | (local.tee $next-block (call $cont-alloc-block)))))
125 | (local.set $block (local.get $next-block))
126 | (br $b_start)))
127 |
128 | (unreachable))
129 |
130 | (func $cont-free (param $ptr i32)
131 | (local $block i32)
132 | (local $size i32)
133 | (local $start i32)
134 | (local $end i32)
135 |
136 | (local.set $block (global.get $g-continuations))
137 |
138 | (block $b_end
139 | (loop $b_start
140 | (br_if $b_end (i32.eqz (local.get $block)))
141 | (local.set $size (i32.load offset=0 (local.get $block)))
142 | (local.set $start (i32.add (local.get $block) (i32.const 16)))
143 |
144 | (if (i32.ge_u (local.get $ptr) (local.get $start))
145 | (then
146 | (local.set $end (i32.add
147 | (local.get $start)
148 | (i32.mul (local.get $size) (i32.const 12))))
149 | (if (i32.lt_u (local.get $ptr) (local.get $end))
150 | (then
151 | ;; ptr is within the block
152 | ;; set ptr to free
153 | (i32.store (local.get $ptr) (i32.load offset=8 (local.get $block)))
154 | ;; set free to ptr
155 | (i32.store offset=8 (local.get $block) (local.get $ptr))
156 | ;; decrement count
157 | (i32.store offset=4
158 | (local.get $block)
159 | (i32.sub
160 | (i32.load offset=4 (local.get $block))
161 | (i32.const 1)))
162 | (return)))))
163 |
164 | (local.set $block (i32.load offset=12 (local.get $block)))
165 | (br $b_start)))
166 |
167 | ;; TODO message that attempted to free invalid continuation
168 | (unreachable))
169 |
--------------------------------------------------------------------------------
/scheme.wasm/src/display.wat:
--------------------------------------------------------------------------------
1 | ;; (display [])
2 | (func $display (param $env i32) (param $args i32) (result i32)
3 | (local $num-args i32)
4 | (local $obj i32)
5 | (local $obj-type i32)
6 | (local $cp i32)
7 | (local $str-ptr i32)
8 |
9 | (block $b_check (block $b_fail
10 | (local.set $num-args (call $list-len (local.get $args)))
11 | (if (i32.eq (local.get $num-args) (i32.const 2)) (then
12 | (return (call $not-implemented-error (local.get $args)))))
13 | (br_if $b_fail (i32.ne (local.get $num-args) (i32.const 1)))
14 | (%pop-l $obj $args)
15 | (br $b_check))
16 |
17 | (return (call $argument-error (local.get $args))))
18 |
19 | (local.set $obj-type (%get-type $obj))
20 |
21 | (if (i32.eq (local.get $obj-type) (%str-type)) (then
22 | (call $io-write (%car-l $obj))
23 | (return (global.get $g-nil))))
24 |
25 | (if (i32.eq (local.get $obj-type) (%char-type)) (then
26 | (local.set $cp (%car-l $obj))
27 | (local.set $str-ptr (call $str-from-32
28 | (call $utf8-code-point-size (local.get $cp))
29 | (call $utf8-from-code-point (local.get $cp))))
30 | (call $io-write (local.get $str-ptr))
31 | (call $malloc-free (local.get $str-ptr))
32 | (return (global.get $g-nil))))
33 |
34 | (call $print (local.get $obj))
35 | (return (global.get $g-nil)))
36 |
37 |
--------------------------------------------------------------------------------
/scheme.wasm/src/environment.wat:
--------------------------------------------------------------------------------
1 | ;; An environment is a hashtable and a pointer to a (heap allocated) outer
2 | ;; environment, conveniently this fits within a heap object
3 | ;;
4 | ;; Environment
5 | ;; hashtable i32 -- ptr to a hashtable allocated with $hashtable-init
6 | ;; outer i32 -- heap-ptr to the outer hashtable (0 if none)
7 |
8 |
9 | (func $environment-init (param $heap i32) (param $outer i32) (result i32)
10 | ;; hashtable = hashtable-init(0)
11 | ;; return heap-alloc(heap, 9, hashtable, outer)
12 | (return
13 | (call $heap-alloc
14 | (local.get $heap)
15 | (i32.const 9)
16 | (call $hashtable-init (i32.const 0))
17 | (local.get $outer)
18 | )
19 | )
20 | )
21 |
22 | (func $environment-destroy (param $env i32) (param $destroy-outer i32)
23 | (block $done (loop $forever
24 | ;; we don't free the keys here because symbols are interned
25 | (call $malloc-free (%car-l $env))
26 |
27 | ;; if (!destroy-outer) break
28 | (br_if $done (i32.eqz (local.get $destroy-outer)))
29 |
30 | ;; if (env = env[8]) continue
31 | (br_if $forever (local.tee $env (%cdr-l $env))))))
32 |
33 | (func $environment-add (param $env i32) (param $key i32) (param $value i32)
34 | (local $key-str i32)
35 | (local $hashtable i32)
36 | (local $new-hash i32)
37 |
38 | ;; check that key is a symbol
39 | (if (i32.ne (%get-type $key) (%symbol-type))
40 | ;; trap
41 | ;; TODO: return error
42 | (then (unreachable))
43 | ;; }
44 | )
45 |
46 | ;; key-str = key[4]
47 | (local.set $key-str (i32.load offset=4 (local.get $key)))
48 | ;; hashtable = env[4]
49 | (local.set $hashtable (i32.load offset=4 (local.get $env)))
50 |
51 | ;; check that there isn't an existing entry in the hashtable
52 | ;; if (hashtable-has(hashtable, key-str)) {
53 | (if (call $hashtable-has (local.get $hashtable) (local.get $key-str))
54 | ;; trap
55 | ;; TODO: return error
56 | (then (unreachable))
57 | ;; }
58 | )
59 |
60 | ;; place value in hashtable
61 | ;; new-hash = hashtable-add(hashtable, str-dup(key-str), value)
62 | (local.set $new-hash
63 | (call $hashtable-add
64 | (local.get $hashtable)
65 | (local.get $key-str)
66 | (local.get $value)
67 | )
68 | )
69 |
70 | ;; if (new-hash != hashtable) {
71 | (if (i32.ne (local.get $new-hash) (local.get $hashtable))
72 | (then
73 | ;; env[4] = new-hash
74 | (i32.store
75 | (i32.add (local.get $env) (i32.const 4))
76 | (local.get $new-hash)
77 | )
78 | )
79 | ;; }
80 | )
81 | )
82 |
83 | (func $environment-has (param $env i32) (param $key i32) (result i32)
84 | ;; check that key is a symbol
85 | (if (i32.ne (%get-type $key) (%symbol-type)) (then
86 | (return (i32.const 0))))
87 |
88 | ;; check that there isn't an existing entry in the hashtable
89 | ;; return hashtable-has(hashtable, key-str)
90 | (return (call $hashtable-has (%car-l $env) (%car-l $key))))
91 |
92 | (func $environment-get (param $env i32) (param $key i32) (result i32)
93 | (local $key-str i32)
94 | (local $hashtable i32)
95 | (local $value i32)
96 |
97 | ;; check that key is a string
98 | (if (i32.ne (%get-type $key) (%symbol-type)) (then
99 | ;; return g-nil
100 | (return (global.get $g-nil))))
101 |
102 | ;; key-str = key[4]
103 | (local.set $key-str (i32.load offset=4 (local.get $key)))
104 |
105 | (loop $forever
106 | ;; hashtable = env[4]
107 | (local.set $hashtable (i32.load offset=4 (local.get $env)))
108 | ;; value = hashtable-get(hashtable, key-str)
109 | (local.set $value (call $hashtable-get
110 | (local.get $hashtable)
111 | (local.get $key-str)))
112 | ;; if (value != 0) {
113 | (if (local.get $value) (then
114 | ;; return value
115 | (return (local.get $value))))
116 |
117 | ;; env = env[8]
118 | (local.set $env (i32.load offset=8 (local.get $env)))
119 |
120 | ;; if (env) continue;
121 | (br_if $forever (local.get $env)))
122 |
123 | ;; return g-nil;
124 | (return (%alloc-error (global.get $g-unknown) (local.get $key))))
125 |
126 | (func $environment-set! (param $env i32) (param $key i32) (param $value i32) (result i32)
127 | (local $key-str i32)
128 | (local $hashtable i32)
129 | (local $curr i32)
130 |
131 | (if (i32.ne (%get-type $key) (%symbol-type)) (then
132 | (return (call $argument-error (%alloc-list-2
133 | (local.get $key)
134 | (local.get $value))))))
135 |
136 | ;; key-str = key[4]
137 | (local.set $key-str (%car-l $key))
138 |
139 | ;; while (true) {
140 | (loop $forever
141 | ;; hashtable = car(env)
142 | (local.set $hashtable (%car-l $env))
143 |
144 | (if (local.tee $curr (call $hashtable-get
145 | (local.get $hashtable)
146 | (local.get $key-str)))
147 | (then
148 | (if (i32.ne (%get-type $curr) (%syntax-rules-type)) (then
149 | ;; Note: cannot remove then add, because the duplicated key-string in
150 | ;; the hashtable will leak.
151 | (if (call $hashtable-replace
152 | (local.get $hashtable)
153 | (local.get $key-str)
154 | (local.get $value))
155 | ;; return
156 | (then (return (global.get $g-nil)))))))
157 | (else
158 | ;; if (env = cdr(env)) continue;
159 | (br_if $forever (local.tee $env (%cdr-l $env))))))
160 |
161 | (return (call $argument-error (%alloc-list-2
162 | (local.get $key)
163 | (local.get $value)))))
164 |
--------------------------------------------------------------------------------
/scheme.wasm/src/exceptions.wat:
--------------------------------------------------------------------------------
1 | ;; (raise )
2 | (func $raise (param $env i32) (param $args i32) (result i32)
3 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1)) (then
4 | (return (call $argument-error (local.get $args)))))
5 |
6 | (return (%alloc-raise (%car-l $args))))
7 |
8 | ;; (cont-raise )
9 | ;; This is used as a continuation by the guard for a raise exception
10 | (func $cont-raise (param $env i32) (param $args i32) (result i32)
11 | (return (%alloc-raise (%car (%cdr-l $args)))))
12 |
13 | ;; (raise-continuable )
14 | (func $raise-continuable (param $env i32) (param $args i32) (result i32)
15 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1)) (then
16 | (return (call $argument-error (local.get $args)))))
17 |
18 | (return (%alloc-raise-continuable (%car-l $args))))
19 |
20 | ;; (error ...)
21 | (func $error (param $env i32) (param $args i32) (result i32)
22 | (local $temp i32)
23 | (local $msg i32)
24 |
25 | (block $check (block $fail
26 | (br_if $fail (i32.eqz (call $list-len (local.get $args))))
27 | (local.set $temp (local.get $args))
28 | (%pop-l $msg $temp)
29 | (%chk-type $fail $msg %str-type)
30 | (br $check))
31 |
32 | (return (call $argument-error (local.get $args))))
33 |
34 | (return (%alloc-raise (%alloc-error-cons
35 | (local.get $msg)
36 | (local.get $temp)))))
37 |
38 | ;; (error-object? )
39 | (func $error-object? (param $env i32) (param $args i32) (result i32)
40 | (local $obj i32)
41 |
42 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1)) (then
43 | (return (call $argument-error (local.get $args)))))
44 |
45 | (local.set $obj (%car-l $args))
46 |
47 | (return (select
48 | (global.get $g-true)
49 | (global.get $g-false)
50 | (i32.eq (%get-type $obj) (%error-type)))))
51 |
52 | ;; (error-object-message )
53 | (func $error-object-message (param $env i32) (param $args i32) (result i32)
54 | (local $obj i32)
55 |
56 | (block $check (block $fail
57 | (br_if $fail (i32.ne (call $list-len (local.get $args)) (i32.const 1)))
58 | (local.set $obj (%car-l $args))
59 | (%chk-type $fail $obj %error-type)
60 | (br $check))
61 |
62 | (return (call $argument-error (local.get $args))))
63 |
64 | (return (%car-l $obj)))
65 |
66 | ;; (error-object-irritants )
67 | (func $error-object-irritants (param $env i32) (param $args i32) (result i32)
68 | (local $obj i32)
69 |
70 | (block $check (block $fail
71 | (br_if $fail (i32.ne (call $list-len (local.get $args)) (i32.const 1)))
72 | (local.set $obj (%car-l $args))
73 | (%chk-type $fail $obj %error-type)
74 | (br $check))
75 |
76 | (return (call $argument-error (local.get $args))))
77 |
78 | (return (%cdr-l $obj)))
79 |
80 | ;; (with-exception-handler )
81 | (func $with-exception-handler (param $env i32) (param $args i32) (result i32)
82 | (local $handler i32)
83 | (local $thunk i32)
84 |
85 | (block $check (block $fail
86 | (br_if $fail (i32.ne (call $list-len (local.get $args)) (i32.const 2)))
87 | (local.set $handler (%car-l $args))
88 | (br_if $fail (i32.eqz (call $procedure?-impl (local.get $handler))))
89 | (local.set $thunk (%car (%cdr-l $args)))
90 | (br_if $fail (i32.eqz (call $procedure?-impl (local.get $thunk))))
91 | (br $check))
92 |
93 | (return (call $argument-error (local.get $args))))
94 |
95 | (return (call $cont-alloc
96 | (%eval-fn)
97 | (local.get $env)
98 | (%alloc-cons (local.get $thunk) (global.get $g-nil))
99 | (call $cont-alloc
100 | (%guard-fn)
101 | (local.get $env)
102 | (local.get $handler)
103 | (i32.const 0)))))
104 |
--------------------------------------------------------------------------------
/scheme.wasm/src/include.wat:
--------------------------------------------------------------------------------
1 | ;; (include ...)
2 | (func $include (param $env i32) (param $args i32) (result i32)
3 | (block $check (block $fail
4 | (br_if $fail (i32.lt_u (call $list-len (local.get $args)) (i32.const 1)))
5 | (br_if $fail (i32.eqz (call $all-string (local.get $args))))
6 | (br $check))
7 |
8 | (return (call $argument-error (local.get $args))))
9 |
10 | (return (call $cont-include-impl
11 | (local.get $env)
12 | (%alloc-cons (global.get $g-nil) (local.get $args))
13 | (i32.const 0))))
14 |
15 | ;; (include-ci ...)
16 | (func $include-ci (param $env i32) (param $args i32) (result i32)
17 | (block $check (block $fail
18 | (br_if $fail (i32.lt_u (call $list-len (local.get $args)) (i32.const 1)))
19 | (br_if $fail (i32.eqz (call $all-string (local.get $args))))
20 | (br $check))
21 |
22 | (return (call $argument-error (local.get $args))))
23 |
24 | (return (call $cont-include-impl
25 | (local.get $env)
26 | (%alloc-cons (global.get $g-nil) (local.get $args))
27 | (i32.const 1))))
28 |
29 | ;; (cont-include ...)
30 | (func $cont-include (param $env i32) (param $args i32) (result i32)
31 | (return (call $cont-include-impl
32 | (local.get $env)
33 | (local.get $args)
34 | (i32.const 0))))
35 |
36 | ;; (cont-include-ci ...)
37 | (func $cont-include-ci (param $env i32) (param $args i32) (result i32)
38 | (return (call $cont-include-impl
39 | (local.get $env)
40 | (local.get $args)
41 | (i32.const 1))))
42 |
43 | (func $cont-include-impl (param $env i32) (param $args i32) (param $is-ci i32) (result i32)
44 | (local $temp i32)
45 | (local $filename i32)
46 | (local $promise i32)
47 |
48 | ;; discard (either a nil, or the result of the eval of an included file)
49 | (%pop-l $temp $args)
50 |
51 | (if (i32.ne (%get-type $args) (%cons-type)) (then
52 | ;; all args have been processed
53 | (return (global.get $g-nil))))
54 |
55 | (%pop-l $filename $args)
56 |
57 | (local.set $promise (call $file-read (%car-l $filename)))
58 |
59 | (return (call $cont-alloc
60 | (%cont-import-promise)
61 | (local.get $env)
62 | (local.get $promise)
63 | (call $cont-alloc
64 | (select (%cont-include-read-ci) (%cont-include-read) (local.get $is-ci))
65 | (local.get $env)
66 | (local.get $args)
67 | (i32.const 0)))))
68 |
69 |
70 | ;; (cont-include-read ...)
71 | (func $cont-include-read (param $env i32) (param $args i32) (result i32)
72 | (return (call $cont-include-read-impl
73 | (local.get $env)
74 | (local.get $args)
75 | (i32.const 0))))
76 |
77 | ;; (cont-include-read-ci ...)
78 | (func $cont-include-read-ci (param $env i32) (param $args i32) (result i32)
79 | (return (call $cont-include-read-impl
80 | (local.get $env)
81 | (local.get $args)
82 | (i32.const 1))))
83 |
84 | (func $cont-include-read-impl (param $env i32) (param $args i32) (param $is-ci i32) (result i32)
85 | (local $contents i32)
86 | (local $contents-type i32)
87 | (local $reader i32)
88 | (local $datum i32)
89 |
90 | (%pop-l $contents $args)
91 | (local.set $contents-type (%get-type $contents))
92 |
93 | (if (i32.eq (local.get $contents-type) (%error-type)) (then
94 | (return (local.get $contents))))
95 |
96 | (if (i32.ne (local.get $contents-type) (%str-type)) (then
97 | (return (%alloc-raise (%alloc-error-cons
98 | (%str %sym-64 64 "bad-read")
99 | (global.get $g-nil))))))
100 |
101 | ;; validate that input from the host is well formed.
102 | (if (i32.eqz (call $str-is-valid (%car-l $contents))) (then
103 | (return (%alloc-raise (%alloc-error-cons
104 | (%str %sym-128 128 "invalid-string")
105 | (global.get $g-nil))))))
106 |
107 | ;; Create a string reader.
108 | (local.set $reader (call $reader-init (i32.const -1)))
109 | ;; Push the contents onto the read-cache.
110 | (i32.store offset=16
111 | (local.get $reader)
112 | (%alloc-list-3
113 | ;; "(begin "
114 | (%alloc-str (call $str-from-64 (i32.const 7) (i64.const 0x206e6967656228)))
115 | (local.get $contents)
116 | ;; ")"
117 | (%alloc-str (call $str-from-32 (i32.const 1) (i32.const 0x29)))))
118 |
119 | ;; tell the reader to fold case if necessary
120 | (if (local.get $is-ci) (then
121 | (i32.store8 offset=25 (local.get $reader) (i32.const 1))))
122 |
123 | (local.set $datum (call $read-with-reader (local.get $reader)))
124 | (call $reader-free (local.get $reader))
125 | (if (i32.eq (%get-type $datum) (%error-type)) (then
126 | (return (local.get $datum))))
127 |
128 | (return (call $cont-alloc
129 | (%eval-fn-def)
130 | (local.get $env)
131 | (local.get $datum)
132 | (call $cont-alloc
133 | (select (%cont-include-ci) (%cont-include) (local.get $is-ci))
134 | (local.get $env)
135 | (local.get $args)
136 | (i32.const 0)))))
137 |
--------------------------------------------------------------------------------
/scheme.wasm/src/lambda.wat:
--------------------------------------------------------------------------------
1 | (func $lambda (param $env i32) (param $args i32) (result i32)
2 | (if (i32.eqz (call $valid-formals? (%car-l $args))) (then
3 | (return (call $argument-error (local.get $args)))))
4 |
5 | ;; return heap-alloc(heap, lambda-type, env, args)
6 | (return (call $heap-alloc
7 | (global.get $g-heap)
8 | (%lambda-type)
9 | (local.get $env)
10 | (local.get $args))))
11 |
12 | ;; checks that formals is a valid formals list.
13 | ;; It must be either
14 | ;; A Symbol
15 | ;; A well formed list of Symbols
16 | ;; A list of symbols with a dotted terminator that is a symbol.
17 | (func $valid-formals? (param $formals i32) (result i32)
18 | (local $f-type i32)
19 | (local $f-val i32)
20 |
21 | (block $end (loop $start
22 | ;; f-type = get-type(formals)
23 | (local.set $f-type (%get-type $formals))
24 | ;; if (f-type == symbol) break
25 | (br_if $end (i32.eq (local.get $f-type) (%symbol-type)))
26 | ;; if (f-type == nil) break
27 | (br_if $end (i32.eq (local.get $f-type) (%nil-type)))
28 | ;; if (f-type != cons) return 0
29 | (if (i32.ne (local.get $f-type) (%cons-type)) (then
30 | (return (i32.const 0))))
31 |
32 | (%pop-l $f-val $formals)
33 |
34 | ;; if (fval not symbol) return 0
35 | (if (i32.ne (%get-type $f-val) (%symbol-type)) (then
36 | (return (i32.const 0))))
37 |
38 | (br $start)))
39 |
40 | (return (i32.const 1)))
41 |
42 | ;; (case-lambda ...)
43 | (func $case-lambda (param $env i32) (param $args i32) (result i32)
44 | (local $clauses i32)
45 | (local $clause i32)
46 |
47 | (block $check (block $fail
48 | (br_if $fail (i32.eqz (call $all-list? (local.get $args))))
49 |
50 | ;; check that each clause starts with a valid formals list (same syntax
51 | ;; as for lambda)
52 | (local.set $clauses (local.get $args))
53 | (block $end (loop $start
54 | (br_if $end (i32.eq (local.get $clauses) (global.get $g-nil)))
55 | (%pop-l $clause $clauses)
56 | (br_if $fail (i32.eqz (call $valid-formals? (%car-l $clause))))
57 | (br $start)))
58 |
59 | (br $check))
60 |
61 | (return (call $argument-error (local.get $args))))
62 |
63 | (return
64 | (call $heap-alloc
65 | (global.get $g-heap)
66 | (%case-lambda-type)
67 | (local.get $env)
68 | (local.get $args)))
69 | )
--------------------------------------------------------------------------------
/scheme.wasm/src/library/boolean.wat:
--------------------------------------------------------------------------------
1 | (func $bool-not (param $env i32) (param $args i32) (result i32)
2 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1))
3 | (then (return (call $argument-error (local.get $args))))
4 | )
5 |
6 | (return
7 | (select
8 | (global.get $g-false)
9 | (global.get $g-true)
10 | (call $is-truthy (%car-l $args))
11 | )
12 | )
13 | )
14 |
15 | (func $bool-boolean? (param $env i32) (param $args i32) (result i32)
16 | (local $obj i32)
17 |
18 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1))
19 | (then (return (call $argument-error (local.get $args))))
20 | )
21 |
22 | (local.set $obj (%car-l $args))
23 |
24 | (return
25 | (select
26 | (global.get $g-true)
27 | (global.get $g-false)
28 | (i32.eq (%get-type $obj) (%boolean-type))
29 | )
30 | )
31 | )
32 |
33 | (func $bool-boolean=? (param $env i32) (param $args i32) (result i32)
34 | (local $obj i32)
35 | (local $val i32)
36 |
37 | (if (i32.lt_u (call $list-len (local.get $args)) (i32.const 1))
38 | (then (return (call $argument-error (local.get $args))))
39 | )
40 |
41 | (local.set $obj (%car-l $args))
42 | (if (i32.ne (%get-type $obj) (%boolean-type))
43 | (then (return (global.get $g-false)))
44 | )
45 | (local.set $val (%car-l $obj))
46 | (local.set $args (%cdr-l $args))
47 |
48 | (block $b_end
49 | (loop $b_start
50 | (br_if $b_end (i32.eq (%get-type $args) (%nil-type)))
51 |
52 | (local.set $obj (%car-l $args))
53 | (if (i32.ne (%get-type $obj) (%boolean-type))
54 | (then (return (global.get $g-false)))
55 | )
56 | (if (i32.ne (local.get $val) (%car-l $obj))
57 | (then (return (global.get $g-false)))
58 | )
59 |
60 | (local.set $args (%cdr-l $args))
61 | (br $b_start)
62 | )
63 | )
64 |
65 | (return (global.get $g-true))
66 | )
--------------------------------------------------------------------------------
/scheme.wasm/src/library/process.wat:
--------------------------------------------------------------------------------
1 | ;; (exit [])
2 | ;; (emergency-exit [])
3 | ;;
4 | ;; NOTE: exit and emergency-exit are not equivalent in the spec
5 | ;; when dynamic-wind is implemented these will need to be different
6 | (func $exit (param $env i32) (param $args i32) (result i32)
7 | (local $arg i32)
8 | (local $exit-code i32)
9 |
10 | (if (i32.eq (%get-type $args) (%nil-type))
11 | (then
12 | (local.set $exit-code (i32.const 0)))
13 | (else
14 | (local.set $arg (%car-l $args))
15 | (if (i32.eq (%get-type $arg) (%i64-type)) (then
16 | (local.set $exit-code (i32.wrap_i64 (i64.load offset=4 (local.get $arg))))))
17 | (if (i32.eq (%get-type $arg) (%boolean-type)) (then
18 | (local.set $exit-code
19 | (select
20 | (i32.const 0)
21 | (i32.const 1)
22 | (%car-l $arg)))))))
23 |
24 | (call $process-exit (local.get $exit-code))
25 | (unreachable))
26 |
27 | (func $get-environment-variable (param $env i32) (param $args i32) (result i32)
28 | (local $name i32)
29 | (local $value i32)
30 |
31 | (block $check (block $fail
32 | (br_if $fail (i32.ne (call $list-len (local.get $args)) (i32.const 1)))
33 | (local.set $name (%car-l $args))
34 | (%chk-type $fail $name %str-type)
35 | (br $check))
36 | (return (call $argument-error (local.get $args))))
37 |
38 | (local.set $value (call $process-get-environment-variable (%car-l $name)))
39 | (if (i32.eqz (local.get $value)) (then
40 | (return (global.get $g-false))))
41 | (if (i32.eq (%get-type $value) (%str-type)) (then
42 | (return (local.get $value))))
43 |
44 | (unreachable))
45 |
46 | (func $get-environment-variables (param $env i32) (param $args i32) (result i32)
47 | (local $list i32)
48 |
49 | (if (call $list-len (local.get $args)) (then
50 | (return (call $argument-error (local.get $args)))))
51 |
52 | (local.set $list (call $process-get-environment-variables))
53 | (if (i32.eqz (call $is-list-impl (local.get $list))) (then
54 | (unreachable)))
55 |
56 | (return (local.get $list)))
57 |
58 | (func $set-environment-variable (param $env i32) (param $args i32) (result i32)
59 | (local $name i32)
60 | (local $value i32)
61 |
62 | (block $check (block $fail
63 | (br_if $fail (i32.ne (call $list-len (local.get $args)) (i32.const 2)))
64 | (%pop-l $name $args)
65 | (%chk-type $fail $name %str-type)
66 |
67 | (local.set $value (%car-l $args))
68 | (%chk-type $fail $value %str-type)
69 | (br $check))
70 | (return (call $argument-error (local.get $args))))
71 |
72 | (call $process-set-environment-variable (%car-l $name) (%car-l $value))
73 | (return (global.get $g-nil)))
74 |
75 | (func $command-line (param $env i32) (param $args i32) (result i32)
76 | (local $list i32)
77 |
78 | (if (call $list-len (local.get $args)) (then
79 | (return (call $argument-error (local.get $args)))))
80 |
81 | (local.set $list (call $process-command-line))
82 | (if (i32.eqz (call $is-list-impl (local.get $list))) (then
83 | (unreachable)))
84 | (if (i32.eqz (call $all-string (local.get $list))) (then
85 | (unreachable)))
86 |
87 | (return (local.get $list)))
88 |
89 | (func $version (param $env i32) (param $args i32) (result i32)
90 | (if (i32.ne (local.get $args) (global.get $g-nil)) (then
91 | (return (call $argument-error (local.get $args)))))
92 |
93 | (return (global.get $g-curr-version)))
94 |
95 | (func $panic (param $env i32) (param $args i32) (result i32)
96 | (if (i32.ne (local.get $args) (global.get $g-nil)) (then
97 | (call $print-cons (%car-l $args) (%cdr-l $args) (i32.const 0))))
98 | (unreachable))
99 |
--------------------------------------------------------------------------------
/scheme.wasm/src/library/symbol.wat:
--------------------------------------------------------------------------------
1 | (func $symbol? (param $env i32) (param $args i32) (result i32)
2 | (local $arg i32)
3 |
4 | (if (i32.ne (call $list-len (local.get $args)) (i32.const 1))
5 | (then (return (call $argument-error (local.get $args))))
6 | )
7 |
8 | (local.set $arg (%car-l $args))
9 |
10 | (return
11 | (select
12 | (global.get $g-true)
13 | (global.get $g-false)
14 | (i32.eq (%get-type $arg) (%symbol-type))
15 | )
16 | )
17 | )
18 |
19 | (func $symbol=? (param $env i32) (param $args i32) (result i32)
20 | (local $arg i32)
21 |
22 | (block $b_check (block $b_fail
23 | (br_if $b_fail (i32.eqz (call $list-len (local.get $args))))
24 | (local.set $arg (%car-l $args))
25 | (br_if $b_fail (i32.ne (%get-type $arg) (%symbol-type)))
26 | (br $b_check))
27 |
28 | (return (call $argument-error (local.get $args))))
29 |
30 | (local.set $args (%cdr-l $args))
31 |
32 | (block $b_end (loop $b_start
33 | (br_if $b_end (i32.eq (%get-type $args) (%nil-type)))
34 |
35 | (if (i32.ne (local.get $arg) (%car-l $args)) (then
36 | (return (global.get $g-false))))
37 |
38 | (local.set $args (%cdr-l $args))
39 | (br $b_start)))
40 |
41 | (return (global.get $g-true)))
42 |
43 | (func $symbol->string (param $env i32) (param $args i32) (result i32)
44 | (local $arg i32)
45 | (local $str i32)
46 |
47 | (block $b_check
48 | (block $b_fail
49 | (br_if $b_fail (i32.ne (call $list-len (local.get $args)) (i32.const 1)))
50 | (local.set $arg (%car-l $args))
51 | (br_if $b_fail (i32.ne (%get-type $arg) (%symbol-type)))
52 | (br $b_check)
53 | )
54 | (return (call $argument-error (local.get $args)))
55 | )
56 |
57 | (local.set $arg (%car-l $args))
58 | (local.set $str (%alloc-str (call $str-dup (%car-l $arg))))
59 | (%set-flags $str (%immutable-flag))
60 | (return (local.get $str))
61 | )
62 |
63 | (func $string->symbol (param $env i32) (param $args i32) (result i32)
64 | (local $arg i32)
65 |
66 | (block $b_check
67 | (block $b_fail
68 | (br_if $b_fail (i32.ne (call $list-len (local.get $args)) (i32.const 1)))
69 | (local.set $arg (%car-l $args))
70 | (br_if $b_fail (i32.ne (%get-type $arg) (%str-type)))
71 | (br $b_check)
72 | )
73 | (return (call $argument-error (local.get $args)))
74 | )
75 |
76 | (local.set $arg (%car-l $args))
77 | (return (%alloc-symbol (call $str-dup (%car-l $arg))))
78 | )
79 |
--------------------------------------------------------------------------------
/scheme.wasm/src/library/time.wat:
--------------------------------------------------------------------------------
1 | (func $current-second (param $env i32) (param $args i32) (result i32)
2 | (if (call $list-len (local.get $args)) (then
3 | (return (call $argument-error (local.get $args)))))
4 |
5 | (return (%alloc-f64 (call $time-current-second))))
6 |
7 | (func $current-jiffy (param $env i32) (param $args i32) (result i32)
8 | (if (call $list-len (local.get $args)) (then
9 | (return (call $argument-error (local.get $args)))))
10 |
11 | (return (%alloc-f64 (call $time-current-jiffy))))
12 |
13 | (func $jiffies-per-second (param $env i32) (param $args i32) (result i32)
14 | (if (call $list-len (local.get $args)) (then
15 | (return (call $argument-error (local.get $args)))))
16 |
17 | (return (%alloc-f64 (call $time-jiffies-per-second))))
18 |
--------------------------------------------------------------------------------
/scheme.wasm/src/quote.wat:
--------------------------------------------------------------------------------
1 | (func $quote (param $env i32) (param $args i32) (result i32)
2 | (local $tail i32)
3 | (local.set $tail (%cdr-l $args))
4 | (%assert-nil $tail)
5 | (return (%car-l $args))
6 | )
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/guard.scm:
--------------------------------------------------------------------------------
1 | (define-syntax call-with-values
2 | (syntax-rules ()
3 | ((call-with-values producer consumer)
4 | ((lambda ()
5 | (define-values els (producer))
6 | (apply consumer els))))))
7 |
8 |
9 | (define-syntax guard
10 | (syntax-rules ()
11 | ((guard (var clause ...) e1 e2 ...)
12 | ((call/cc
13 | (lambda (guard-k)
14 | (with-exception-handler
15 | (lambda (condition)
16 | ((call/cc
17 | (lambda (handler-k)
18 | (guard-k
19 | (lambda ()
20 | (let ((var condition))
21 | (guard-aux
22 | (handler-k
23 | (lambda () (raise-continuable var)))
24 | clause ...))))))))
25 | (lambda ()
26 | (call-with-values
27 | (lambda () e1 e2 ...)
28 | (lambda args
29 | (guard-k
30 | (lambda () (apply values args)))))))))))))
31 |
32 | (define-syntax guard-aux
33 | (syntax-rules (else =>)
34 | ((guard-aux reraise (else result1 result2 ...))
35 | (begin result1 result2 ...))
36 | ((guard-aux reraise (test => result))
37 | (let ((temp test))
38 | (if temp
39 | (result temp)
40 | reraise)))
41 | ((guard-aux reraise (test => result) clause1 clause2 ...)
42 | (let ((temp test))
43 | (if temp
44 | (result temp)
45 | (guard-aux reraise clause1 clause2 ...))))
46 | ((guard-aux reraise (test))
47 | (or test reraise))
48 | ((guard-aux reraise (test) clause1 clause2 ...)
49 | (let ((temp test))
50 | (if temp
51 | temp
52 | (guard-aux reraise clause1 clause2 ...))))
53 | ((guard-aux reraise (test result1 result2 ...))
54 | (if test
55 | (begin result1 result2 ...)
56 | reraise))
57 | ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
58 | (if test
59 | (begin result1 result2 ...)
60 | -aux reraise clause1 clause2 ...)))))
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/lazy.scm:
--------------------------------------------------------------------------------
1 | (define-syntax delay-force
2 | (syntax-rules ()
3 | ((delay-force expression)
4 | (make-promise #f (lambda () expression)))))
5 |
6 | (define-syntax delay
7 | (syntax-rules ()
8 | ((delay expression)
9 | (delay-force (make-promise #t expression)))))
10 |
11 | (define-syntax make-promise
12 | (syntax-rules ()
13 | ((make-promise obj)
14 | (let ((val obj))
15 | (if (promise? val)
16 | val
17 | (list ' #t val))))
18 | ((make-promise done? obj)
19 | (let ((val obj))
20 | (list ' done? val)))))
21 |
22 | (define (force promise)
23 | (if (not (promise? promise)) (error "not-promise" promise))
24 | (if (promise-done? promise)
25 | (promise-value promise)
26 | (let ((promise* ((promise-value promise))))
27 | (unless (promise-done? promise)
28 | (promise-update! promise* promise))
29 | (force promise))))
30 |
31 | (define (promise? x) (and (pair? x) (eq? ' (car x))))
32 | (define (promise-done? x) (cadr x))
33 | (define (promise-value x) (caddr x))
34 | (define (promise-update! new old)
35 | (if (not (and (promise? new) (promise? old))) (error "not-promise" new old))
36 | (set-car! (cdr old) (promise-done? new))
37 | (set-car! (cddr old) (promise-value new))
38 | (set-car! new (car old)))
39 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/numerics.scm:
--------------------------------------------------------------------------------
1 | (define number? complex?)
2 |
3 | (define (exact-integer? x) (and (exact? x) (integer? x)))
4 |
5 | (define (zero? x) (= x 0))
6 | (define (positive? x) (> x 0))
7 | (define (negative? x) (< x 0))
8 | (define (even? x) (cond
9 | ((integer? x) (zero? (floor-remainder (abs x) 2)))
10 | (else (error "invalid integer"))))
11 | (define (odd? x) (not (even? x)))
12 |
13 | (define (make-polar r a) (make-rectangular (* r (cos a)) (* r (sin a))))
14 | (define (magnitude z)
15 | (let ((r (real-part z))
16 | (i (imag-part z)))
17 | (sqrt (+ (* r r) (* i i)))))
18 | (define (angle z) (atan (imag-part z) (real-part z)))
19 |
20 | (define-syntax max
21 | (syntax-rules ()
22 | ((max a) a)
23 | ((max a b)
24 | (let ((x a) (y b))
25 | (if (not (eq? (inexact? x) (inexact? y)))
26 | (max (inexact x) (inexact y))
27 | (if (>= x y) x y))))
28 | ((max a b c ...) (max (max a b) c ...))))
29 |
30 | (define-syntax min
31 | (syntax-rules ()
32 | ((min a) a)
33 | ((min a b)
34 | (let ((x a) (y b))
35 | (if (not (eq? (inexact? x) (inexact? y)))
36 | (min (inexact x) (inexact y))
37 | (if (<= x y) x y))))
38 | ((min a b c ...) (min (min a b) c ...))))
39 |
40 | (define modulo floor-remainder)
41 |
42 | (define (gcd . lst)
43 | (if (null? lst)
44 | 0
45 | (letrec ((gcd-core (lambda (a b)
46 | (if (zero? b)
47 | a
48 | (if (> a b)
49 | (gcd-core b (floor-remainder a b))
50 | (gcd-core a (floor-remainder b a))))))
51 | (result (abs (car lst))))
52 | (for-each
53 | (lambda (x) (set! result (gcd-core result (abs x))))
54 | (cdr lst))
55 | result)))
56 |
57 | (define (lcm . lst)
58 | (if (null? lst)
59 | 1
60 | (letrec ((lcm-core (lambda (a b)
61 | (if (or (zero? a) (zero? b))
62 | (+ a b)
63 | (* a (truncate-quotient b (gcd a b))))))
64 | (result (abs (car lst))))
65 | (for-each
66 | (lambda (x) (set! result (lcm-core result (abs x))))
67 | (cdr lst))
68 | result)))
69 |
70 | (define (square x) (* x x))
71 | (define (expt a b)
72 | (cond
73 | ((zero? a)
74 | (cond
75 | ((zero? b) 1)
76 | ((positive? (real-part b)) 0)
77 | (else (error "invalid expt"))))
78 | ((and (integer? b) (positive? b))
79 | (* a (expt a (- b 1))))
80 | ((and (integer? b) (zero? b)) 1)
81 | ((integer? b)
82 | (/ (expt a (- b))))
83 | (else (exp (* b (log a))))))
84 | (define (sqrt x)
85 | (cond
86 | ((zero? x) 0)
87 | ((and (integer? x) (positive? x))
88 | (let-values (((root rem) (exact-integer-sqrt x)))
89 | (if (zero? rem)
90 | root
91 | (expt x 0.5))))
92 | ((integer? x) (make-rectangular 0 (sqrt (abs x))))
93 | (else (expt x 0.5))))
94 | (define pi (* 4 (atan 1)))
95 | (define (acos x) (- (* pi 0.5) (asin x)))
96 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/pair.scm:
--------------------------------------------------------------------------------
1 | (define (caar x) (car (car x)))
2 | (define (cadr x) (car (cdr x)))
3 | (define (cdar x) (cdr (car x)))
4 | (define (cddr x) (cdr (cdr x)))
5 |
6 | (define (caaar x) (car (car (car x))))
7 | (define (caadr x) (car (car (cdr x))))
8 | (define (cadar x) (car (cdr (car x))))
9 | (define (caddr x) (car (cdr (cdr x))))
10 | (define (cdaar x) (cdr (car (car x))))
11 | (define (cdadr x) (cdr (car (cdr x))))
12 | (define (cddar x) (cdr (cdr (car x))))
13 | (define (cdddr x) (cdr (cdr (cdr x))))
14 |
15 | (define (caaaar x) (car (car (car (car x)))))
16 | (define (caaadr x) (car (car (car (cdr x)))))
17 | (define (caadar x) (car (car (cdr (car x)))))
18 | (define (caaddr x) (car (car (cdr (cdr x)))))
19 | (define (cadaar x) (car (cdr (car (car x)))))
20 | (define (cadadr x) (car (cdr (car (cdr x)))))
21 | (define (caddar x) (car (cdr (cdr (car x)))))
22 | (define (cadddr x) (car (cdr (cdr (cdr x)))))
23 | (define (cdaaar x) (cdr (car (car (car x)))))
24 | (define (cdaadr x) (cdr (car (car (cdr x)))))
25 | (define (cdadar x) (cdr (car (cdr (car x)))))
26 | (define (cdaddr x) (cdr (car (cdr (cdr x)))))
27 | (define (cddaar x) (cdr (cdr (car (car x)))))
28 | (define (cddadr x) (cdr (cdr (car (cdr x)))))
29 | (define (cdddar x) (cdr (cdr (cdr (car x)))))
30 | (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
31 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/prelude.scm:
--------------------------------------------------------------------------------
1 | (define have-prelude? #f)
2 | (cond
3 | ((not have-prelude?)
4 | (include
5 | "lazy.scm"
6 | "pair.scm"
7 | "numerics.scm"
8 | "port.scm"
9 | "procedures.scm"
10 | "guard.scm")
11 | (for-each display (list "Version: " (version) #\newline))
12 | (display "Loaded prelude")
13 | (set! have-prelude? #t))
14 | (else
15 | (display "\x1B;[0;31mprelude has already been loaded!\x1B;[0m")))
16 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/procedures.scm:
--------------------------------------------------------------------------------
1 | (define string-for-each
2 | (lambda (proc . args)
3 | (apply for-each proc (map string->list args))))
4 |
5 | (define vector-for-each
6 | (lambda (proc . args)
7 | (apply for-each proc (map vector->list args))))
8 |
9 | (define call-with-current-continuation call/cc)
10 | (define emergency-exit exit)
11 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/boolean.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test boolean operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "boolean"
8 | (test-case "(boolean? )" (lambda ()
9 | (assert (boolean? #t))
10 | (assert (boolean? #f))
11 | (assert (boolean? #true))
12 | (assert (boolean? #false))
13 | (assert-not (boolean? 0))
14 | (assert-not (boolean? '()))))
15 |
16 | (test-case "(boolean=? ...)" (lambda ()
17 | (assert (boolean=? #t #true (= 1 1)))
18 | (assert (boolean=? #f #false (= 1 2)))
19 | (assert-not (boolean=? #t #f))
20 | (assert-not (boolean=? 1 2))))
21 |
22 | (test-case "(not )" (lambda ()
23 | (assert-not (not #t))
24 | (assert-not (not 3))
25 | (assert-not (not (list 3)))
26 | (assert (not #f))
27 | (assert-not (not '()))
28 | (assert-not (not (list)))
29 | (assert-not (not 'nil))))
30 | )
31 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/bytevector.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test bytevector operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "bytevector"
8 | (test-case "(bytevector? )" (lambda ()
9 | (assert (bytevector? #u8()))
10 | (assert (bytevector? #u8(1 2 3)))
11 | (assert-not (bytevector? 0))
12 | (assert-not (bytevector? '()))))
13 |
14 | (test-case "(equal? )" (lambda ()
15 | (assert-equal #u8(#x66 #x69 #x69) #u8(102 105 105))))
16 |
17 | (test-case "(make-bytevector [])" (lambda ()
18 | (assert-equal (make-bytevector 2 12) #u8(12 12))
19 | (assert-equal (bytevector-length (make-bytevector 14)) 14)))
20 |
21 | (test-case "(bytevector ...)" (lambda ()
22 | (assert-equal (bytevector 1 3 5 1 3 5) #u8(1 3 5 1 3 5))
23 | (assert-equal (bytevector) #u8())))
24 |
25 | (test-case "(bytevector-length )" (lambda ()
26 | (assert-equal (bytevector-length (bytevector)) 0)
27 | (assert-equal (bytevector-length #u8(1 1 2 3 5 8 13 21)) 8)))
28 |
29 | (test-case "(bytevector-u8-ref )" (lambda ()
30 | (assert-equal (bytevector-u8-ref #u8(1 1 2 3 5 8 13 21) 5) 8)))
31 |
32 | (test-case "(bytevector-u8-set! )" (lambda ()
33 | (let ((bv (bytevector 1 2 3 4)))
34 | (bytevector-u8-set! bv 1 3)
35 | (assert-equal bv #u8(1 3 3 4)))))
36 |
37 | (test-case "(bytevector-copy [ []])" (lambda ()
38 | (let ((bv #u8(1 2 3 4 5)))
39 | (assert-equal (bytevector-copy bv) #u8(1 2 3 4 5))
40 | (assert-equal (bytevector-copy bv 2) #u8(3 4 5))
41 | (assert-equal (bytevector-copy bv 2 4) #u8(3 4)))))
42 |
43 | (test-case "(bytevector-copy! [ []])" (lambda ()
44 | (let ((a #u8(1 2 3 4 5))
45 | (b #u8(10 20 30 40 50)))
46 | (bytevector-copy! b 1 a 0 2)
47 | (assert-equal b #u8(10 1 2 40 50)))))
48 |
49 | (test-case "(bytevector-append ...)" (lambda ()
50 | (assert-equal (bytevector-append #u8(0 1 2) #u8(3 4 5))
51 | #u8(0 1 2 3 4 5))))
52 |
53 | (test-case "(utf8->string [ []])" (lambda ()
54 | (assert-equal (utf8->string #u8(#x46 #x6f #x6f)) "Foo")
55 | (assert-equal (utf8->string #u8(#x42 #x61 #x72) 1) "ar")
56 | (assert-equal (utf8->string #u8(#x42 #x61 #x72) 1 2) "a")))
57 |
58 | (test-case "(string->utf8 )" (lambda ()
59 | (assert-equal (string->utf8 "Foo") #u8(70 111 111))
60 | (assert-equal (string->utf8 "λ") #u8(#xCE #xBB))))
61 | )
62 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/case-lambda.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test case-lambda
3 | |#
4 |
5 | (if (not (procedure? assert))
6 | (include "test/test.scm"))
7 |
8 | (run-tests "case-lambda"
9 | (test-case "(case-lambda ...)" (lambda ()
10 | (define range (case-lambda
11 | ((a) (range 0 a 1))
12 | ((a b) (range a b 1))
13 | ((a b c) (letrec ((fn (lambda (x)
14 | (if (>= x b)
15 | '()
16 | (cons x (fn (+ x c)))))))
17 | (fn a)))))
18 |
19 | (assert-equal (range 4) '(0 1 2 3))
20 | (assert-equal (range 2 4) '(2 3))
21 | (assert-equal (range 4 2) '())
22 | (assert-equal (range 2 10 3) '(2 5 8))
23 | (assert-error (range 1 2 3 4))))
24 | )
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/complex.spec.scm:
--------------------------------------------------------------------------------
1 | (if (not (procedure? assert))
2 | (include "test/test.scm"))
3 |
4 | (run-tests "complex"
5 | (test-case "(make-rectangular )" (lambda ()
6 | (assert-equal (make-rectangular 1 2) 1+2i)
7 | (assert-equal (make-rectangular 1 0) 1)
8 | (assert-equal (make-rectangular +inf.0 -inf.0) +inf.0-inf.0i)
9 | (assert-equal (make-rectangular 1.23 -4/5) 1.23-4/5i)))
10 |
11 | (test-case "(real-part )" (lambda ()
12 | (assert-equal (real-part 1+2i) 1)
13 | (assert-equal (real-part +inf.0-nan.0i) +inf.0)
14 | (assert-equal (real-part 1.23-4/5i) 1.23)
15 | (assert-equal (real-part 7) 7)))
16 |
17 | (test-case "(imag-part )" (lambda ()
18 | (assert-equal (imag-part 1+2i) 2)
19 | (assert (nan? (real-part +nan.0-nan.0i)))
20 | (assert-equal (imag-part 1.23-4/5i) -4/5)
21 | (assert-equal (imag-part 7) 0)))
22 | )
23 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/conditionals.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test conditional operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "control"
8 | (test-case "(cond ...)" (lambda ()
9 | (assert-equal
10 | (cond ((> 3 2) 'greater)
11 | ((< 3 2) 'less))
12 | 'greater)
13 | (assert-equal
14 | (cond ((> 3 3) 'greater)
15 | ((< 3 3) 'less)
16 | (else 'equal))
17 | 'equal)
18 | (assert-equal
19 | (cond ((assv 'b '((a 1) (b 2))) => cadr)
20 | (else #f))
21 | 2)))
22 |
23 | (test-case "(case ...)" (lambda ()
24 | (assert-equal
25 | (case (* 2 3)
26 | ((2 3 5 7) 'prime)
27 | ((1 4 6 8 9) 'composite))
28 | 'composite)
29 | (assert-equal
30 | (case (car '(c d))
31 | ((a) 'a)
32 | ((b) 'b)
33 | (else 'unknown))
34 | 'unknown)
35 | (assert-equal
36 | (case (car '(a b))
37 | ((a e i o u) 'vowel)
38 | ((w y) 'semivowel)
39 | (else => (lambda (x) x)))
40 | 'vowel)
41 | (assert-equal
42 | (case (car '(c d))
43 | ((a e i o u) 'vowel)
44 | ((w y) 'semivowel)
45 | (else => (lambda (x) x)))
46 | 'c)))
47 |
48 | (test-case "(and ...)" (lambda ()
49 | (assert (and (= 2 2) (> 2 1)))
50 | (assert-not (and (= 2 2) (< 2 1)))
51 | (assert-equal (and 1 2 'c '(f g)) '(f g))
52 | (assert (and))))
53 |
54 | (test-case "(or ...)" (lambda ()
55 | (assert (or (= 2 2) (> 2 1)))
56 | (assert (or (= 2 2) (< 2 1)))
57 | (assert-not (or #f #f #f))
58 | (assert-equal (or (memq 'b '(a b c)) (/ 3 0)) '(b c))
59 | (assert-not (or))))
60 |
61 | (test-case "(when ...)" (lambda ()
62 | (define x 0)
63 | (define y 0)
64 | (when (= 1 1)
65 | (set! x 1)
66 | (set! y 2))
67 | (assert-equal x 1)
68 | (assert-equal y 2)
69 |
70 | (when (= 1 0)
71 | (set! x 2)
72 | (set! y 1))
73 | (assert-equal x 1)
74 | (assert-equal y 2)))
75 |
76 | (test-case "(unless ...)" (lambda ()
77 | (define x 0)
78 | (define y 0)
79 | (unless (= 1 1)
80 | (set! x 1)
81 | (set! y 2))
82 | (assert-equal x 0)
83 | (assert-equal y 0)
84 |
85 | (unless (= 1 0)
86 | (set! x 2)
87 | (set! y 1))
88 | (assert-equal x 2)
89 | (assert-equal y 1)))
90 |
91 | #|
92 | | (test-case "(cond-expand ...)" (lambda ()
93 | | ; Implement test for cond-expand when cond-expand has been implemented.
94 | | ))
95 | |#
96 | )
97 | ))
98 | )
99 |
100 |
101 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/control.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test control operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "control"
8 | (test-case "(procedure? )" (lambda ()
9 | (assert (procedure? car))
10 | (assert-not (procedure? 'car))
11 | (assert (procedure? (lambda (x) (* x x))))
12 | (assert-not (procedure? '(lambda (x) (* x x))))
13 | (assert (call-with-current-continuation procedure?))))
14 |
15 | (test-case "(apply ... )" (lambda ()
16 | (assert-equal (apply + (list 3 4)) 7)
17 | (assert-equal (apply + 1 2 (list 3 4)) 10)
18 | (define compose
19 | (lambda (f g)
20 | (lambda args
21 | (f (apply g args)))))
22 | (assert-equal ((compose sqrt *) 12 75) 30)))
23 |
24 | (test-case "(map ...)" (lambda ()
25 | (assert-equal (map cadr '((a b) (d e) (g h))) '(b e h))
26 | (assert-equal
27 | (map (lambda (n) (expt n n)) '(1 2 3 4 5))
28 | '(1 4 27 256 3125))
29 | (assert-equal
30 | (map + '(1 2 3) '(4 5 6 7))
31 | '(5 7 9))
32 |
33 | (define counts
34 | (let ((count 0))
35 | (map (lambda (ignored)
36 | (set! count (+ count 1))
37 | count)
38 | '(a b c))))
39 | (assert (or (equal? counts '(1 2 3))
40 | (equal? counts '(3 2 1))) counts)))
41 |
42 | (test-case "(string-map ...)" (lambda ()
43 | (assert-equal (string-map char-foldcase "AbdEgH") "abdegh")
44 | (assert-equal
45 | (string-map
46 | (lambda (c) (integer->char (+ 1 (char->integer c))))
47 | "HAL")
48 | "IBM")
49 | (assert-equal
50 | (string-map
51 | (lambda (c k) ((if (eqv? k #\u) char-upcase char-downcase) c))
52 | "studlycaps xxx"
53 | "ululululul")
54 | "StUdLyCaPs")))
55 |
56 | (test-case "(vector-map ...)" (lambda ()
57 | (assert-equal (vector-map cadr #((a b) (d e) (g h))) #(b e h))
58 | (assert-equal
59 | (vector-map (lambda (n) (expt n n)) #(1 2 3 4 5))
60 | #(1 4 27 256 3125))
61 | (assert-equal
62 | (vector-map + #(1 2 3) #(4 5 6 7))
63 | #(5 7 9))
64 |
65 | (define counts
66 | (let ((count 0))
67 | (vector-map (lambda (ignored)
68 | (set! count (+ count 1))
69 | count)
70 | #(a b c))))
71 | (assert (or (equal? counts #(1 2 3))
72 | (equal? counts #(3 2 1))) counts)))
73 |
74 | (test-case "(for-each ...)" (lambda ()
75 | (let ((v (make-vector 5)))
76 | (for-each
77 | (lambda (i) (vector-set! v i (* i i)))
78 | '(0 1 2 3 4))
79 | (assert-equal v #(0 1 4 9 16)))))
80 |
81 | (test-case "(string-for-each ...)" (lambda ()
82 | (let ((v '()))
83 | (string-for-each
84 | (lambda (c) (set! v (cons (char->integer c) v)))
85 | "abcde")
86 | (assert-equal v '(101 100 99 98 97)))))
87 |
88 | (test-case "(vector-for-each ...)" (lambda ()
89 | (let ((v (make-vector 5)))
90 | (vector-for-each
91 | (lambda (i) (vector-set! v i (* i i)))
92 | #(0 1 2 3 4))
93 | (assert-equal v #(0 1 4 9 16)))))
94 |
95 | (test-case "call-with-current-continuation" (lambda ()
96 | (assert-equal
97 | (call-with-current-continuation
98 | (lambda (exit)
99 | (for-each
100 | (lambda (x) (if (negative? x) (exit x)))
101 | '(54 0 37 -3 245 19))
102 | #t))
103 | -3)
104 |
105 | (define list-length
106 | (lambda (obj)
107 | (call/cc
108 | (lambda (return)
109 | (letrec ((r (lambda (obj)
110 | (cond ((null? obj) 0)
111 | ((pair? obj) (+ (r (cdr obj)) 1))
112 | (else (return #f))))))
113 | (r obj))))))
114 |
115 | (assert-equal (list-length '(1 2 3 4)) 4)
116 | (assert-equal (list-length '(a b . c)) #f)))
117 | )
118 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/equivalence.spec.scm:
--------------------------------------------------------------------------------
1 | (if (not (procedure? assert))
2 | (include "test/test.scm"))
3 |
4 | (run-tests "equivalence"
5 | (test-case "(eqv? )" (lambda ()
6 | (assert (eqv? 'a 'a))
7 | (assert-not (eqv? 'a 'b))
8 | (assert (eqv? 2 2))
9 | (assert-not (eqv? 2 2.0))
10 | (assert (eqv? '() '()))
11 | (assert (eqv? #t #t))
12 | (assert-not (eqv? #t #f))
13 | (assert (eqv? #f #f))
14 | (assert-not (eqv? #\A #\a))
15 | (assert (eqv? #\a #\a))
16 | (assert (eqv? #\δ #\x3b4))
17 | (assert (eqv? 100000000 100000000))
18 | (assert-not (eqv? 0.0 +nan.0))
19 | (assert-not (eqv? (cons 1 2) (cons 1 2)))
20 | (assert-not (eqv? (lambda () 1) (lambda () 2)))
21 | (let ((p (lambda (x) x)))
22 | (assert (eqv? p p) " p <== (lambda (x) x)"))
23 | (assert-not (eqv? #f 'nil))
24 |
25 | (define gen-counter
26 | (lambda ()
27 | (let ((n 0))
28 | (lambda () (set! n (+ 1 n)) n))))
29 | (let ((g (gen-counter)))
30 | (assert (eqv? g g) "same instances of the lambda should be the same"))
31 | (assert-not (eqv? (gen-counter) (gen-counter)) "difference instnace should be different")
32 |
33 | (letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
34 | (g (lambda () (if (eqv? f g) 'both 'g))))
35 | (assert-not (eqv? f g)))
36 |
37 | (let ((x '(a)))
38 | (assert (eqv? x x)))))
39 |
40 | (test-case "(eq? )" (lambda ()
41 | (assert (eq? 'a 'a))
42 | (assert-not (eq? 'a 'b))
43 | (assert (eq? #t #t))
44 | (assert-not (eq? #t #f))
45 | (assert (eq? #f #f))
46 | (assert (eq? () ()))
47 | (assert-not (eq? (cons 1 2) (cons 1 2)))
48 | (let ((p (lambda (x) x)))
49 | (assert (eq? p p) " p <== (lambda (x) x)"))
50 |
51 | (let ((x '(a)))
52 | (assert (eq? x x)))))
53 |
54 | (test-case "(equal? )" (lambda ()
55 | (assert (equal? 'a 'a))
56 | (assert (equal? '(a) '(a)))
57 | (assert (equal? '(a (b) c) '(a (b) c)))
58 | (assert (equal? "abc" "abc"))
59 | (assert (equal? 2 2))
60 | (assert (equal? (make-vector 5 'a) (make-vector 5 'a)))
61 | ; TODO implement labels
62 | ; (assert (equal? '#1=(a b . #1#) '#2=(a b a b . #2#)))
63 | (assert (equal? (lambda (x) x) (lambda (x) x)))
64 | ))
65 | )
66 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/exceptions.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test exceptions.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "exceptions"
8 | (test-case "(with-exception-handler )" (lambda ()
9 | (assert-equal
10 | (call-with-current-continuation
11 | (lambda (cont)
12 | (with-exception-handler
13 | (lambda (ex)
14 | (cont 'exception))
15 | (lambda ()
16 | (+ 1 (raise 'an-error))))))
17 | 'exception)))
18 |
19 | (test-case "(raise )" (lambda ()
20 | (assert-error (raise 'an-error))))
21 |
22 | (test-case "(raise-continuable )" (lambda ()
23 | (assert-equal
24 | (with-exception-handler
25 | (lambda (ex) 'handled)
26 | (lambda () (raise-continuable 'an-error)))
27 | 'handled)))
28 |
29 | (test-case "(error ...)" (lambda ()
30 | (assert
31 | (error-object?
32 | (call-with-current-continuation (lambda (cont)
33 | (with-exception-handler
34 | (lambda (ex) (cont ex))
35 | (lambda () (error "an error")))))))
36 | (assert-not
37 | (error-object?
38 | (call-with-current-continuation (lambda (cont)
39 | (with-exception-handler
40 | (lambda (ex) (cont ex))
41 | (lambda () (raise "an error")))))))))
42 |
43 | (test-case "(error-object-message )" (lambda ()
44 | (assert-equal
45 | (error-object-message
46 | (call-with-current-continuation (lambda (cont)
47 | (with-exception-handler
48 | (lambda (ex) (cont ex))
49 | (lambda () (error "an error"))))))
50 | "an error")))
51 |
52 | (test-case "(error-object-irritants )" (lambda ()
53 | (assert-equal
54 | (error-object-irritants
55 | (call-with-current-continuation (lambda (cont)
56 | (with-exception-handler
57 | (lambda (ex) (cont ex))
58 | (lambda () (error "an error" 'foo 'bar 123))))))
59 | '(foo bar 123))
60 | (assert-equal
61 | (error-object-irritants
62 | (call-with-current-continuation (lambda (cont)
63 | (with-exception-handler
64 | (lambda (ex) (cont ex))
65 | (lambda () (error "an error"))))))
66 | '())))
67 |
68 | (test-case "(guard ( ...) )" (lambda ()
69 | (assert-equal
70 | (guard (condition
71 | ((assq 'a condition) => cdr)
72 | ((assq 'b condition)))
73 | (raise (list (cons 'a 42))))
74 | 42)
75 | (assert-equal
76 | (guard (condition
77 | ((assq 'a condition) => cdr)
78 | ((assq 'b condition)))
79 | (raise (list (cons 'b 23))))
80 | '(b . 23))
81 | (assert-error
82 | (guard (condition
83 | ((assq 'a condition) => cdr)
84 | ((assq 'b condition)))
85 | (raise (list (cons 'c 7)))))))
86 | )
87 | )
88 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/include-ci.spec.scm:
--------------------------------------------------------------------------------
1 | (if (not (procedure? assert))
2 | (include "test/test.scm"))
3 |
4 | (run-tests "include-ci"
5 | (test-case "loads upper case file" (lambda ()
6 | (include-ci "test/include-ci.test.scm")
7 | (assert (procedure? fact))
8 | (assert-equal (fact 10) 3628800))))
9 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/include-ci.test.scm:
--------------------------------------------------------------------------------
1 | #| This file is designed to be included with include-ci |#
2 |
3 | (DEFINE (FACT X)
4 | (LETREC ((INNER (LAMBDA (A N)
5 | (IF (= N 1)
6 | A
7 | (INNER (* A N) (- N 1))))))
8 | (INNER 1 X)))
9 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/lazy.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test lazy operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "lazy"
8 | (test-case "delay, delay-force, and force" (lambda ()
9 | (assert-equal (force (delay (+ 1 2))) 3)
10 |
11 | (let ((p (delay (+ 1 2))))
12 | (assert-equal (force p) 3)
13 | (assert-equal (force p) 3))
14 |
15 | (define integers
16 | (letrec ((next
17 | (lambda (n)
18 | (delay (cons n (next (+ 1 n)))))))
19 | (next 0)))
20 | (define (head stream) (car (force stream)))
21 | (define (tail stream) (cdr (force stream)))
22 |
23 | (assert-equal (head (tail (tail integers))) 2)
24 |
25 | (define (stream-filter p? s)
26 | (delay-force
27 | (if (null? (force s))
28 | (delay '())
29 | (let ((h (car (force s)))
30 | (t (cdr (force s))))
31 | (if (p? h)
32 | (delay (cons h (stream-filter p? t)))
33 | (stream-filter p? t))))))
34 | (assert-equal (head (tail (tail (stream-filter odd? integers)))) 5)
35 |
36 | (define count 0)
37 | (define p
38 | (delay (begin (set! count (+ count 1))
39 | (if (> count x)
40 | count
41 | (force p)))))
42 | (define x 5)
43 | (assert (promise? p) "p should be a promise, not: " p)
44 | (assert-equal (force p) 6)
45 | (assert (promise? p) "p should still be a promise, not: " p)
46 | (begin (set! x 10)
47 | (assert-equal (force p) 6))))
48 |
49 | (test-case "(promise? )" (lambda ()
50 | (assert (promise? (delay 1)))
51 | (assert (promise? (delay-force 1)))
52 | (assert (promise? (make-promise 1)))
53 | (assert-not (promise? 1))
54 | (assert-not (promise? #t))))
55 |
56 | (test-case "(make-promise )" (lambda ()
57 | (define x 2)
58 | (define p (make-promise (+ 1 x)))
59 | (assert (promise? p))
60 | (set! x 3)
61 | (assert-equal (force p) 3)
62 |
63 | (define pp (delay (+ 1 x)))
64 | (assert (promise? pp))
65 | (set! x 7)
66 | (assert-equal (force pp) 8)))
67 | )
68 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/pair.spec.scm:
--------------------------------------------------------------------------------
1 | (if (not (procedure? assert))
2 | (include "test/test.scm"))
3 |
4 | (run-tests "list and pair"
5 |
6 | (test-case "(pair? )" (lambda ()
7 | (assert (pair? '(a . b)) "'(a . b) is a pair")
8 | (assert (pair? '(a b c)) "'(a b c) is a pair")
9 | (assert-not (pair? '()) "'() is not a pair")
10 | (assert-not (pair? '#(a b)) "'#(a b) is not a pair")
11 | ))
12 |
13 | (test-case "(cons )" (lambda ()
14 | (assert-equal (cons 'a '()) '(a) "(cons 'a '()) is (a)")
15 | (assert-equal (cons 'a '(b c d)) '(a b c d) "(cons 'a '(b c d)) is (a b c d)")
16 | (assert-equal (cons "a" '(b c)) '("a" b c) "(cons \"a\" '(b c)) is (\"a\" b c)")
17 | (assert-equal (cons 'a 3) '(a . 3) "(cons 'a 3) is (a . 3)")
18 | (assert-equal (cons '(a b) 'c) '((a b) . c) "(cons '(a b) 'c) is ((a b) . c)")))
19 |
20 | (test-case "(car )" (lambda ()
21 | (assert-equal (car '(a b c)) 'a "(car '(a b c)) is a")
22 | (assert-equal (car '((a) b c d)) '(a) "(car '((a) b c d)) is (a)")
23 | (assert-equal (car '(1 . 2)) 1 "(car '(1 . 2)) is 1")
24 | (assert-error (car '()) "(car '()) is an error")))
25 |
26 | (test-case "(cdr )" (lambda ()
27 | (assert-equal (cdr '(a b c)) '(b c) "(cdr '(a b c)) is (b c)")
28 | (assert-equal (cdr '((a) b c d)) '(b c d) "(cdr '((a) b c d)) is (b c d)")
29 | (assert-equal (cdr '(1 . 2)) 2 "(cdr '(1 . 2)) is 2")
30 | (assert-error (cdr '()) "(cdr '()) is an error")))
31 |
32 | (test-case "(set-car! )" (lambda ()
33 | (define f (list 'not-a-constant-list))
34 | (define g '(constant-list))
35 | (set-car! f 3)
36 | (assert-equal f '(3) "set-car! sets the first item on the cons")
37 | (assert-error (set-car! g 3) "cannot set-car! on a constant list")))
38 |
39 | (test-case "(null? )" (lambda ()
40 | (assert (null? ()) "(null? ()) is true")
41 | (assert-not (null? '(a b)) "(null? (a b)) is false")))
42 |
43 | (test-case "(list? )" (lambda ()
44 | (assert (list? '(a b c)) "(list? '(a b c)) is true")
45 | (assert (list? '()) "(list? '()) is true")
46 | (assert-not (list? '(a . b)) "(list? '(a . b)) is false")
47 | (let ((x (list 'a)))
48 | (set-cdr! x x)
49 | (assert-not (list? x) "list? on a circular list is false"))))
50 |
51 | (test-case "(make-list )" (lambda ()
52 | (assert-equal (make-list 2 3) '(3 3) "(make-list 2 3) is (3 3)")))
53 |
54 | (test-case "(list ...)" (lambda ()
55 | (assert-equal (list 'a (+ 3 4) 'c) '(a 7 c) "(list 'a (+ 3 4) 'c) is (a 7 c)")
56 | (assert-equal (list) '() "(list) is ()")))
57 |
58 | (test-case "(length )" (lambda ()
59 | (assert-equal (length '(a b c)) 3 "(length '(a b c)) is 3")
60 | (assert-equal (length '(a (b) (c d e))) 3 "(length '(a (b) (c d e))) is 3")
61 | (assert-equal (length '()) 0 "(length '()) is 0")))
62 |
63 | (test-case "(append ...)" (lambda ()
64 | (assert-equal (append '(x) '(y)) '(x y) "(append '(x) '(y)) is (x y)")
65 | (assert-equal (append '(a) '(b c d)) '(a b c d) "(append '(a) '(b c d)) is (a b c d)")
66 | (assert-equal (append '(a (b)) '((c))) '(a (b) (c)) "(append '(a (b)) '((c))) is (a (b) (c))")
67 | (assert-equal (append '(a b) '(c . d)) '(a b c . d) "(append '(a b) '(c . d)) is (a b c . d)")
68 | (assert-equal (append '() 'a) 'a "(append '() 'a) is a")))
69 |
70 | (test-case "(reverse )" (lambda ()
71 | (assert-equal (reverse '(a b c)) '(c b a) "(reverse '(a b c))")
72 | (assert-equal (reverse '(a (b c) d (e (f)))) '((e (f)) d (b c) a) "(reverse '(a (b c) d (e (f))))")))
73 |
74 | (test-case "(list-tail )" (lambda ()
75 | (assert-equal (list-tail '(a b c d) 2) '(c d) "(list-tail '(a b c d))")))
76 |
77 | (test-case "(list-ref )" (lambda ()
78 | (assert-equal (list-ref '(a b c d) 2) 'c "(list-ref '(a b c d))")
79 | (assert-equal (list-ref '(a b c d) (exact (round 1.8))) 'c "(list-ref '(a b c d) (exact (round 1.8)))")))
80 |
81 | (test-case "(list-set! )" (lambda ()
82 | (let ((ls (list 'one 'two 'five)))
83 | (list-set! ls 2 'three)
84 | (assert-equal ls '(one two three)))
85 | (assert-error (list-set! '(0 1 2) 1 "oops") "(list-set! '(0 1 2) 1 \"oops\")")))
86 |
87 | (test-case "(memq )" (lambda ()
88 | (assert-equal (memq 'a '(a b c)) '(a b c) "(memq 'a '(a b c))")
89 | (assert-equal (memq 'b '(a b c)) '(b c) "(memq 'b '(b c))")
90 | (assert-equal (memq 'a '(b c d)) #f "(memq 'a '(b c d))")
91 | (assert-equal (memq (list a) '(b (a) c)) #f "(memq (list a) '(b (a) c))")
92 | (assert-equal (memq 101 '(100 101 102)) #f "(memq 101 '(100 101 102))")))
93 |
94 | (test-case "(member )" (lambda ()
95 | (assert-equal (member (list 'a) '(b (a) c)) '((a) c) "(member (list a) '(b (a) c))")
96 | (assert-equal (member "B" '("a" "b" "c") string-ci=?) '("b" "c") "(member \"B\" '(\"a\" \"b\" \"c\") string-ci=?)")))
97 |
98 | (test-case "(memv )" (lambda ()
99 | (assert-equal (memv 101 '(100 101 102)) '(101 102) "(memv 101 '(100 101 102))")))
100 |
101 | (test-case "(assq )" (lambda ()
102 | (define e '((a 1) (b 2) (c 3)))
103 | (assert-equal (assq 'a e) '(a 1) "(assq 'a e)")
104 | (assert-equal (assq 'b e) '(b 2) "(assq 'b e)")
105 | (assert-equal (assq 'd e) #f "(assq 'd e)")
106 | (assert-equal (assq (list 'a) '(((a)) ((b)) ((c)))) #f "(assq (list 'a) '(((a)) ((b)) ((c))))")
107 | (assert-equal (assq 5 '((2 3) (5 7) (11 13))) #f "(assq 5 '((2 3) (5 7) (11 13)))")))
108 |
109 | (test-case "(assoc )" (lambda ()
110 | (assert-equal (assoc (list 'a) '(((a)) ((b)) ((c)))) '((a)) "(assoc (list 'a) '(((a)) ((b)) ((c))))")
111 | (assert-equal (assoc 2.0 '((1 1) (2 4) (3 9))) '(2 4) "(assoc 2.0 '((1 1) (2 4) (3 9)))")))
112 |
113 | (test-case "(assv )" (lambda ()
114 | (define e '((a 1) (b 2) (c 3)))
115 | (assert-equal (assv 5 '((2 3) (5 7) (11 13))) '(5 7) "(assv 5 '((2 3) (5 7) (11 13)))")))
116 |
117 | (test-case "(list-copy )" (lambda ()
118 | (define a '(1 8 2 8))
119 | (define b (list-copy a))
120 | (set-car! b 3)
121 | (assert-equal b '(3 8 2 8) "Should have changed")
122 | (assert-equal a '(1 8 2 8) "Should be the same")))
123 | )
124 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/process.spec.scm:
--------------------------------------------------------------------------------
1 | (if (not (procedure? assert))
2 | (include "test/test.scm"))
3 |
4 | (run-tests "process"
5 | (test-case "(get-environment-variable )" (lambda ()
6 | (assert-not (get-environment-variable "TEST_ONE"))
7 | (set-environment-variable "TEST_ONE" "TEST_ONE_VALUE")
8 | (set-environment-variable "TEST_TWO" "TEST_TWO_VALUE")
9 | (assert-equal (get-environment-variable "TEST_ONE") "TEST_ONE_VALUE")
10 | ))
11 |
12 | (test-case "(get-environment-variables)" (lambda ()
13 | (assert-not (assoc "TEST_THREE" (get-environment-variables)))
14 | (set-environment-variable "TEST_THREE" "TEST_THREE_VALUE")
15 | (set-environment-variable "TEST_FOUR" "TEST_FOUR_VALUE")
16 | (assert-equal (assoc "TEST_THREE" (get-environment-variables)) '("TEST_THREE" . "TEST_THREE_VALUE"))
17 | (assert-equal (assoc "TEST_FOUR" (get-environment-variables)) '("TEST_FOUR" . "TEST_FOUR_VALUE"))
18 | ))
19 |
20 | (test-case "(command-line)" (lambda ()
21 | (assert (list? (command-line)))
22 | (assert (> (length (command-line)) 0))
23 | ))
24 | )
25 |
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/sequence.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test sequence operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "sequence"
8 | (test-case "begin at body scope" (lambda ()
9 | (begin
10 | (define x 10)
11 | (assert-equal x 10))))
12 |
13 | (test-case "begin at expression scope" (lambda ()
14 | (assert-error
15 | (if #t
16 | (begin
17 | (define x 10)
18 | (assert-equal x 10))))))
19 | )
--------------------------------------------------------------------------------
/scheme.wasm/src/scheme/test/string.spec.scm:
--------------------------------------------------------------------------------
1 | #|
2 | | Test string operations.
3 | |#
4 | (if (not (procedure? assert))
5 | (include "test/test.scm"))
6 |
7 | (run-tests "string"
8 | (test-case "(string? )" (lambda ()
9 | (assert (string? "Foo"))
10 | (assert (string? ""))
11 | (assert-not (string? '()))
12 | (assert-not (string? #\x))))
13 |
14 | (test-case "(make-string )" (lambda ()
15 | (assert-equal (make-string 4 #\a) "aaaa")
16 | (assert-equal (string-length (make-string 4)) 4)))
17 |
18 | (test-case "(string ...)" (lambda ()
19 | (assert-equal (string #\f #\o #\o) "foo")
20 | (assert-equal (string) "")))
21 |
22 | (test-case "(string-length )" (lambda ()
23 | (assert-equal (string-length "foobar") 6)
24 | (assert-equal (string-length "φδπ") 3)
25 | (assert-equal (string-length "") 0)))
26 |
27 | (test-case "(string-ref )" (lambda ()
28 | (assert-equal (string-ref "bar" 1) #\a)
29 | (assert-error (string-ref "bar" 3))))
30 |
31 | (test-case "(string-set! " (lambda ()
32 | (define f (make-string 3 #\*))
33 | (define g "***") ;; immutable
34 | (string-set! f 0 #\?)
35 | (assert-equal f "?**")
36 | (assert-error (string-set! g 0 #\?) "writing to an immutable string")
37 | (assert-error (string-set! (symbol->string 'immutable)
38 | 0
39 | #\?)
40 | "writing to an immutable string")))
41 |
42 | (test-case "(string=? ...)" (lambda ()
43 | (assert (string=? "foo" "foo" (symbol->string 'foo)))
44 | (assert-not (string=? "foo" "FOO"))
45 | (assert-not (string=? "foo" "bar"))))
46 |
47 | (test-case "(string-ci=? ...)" (lambda ()
48 | (assert (string-ci=? "foo" "FOO" (symbol->string 'foo)))
49 | (assert-not (string-ci=? "foo" "bar"))))
50 |
51 | (test-case "(string ...)" (lambda ()
52 | (assert (string "abc" "def" "ghi"))
53 | (assert (string "ABC" "abc" "ghi"))
54 | (assert-not (string "abc" "DEF" "ghi"))))
55 |
56 | (test-case "(string-ci ...)" (lambda ()
57 | (assert (string-ci "Abc" "def" "Ghi"))
58 | (assert (string-ci "abc" "DEF" "ghi"))
59 | (assert-not (string-ci "abc" "ABC" "ghi"))))
60 |
61 | (test-case "(string>? ...)" (lambda ()
62 | (assert (string>? "ghi" "def" "abc"))
63 | (assert (string>? "ghi" "abc" "ABC"))
64 | (assert-not (string>? "abc" "DEF" "ghi"))))
65 |
66 | (test-case "(string-ci>? ...)" (lambda ()
67 | (assert (string-ci>? "Ghi" "def" "Abc"))
68 | (assert (string-ci>? "ghi" "DEF" "abc"))
69 | (assert-not (string-ci>? "ghi" "abc" "ABC"))))
70 |
71 | (test-case "(string<=? ...)" (lambda ()
72 | (assert (string<=? "abc" "def" "def" "ghi"))
73 | (assert (string<=? "ABC" "abc" "abc" "ghi"))
74 | (assert-not (string<=? "abc" "def" "DEF" "ghi"))))
75 |
76 | (test-case "(string-ci<=? ...)" (lambda ()
77 | (assert (string-ci<=? "Abc" "def" "DEF" "Ghi"))
78 | (assert (string-ci<=? "abc" "DEF" "def" "ghi"))
79 | (assert-not (string-ci<=? "abc" "ABb" "ghi"))))
80 |
81 | (test-case "(string>=? ...)" (lambda ()
82 | (assert (string>=? "ghi" "def" "def" "abc"))
83 | (assert (string>=? "ghi" "abc" "ABC"))
84 | (assert-not (string>=? "abc" "DEF" "def" "ghi"))))
85 |
86 | (test-case "(string-ci>=? ...)" (lambda ()
87 | (assert (string-ci>=? "Ghi" "def" "DEF" "Abc"))
88 | (assert (string-ci>=? "ghi" "DEF" "def" "abc"))
89 | (assert-not (string-ci>=? "ghi" "abc" "ABD"))))
90 |
91 | (test-case "(string-upcase )" (lambda ()
92 | (assert-equal (string-upcase "Foo Bar") "FOO BAR")
93 | (assert-equal (string-upcase "δπφ") "ΔΠΦ")))
94 |
95 | (test-case "(string-downcase )" (lambda ()
96 | (assert-equal (string-downcase "Foo Bar") "foo bar")
97 | (assert-equal (string-downcase "ΔΠΦ") "δπφ")))
98 |
99 | (test-case "(string-foldcase )" (lambda ()
100 | (assert-equal (string-foldcase "Foo Bar") "foo bar")
101 | (assert-equal (string-foldcase "ΔΠΦ") "δπφ")))
102 |
103 | (test-case "(string-append ...)" (lambda ()
104 | (assert-equal (string-append) "")
105 | (assert-equal (string-append "abc" "def") "abcdef")
106 | (assert-equal (string-append "abc" "def" "ghi") "abcdefghi")))
107 |
108 | (test-case "(string->list [ []])" (lambda ()
109 | (assert-equal (string->list "Foo Bar") '(#\F #\o #\o #\space #\B #\a #\r))
110 | (assert-equal (string->list "Foo Bar" 4) '(#\B #\a #\r))
111 | (assert-equal (string->list "Foo Bar" 4 6) '(#\B #\a))
112 | (assert-error (string->list "Foo Bar" 4 8))))
113 |
114 | (test-case "(list->string )" (lambda ()
115 | (assert-equal (list->string '(#\F #\o #\o)) "Foo")
116 | (assert-error (list->string '(#\F o #\o)))))
117 |
118 | (test-case "(string-copy [ []])" (lambda ()
119 | (assert-equal (string-copy "Foo Bar") "Foo Bar")
120 | (assert-equal (string-copy "Foo Bar" 4) "Bar")
121 | (assert-equal (string-copy "Foo Bar" 4 6) "Ba")
122 | (assert-error (string-copy "Foo Bar" 4 8))))
123 |
124 | (test-case "(substring )" (lambda ()
125 | (assert-equal (substring "Foo Bar" 4 6) "Ba")
126 | (assert-error (substring "Foo Bar" 4 8))))
127 |
128 | (test-case "(string-copy! [ []])" (lambda ()
129 | (define a "12345")
130 | (define b (string-copy "abcde"))
131 | (string-copy! b 1 a 0 2)
132 | (assert-equal b "a12de")
133 | (assert-error (string-copy! a 0 b))))
134 |
135 | (test-case "(string-fill!