├── .dir-locals.el ├── .envrc ├── .gitignore ├── DevNotes.md ├── LICENSE ├── Makefile ├── README.md ├── assert.scm ├── compilation-error.scm ├── compiled-program.scm ├── counted-set.scm ├── definitions-table.scm ├── demo ├── .gitignore ├── compile-exps-demo.scm └── example-module.scm ├── driver.scm ├── expression-compiler.scm ├── flake.lock ├── flake.nix ├── lexical-env.scm ├── lists.scm ├── literals-compiler.scm ├── module-compiler.scm ├── pattern-match.scm ├── runtime-memory.scm ├── scheme-r7rs-syntax.scm ├── scheme-runtime-base.scm ├── scheme-runtime-write.scm ├── scheme-runtime.scm ├── scheme-syntax.scm ├── test-compiler ├── and.scm ├── arithmetic-operators.scm ├── assignment.scm ├── comparison-operators.scm ├── cond.scm ├── define.scm ├── eqv.scm ├── exported-procedure.scm ├── if.scm ├── imports-as-values.scm ├── lambda.scm ├── lib │ ├── compiler-test-to-wast.scm │ └── compiler-test.scm ├── local-let-star.scm ├── local-let.scm ├── not.scm ├── or.scm ├── override-special-form-as-operator.scm ├── override-special-form-as-variable.scm ├── re-export.scm ├── recursive-definition.scm ├── sequence.scm ├── sicp-exercise-1-19.scm ├── string.scm ├── symbol.scm ├── test-compiler.mk ├── test │ ├── and.scm │ ├── arithmetic-operators.scm │ ├── assignment.scm │ ├── comparison-operators.scm │ ├── cond.scm │ ├── define.scm │ ├── eqv.scm │ ├── exported-procedure.scm │ ├── if.scm │ ├── imports-as-values.scm │ ├── lambda.scm │ ├── local-let-star.scm │ ├── local-let.scm │ ├── not.scm │ ├── or.scm │ ├── override-special-form-as-operator.scm │ ├── override-special-form-as-variable.scm │ ├── re-export.scm │ ├── recursive-definition.scm │ ├── sequence.scm │ ├── sicp-exercise-1-19.scm │ ├── string.scm │ ├── symbol.scm │ ├── type-errors.scm │ ├── types.scm │ └── values.scm ├── type-errors.scm ├── types.scm ├── values.scm └── wat │ ├── README.md │ ├── and.wat │ ├── arithmetic-operators.wat │ ├── assignment.wat │ ├── comparison-operators.wat │ ├── cond.wat │ ├── define.wat │ ├── eqv.wat │ ├── exported-procedure.wat │ ├── if.wat │ ├── imports-as-values.wat │ ├── lambda.wat │ ├── local-let-star.wat │ ├── local-let.wat │ ├── not.wat │ ├── or.wat │ ├── override-special-form-as-operator.wat │ ├── override-special-form-as-variable.wat │ ├── re-export.wat │ ├── recursive-definition.wat │ ├── sequence.wat │ ├── sicp-exercise-1-19.wat │ ├── string.wat │ ├── symbol.wat │ ├── type-errors.wat │ ├── types.wat │ └── values.wat ├── test-io └── test-write-string.scm ├── test-unit ├── library-errors.scm ├── semantic-errors.scm ├── test-compiled-program.scm ├── test-counted-set.scm ├── test-definitions-table.scm ├── test-lexical-env.scm ├── test-lists.scm ├── test-pattern-match.scm ├── test-scheme-r7rs-syntax.scm ├── test-scheme-syntax.scm ├── test-syntax-errors.scm ├── test-unit.mk └── test-wasm-syntax.scm ├── tools ├── .dir-locals.el ├── scheme-dependencies.scm └── tools.mk ├── values.scm ├── wasm-syntax.scm └── wasm-test-snippets ├── .gitignore ├── data-test.wast ├── import-indices-test.wast ├── memequal.wast ├── trap-test.wast └── wasi-echo.wat /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil . ((geiser-scheme-implementation . guile) 2 | (compile-command . "gmake -k -j -O test"))) 3 | (scheme-mode . ((geiser-guile-binary . ("guile" "--r7rs")) 4 | (geiser-guile-load-path . ("./test-compiler" "./test-compiler/lib"))))) 5 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *~ 3 | *.tmp 4 | \#*\# 5 | compiled/ 6 | build/ 7 | log/ 8 | test-compiler/host-log/ 9 | test-compiler/wast-log/ 10 | .direnv/ -------------------------------------------------------------------------------- /DevNotes.md: -------------------------------------------------------------------------------- 1 | # Development notes 2 | 3 | ## Compiler output 4 | ### Current solution – runtime module 5 | Currently the compiler is producing Wasm modules that import memory, globals and functions from a runtime support module, see [runtime](runtime/). This has worked OK with the current compiler that can only produce library-like modules from Scheme libraries. The compiler tests have used [WAST][wast] with its rudimentary multi-module support in the compiler tests to link the runtime support and the compiler-produced modules together. 6 | 7 | ### Why this is a problem now? 8 | I am planning to extend the compiler to produce executable Scheme programs that could be run with a standard command-line WebAssembly runtime. To have the programs do something useful, I also plan to add a rudimentary output facility as some basic version of the `(scheme write)` standard libary. I could then rethink the compiler testing by adding a simple testing library and have compiled test programs that could be executed, instead of the current approach that compiles Wasm modules and tests them with WAST scripts that are generated from simple Scheme-like test scripts (see [test-compiler/test/](test-compiler/test/) and -[/lib/](test-compiler/lib/)). 9 | 10 | Testing with WAST is very limited and test errors are hard to debug. The next big thing that I want to add to the compiler is support for lists, vectors and garbage collection. I feel that I need stronger testing tools to help with developing those. Now that support for output and executable Scheme programs is planned to be added, the separate runtime and executable modules would require some kind of module linking support from the Wasm runtime that I will to use to execute the compiled programs. 11 | 12 | ### Issues with module linking 13 | There is no straightforward module linking support in the current, popular Wasm command-line runtimes, which I would like to use in the project for simplicity and minimal dependencies. Modules could be linked with a programming language integrated Wasm runtime, such as Node.js, or with a Wasm runtime that provides a library and an API, by writing explict code to link the runtime module exports with the compiled module imports, but that would require the compiler to preferably generate the linking code too and would add a huge dependency to the project. Also the compiler-generated Wasm modules would not be self-sufficient anymore, but would require the linking code and its runtime to execute. 14 | 15 | ### Use WebAssembly Component Model? 16 | The nascent [WebAssembly component model][component-model] promises to provide module linking support and its [use cases documentation][component-model-use-cases-performance] has a case that sounds like a good fit for this project. The [Wasmtime runtime][wasmtime] has early support for executing components with support for I/O. I took a long look at the component model documentation, installed the [wasm-tools][wasm-tools] package, read its documentation, tried to build some simple test components that mimicked my problem of linking runtime library with compiled code, but got nowhere. The documentation on the Wasm component model is still very rudimentary and I found the tools hard to use and some of the concepts hard to understand. Also, I don't currently have use case for the number 1 feature of component model, which is language-agnostic component interfaces. 17 | 18 | ### The solution – for now 19 | After banging my head against the component model documentation and tooling I gave up on it for now and decided to let it mature a bit. I decided to just emit the runtime code into the same module with compiled code to avoid the module linking issues altogether. Generating self-sufficient programs with I/O support with this approach is still possible using the Wasmtime runtime and the [WASI][wasi] preview 1 system interface it provides. See [wasi-echo.wat](wasm-test-snippets/wasi-echo.wat) in this repository for an example. 20 | 21 | Changing the compiler to emit the runtime code into the compiled module is not a small change, but it should not be overwhelming either. 22 | 23 | ## lexical-env 24 | - Variables can be overridden in lexical-env, but additional-info is the same 25 | for all variables with the same name. Maybe change the lexical-frame to an 26 | association list with (var-name additional-info) pairs? 27 | 28 | [wast]: https://github.com/WebAssembly/spec/blob/main/interpreter/README.md#scripts 29 | [component-model]: https://component-model.bytecodealliance.org 30 | [component-model-use-cases-performance]: https://github.com/WebAssembly/component-model/blob/main/design/high-level/UseCases.md#performance 31 | [wasmtime]: https://wasmtime.dev/ 32 | [wasm-tools]: https://github.com/bytecodealliance/wasm-tools 33 | [wasi]: https://github.com/WebAssembly/WASI -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Sami Rosendahl 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. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL := bash 2 | .SHELLFLAGS := -o pipefail -c 3 | 4 | HOST_SCHEME_FLAGS := --r7rs 5 | HOST_SCHEME_COMPILED_DIR := ./compiled/ 6 | HOST_SCHEME_COMPILE_MODULE := guild compile $(HOST_SCHEME_FLAGS) 7 | HOST_SCHEME_RUN_PROGRAM := guile $(HOST_SCHEME_FLAGS) --no-auto-compile 8 | COMPILER_SOURCES := $(wildcard *.scm) 9 | COMPILER_BINARIES := $(COMPILER_SOURCES:%.scm=$(HOST_SCHEME_COMPILED_DIR)%.go) 10 | RUN_COMPILER := $(HOST_SCHEME_RUN_PROGRAM) -L . -C $(HOST_SCHEME_COMPILED_DIR) driver.scm 11 | 12 | .PHONY : help 13 | help : ## Display this help 14 | help : Makefile test-compiler/test-compiler.mk test-unit/test-unit.mk tools/tools.mk 15 | @echo "Targets:" 16 | @sed -nE 's/^([[:alnum:]-]+)[[:space:]]*:[^#]*##[[:space:]]*(.*)$$/ \1: \2/p' $^ \ 17 | | column -t -s " " 18 | 19 | .PHONY : compile 20 | compile : ## Compiles a scheme file from standard input and outputs WAT to standard output 21 | compile : $(COMPILER_BINARIES) 22 | $(RUN_COMPILER) $< 23 | 24 | .PHONY : compile-compiler 25 | compile-compiler : ## Compiles the compiler with host scheme 26 | compile-compiler : $(COMPILER_BINARIES) 27 | 28 | $(HOST_SCHEME_COMPILED_DIR) : 29 | mkdir -p $@ 30 | 31 | COMPILER_DEPENDENCIES := $(HOST_SCHEME_COMPILED_DIR)module-dependencies.mk 32 | 33 | include tools/tools.mk 34 | $(COMPILER_DEPENDENCIES) : $(COMPILER_SOURCES) $(TOOL_SCHEME_DEPENDENCIES) | $(HOST_SCHEME_COMPILED_DIR) 35 | $(RUN_TOOL_SCHEME_DEPENDENCIES) $(COMPILER_SOURCES) \ 36 | | sed -e 's|\([^[:space:]]*\)\.scm|$(HOST_SCHEME_COMPILED_DIR)\1\.go|g' \ 37 | | tee $@.tmp && mv -f $@.tmp $@ 38 | 39 | include $(COMPILER_DEPENDENCIES) 40 | 41 | $(COMPILER_BINARIES) : $(HOST_SCHEME_COMPILED_DIR)%.go : %.scm | $(HOST_SCHEME_COMPILED_DIR) 42 | GUILE_LOAD_COMPILED_PATH=$(HOST_SCHEME_COMPILED_DIR) $(HOST_SCHEME_COMPILE_MODULE) -o $@ $< 43 | 44 | include test-compiler/test-compiler.mk 45 | 46 | include test-unit/test-unit.mk 47 | 48 | .PHONY : test 49 | test : ## Executes all tests 50 | test : test-unit test-compiler 51 | 52 | .PHONY : clean 53 | clean : ## Removes test outputs, compiled tools and forces compiler re-compilation 54 | clean : clean-test clean-compiler clean-tools 55 | 56 | .PHONY : clean-compiler 57 | clean-compiler : ## Forces compiler re-compilation 58 | -rm -rf $(HOST_SCHEME_COMPILED_DIR) 59 | 60 | .PHONY : clean-test 61 | clean-test : ## Removes all test build artefacts and results 62 | clean-test : clean-test-unit clean-test-compiler 63 | -------------------------------------------------------------------------------- /assert.scm: -------------------------------------------------------------------------------- 1 | (define-library (assert) 2 | 3 | (export assert-equal 4 | install-test-compilation-error-handler! assert-raises-compilation-error) 5 | 6 | (import (scheme base) 7 | (scheme cxr) 8 | (compilation-error)) 9 | 10 | (begin 11 | (define (assert-equal expected actual text) 12 | (if (not (equal? expected actual)) 13 | (error text (list expected actual)))) 14 | 15 | (define (make-test-compilation-error message object) 16 | (list 'test-compilation-error message object)) 17 | 18 | (define (test-compilation-error? e) 19 | (and (list? e) (eq? (car e) 'test-compilation-error))) 20 | 21 | (define (assert-equal-test-compilation-error expected actual) 22 | (assert-equal (cadr expected) (cadr actual) "Error messages should be equal") 23 | (assert-equal (caddr expected) (caddr actual) "Error objects should be equal")) 24 | 25 | (define (error-handler message object) 26 | (raise (make-test-compilation-error message object))) 27 | 28 | (define (install-test-compilation-error-handler!) 29 | (set-compilation-error-handler! error-handler)) 30 | 31 | (define (assert-raises-compilation-error action expected-message expected-object description) 32 | (let ((expected-error (make-test-compilation-error expected-message expected-object))) 33 | (guard (cond 34 | ((test-compilation-error? cond) 35 | (assert-equal-test-compilation-error expected-error cond) 36 | expected-error)) 37 | (let ((result (action))) 38 | (if (not (eq? result expected-error)) 39 | (error description (list (cdr expected-error) result))))))) 40 | )) 41 | -------------------------------------------------------------------------------- /compilation-error.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (compilation-error) 3 | 4 | (export make-compilation-error compilation-error? 5 | compilation-error-message compilation-error-object 6 | raise-as-error raise-if-error 7 | raise-compilation-error set-compilation-error-handler!) 8 | 9 | (import (scheme base) 10 | (scheme cxr)) 11 | 12 | (begin 13 | (define compilation-error-handler error) 14 | 15 | (define (set-compilation-error-handler! handler) 16 | (set! compilation-error-handler handler)) 17 | 18 | (define (make-compilation-error message object) 19 | (list make-compilation-error message object)) 20 | 21 | (define (compilation-error? x) 22 | (and (list? x) (eq? (car x) make-compilation-error))) 23 | 24 | (define (compilation-error-message e) (cadr e)) 25 | (define (compilation-error-object e) (caddr e)) 26 | 27 | (define (raise-as-error e) 28 | (raise-compilation-error (compilation-error-message e) (compilation-error-object e))) 29 | 30 | (define (raise-if-error x) 31 | (if (compilation-error? x) 32 | (raise-as-error x))) 33 | 34 | (define (raise-compilation-error message object) 35 | (compilation-error-handler message object)))) 36 | -------------------------------------------------------------------------------- /compiled-program.scm: -------------------------------------------------------------------------------- 1 | (define-library (compiled-program) 2 | 3 | (export make-empty-compiled-program 4 | compiled-program-module-definitions 5 | compiled-program-value-code 6 | compiled-program-with-value-code 7 | compiled-program-append-value-code 8 | compiled-program-append-value-codes 9 | compiled-program-add-definition 10 | compiled-program-last-definition 11 | compiled-program-lookup-definition 12 | compiled-program-fold-definitions 13 | compiled-program-flatmap-definitions 14 | compiled-program-get-definitions 15 | compiled-program-contains-definition 16 | compiled-program-definition-index 17 | compiled-program-definitions-count 18 | compiled-program-with-definition-and-value-code 19 | compiled-program-with-definitions-and-value-code) 20 | 21 | (import (scheme base) 22 | (lists) 23 | (definitions-table)) 24 | 25 | (begin 26 | (define (make-compiled-program module-definitions value-code) 27 | (list module-definitions value-code)) 28 | 29 | (define (compiled-program-module-definitions cp) 30 | (car cp)) 31 | 32 | (define (compiled-program-value-code cp) 33 | (cadr cp)) 34 | 35 | (define (make-empty-compiled-program) 36 | (make-compiled-program 37 | (make-empty-definitions-table) 38 | '())) 39 | 40 | (define (compiled-program-with-value-code cp code) 41 | (make-compiled-program 42 | (compiled-program-module-definitions cp) 43 | code)) 44 | 45 | (define (compiled-program-append-value-code cp code) 46 | (make-compiled-program 47 | (compiled-program-module-definitions cp) 48 | (append (compiled-program-value-code cp) 49 | code))) 50 | 51 | (define (compiled-program-append-value-codes cp1 cp2) 52 | (make-compiled-program 53 | (compiled-program-module-definitions cp2) 54 | (append (compiled-program-value-code cp1) 55 | (compiled-program-value-code cp2)))) 56 | 57 | (define (compiled-program-add-definition cp definition) 58 | (make-compiled-program 59 | (add-definition 60 | (compiled-program-module-definitions cp) 61 | definition) 62 | (compiled-program-value-code cp))) 63 | 64 | (define (compiled-program-last-definition cp type) 65 | (last-definition 66 | (compiled-program-module-definitions cp) 67 | type)) 68 | 69 | (define (compiled-program-lookup-definition cp predicate) 70 | (lookup-definition 71 | (compiled-program-module-definitions cp) 72 | predicate)) 73 | 74 | (define (compiled-program-fold-definitions cp proc init) 75 | (fold-definitions 76 | (compiled-program-module-definitions cp) 77 | proc 78 | init)) 79 | 80 | (define (compiled-program-flatmap-definitions cp proc) 81 | (flatmap-definitions 82 | (compiled-program-module-definitions cp) 83 | proc)) 84 | 85 | (define (compiled-program-get-definitions cp type) 86 | (get-definitions 87 | (compiled-program-module-definitions cp) 88 | type)) 89 | 90 | (define (compiled-program-contains-definition cp definition) 91 | (contains-definition 92 | (compiled-program-module-definitions cp) 93 | definition)) 94 | 95 | (define (compiled-program-definition-index cp definition) 96 | (definition-index 97 | (compiled-program-module-definitions cp) 98 | definition)) 99 | 100 | (define (compiled-program-definitions-count cp type) 101 | (definitions-count 102 | (compiled-program-module-definitions cp) 103 | type)) 104 | 105 | (define (compiled-program-with-definition-and-value-code cp definition code) 106 | (make-compiled-program 107 | (add-definition 108 | (compiled-program-module-definitions cp) 109 | definition) 110 | code)) 111 | 112 | (define (compiled-program-with-definitions-and-value-code cp definitions code) 113 | (fold 114 | (lambda (definition cp) 115 | (compiled-program-with-definition-and-value-code cp definition code)) 116 | cp 117 | definitions)) 118 | )) 119 | -------------------------------------------------------------------------------- /counted-set.scm: -------------------------------------------------------------------------------- 1 | (define-library (counted-set) 2 | 3 | (export make-counted-set 4 | counted-set-add 5 | counted-set-count 6 | counted-set-unique-keys) 7 | 8 | (import (scheme base) 9 | (lists)) 10 | 11 | (begin 12 | (define (make-counted-set) '()) 13 | 14 | (define (counted-set-add s key amount) 15 | (let* ((existing (assq key s)) 16 | (count (if existing 17 | (+ (cdr existing) amount) 18 | amount)) 19 | (new-head (cons key count)) 20 | (rest (filter (lambda (entry) (not (eq? key (car entry)))) s))) 21 | (cons new-head rest))) 22 | 23 | (define (counted-set-count s key) 24 | (let ((existing (assq key s))) 25 | (if existing (cdr existing) 0))) 26 | 27 | (define (counted-set-unique-keys s) 28 | (length s)) 29 | )) 30 | -------------------------------------------------------------------------------- /definitions-table.scm: -------------------------------------------------------------------------------- 1 | (define-library (definitions-table) 2 | 3 | (export make-empty-definitions-table 4 | definitions-count 5 | add-definition 6 | last-definition 7 | contains-definition 8 | lookup-definition 9 | fold-definitions 10 | flatmap-definitions 11 | lookup-definition-index 12 | definition-index 13 | get-definitions) 14 | 15 | (import (scheme base) 16 | (counted-set) 17 | (lists) 18 | (wasm-syntax)) 19 | 20 | (begin 21 | (define (make-definitions-table defs def-counts) 22 | (list defs def-counts)) 23 | 24 | (define (make-empty-definitions-table) 25 | (make-definitions-table '() (make-counted-set))) 26 | 27 | (define (definitions defs) 28 | (car defs)) 29 | 30 | (define (definition-counts defs) 31 | (cadr defs)) 32 | 33 | (define (definitions-count defs type) 34 | (counted-set-count (definition-counts defs) type)) 35 | 36 | (define (add-definition defs def) 37 | (make-definitions-table 38 | (cons def (definitions defs)) 39 | (counted-set-add (definition-counts defs) (car def) 1))) 40 | 41 | (define (last-definition defs type) 42 | (assq type (definitions defs))) 43 | 44 | (define (contains-definition defs def) 45 | (if (member def (definitions defs)) #t #f)) 46 | 47 | (define (lookup-definition defs predicate) 48 | (let loop ((ds (definitions defs))) 49 | (cond ((null? ds) #f) 50 | ((predicate (car ds)) (car ds)) 51 | (else (loop (cdr ds)))))) 52 | 53 | (define (fold-definitions defs proc init) 54 | (fold proc init (definitions defs))) 55 | 56 | (define (flatmap-definitions defs proc) 57 | (let loop ((ds (definitions defs)) 58 | (rs '())) 59 | (if (null? ds) 60 | rs 61 | (loop (cdr ds) 62 | (append (proc (car ds)) rs))))) 63 | 64 | (define (lookup-definition-index defs type predicate) 65 | (let loop ((ds (definitions defs)) 66 | (count (definitions-count defs type))) 67 | (cond ((null? ds) #f) 68 | ((wasm-definition-type? type (car ds)) 69 | (if (predicate (car ds)) 70 | (- count 1) 71 | (loop (cdr ds) (- count 1)))) 72 | (else 73 | (loop (cdr ds) count))))) 74 | 75 | (define (definition-index defs def) 76 | (lookup-definition-index 77 | defs 78 | (wasm-definition-type def) 79 | (lambda (d) (equal? def d)))) 80 | 81 | (define (get-definitions defs type) 82 | (let collect ((ds (definitions defs)) 83 | (result '())) 84 | (cond ((null? ds) result) 85 | ((eq? type (caar ds)) 86 | (collect (cdr ds) (cons (car ds) result))) 87 | (else 88 | (collect (cdr ds) result))))) 89 | )) 90 | -------------------------------------------------------------------------------- /demo/.gitignore: -------------------------------------------------------------------------------- 1 | *.wat 2 | *.wasm 3 | -------------------------------------------------------------------------------- /demo/compile-exps-demo.scm: -------------------------------------------------------------------------------- 1 | (define-library (compile-exps-demo) 2 | 3 | (export compile-exp 4 | demo1 demo2 demo3 demo4) 5 | 6 | (import (scheme base) 7 | (expression-compiler) 8 | (compiled-program) 9 | (lexical-env)) 10 | 11 | (begin 12 | (define (compile-exp exp) 13 | (let ((env (add-new-top-level-frame 14 | (make-empty-lexical-env) 15 | 0 '() '()))) 16 | (compile exp (make-empty-compiled-program) env))) 17 | 18 | (define (demo1) 19 | (compile-exp '(+ 1 2))) 20 | 21 | (define (demo2) 22 | (compile-exp '(if (> 1 2) (+ 1 2) 42))) 23 | 24 | (define (demo3) 25 | (compile-exp '(lambda (x) x))) 26 | 27 | (define (demo4) 28 | (compile-exp '((lambda (x) (* x x)) 2))) 29 | 30 | )) 31 | -------------------------------------------------------------------------------- /demo/example-module.scm: -------------------------------------------------------------------------------- 1 | (define-library (example-module) 2 | (export square get-value) 3 | 4 | ;; (import (scheme base)) 5 | 6 | (begin 7 | (define (square x) (* x x)) 8 | 9 | (define a (square 4)) 10 | 11 | (define (get-value) a) 12 | )) 13 | 14 | ;; Compiling 15 | ;; make -s compile < demo/example-module.scm > demo/example-module.wat 16 | ;; wat-desugar demo/example-module.wat 17 | 18 | ;; Running 19 | ;; make -s compile < demo/example-module.scm > demo/example-module.wat 20 | ;; wat2wasm demo/example-module.wat -o demo/example-module.wasm 21 | ;; wasm-interp demo/example-module.wasm --run-all-exports 22 | 23 | ;; Examining Wasm binary 24 | ;; file demo/example-module.wasm 25 | ;; hexdump demo/example-module.wasm 26 | ;; wasm2wat demo/example-module.wasm 27 | 28 | ;; Piping 29 | ;; make -s compile < demo/example-module.scm | wat2wasm --output=- - | wasm-interp - --run-all-exports 30 | -------------------------------------------------------------------------------- /driver.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme read) 3 | (scheme write) 4 | (lists) 5 | (module-compiler) 6 | (wasm-syntax)) 7 | 8 | (let ((output-port (current-output-port))) 9 | (emit-wat 10 | (compile-r7rs-library-to-wasm-module (read)) 11 | output-port)) 12 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "nixpkgs": { 4 | "locked": { 5 | "lastModified": 1742889210, 6 | "narHash": "sha256-hw63HnwnqU3ZQfsMclLhMvOezpM7RSB0dMAtD5/sOiw=", 7 | "owner": "NixOS", 8 | "repo": "nixpkgs", 9 | "rev": "698214a32beb4f4c8e3942372c694f40848b360d", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "NixOS", 14 | "ref": "nixos-unstable", 15 | "repo": "nixpkgs", 16 | "type": "github" 17 | } 18 | }, 19 | "root": { 20 | "inputs": { 21 | "nixpkgs": "nixpkgs" 22 | } 23 | } 24 | }, 25 | "root": "root", 26 | "version": 7 27 | } 28 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Development shell for samirose/sicp-compiler-project"; 3 | 4 | inputs = { 5 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; 6 | }; 7 | 8 | outputs = 9 | { self, nixpkgs }: 10 | let 11 | system = "x86_64-linux"; 12 | pkgs = nixpkgs.legacyPackages.${system}; 13 | in 14 | { 15 | devShells.${system}.default = pkgs.mkShell { 16 | packages = [ 17 | pkgs.bash 18 | pkgs.gnumake 19 | pkgs.guile 20 | pkgs.wabt 21 | pkgs.wasmtime 22 | ]; 23 | }; 24 | formatter.${system} = pkgs.nixfmt-rfc-style; 25 | }; 26 | } 27 | -------------------------------------------------------------------------------- /lexical-env.scm: -------------------------------------------------------------------------------- 1 | (define-library (lexical-env) 2 | 3 | (export make-empty-lexical-env 4 | global-lexical-env? 5 | add-new-top-level-frame 6 | add-new-lexical-frame 7 | add-new-local-frame 8 | add-new-local-temporaries-frame 9 | find-variable 10 | frame-index 11 | var-index 12 | update-additional-info 13 | additional-info 14 | global-address? 15 | env-get-additional-info 16 | env-find-additional-info 17 | env-var-index-offset) 18 | 19 | (import (scheme base) 20 | (scheme cxr) 21 | (lists)) 22 | 23 | (begin 24 | (define (make-empty-lexical-env) '()) 25 | 26 | (define (add-frame lexical-env frame) 27 | (cons frame lexical-env)) 28 | 29 | (define (head-frame lexical-env) 30 | (car lexical-env)) 31 | 32 | (define (rest-frames lexical-env) 33 | (cdr lexical-env)) 34 | 35 | (define (global-lexical-env? lexical-env) 36 | (and (not (null? lexical-env)) 37 | (null? (base-env (head-frame lexical-env))))) 38 | 39 | (define (make-frame-with-variables 40 | frame-index-offset 41 | var-index-offset 42 | variables 43 | base-env 44 | additional-info-map) 45 | (list 46 | (list frame-index-offset var-index-offset (length variables)) 47 | (reverse variables) 48 | base-env 49 | additional-info-map)) 50 | 51 | (define (make-local-temporaries-frame var-index-offset n base-env) 52 | (list (list 0 var-index-offset n) '() base-env '())) 53 | 54 | (define (make-update-additional-info-frame lexical-env update-additional-info) 55 | (let ((base-frame (head-frame lexical-env))) 56 | (list 57 | (list 0 (var-index-offset base-frame) (var-count base-frame)) 58 | (reversed-frame-variables base-frame) 59 | (base-env base-frame) 60 | (update-additional-info (frame-additional-info-map base-frame))))) 61 | 62 | (define (make-lexical-frame variables base-env additional-info-map) 63 | (make-frame-with-variables 1 0 variables base-env additional-info-map)) 64 | 65 | (define (make-local-frame var-index-offset variables base-env additional-info-map) 66 | (make-frame-with-variables 0 var-index-offset variables base-env additional-info-map)) 67 | 68 | (define (frame-indices frame) 69 | (car frame)) 70 | 71 | (define (frame-index-offset frame) 72 | (car (frame-indices frame))) 73 | 74 | (define (var-index-offset frame) 75 | (cadr (frame-indices frame))) 76 | 77 | (define (var-count frame) 78 | (caddr (frame-indices frame))) 79 | 80 | (define (last-var-index frame) 81 | (+ (var-count frame) -1 (var-index-offset frame))) 82 | 83 | (define (env-var-index-offset lexical-env) 84 | (if (null? lexical-env) 85 | 0 86 | (var-index-offset (head-frame lexical-env)))) 87 | 88 | (define (reversed-frame-variables frame) 89 | (cadr frame)) 90 | 91 | (define (base-env frame) 92 | (caddr frame)) 93 | 94 | (define (frame-additional-info-map frame) 95 | (cadddr frame)) 96 | 97 | (define (frame-get-additional-info var frame) 98 | (map cadr 99 | (filter 100 | (lambda (entry) (eq? (car entry) var)) 101 | (frame-additional-info-map frame)))) 102 | 103 | (define (env-get-additional-info var lexical-env) 104 | (if (null? lexical-env) 105 | '() 106 | (frame-get-additional-info var (head-frame lexical-env)))) 107 | 108 | (define (env-find-additional-info pred lexical-env) 109 | (find pred (frame-additional-info-map (head-frame lexical-env)))) 110 | 111 | (define (add-new-lexical-frame lexical-env variables additional-info-map) 112 | (add-frame 113 | lexical-env 114 | (make-lexical-frame variables lexical-env additional-info-map))) 115 | 116 | (define (add-new-top-level-frame lexical-env var-index-offset variables additional-info-map) 117 | (add-frame 118 | lexical-env 119 | (make-local-frame var-index-offset variables lexical-env additional-info-map))) 120 | 121 | (define (next-free-local-var-index lexical-env) 122 | (if (global-lexical-env? lexical-env) 123 | 0 124 | (let* ((curr-frame (head-frame lexical-env)) 125 | (curr-frame-length (var-count curr-frame)) 126 | (curr-var-index-offset (var-index-offset curr-frame))) 127 | (+ curr-var-index-offset curr-frame-length)))) 128 | 129 | (define (add-new-local-frame lexical-env variables additional-info-map) 130 | (if (null? lexical-env) 131 | (error "Internal compiler error: cannot add new local frame to an empty environment" variables) 132 | (add-frame 133 | lexical-env 134 | (make-local-frame 135 | (next-free-local-var-index lexical-env) 136 | variables 137 | lexical-env 138 | additional-info-map)))) 139 | 140 | (define (add-new-local-temporaries-frame lexical-env n) 141 | (if (null? lexical-env) 142 | (error "Internal compiler error: cannot add new local temporaries frame to an empty environment" n) 143 | (add-frame 144 | lexical-env 145 | (make-local-temporaries-frame (next-free-local-var-index lexical-env) n lexical-env)))) 146 | 147 | (define (update-additional-info lexical-env proc) 148 | (if (null? lexical-env) 149 | (error "Internal compiler error: cannot update additional info of empty environment") 150 | (add-frame 151 | lexical-env 152 | (make-update-additional-info-frame lexical-env proc)))) 153 | 154 | (define (make-lexical-address frame-index var-index lexical-env additional-info) 155 | (list frame-index var-index lexical-env additional-info)) 156 | 157 | (define (frame-index lexical-address) 158 | (car lexical-address)) 159 | 160 | (define (var-index lexical-address) 161 | (cadr lexical-address)) 162 | 163 | (define (global-address? lexical-address) 164 | (global-lexical-env? (caddr lexical-address))) 165 | 166 | (define (additional-info lexical-address) 167 | (cadddr lexical-address)) 168 | 169 | (define (find-variable var lexical-env) 170 | (if (null? lexical-env) 171 | #f 172 | (let scan ((env lexical-env) 173 | (vars (reversed-frame-variables (head-frame lexical-env))) 174 | (frame-index 0) 175 | (var-index (last-var-index (head-frame lexical-env)))) 176 | (cond ((null? vars) 177 | (let ((next-env (rest-frames env))) 178 | (if (null? next-env) 179 | #f 180 | (let ((curr-frame (head-frame env)) 181 | (next-frame (head-frame next-env))) 182 | (scan next-env 183 | (reversed-frame-variables next-frame) 184 | (+ frame-index (frame-index-offset curr-frame)) 185 | (last-var-index next-frame)))))) 186 | ((eq? (car vars) var) 187 | (make-lexical-address 188 | frame-index 189 | var-index 190 | env 191 | (frame-get-additional-info var (head-frame env)))) 192 | (else 193 | (scan env (cdr vars) frame-index (- var-index 1))))))) 194 | )) 195 | -------------------------------------------------------------------------------- /lists.scm: -------------------------------------------------------------------------------- 1 | (define-library (lists) 2 | 3 | (export 4 | index-of-equal 5 | first-duplicate 6 | flatten-n 7 | all? 8 | replace-seqs 9 | ;; from srfi-1 10 | filter find fold partition) 11 | 12 | (import 13 | (scheme base) 14 | (scheme cxr) 15 | (srfi srfi-1)) 16 | 17 | (begin 18 | (define (index-of-equal l e) 19 | (let search ((l l) (i 0)) 20 | (cond ((null? l) #f) 21 | ((equal? (car l) e) i) 22 | (else (search (cdr l) (+ i 1)))))) 23 | 24 | (define (first-duplicate l) 25 | (let search ((l l)) 26 | (cond ((null? l) '()) 27 | ((memq (car l) (cdr l))) 28 | (else (search (cdr l)))))) 29 | 30 | (define (flatten-n n x) 31 | (cond ((null? x) '()) 32 | ((= n 0) x) 33 | ((pair? x) 34 | (let ((head (car x))) 35 | (if (pair? head) 36 | (append 37 | (flatten-n (- n 1) head) 38 | (flatten-n n (cdr x))) 39 | (cons head (flatten-n n (cdr x)))))) 40 | (else x))) 41 | 42 | (define (all? p? l) 43 | (cond ((null? l)) 44 | ((p? (car l)) (all? p? (cdr l))) 45 | (else #f))) 46 | 47 | (define (replace-seqs seq with-seq lst) 48 | (if (null? seq) 49 | lst 50 | (let reduce ((s seq) (f '()) (a '()) (l lst)) 51 | (cond ((null? s) 52 | (let ((f' (append-reverse with-seq f))) 53 | (reduce seq f' f' l))) 54 | ((null? l) 55 | (reverse (if (null? s) f a))) 56 | ((eq? (car l) (car s)) 57 | (let ((a' (cons (car l) a))) 58 | (reduce (cdr s) f a' (cdr l)))) 59 | (else 60 | (let ((a' (cons (car l) a))) 61 | (reduce seq a' a' (cdr l)))))))) 62 | )) 63 | -------------------------------------------------------------------------------- /literals-compiler.scm: -------------------------------------------------------------------------------- 1 | (define-library (literals-compiler) 2 | 3 | (export 4 | compile-literal-symbol 5 | compile-literal-string 6 | literal-data-definitions) 7 | 8 | (import 9 | (scheme base) 10 | (scheme cxr) 11 | (srfi srfi-60) 12 | (lists) 13 | (values) 14 | (wasm-syntax) 15 | (compiled-program) 16 | (runtime-memory)) 17 | 18 | (begin 19 | (define (align-address address alignment) 20 | (* (quotient (+ address (- alignment 1)) alignment) 21 | alignment)) 22 | 23 | (define (next-literal-address program alignment) 24 | (align-address 25 | (cond ((compiled-program-last-definition 26 | program 27 | 'literal-data-definition) 28 | => (lambda (def) 29 | (+ (literal-data-attribute-value 'address def) 30 | (literal-data-attribute-value 'length def)))) 31 | (else literal-memory-start-address)) 32 | alignment)) 33 | 34 | (define (compile-literal-symbol symbol program) 35 | (cond ((let ((symbol-def 36 | (compiled-program-lookup-definition 37 | program 38 | (lambda (def) 39 | (and (literal-data-definition? def) 40 | (eq? (literal-data-attribute-value 'symbol def) symbol)))))) 41 | (and symbol-def 42 | (literal-data-attribute-value 'address symbol-def))) 43 | => (lambda (address) 44 | (compiled-program-with-value-code 45 | program 46 | `(i32.const ,address)))) 47 | (else 48 | (let*-values 49 | (((symbol-data symbol-data-length) 50 | (string-as-wasm-data (symbol->string symbol))) 51 | ((symbol-header-data symbol-header-length) 52 | (i32-as-wasm-data (symbol-literal-header symbol-data-length)))) 53 | (let ((address (next-literal-address program 4))) 54 | (compiled-program-with-definition-and-value-code 55 | program 56 | (literal-data-definition 57 | `((symbol . ,symbol) 58 | (address . ,address) 59 | (length . ,(+ symbol-header-length symbol-data-length))) 60 | (list symbol-header-data symbol-data)) 61 | `(i32.const ,address))))))) 62 | 63 | (define (compile-literal-string string program) 64 | (let*-values 65 | (((string-data string-data-length) 66 | (string-as-wasm-data string)) 67 | ((string-header-data string-header-length) 68 | (i32-as-wasm-data (string-literal-header string-data-length)))) 69 | (let ((address (next-literal-address program 4))) 70 | (compiled-program-with-definition-and-value-code 71 | program 72 | (literal-data-definition 73 | `((address . ,address) 74 | (length . ,(+ string-header-length string-data-length))) 75 | (list string-header-data string-data)) 76 | `(i32.const ,address))))) 77 | 78 | (define (literal-data-definition? exp) 79 | (eq? (car exp) 'literal-data-definition)) 80 | 81 | (define (literal-data-attributes exp) 82 | (cadr exp)) 83 | 84 | (define (literal-data-attribute-value attr exp) 85 | (cond ((assq attr (literal-data-attributes exp)) => cdr) 86 | (else #f))) 87 | 88 | (define (literal-data-values exp) 89 | (cddr exp)) 90 | 91 | (define (literal-data-definition attributes values) 92 | `(literal-data-definition ,attributes ,@values)) 93 | 94 | (define (last-literal-data-address program) 95 | (compiled-program-fold-definitions 96 | program 97 | (lambda (def max-address) 98 | (if (literal-data-definition? def) 99 | (let ((last-address 100 | (+ (literal-data-attribute-value 'address def) 101 | (literal-data-attribute-value 'length def)))) 102 | (if (> last-address max-address) 103 | last-address 104 | max-address)) 105 | max-address)) 106 | literal-memory-start-address)) 107 | 108 | (define (literal-data-definitions program) 109 | (let-values 110 | (((first-heap-address-data _) 111 | (i32-as-wasm-data (align-address (last-literal-data-address program) 4)))) 112 | (cons 113 | `(data (i32.const ,heap-memory-start-vector) ,first-heap-address-data) 114 | (compiled-program-flatmap-definitions 115 | program 116 | (lambda (def) 117 | (if (literal-data-definition? def) 118 | `((data 119 | (i32.const ,(literal-data-attribute-value 'address def)) 120 | ,@(literal-data-values def))) 121 | '())))))) 122 | ) 123 | ) 124 | -------------------------------------------------------------------------------- /pattern-match.scm: -------------------------------------------------------------------------------- 1 | (define-library (pattern-match) 2 | 3 | (export pattern-match? ?? ??*) 4 | 5 | (import (scheme base)) 6 | 7 | (begin 8 | (define (pattern-match? pat exp) 9 | (cond 10 | ((null? pat) (null? exp)) 11 | ((pair? pat) 12 | (let ((pat-head (car pat))) 13 | (cond 14 | ((memq pat-head list-matchers) 15 | (and (or (pair? exp) (null? exp)) 16 | (pat-head (cdr pat) exp))) 17 | ((pair? exp) 18 | (and (pattern-match? (car pat) (car exp)) 19 | (pattern-match? (cdr pat) (cdr exp)))) 20 | (else #f)))) 21 | ((memq pat list-matchers) #f) 22 | ((procedure? pat) (pat exp)) 23 | ((boolean? pat) (eq? pat exp)) 24 | ((symbol? pat) (eq? pat exp)) 25 | ((number? pat) (and (number? exp) (= pat exp))) 26 | ((string? pat) (and (string? exp) (equal? pat exp))) 27 | (else (error "Pattern matching not supported for" exp)))) 28 | 29 | (define (?? exp) #t) 30 | 31 | (define (scan-match pat exp) 32 | (cond ((null? exp) (null? pat)) 33 | ((pattern-match? pat exp) #t) 34 | (else (scan-match pat (cdr exp))))) 35 | 36 | (define ??* scan-match) 37 | 38 | (define list-matchers (list ??*)) 39 | )) 40 | -------------------------------------------------------------------------------- /runtime-memory.scm: -------------------------------------------------------------------------------- 1 | (define-library (runtime-memory) 2 | 3 | (export memory-definitions 4 | literal-memory-start-address 5 | heap-memory-start-vector 6 | write-string-pointer-addr 7 | write-string-length-addr 8 | write-string-bytes-written-addr) 9 | 10 | (import (scheme base) 11 | (values)) 12 | 13 | (begin 14 | (define memory-definitions 15 | ;; WASI requires the export name "memory" 16 | '(($heap (memory (export "memory") 10)))) 17 | 18 | ;; Reserve memory addresses 0x00000000-0x000000ff for runtime internal data. 19 | ;; Literal data will start from 0x00000100 20 | (define literal-memory-start-address #x00000100) 21 | 22 | ;; Address of pointer to start of heap after literal data 23 | (define heap-memory-start-vector #x00000000) 24 | 25 | ;; write-string iovec 26 | (define write-string-pointer-addr #x00000004) 27 | (define write-string-length-addr #x00000008) 28 | (define write-string-bytes-written-addr #x00000010) 29 | )) 30 | -------------------------------------------------------------------------------- /scheme-r7rs-syntax.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme-r7rs-syntax) 2 | 3 | (export check-library 4 | check-library-declarations 5 | library-has-declaration? 6 | library-declarations) 7 | 8 | (import (scheme base) 9 | (lists) 10 | (pattern-match) 11 | (compilation-error)) 12 | 13 | (begin 14 | (define (check-library exp) 15 | (cond 16 | ((pattern-match? `(define-library (,?? ,??*) ,??*) exp) 17 | (let ((identifiers (cadr exp))) 18 | (if (pattern-match? `(scheme ,??*) identifiers) 19 | (raise-compilation-error "scheme as first library name identifier is reserved" identifiers)) 20 | (let ((invalid-identifiers 21 | (filter 22 | (lambda (identifier) 23 | (not 24 | (or (symbol? identifier) 25 | (and (number? identifier) (integer? identifier) (>= identifier 0))))) 26 | identifiers))) 27 | (unless (null? invalid-identifiers) 28 | (raise-compilation-error "Invalid library name identifiers" invalid-identifiers))))) 29 | ((pattern-match? `(define-library) exp) 30 | (raise-compilation-error "Empty library definition" exp)) 31 | ((pattern-match? `(define-library ,??) exp) 32 | (raise-compilation-error "Expected list as library name" (cadr exp))) 33 | (else 34 | (raise-compilation-error "Invalid R7RS library definition" exp)))) 35 | 36 | (define (check-declaration decl) 37 | (cond ((pattern-match? `(export ,?? ,??*) decl)) 38 | ((pattern-match? '(export) decl) 39 | (raise-compilation-error "Empty export library declaration" decl)) 40 | ((pattern-match? `(import ,?? ,??*) decl)) 41 | ((pattern-match? '(import) decl) 42 | (raise-compilation-error "Empty import library declaration" decl)) 43 | ((pattern-match? `(begin ,?? ,??*) decl)) 44 | ((pattern-match? '(begin) decl) 45 | (raise-compilation-error "Empty begin library declaration" decl)) 46 | ((pattern-match? `(,?? ,??*) decl) 47 | (raise-compilation-error "Unsupported R7RS library declaration" decl)) 48 | ((not (pattern-match? `(,?? ,??*) decl)) 49 | (raise-compilation-error "Illegal R7RS library declaration" decl)))) 50 | 51 | (define (check-library-declarations library-def) 52 | (for-each check-declaration (cddr library-def))) 53 | 54 | (define (library-has-declaration? type library-def) 55 | (and (assq type (cddr library-def)) #t)) 56 | 57 | (define (library-declarations type library-def) 58 | (let collect ((decls (cddr library-def)) 59 | (decl '()) 60 | (result '())) 61 | (cond ((null? decl) 62 | (cond ((null? decls) (reverse result)) 63 | ((eq? (caar decls) type) (collect (cdr decls) (cdar decls) result)) 64 | (else (collect (cdr decls) '() result)))) 65 | (else (collect decls (cdr decl) (cons (car decl) result)))))) 66 | )) 67 | -------------------------------------------------------------------------------- /scheme-runtime-write.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme-runtime-write) 2 | 3 | (export scheme-write-table-entry) 4 | 5 | (import (scheme base) 6 | (scheme-runtime-base) 7 | (runtime-memory) 8 | (values)) 9 | 10 | (begin 11 | (define definitions 12 | '(($fd_write 13 | (func (import "wasi_snapshot_preview1" "fd_write") 14 | (param i32 i32 i32 i32) (result i32))))) 15 | 16 | (define code-table 17 | `(($write-string 18 | write-string 19 | ,(lambda (runtime-index) 20 | `(func (param $obj i32) (result i32) 21 | (local $bytes_written i32) 22 | ;; TEST==> 23 | ;; (local $simulate_partial i32) (local $temp i32) 24 | ;; <==TEST 25 | ;; set up iovec from the string contents 26 | i32.const ,write-string-length-addr 27 | local.get $obj 28 | call ,(runtime-index '((scheme base) $check-string)) 29 | i32.const ,heap-object-size-mask 30 | i32.and 31 | ;; TEST==> 32 | ;; i32.const 7 33 | ;; local.tee $simulate_partial 34 | ;; i32.sub 35 | ;; <==TEST 36 | i32.store 37 | i32.const ,write-string-pointer-addr 38 | local.get $obj 39 | i32.const ,heap-object-header-size 40 | i32.add 41 | i32.store 42 | ;; start writing loop 43 | loop $write 44 | block $result_ok 45 | ;; call WASI fd_write with iovec 46 | i32.const 1 ;; stdout 47 | i32.const ,write-string-pointer-addr 48 | i32.const 1 ;; one iovec 49 | i32.const ,write-string-bytes-written-addr 50 | call ,(runtime-index '$fd_write) 51 | ;; check for errors 52 | i32.eqz 53 | br_if $result_ok 54 | i32.const ,error-io-write 55 | ,@(macro-raise-error runtime-index) 56 | end ;; block $result_ok 57 | block $done 58 | ;; TEST ==> 59 | ;; i32.const ,write-string-length-addr 60 | ;; i32.load 61 | ;; local.get $simulate_partial 62 | ;; i32.add 63 | ;; local.tee $temp 64 | ;; i32.const ,write-string-length-addr 65 | ;; local.get $temp 66 | ;; i32.store 67 | ;; i32.const 0 68 | ;; local.set $simulate_partial 69 | ;; <== TEST 70 | ;; check for partial write 71 | i32.const ,write-string-bytes-written-addr 72 | i32.load 73 | local.tee $bytes_written 74 | i32.const ,write-string-length-addr 75 | i32.load 76 | i32.eq 77 | br_if $done 78 | ;; partial write, setup iovec for next write 79 | i32.const ,write-string-pointer-addr 80 | i32.const ,write-string-pointer-addr 81 | i32.load 82 | local.get $bytes_written 83 | i32.add 84 | i32.store 85 | i32.const ,write-string-length-addr 86 | i32.const ,write-string-length-addr 87 | i32.load 88 | local.get $bytes_written 89 | i32.sub 90 | i32.store 91 | br $write 92 | end ;; block $done 93 | end ;; loop $write 94 | i32.const ,unspecified-value))))) 95 | 96 | (define scheme-write-table-entry 97 | `((scheme write) ,definitions ,code-table)) 98 | ) 99 | ) 100 | -------------------------------------------------------------------------------- /scheme-runtime.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme-runtime) 2 | 3 | (export is-runtime-library 4 | compile-runtime-library-definitions 5 | compile-runtime-library 6 | runtime-exports 7 | lookup-runtime-index) 8 | 9 | (import (scheme base) 10 | (scheme cxr) 11 | (lists) 12 | (definitions-table) 13 | (compiled-program) 14 | (wasm-syntax)) 15 | 16 | (import (scheme-runtime-base) 17 | (scheme-runtime-write)) 18 | 19 | (begin 20 | (define runtime-libraries-table 21 | (list scheme-base-table-entry 22 | scheme-write-table-entry)) 23 | 24 | (define (runtime-library-entry library) 25 | (assoc library runtime-libraries-table)) 26 | 27 | (define (is-runtime-library library) 28 | (cond ((runtime-library-entry library) #t) 29 | (else #f))) 30 | 31 | (define (runtime-library-definitions library-entry) 32 | (cadr library-entry)) 33 | 34 | (define (runtime-library-definition-name definition-entry) 35 | (car definition-entry)) 36 | 37 | (define (runtime-library-definition definition-entry) 38 | (cadr definition-entry)) 39 | 40 | (define (runtime-library-table library-entry) 41 | (caddr library-entry)) 42 | 43 | (define (runtime-library-table-entry library-table name) 44 | (assq name library-table)) 45 | 46 | (define (runtime-entry-name entry) 47 | (car entry)) 48 | 49 | (define (runtime-entry-exported-name entry) 50 | (cadr entry)) 51 | 52 | (define (runtime-entry-definition-generator entry) 53 | (caddr entry)) 54 | 55 | (define (error-unknown-library library) 56 | (error "Unknown runtime library" library)) 57 | 58 | (define (compile-runtime-library-definitions library program) 59 | (let ((library-entry 60 | (cond ((runtime-library-entry library)) 61 | (else (error-unknown-library library))))) 62 | (fold 63 | (lambda (definition-entry program) 64 | (add-runtime-definition 65 | program 66 | library 67 | (runtime-library-definition-name definition-entry) 68 | #f 69 | (runtime-library-definition definition-entry))) 70 | program 71 | (runtime-library-definitions library-entry)))) 72 | 73 | (define (compile-runtime-library library program) 74 | (let ((library-entry 75 | (cond ((runtime-library-entry library)) 76 | (else (error-unknown-library library))))) 77 | (fold 78 | (lambda (entry program) 79 | (add-runtime-definition 80 | program 81 | library 82 | (runtime-entry-name entry) 83 | (runtime-entry-exported-name entry) 84 | ((runtime-entry-definition-generator entry) 85 | (lambda (library/name) 86 | (let ((library (if (pair? library/name) 87 | (car library/name) 88 | library)) 89 | (name (if (pair? library/name) 90 | (cadr library/name) 91 | library/name))) 92 | (or 93 | (lookup-runtime-index 94 | program 95 | library 96 | name) 97 | (error "Unknown runtime symbol" 98 | (list library 99 | (runtime-entry-name entry) 100 | library/name)))))))) 101 | program 102 | (runtime-library-table library-entry)))) 103 | 104 | (define (runtime-exports program library) 105 | (reverse 106 | (fold 107 | (lambda (definition exports) 108 | (let ((properties (cadr definition))) 109 | (cond ((and (equal? library (properties-library properties)) 110 | (properties-exported-name properties)) 111 | => (lambda (exported-name) 112 | (cons (cons exported-name 113 | (properties-definition-index properties)) 114 | exports))) 115 | (else exports)))) 116 | '() 117 | (compiled-program-get-definitions program 'runtime-index)))) 118 | 119 | (define-record-type runtime-index-properties 120 | (make-runtime-index-properties library name exported-name definition-index) 121 | runtime-index-properties? 122 | (library properties-library) 123 | (name properties-name) 124 | (exported-name properties-exported-name) 125 | (definition-index properties-definition-index)) 126 | 127 | (define (lookup-runtime-index program library name) 128 | (cond 129 | ((lookup-definition 130 | (compiled-program-module-definitions program) 131 | (lambda (def) 132 | (and (eq? (car def) 'runtime-index) 133 | (equal? library (properties-library (cadr def))) 134 | (eq? name (properties-name (cadr def)))))) => (lambda (def) 135 | (properties-definition-index (cadr def)))) 136 | (else #f))) 137 | 138 | (define (add-runtime-definition program library name exported-name definition) 139 | (if (lookup-runtime-index program library name) 140 | program 141 | (let* ((program 142 | (compiled-program-add-definition 143 | program 144 | definition)) 145 | (definition-index 146 | (- (compiled-program-definitions-count 147 | program 148 | (wasm-definition-type definition)) 149 | 1))) 150 | (compiled-program-add-definition 151 | program 152 | (list 'runtime-index 153 | (make-runtime-index-properties 154 | library name exported-name definition-index)))))) 155 | )) 156 | -------------------------------------------------------------------------------- /scheme-syntax.scm: -------------------------------------------------------------------------------- 1 | (define-library (scheme-syntax) 2 | 3 | (export variable? 4 | definition? definition-variable definition-value 5 | check-binding 6 | check-all-identifiers check-syntax-errors) 7 | 8 | (import (scheme base) 9 | (scheme cxr) 10 | (pattern-match) 11 | (compilation-error)) 12 | 13 | (begin 14 | (define (raise-error-on-match pat exp message object) 15 | (if (pattern-match? pat exp) 16 | (raise-compilation-error message object) 17 | #f)) 18 | 19 | ;; assignment 20 | (define (variable? exp) (symbol? exp)) 21 | (define (not-variable? exp) (not (variable? exp))) 22 | 23 | ;; syntax errors 24 | (define syntax-error-patterns 25 | `( 26 | ;; quote 27 | ((quote) "Too few operands") 28 | ((quote ,?? ,?? ,??*) "Too many operands") 29 | ;; assignment 30 | ((set!) "Variable and value missing from assignment") 31 | ((set! ,??) "Variable or value missing from assignment") 32 | ((set! ,?? ,?? ,?? ,??*) "Too many operands to assignment") 33 | ((set! ,not-variable? ,??) "Invalid variable in assignment") 34 | ;: lambda expression 35 | ((lambda) "Arguments and body missing from lambda expression") 36 | ((lambda ,??) "Body missing from lambda expression") 37 | ((lambda ,?? ,??) "Arguments list missing from lambda expression") 38 | ;: definition 39 | ((define) "Variable and value missing from definition") 40 | ((define (,?? ,??*)) "Empty body in procedure definition") 41 | ((define ,??) "Variable or value missing from definition") 42 | ((define ,variable? ,?? ,?? ,??*) "Too many operands to variable definition") 43 | ((define () ,??*) "Variable missing from procedure definition") 44 | ((define (,not-variable? ,??*) ,??*) "Not an identifier in variable position") 45 | ((define ,not-variable? ,??) "Not an identifier in variable position") 46 | ((define ,?? ,?? ,?? ,??*) "Not a variable or procedure definition") 47 | ;; if expression 48 | ((if) "Test and consequent missing from if expression") 49 | ((if ,??) "Consequent missing from if expression") 50 | ((if ,?? ,?? ,?? ,??*) "Too many subexpressions in if expression") 51 | ;; cond expression 52 | ((cond) "No clauses in cond expression") 53 | ;; not expression 54 | ((not) "Argument missing from not expression") 55 | ((not ,?? ,??*) "Too many arguments in not expression") 56 | ;; let expressions 57 | ((let () ,?? ,??*) "Empty bindings in let expression") 58 | ((let ,?? ,?? ,??*) "Bindings missing from let expression") 59 | ((let ,??) "Bindings or body missing from let expression") 60 | ((let) "Bindings and body missing from let expression") 61 | ((let* () ,?? ,??*) "Empty bindings in let* expression") 62 | ((let* ,?? ,?? ,??*) "Bindings missing from let* expression") 63 | ((let* ,??) "Bindings or body missing from let* expression") 64 | ((let*) "Bindings and body missing from let* expression") 65 | ((begin) "Empty sequence") 66 | (() "No operator in application"))) 67 | 68 | (define (check-syntax-errors exp) 69 | (for-each 70 | (lambda (pattern-and-message) 71 | (raise-error-on-match (car pattern-and-message) exp (cadr pattern-and-message) exp)) 72 | syntax-error-patterns) 73 | #f) 74 | 75 | (define (check-all-identifiers exps) 76 | (cond ((null? exps)) 77 | ((variable? (car exps)) (check-all-identifiers (cdr exps))) 78 | (else (raise-compilation-error "Not an identifier" (car exps))))) 79 | 80 | ;; definition 81 | (define (definition? exp) 82 | (or (pattern-match? `(define ,variable? ,??) exp) 83 | (pattern-match? `(define (,variable? ,??*) ,?? ,??*) exp))) 84 | 85 | (define (definition-variable exp) 86 | (if (pattern-match? `(define ,variable? ,??) exp) 87 | (cadr exp) 88 | (caadr exp))) 89 | 90 | (define (definition-value exp) 91 | (if (pattern-match? `(define ,variable? ,??) exp) 92 | (caddr exp) 93 | `(lambda ,(cdadr exp) ,@(cddr exp)))) 94 | 95 | ;; let expression 96 | (define (check-binding exp) 97 | (cond ((pattern-match? `(,variable? ,??) exp)) 98 | ((not (pattern-match? `(,??*) exp)) 99 | (raise-compilation-error "Not a binding" exp)) 100 | ((raise-error-on-match 101 | `(,?? ,??) exp "Not an identifier" (car exp))) 102 | ((raise-error-on-match 103 | `(,variable?) exp "Value missing from binding" exp)) 104 | ((raise-error-on-match 105 | `(,variable? ,?? ,?? ,??*) exp "Too many operands in binding" exp)) 106 | ((raise-error-on-match 107 | '() exp "Empty binding" exp)) 108 | (else (raise-compilation-error "Not a binding" exp)))) 109 | 110 | )) 111 | -------------------------------------------------------------------------------- /test-compiler/and.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (and) 3 | 4 | (export 5 | empty-and-is-true 6 | and-one-false-is-false 7 | and-one-non-false-value-is-value 8 | and-two-non-false-values-is-last-value 9 | and-any-false-is-false 10 | and-with-complex-expressions 11 | and-evaluates-expressions-from-left-to-right 12 | and-false-short-circuits-to-false) 13 | 14 | (import (scheme base)) 15 | 16 | (begin 17 | (define (empty-and-is-true) 18 | (and)) 19 | 20 | (define (and-one-false-is-false) 21 | (and #f)) 22 | 23 | (define (and-one-non-false-value-is-value) 24 | (and 42)) 25 | 26 | (define (and-two-non-false-values-is-last-value) 27 | (and 1 2)) 28 | 29 | (define (and-any-false-is-false) 30 | (if (and #f 2) 31 | #t 32 | (if (and 1 #f) 33 | #t 34 | #f))) 35 | 36 | (define (and-with-complex-expressions) 37 | (and (+ 0 1) 38 | ((lambda (x) (if x #f #t)) #f) 39 | (let ((x 1)) (* x 2)))) 40 | 41 | (define (and-evaluates-expressions-from-left-to-right) 42 | (let ((step 0)) 43 | (and (begin (set! step 1) 1) 44 | (begin (set! step 2) 2) 45 | (begin (set! step 3) 3)) 46 | step)) 47 | 48 | (define (and-false-short-circuits-to-false) 49 | (let ((step 0)) 50 | (and (begin (set! step 1) 1) 51 | (begin (set! step 2) #f) 52 | (begin (set! step 3) 3)) 53 | step)) 54 | ) 55 | ) 56 | -------------------------------------------------------------------------------- /test-compiler/arithmetic-operators.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (arithmetic-operators) 3 | 4 | (export 5 | plus-identity 6 | multiply-identity 7 | plus-single 8 | plus-single-expr 9 | minus-single 10 | minus-single-expr 11 | multiply-single 12 | plus-zero-to-positive 13 | plus-positive-result 14 | signed-plus-positive-result 15 | signed-plus-zero-result 16 | signed-plus-negative-result 17 | plus-zero-to-negative 18 | plus-multiple 19 | complex) 20 | 21 | (import (scheme base)) 22 | 23 | (begin 24 | (define (plus-identity) (+)) 25 | (define (multiply-identity) (*)) 26 | (define (plus-single) (+ 2)) 27 | (define (plus-single-expr) (+ (+ 1 2))) 28 | (define (minus-single) (- 2)) 29 | (define (minus-single-expr) (- (+ 2 3))) 30 | (define (multiply-single) (* 2)) 31 | (define (plus-zero-to-positive) (+ 0 2)) 32 | (define (plus-positive-result) (+ 1 2)) 33 | (define (signed-plus-positive-result) (+ 2 -1)) 34 | (define (signed-plus-zero-result) (+ 2 -2)) 35 | (define (signed-plus-negative-result) (+ 2 -3)) 36 | (define (plus-zero-to-negative) (+ -2 0)) 37 | (define (plus-multiple) (+ 1 2 3)) 38 | 39 | (define (complex) (+ (/ (* 2 -6 2) 3 2) (- (+ 1 2 3)) (* (+ (+ 1 1))))) 40 | ) 41 | ) 42 | -------------------------------------------------------------------------------- /test-compiler/assignment.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (assignment) 3 | 4 | (export set!-local-lambda) 5 | (export set!-local-let) 6 | (export set!-global) 7 | (export get-global) 8 | (export increment-global!) 9 | (export get-lambda-computed-global) 10 | 11 | (import (scheme base)) 12 | 13 | (begin 14 | (define (set!-local-lambda) 15 | ((lambda (x) 16 | (set! x 10) 17 | (+ x 3)) 18 | 5)) 19 | 20 | (define (set!-local-let) 21 | (let ((x 5)) 22 | (set! x 10) 23 | (+ x 3))) 24 | 25 | (define a 5) 26 | 27 | (define (set!-global) 28 | (set! a 10) 29 | (+ a 3)) 30 | 31 | (define b 0) 32 | (set! b 5) 33 | 34 | (define (get-global) b) 35 | 36 | (define (increment-global!) 37 | (set! b (+ b 1))) 38 | 39 | (define c 0) 40 | (set! c ((lambda (x) (+ x x)) 11)) 41 | 42 | (define (get-lambda-computed-global) c) 43 | ) 44 | ) 45 | -------------------------------------------------------------------------------- /test-compiler/comparison-operators.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (comparison-operators) 3 | 4 | (export 5 | all-with-single-argument-are-true 6 | binary-equal 7 | binary-greater-than 8 | binary-less-than 9 | binary-greater-or-equal-than 10 | binary-less-or-equal-than 11 | more-than-two-params-true 12 | more-than-two-params-false) 13 | 14 | (import (scheme base)) 15 | 16 | (begin 17 | (define (all-with-single-argument-are-true) 18 | (and (= 1) (< 2) (> 2) (<= 3) (>= 4))) 19 | 20 | (define (binary-equal x y) 21 | (= x y)) 22 | 23 | (define (binary-greater-than x y) 24 | (> x y)) 25 | 26 | (define (binary-less-than x y) 27 | (< x y)) 28 | 29 | (define (binary-greater-or-equal-than x y) 30 | (>= x y)) 31 | 32 | (define (binary-less-or-equal-than x y) 33 | (<= x y)) 34 | 35 | (define (more-than-two-params-true) 36 | (and (= 1 1 1) (< 1 2 3 4) (> 3 2 1 0 -1) (<= 1 2 2 3) (>= 3 2 2 1))) 37 | 38 | (define (more-than-two-params-false) 39 | (or (= 1 1 0) (< 1 2 4 3) (> 3 2 1 -1 0) (<= 1 2 0 2) (>= 3 2 3 2))) 40 | ) 41 | ) 42 | -------------------------------------------------------------------------------- /test-compiler/cond.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (cond) 3 | 4 | (export single-exp 5 | single-exp-else 6 | test-and-exp 7 | test-and-exp-else 8 | only-else 9 | nested 10 | short-circuit 11 | sequence-exps 12 | lambda-exps) 13 | 14 | (import (scheme base)) 15 | 16 | (begin 17 | (define (single-exp x) 18 | (cond (x))) 19 | 20 | (define (single-exp-else x) 21 | (cond (x) 22 | (else 2))) 23 | 24 | (define (test-and-exp x) 25 | (cond ((= x 1) (+ x 1)))) 26 | 27 | (define (test-and-exp-else x) 28 | (cond ((< x 10) (+ x 1)) 29 | (else (- x 1)))) 30 | 31 | (define (only-else) 32 | (cond (else 42))) 33 | 34 | (define (nested x) 35 | (cond ((< x 10) 36 | (cond ((> x 0) (+ x 1)) 37 | (else 0))) 38 | (else (- x 1)))) 39 | 40 | (define (short-circuit x) 41 | (let ((step 0)) 42 | (cond 43 | ((> x 1) (set! step (+ step 2))) 44 | ((> x 0) (set! step (+ step 1))) 45 | (else (set! step (+ step 3)))) 46 | step)) 47 | 48 | (define (sequence-exps x) 49 | (let ((step 0)) 50 | (cond 51 | ((> x 1) (set! step (+ step 2)) step) 52 | ((> x 0) (set! step (+ step 1)) step) 53 | (else (set! step (+ step 3)) step)))) 54 | 55 | (define (lambda-exps x) 56 | ((cond ((> x 1) (lambda (x) (+ x 2))) 57 | ((> x 0) (lambda (x) (+ x 1))) 58 | (else (lambda (x) (+ x 3)))) x)) 59 | ) 60 | ) 61 | -------------------------------------------------------------------------------- /test-compiler/define.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (define) 3 | 4 | (export define-constants 5 | define-combinations 6 | define-lambda-combination 7 | define-procedure 8 | define-procedure-with-lambda) 9 | 10 | (import (scheme base)) 11 | 12 | (begin 13 | (define x 40) 14 | (define y 2) 15 | 16 | (define (define-constants) (+ x y)) 17 | 18 | (define a (+ 30 2)) 19 | (define b (+ a 11)) 20 | 21 | (define (define-combinations) b) 22 | 23 | (define c ((lambda (x) (+ x x)) 11)) 24 | (define (define-lambda-combination) c) 25 | 26 | (define (double x) (* x 2)) 27 | 28 | (define (define-procedure) (double 8)) 29 | 30 | (define square (lambda (x) (* x x))) 31 | 32 | (define (define-procedure-with-lambda) (square 5))) 33 | ) 34 | -------------------------------------------------------------------------------- /test-compiler/eqv.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (eqv) 3 | 4 | (export 5 | eqv-literals 6 | eqv-proc-reference-to-same-proc-reference 7 | eqv-proc-reference-to-different-proc-reference 8 | eqv-proc-reference-to-lambda 9 | eqv-lambda-to-lambda-with-different-form 10 | eqv-lambda-to-lambda-with-same-form-is-boolean 11 | eqv-procedure-to-literal 12 | eqv-symbol-literal-with-same-symbol-literal 13 | eqv-symbol-reference-with-same-symbol-literal 14 | eqv-symbol-reference-with-same-reference 15 | eqv-symbol-to-literal 16 | eqv-symbol-to-procedure 17 | eqv-string-to-same-string-location 18 | eqv-string-to-string-literal-is-boolean 19 | eqv-string-to-literal 20 | eqv-string-to-procedure 21 | eqv-string-to-symbol) 22 | 23 | (import (scheme base)) 24 | 25 | (begin 26 | ;; literals 27 | (define (eqv-literals x y) 28 | (eqv? x y)) 29 | 30 | ;; procedures 31 | (define (proc x) (* x x)) 32 | (define (proc2 x) (+ x x)) 33 | 34 | (define (eqv-proc-reference-to-same-proc-reference) 35 | (and 36 | (eqv? proc proc) 37 | (let ((p (lambda (x) x))) 38 | (eqv? p p)))) 39 | 40 | (define (eqv-proc-reference-to-different-proc-reference) 41 | (eqv? proc proc2)) 42 | 43 | (define (eqv-proc-reference-to-lambda) 44 | (eqv? proc (lambda (x) (* x x)))) 45 | 46 | (define (eqv-lambda-to-lambda-with-different-form) 47 | (eqv? (lambda (x) (+ x 1)) (lambda (y) (+ y 2)))) 48 | 49 | (define (eqv-lambda-to-lambda-with-same-form-is-boolean) 50 | (boolean? (eqv? (lambda (x) (* x x)) (lambda (y) (* y y))))) 51 | 52 | (define (eqv-procedure-to-literal x) 53 | (or (eqv? proc x) 54 | (eqv? x proc) 55 | (eqv? (lambda (x) x) x) 56 | (eqv? x (lambda (y) (+ y 1))))) 57 | 58 | ;; symbols 59 | (define symbref 'symb) 60 | 61 | (define (eqv-symbol-literal-with-same-symbol-literal) 62 | (eqv? 'foo 'foo)) 63 | 64 | (define (eqv-symbol-reference-with-same-symbol-literal) 65 | (and (eqv? symbref 'symb) 66 | (eqv? 'symb symbref))) 67 | 68 | (define (eqv-symbol-reference-with-same-reference) 69 | (eqv? symbref symbref)) 70 | 71 | (define (eqv-symbol-to-literal x) 72 | (or (eqv? 'symb x) (eqv? symbref x) 73 | (eqv? x 'symb) (eqv? x symbref))) 74 | 75 | (define (eqv-symbol-to-procedure) 76 | (or (eqv? 'symb proc) (eqv? symbref proc) 77 | (eqv? proc 'symb) (eqv? proc symbref) 78 | (eqv? 'symb (lambda (x) x)) (eqv? (lambda (y) (+ y 1)) symbref))) 79 | 80 | ;; strings 81 | (define (eqv-string-to-same-string-location) 82 | (and 83 | (let ((s "")) 84 | (eqv? s s)) 85 | (let ((s "foobarxyzzy")) 86 | (eqv? s s)))) 87 | 88 | (define (eqv-string-to-string-literal-is-boolean) 89 | (and 90 | (boolean? (eqv? "" "")) 91 | (boolean? (eqv? "foobar1234" "foobar1234")) 92 | (boolean? (eqv? "x" "y")))) 93 | 94 | (define (eqv-string-to-literal x) 95 | (or (eqv? "foo" x) (eqv? x ""))) 96 | 97 | (define (eqv-string-to-procedure) 98 | (or (eqv? "proc" proc) (eqv? proc "") 99 | (eqv? "lambda" (lambda (x) x)) (eqv? (lambda (y) (+ y 1)) "lambda"))) 100 | 101 | (define (eqv-string-to-symbol) 102 | (or (eqv? "symb" 'symb) (eqv? 'symb "symb") 103 | (eqv? "" symbref) (eqv? symbref "foo"))) 104 | 105 | ) 106 | ) 107 | -------------------------------------------------------------------------------- /test-compiler/exported-procedure.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (exported-procedure) 3 | 4 | (export value square minus double) 5 | 6 | (import (scheme base)) 7 | 8 | (begin 9 | (define (value) 42) 10 | (define (square x) (* x x)) 11 | (define (minus x y) (- x y)) 12 | (define double (lambda (x) (+ x x))))) 13 | -------------------------------------------------------------------------------- /test-compiler/if.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (if) 3 | 4 | (export if-true 5 | if-number 6 | if-procedure 7 | if-symbol 8 | if-string 9 | if-true-expression 10 | if-true-does-not-evaluate-alternative 11 | if-true-consequent-only 12 | if-false 13 | if-false-expression 14 | if-false-does-not-evaluate-consequent 15 | if-false-consequent-only 16 | if-lambda-condition 17 | if-lambda-consequent 18 | if-lambda-alternative) 19 | 20 | (import (scheme base)) 21 | 22 | (begin 23 | (define x 1) 24 | 25 | (define (if-true) 26 | (if #t 1 2)) 27 | 28 | (define (if-number) 29 | (if 0 1 2)) 30 | 31 | (define (if-procedure) 32 | (if if-true 1 2)) 33 | 34 | (define (if-symbol) 35 | (if 'symb 1 2)) 36 | 37 | (define (if-string) 38 | (if "str" 1 2)) 39 | 40 | (define (if-true-expression) 41 | (set! x 1) 42 | (if (= x 1) x (+ x 1))) 43 | 44 | (define (if-true-does-not-evaluate-alternative) 45 | (set! x 0) 46 | (if (= x 0) (set! x (+ x 1)) (set! x (+ x 2))) 47 | x) 48 | 49 | (define (if-true-consequent-only) 50 | (set! x 1) 51 | (if (= x 1) (set! x (+ x 2))) 52 | x) 53 | 54 | (define (if-false) 55 | (if #f 1 2)) 56 | 57 | (define (if-false-expression) 58 | (set! x 1) 59 | (if (> x 1) x (+ x 1))) 60 | 61 | (define (if-false-does-not-evaluate-consequent) 62 | (set! x 0) 63 | (if (= x 1) (set! x (+ x 2)) (set! x (+ x 1))) 64 | x) 65 | 66 | (define (if-false-consequent-only) 67 | (set! x 1) 68 | (if (> x 1) (set! x (+ x 2))) 69 | x) 70 | 71 | (define (if-lambda-condition) 72 | (if ((lambda (x) (> x 0)) 1) 73 | 1 2)) 74 | 75 | (define (if-lambda-consequent) 76 | (if ((lambda (x) (> x 0)) 1) 77 | ((lambda (x) (+ x 1)) 1) 78 | 3)) 79 | 80 | (define (if-lambda-alternative) 81 | (if ((lambda (x) (> x 0)) 0) 82 | ((lambda (x) (+ x 1)) 1) 83 | ((lambda (x) (+ x 2)) 2))) 84 | ) 85 | ) 86 | -------------------------------------------------------------------------------- /test-compiler/imports-as-values.scm: -------------------------------------------------------------------------------- 1 | (define-library (imports-as-values) 2 | 3 | (import (scheme base)) 4 | 5 | (export imported-procedure-value-is-procedure 6 | apply-number?-as-value) 7 | 8 | (begin 9 | (define (get-number?) 10 | number?) 11 | 12 | (define (pred? p? x) 13 | (p? x)) 14 | 15 | (define (imported-procedure-value-is-procedure) 16 | (procedure? (get-number?))) 17 | 18 | (define (apply-number?-as-value x) 19 | ((get-number?) x)) 20 | 21 | )) 22 | -------------------------------------------------------------------------------- /test-compiler/lambda.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (lambda) 3 | 4 | (import (scheme base)) 5 | 6 | (export lambda-application 7 | lambda-argument 8 | lambda-without-parameters 9 | lambda-parameters-shadow-globals 10 | inner-lambda-parameters-shadow-outer 11 | lambda-procedure-result) 12 | 13 | (begin 14 | (define (lambda-application) 15 | ((lambda (x) (* x x)) 2)) 16 | 17 | (define (lambda-argument) 18 | ((lambda (n) 19 | ((lambda (fact n) (fact fact n)) 20 | (lambda (ft k) (if (= k 1) 1 (* k (ft ft (- k 1))))) n)) 21 | 5)) 22 | 23 | (define (lambda-without-parameters) 24 | ((lambda () (+ 40 2)))) 25 | 26 | (define g 2) 27 | (define h 3) 28 | 29 | (define (lambda-parameters-shadow-globals) 30 | ((lambda (g) (+ g h)) 4)) 31 | 32 | (define (inner-lambda-parameters-shadow-outer) 33 | ((lambda (x) (+ 2 ((lambda (x) (* x x)) 3))) 4)) 34 | 35 | (define (doubler) 36 | (lambda (x) (* 2 x))) 37 | 38 | (define (lambda-procedure-result) 39 | ((doubler) 3))) 40 | ) 41 | -------------------------------------------------------------------------------- /test-compiler/lib/compiler-test-to-wast.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (scheme read) 3 | (scheme write) 4 | (only (srfi srfi-1) fold for-each) 5 | (pattern-match) 6 | (values)) 7 | 8 | (define (compile-value exp) 9 | (cond ((boolean? exp) 10 | `(i32.const ,(boolean->boolean-value exp))) 11 | ((number? exp) 12 | `(i32.const ,(number->fixnum-value exp))) 13 | (else (error "Unsupported value" exp)))) 14 | 15 | (define (compile-test-exp exp) 16 | (let ((proc-name (symbol->string (car exp))) 17 | (args (cdr exp))) 18 | `(invoke ,proc-name ,@(map compile-value args)))) 19 | 20 | (define (compile-test-eq exp) 21 | (let ((name (cadr exp)) 22 | (test-exp (compile-test-exp (cadddr exp))) 23 | (expected-value (compile-value (caddr exp)))) 24 | `(,(string-append ";; " name) 25 | (assert_return ,test-exp ,expected-value)))) 26 | 27 | (define (compile-test-unspecified exp) 28 | (let ((name (cadr exp)) 29 | (test-exp (compile-test-exp (caddr exp)))) 30 | `(,(string-append ";; " name) 31 | (assert_return ,test-exp (i32.const ,unspecified-value))))) 32 | 33 | (define (compile-test-error exp) 34 | (let* ((name (cadr exp)) 35 | (test-exp (compile-test-exp (caddr exp))) 36 | (expected-error (cadddr exp)) 37 | (expected-error-code-entry (assq expected-error symbol->error)) 38 | (expected-error-code 39 | (if expected-error-code-entry 40 | (cdr expected-error-code-entry) 41 | (error "Unknown runtime error type" expected-error)))) 42 | `(,(string-append ";; " name) 43 | (assert_trap ,test-exp "unreachable") 44 | (assert_return (invoke "get-error-code") (i32.const ,expected-error-code))))) 45 | 46 | (define (compiler-test-expect-fail-host specifier) 47 | '()) 48 | 49 | (define (value->string exp) 50 | (cond ((boolean? exp) 51 | (if exp "#t" "#f")) 52 | ((number? exp) 53 | (number->string exp 10)) 54 | (else (error "Unsupported value" exp)))) 55 | 56 | (define (invocation-expr->string exp) 57 | (let ((proc (car exp)) 58 | (args (cdr exp))) 59 | (apply string-append 60 | `("(" 61 | ,(symbol->string proc) 62 | ,@(reverse 63 | (fold (lambda (v l) 64 | (cons (value->string v) 65 | (cons " " l))) 66 | '() 67 | args)) 68 | ")")))) 69 | 70 | (define (compile-test-invoke exp) 71 | `(,(string-append ";; " (invocation-expr->string (cdr exp))) 72 | ,(compile-test-exp (cdr exp)))) 73 | 74 | (define (compile-exp exp) 75 | (cond ((pattern-match? `(compiler-test-eq ,?? ,?? ,??) exp) 76 | (compile-test-eq exp)) 77 | ((pattern-match? `(compiler-test-invoke ,?? ,??*) exp) 78 | (compile-test-invoke exp)) 79 | ((pattern-match? `(compiler-test-unspecified ,?? ,??*) exp) 80 | (compile-test-unspecified exp)) 81 | ((pattern-match? `(compiler-test-error ,?? ,?? ,??) exp) 82 | (compile-test-error exp)) 83 | (else 'UNKNOWN))) 84 | 85 | (define (is-wast-ast? ast) 86 | (pair? ast)) 87 | 88 | (define (emit-wast wast-ast) 89 | (write-string (car wast-ast)) 90 | (newline) 91 | (for-each 92 | (lambda (wast-ast) 93 | (write wast-ast) 94 | (newline)) 95 | (cdr wast-ast))) 96 | 97 | (let compile-next ((exp (read))) 98 | (cond ((eof-object? exp) (newline)) 99 | (else 100 | (let ((ast (compile-exp exp))) 101 | (if (is-wast-ast? ast) 102 | (emit-wast ast))) 103 | (compile-next (read))))) 104 | -------------------------------------------------------------------------------- /test-compiler/lib/compiler-test.scm: -------------------------------------------------------------------------------- 1 | (define-library (compiler-test) 2 | 3 | (export compiler-test-begin 4 | compiler-test-end 5 | compiler-test-eq 6 | compiler-test-unspecified 7 | compiler-test-invoke 8 | compiler-test-error 9 | compiler-test-expect-fail-host) 10 | 11 | (import (scheme base) 12 | (scheme process-context) 13 | (srfi srfi-64)) 14 | 15 | (begin 16 | (define (compiler-test-begin name) 17 | (test-begin name)) 18 | 19 | (define-syntax compiler-test-eq 20 | (syntax-rules () 21 | ((compiler-test-eq test-name expected test-expr) 22 | (test-eq test-name expected test-expr)))) 23 | 24 | (define-syntax compiler-test-unspecified 25 | (syntax-rules () 26 | ((compiler-test-unspecified test-name test-expr) 27 | test-expr))) 28 | 29 | (define-syntax compiler-test-invoke 30 | (syntax-rules () 31 | ((compiler-test-invoke proc args ...) 32 | (proc args ...)))) 33 | 34 | (define-syntax compiler-test-error 35 | (syntax-rules () 36 | ((compiler-test-error test-name test-expr expected-error) 37 | (test-error test-name #t test-expr)))) 38 | 39 | (define (compiler-test-end name) 40 | (let ((fail-count (test-runner-fail-count (test-runner-current)))) 41 | (test-end name) 42 | (if (> fail-count 0) 43 | (exit #f)))) 44 | 45 | (define-syntax compiler-test-expect-fail-host 46 | (syntax-rules () 47 | ((compiler-test-expect-fail-host specifier) 48 | (test-expect-fail specifier)))) 49 | )) 50 | -------------------------------------------------------------------------------- /test-compiler/local-let-star.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (local-let-star) 3 | 4 | (export constant-let* 5 | expression-let* 6 | let*-shadowing 7 | let*-in-lambda 8 | let*-value-referring-lambda-arg 9 | let*-value-shadowing-lambda-arg 10 | lambda-as-let*-value 11 | mutate-locals 12 | get-global-with-let*-value 13 | get-global-assigned-with-let*-value) 14 | 15 | (import (scheme base)) 16 | 17 | (begin 18 | (define (constant-let*) 19 | (let* ((a 2)) 20 | (+ 40 a))) 21 | 22 | (define (expression-let*) 23 | (let* ((a (* 2 3)) 24 | (b (* 5 a))) 25 | b)) 26 | 27 | (define (let*-shadowing) 28 | (let* ((a 2) (b 3) (b 5)) 29 | (* a b))) 30 | 31 | (define (let*-in-lambda) 32 | ((lambda (x) 33 | (let* ((a 2)) 34 | (* a x))) 35 | 5)) 36 | 37 | (define (let*-value-referring-lambda-arg) 38 | ((lambda (x) 39 | (let* ((a (* x 2))) 40 | (* a x))) 41 | 3)) 42 | 43 | (define (let*-value-shadowing-lambda-arg) 44 | ((lambda (x) 45 | (let* ((x (* x 2))) 46 | (* x x))) 47 | 3)) 48 | 49 | (define (lambda-as-let*-value) 50 | (let* ((prod (* 2 3)) 51 | (double (lambda (x) (+ x x)))) 52 | (double prod))) 53 | 54 | (define (mutate-locals) 55 | (let* ((a 1) (b 2) (b (+ a b 3))) 56 | (set! a b) 57 | (set! b (+ b 1)) 58 | (+ a b))) 59 | 60 | (define global-with-let*-value 61 | (let* ((x 2) (y (+ x 1))) 62 | (+ x y))) 63 | 64 | (define (get-global-with-let*-value) 65 | global-with-let*-value) 66 | 67 | (define global-assigned-with-let*-value 0) 68 | 69 | (define (get-global-assigned-with-let*-value) 70 | global-assigned-with-let*-value) 71 | 72 | (set! global-assigned-with-let*-value 73 | (let* ((a 2) (b 3) (b (+ a b 4))) 74 | b)) 75 | ) 76 | ) 77 | -------------------------------------------------------------------------------- /test-compiler/local-let.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (local-let) 3 | 4 | (export constant-let 5 | expression-let 6 | multi-variable-let 7 | nested-let 8 | nested-let-referring-outer-let 9 | let-shadowing-let 10 | let-in-lambda 11 | let-value-referring-lambda-arg 12 | let-value-shadowing-lambda-arg 13 | lambda-as-let-value 14 | mutate-locals 15 | get-global-with-let-value 16 | get-global-assigned-with-let-value) 17 | 18 | (import (scheme base)) 19 | 20 | (begin 21 | (define (constant-let) 22 | (let ((a 2)) 23 | (+ 40 a))) 24 | 25 | (define (expression-let) 26 | (let ((a (* 2 3))) 27 | (* 5 a))) 28 | 29 | (define (multi-variable-let) 30 | (let ((a 2) (b 3)) 31 | (* a b))) 32 | 33 | (define (nested-let) 34 | (let ((a 2)) 35 | (let ((b 3)) 36 | (* a b)))) 37 | 38 | (define (nested-let-referring-outer-let) 39 | (let ((a 2)) 40 | (let ((b (+ a 1))) 41 | (* a b)))) 42 | 43 | (define (let-shadowing-let) 44 | (let ((a 2) (b 3)) 45 | (let ((b 5)) 46 | (* a b)))) 47 | 48 | (define (let-in-lambda) 49 | ((lambda (x) 50 | (let ((a 2)) 51 | (* a x))) 52 | 5)) 53 | 54 | (define (let-value-referring-lambda-arg) 55 | ((lambda (x) 56 | (let ((a (* x 2))) 57 | (* a x))) 58 | 3)) 59 | 60 | (define (let-value-shadowing-lambda-arg) 61 | ((lambda (x) 62 | (let ((x (* x 2))) 63 | (* x x))) 64 | 3)) 65 | 66 | (define (lambda-as-let-value) 67 | (let ((prod (* 2 3)) 68 | (double (lambda (x) (+ x x)))) 69 | (double prod))) 70 | 71 | (define (mutate-locals) 72 | (let ((a 1) (b 2)) 73 | (let ((c 3)) 74 | (set! a b) 75 | (set! b c) 76 | (set! c (+ c 1)) 77 | (+ a b c)))) 78 | 79 | (define global-with-let-value 80 | (let ((x 2) (y 3)) 81 | (+ x y))) 82 | 83 | (define (get-global-with-let-value) 84 | global-with-let-value) 85 | 86 | (define global-assigned-with-let-value 0) 87 | 88 | (define (get-global-assigned-with-let-value) 89 | global-assigned-with-let-value) 90 | 91 | (set! 92 | global-assigned-with-let-value 93 | (let ((a 2) (b 3)) 94 | (let ((c 4)) 95 | (+ a b c)))) 96 | ) 97 | ) 98 | -------------------------------------------------------------------------------- /test-compiler/not.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (not) 3 | 4 | (export 5 | not-true-is-false 6 | not-false-is-true 7 | not-non-false-value-is-false 8 | not-true-expression-is-false 9 | not-non-false-expression-is-false 10 | not-false-expression-is-true) 11 | 12 | (import (scheme base)) 13 | 14 | (begin 15 | (define (not-true-is-false) 16 | (not #t)) 17 | 18 | (define (not-false-is-true) 19 | (not #f)) 20 | 21 | (define (not-non-false-value-is-false) 22 | (not 42)) 23 | 24 | (define (not-true-expression-is-false) 25 | (not (> 1 0))) 26 | 27 | (define (not-non-false-expression-is-false) 28 | (not ((lambda (x) (+ x 1)) 2))) 29 | 30 | (define (not-false-expression-is-true) 31 | (not (> 0 1))) 32 | ) 33 | ) 34 | -------------------------------------------------------------------------------- /test-compiler/or.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (or) 3 | 4 | (export 5 | empty-or-is-false 6 | or-one-false-is-false 7 | or-one-non-false-value-is-value 8 | or-two-non-falses-is-first-value 9 | or-any-non-false-is-non-false 10 | or-with-complex-expressions 11 | or-evaluates-expressions-from-left-to-right 12 | or-true-short-circuits-to-true) 13 | 14 | (import (scheme base)) 15 | 16 | (begin 17 | (define (empty-or-is-false) 18 | (or)) 19 | 20 | (define (or-one-false-is-false) 21 | (or #f)) 22 | 23 | (define (or-one-non-false-value-is-value) 24 | (or 42)) 25 | 26 | (define (or-two-non-falses-is-first-value) 27 | (or 1 2)) 28 | 29 | (define (or-any-non-false-is-non-false) 30 | (if (or #f 2) 31 | (if (or 1 #f) 32 | #t 33 | #f) 34 | #f)) 35 | 36 | (define (or-with-complex-expressions) 37 | (or ((lambda (x) (if x #t #f)) #f) 38 | (> (+ 0 1) 2) 39 | (let ((x 1)) (* x 2)))) 40 | 41 | (define (or-evaluates-expressions-from-left-to-right) 42 | (let ((step 0)) 43 | (if (or 44 | (begin (set! step 1) (> step 1)) 45 | (begin (set! step 2) (> step 2)) 46 | (begin (set! step 3) 3)) 47 | step 48 | #f))) 49 | 50 | (define (or-true-short-circuits-to-true) 51 | (let ((step 0)) 52 | (or (begin (set! step 1) #f) 53 | (begin (set! step 2) 2) 54 | (begin (set! step 3) 3)) 55 | step)) 56 | ) 57 | ) 58 | -------------------------------------------------------------------------------- /test-compiler/override-special-form-as-operator.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (override-special-form-as-operator) 3 | 4 | (export override-quote-let 5 | override-quote-arg 6 | override-define-let 7 | override-define-arg 8 | override-lambda-let 9 | override-lambda-arg 10 | override-special-symbols-let*) 11 | 12 | (import (scheme base)) 13 | 14 | (begin 15 | (define (override-quote-let) 16 | (let ((quote (lambda (x) (+ x 2)))) 17 | (quote 40))) 18 | 19 | (define (quote-arg quote) 20 | (quote 2)) 21 | 22 | (define (override-quote-arg) 23 | (quote-arg (lambda (x) (+ x 40)))) 24 | 25 | (define (override-define-let) 26 | (let ((define (lambda (x) (+ x 2)))) 27 | (define 40))) 28 | 29 | (define (define-arg define) 30 | (define 2)) 31 | 32 | (define (override-define-arg) 33 | (define-arg (lambda (x) (+ x 40)))) 34 | 35 | (define (override-lambda-let) 36 | (let ((lambda (lambda (x) (+ x 2)))) 37 | (lambda 40))) 38 | 39 | (define (lambda-arg lambda) 40 | (lambda 2)) 41 | 42 | (define (override-lambda-arg) 43 | (lambda-arg (lambda (x) (+ x 40)))) 44 | 45 | (define (override-special-symbols-let*) 46 | (let* ((if (lambda (cond x) (cond x))) 47 | (set! (lambda (x) (+ x 2)))) 48 | (if set! 40))) 49 | ) 50 | ) 51 | -------------------------------------------------------------------------------- /test-compiler/override-special-form-as-variable.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (override-special-form-as-variable) 3 | 4 | (export override-quote-let 5 | override-quote-arg 6 | override-define-let 7 | override-define-arg 8 | override-lambda-let 9 | override-lambda-arg 10 | override-special-symbols-let*) 11 | 12 | (import (scheme base)) 13 | 14 | (begin 15 | (define (override-quote-let) 16 | (let ((quote (+ 40 2))) 17 | quote)) 18 | 19 | (define (override-quote-arg quote) 20 | (+ quote 1)) 21 | 22 | (define (override-define-let) 23 | (let ((define 42)) 24 | define)) 25 | 26 | (define (override-define-arg define) 27 | (+ define 1)) 28 | 29 | (define (override-lambda-let) 30 | (let ((lambda (+ 40 2))) 31 | lambda)) 32 | 33 | (define (override-lambda-arg lambda) 34 | (+ lambda 1)) 35 | 36 | (define (override-special-symbols-let*) 37 | (let* ((if 40) 38 | (set! 2)) 39 | (+ if set!))) 40 | ) 41 | ) 42 | -------------------------------------------------------------------------------- /test-compiler/re-export.scm: -------------------------------------------------------------------------------- 1 | (define-library (re-export) 2 | 3 | (import (scheme base)) 4 | 5 | ;; should export the re-defined number? 6 | (export number?) 7 | 8 | ;; should export the original zero? 9 | (export zero?) 10 | 11 | (begin 12 | ;; re-define imported number? 13 | (define (number? x) 42) 14 | 15 | )) 16 | -------------------------------------------------------------------------------- /test-compiler/recursive-definition.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (recursive-definition) 3 | 4 | (export gcd-test) 5 | 6 | (import (scheme base)) 7 | 8 | (begin 9 | (define (remainder-exp-positive n d e) 10 | (cond ((< n d) n) 11 | ((<= e n) (remainder-exp-positive (- n e) d (* e d))) 12 | (else (remainder-exp-positive n d (/ e d))))) 13 | 14 | ;; undefined for d=0 15 | (define (remainder-positive n d) 16 | (remainder-exp-positive n d d)) 17 | 18 | (define (gcd-positive a b) 19 | (if (= b 0) 20 | a 21 | (gcd-positive b (remainder-positive a b)))) 22 | 23 | (define (gcd-test a b) 24 | (let ((a (if (< a 0) (- a) a)) 25 | (b (if (< b 0) (- b) b))) 26 | (gcd-positive a b))) 27 | ) 28 | ) 29 | -------------------------------------------------------------------------------- /test-compiler/sequence.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (sequence) 3 | 4 | (export 5 | sequence-has-last-value 6 | sequence-has-last-expressions-value 7 | all-sequence-expressions-are-evaluated 8 | sequence-expressions-are-evaluated-in-order) 9 | 10 | (import (scheme base)) 11 | 12 | (begin 13 | (define (sequence-has-last-value) 14 | (begin 1 2 3)) 15 | 16 | (define (sequence-has-last-expressions-value) 17 | (begin (+ 0 1) (+ 0 2))) 18 | 19 | (define (all-sequence-expressions-are-evaluated) 20 | ((lambda (x) 21 | (begin (set! x (+ x 1)) (set! x (+ x 2)) (set! x (+ x 3))) x) 0)) 22 | 23 | (define (sequence-expressions-are-evaluated-in-order) 24 | ((lambda (x) 25 | (begin (set! x (+ x 1)) (set! x (* x 10)) (set! x (/ x 10))) x) 0)) 26 | ) 27 | ) 28 | -------------------------------------------------------------------------------- /test-compiler/sicp-exercise-1-19.scm: -------------------------------------------------------------------------------- 1 | ; SICP exercise 1.19 2 | 3 | ; Tpq: a <- bq + aq + ap, b <- bp + aq 4 | ; Compute (Tpq)^2 5 | ; a1 = bq + aq + ap, b1 = bp + aq 6 | ; b2 = b1p + a1p 7 | ; b2 = (bp + aq)p + (bq + aq + ap)p 8 | ; = bp^2 + aqp + bqp + aqp + apq 9 | ; = bp^2 + 2apq + bq^2 + aq^2 10 | ; = b(p^2 + q^2) + a(2pq + q^2) 11 | ; -> p ́ = p^2 + q^2, q ́ = 2pq + q^2 12 | 13 | (define-library 14 | (sicp-exercise-1-19) 15 | 16 | (export fib) 17 | 18 | (import (scheme base)) 19 | 20 | (begin 21 | (define (square x) (* x x)) 22 | 23 | (define (even?-exp-neg x e) 24 | (cond ((= x 0) #t) 25 | ((= x -1) #f) 26 | ((<= x e) (even?-exp-neg (- x e) (* e 2))) 27 | (else (even?-exp-neg x (/ e 2))))) 28 | 29 | (define (even? x) 30 | (even?-exp-neg (if (> x 0) (- x) x) -2)) 31 | 32 | (define (fib-iter a b p q count) 33 | (cond ((= count 0) b) 34 | ((even? count) 35 | (fib-iter a 36 | b 37 | (+ (square p) (square q)) ; p′ 38 | (+ (* 2 p q) (square q)) ; q′ 39 | (/ count 2))) 40 | (else 41 | (fib-iter (+ (* b q) (* a q) (* a p)) 42 | (+ (* b p) (* a q)) 43 | p 44 | q 45 | (- count 1))))) 46 | 47 | (define (fib n) (fib-iter 1 0 0 1 n)) 48 | ) 49 | ) 50 | -------------------------------------------------------------------------------- /test-compiler/string.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (string) 3 | 4 | (export 5 | literal-string-is-string 6 | literal-strings-as-values-are-strings 7 | string-may-contain-special-characters 8 | string=?-empty-literal-strings 9 | string=?-literal-strings-with-equal-content 10 | string=?-literal-strings-with-same-length-nonequal-content 11 | string=?-literal-strings-with-different-length 12 | string=?-one-char-equal-strings 13 | string=?-one-char-nonequal-strings 14 | string=?-expects-string-first-argument 15 | string=?-expects-string-second-argument) 16 | 17 | (import (scheme base)) 18 | 19 | (begin 20 | (define (literal-string-is-string) 21 | (string? "foo")) 22 | 23 | (define s1 "foobar") 24 | 25 | (define (is-string? x) 26 | (string? x)) 27 | 28 | (define (get-string) 29 | "got string") 30 | 31 | (define (literal-strings-as-values-are-strings) 32 | (let ((str "bound string")) 33 | (and 34 | (is-string? "foobar") 35 | (is-string? s1) 36 | (string? (get-string)) 37 | (string? str)))) 38 | 39 | (define (string-may-contain-special-characters) 40 | (let ((str "foo \t\n\r\\'bar' 😀 🤦🏼‍♂️ !@\x7f;\x07;")) 41 | (string? str))) 42 | 43 | (define (string=?-empty-literal-strings) 44 | (string=? "" "")) 45 | 46 | (define (string=?-one-char-equal-strings) 47 | (string=? "a" "a")) 48 | 49 | (define (string=?-one-char-nonequal-strings) 50 | (string=? "a" "b")) 51 | 52 | (define (string=?-literal-strings-with-equal-content) 53 | (string=? ":foo#😀🤦🏼‍♂️bar!\r\n" ":foo#😀🤦🏼‍♂️bar!\r\n")) 54 | 55 | (define (string=?-literal-strings-with-same-length-nonequal-content) 56 | (string=? ":foobar#" ":foobaz#")) 57 | 58 | (define (string=?-literal-strings-with-different-length) 59 | (string=? ":foobar#" ":foobazz#")) 60 | 61 | (define (string=?-expects-string-first-argument) 62 | (string=? 42 s1)) 63 | 64 | (define (string=?-expects-string-second-argument) 65 | (string=? "symb" 'symb)) 66 | ) 67 | ) 68 | -------------------------------------------------------------------------------- /test-compiler/symbol.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (symbol) 3 | 4 | (export 5 | literal-symbol-is-symbol 6 | literal-symbols-with-same-name-are-eq 7 | literal-symbols-with-same-name-are-symbol=? 8 | literal-symbols-with-different-name-are-not-eq 9 | literal-symbols-with-different-name-are-not-symbol=? 10 | literal-symbols-as-values-are-symbols 11 | symbol-may-contain-special-characters 12 | symbol=?-expects-symbol-first-argument 13 | symbol=?-expects-symbol-second-argument) 14 | 15 | (import (scheme base)) 16 | 17 | (begin 18 | (define (literal-symbol-is-symbol) 19 | (symbol? 'foo)) 20 | 21 | (define s1 'foo) 22 | (define s2 'foobar) 23 | 24 | (define (literal-symbols-with-same-name-are-eq) 25 | (and (eq? 'foo 'foo) (eq? s1 'foo))) 26 | 27 | (define (literal-symbols-with-same-name-are-symbol=?) 28 | (and (symbol=? 'foo 'foo) (symbol=? s1 'foo))) 29 | 30 | (define (literal-symbols-with-different-name-are-not-eq) 31 | (or (eq? 'baz s1) (eq? s1 s2))) 32 | 33 | (define (literal-symbols-with-different-name-are-not-symbol=?) 34 | (or (symbol=? 'baz s1) (symbol=? s1 s2))) 35 | 36 | (define (is-symbol? x) 37 | (symbol? x)) 38 | 39 | (define (get-symbol) 40 | 'got-symbol) 41 | 42 | (define (literal-symbols-as-values-are-symbols) 43 | (let ((symb 'bound-symbol)) 44 | (and 45 | (is-symbol? 'foobar) 46 | (is-symbol? s2) 47 | (symbol? (get-symbol)) 48 | (symbol? symb)))) 49 | 50 | (define (symbol-may-contain-special-characters) 51 | (let ((symb '|"foo" \t\n\r\\'bar'😀!@\x7f;\x07;|)) 52 | (symbol? symb))) 53 | 54 | (define (symbol=?-expects-symbol-first-argument) 55 | (symbol=? 42 s1)) 56 | 57 | (define (symbol=?-expects-symbol-second-argument) 58 | (symbol=? 'symb "symb")) 59 | ) 60 | ) 61 | -------------------------------------------------------------------------------- /test-compiler/test-compiler.mk: -------------------------------------------------------------------------------- 1 | COMPILER_TEST_PROGRAMS := $(wildcard test-compiler/test/*.scm) 2 | COMPILER_TEST_HOST_TARGETS := $(COMPILER_TEST_PROGRAMS:test-compiler/test/%.scm=test-compiler/%-host) 3 | COMPILER_TEST_HOST_LOGS := $(COMPILER_TEST_PROGRAMS:test-compiler/test/%.scm=test-compiler/host-log/%.log) 4 | RUN_COMPILER_TEST_HOST := $(HOST_SCHEME_RUN_PROGRAM) -L .. -L ../lib 5 | 6 | test-compiler/build/ \ 7 | test-compiler/log/ \ 8 | test-compiler/host-log/ \ 9 | test-compiler/wast-log/ \ 10 | test-compiler/wat : 11 | mkdir -p $@ 12 | 13 | .PHONY : test-compiler 14 | test-compiler : ## Executes all compiler integration tests 15 | test-compiler : test-compiler-host test-compiler-wast 16 | 17 | .PHONY : test-compiler-host 18 | test-compiler-host : ## Executes the compiler integration tests on the host scheme 19 | test-compiler-host : $(COMPILER_TEST_HOST_LOGS) 20 | 21 | $(COMPILER_TEST_HOST_TARGETS) : test-compiler/%-host : test-compiler/host-log/%.log 22 | 23 | $(COMPILER_TEST_HOST_LOGS) : test-compiler/host-log/%.log : test-compiler/%.scm \ 24 | test-compiler/test/%.scm \ 25 | test-compiler/lib/compiler-test.scm \ 26 | | test-compiler/host-log/ 27 | cd test-compiler/host-log ; \ 28 | rm -f $(notdir $(@:%.log=%.fail.log)) ; \ 29 | $(RUN_COMPILER_TEST_HOST) ../test/$(notdir $<) || \ 30 | (mv -f $(notdir $@) $(notdir $(@:%.log=%.fail.log)) && cat $(notdir $(@:%.log=%.fail.log))) 31 | 32 | COMPILER_TEST_WAST_TARGETS := $(COMPILER_TEST_PROGRAMS:test-compiler/test/%.scm=test-compiler/%-wast) 33 | COMPILER_TEST_WAST_TESTS := $(COMPILER_TEST_PROGRAMS:test-compiler/test/%.scm=test-compiler/build/%-test.wast) 34 | COMPILER_TEST_WAST_LOGS := $(COMPILER_TEST_PROGRAMS:test-compiler/test/%.scm=test-compiler/wast-log/%.log) 35 | COMPILER_TEST_WAST_COMPILER := test-compiler/lib/compiler-test-to-wast.scm 36 | COMPILER_TEST_TO_WAST := $(HOST_SCHEME_RUN_PROGRAM) -L . -C $(HOST_SCHEME_COMPILED_DIR) $(COMPILER_TEST_WAST_COMPILER) 37 | COMPILER_TEST_SCM_MODULES := $(wildcard test-compiler/*.scm) 38 | COMPILER_TEST_WAT_MODULES := $(COMPILER_TEST_SCM_MODULES:test-compiler/%.scm=test-compiler/wat/%.wat) 39 | 40 | .PHONY : test-compiler-wast 41 | test-compiler-wast : ## Compiles the compiler tests to WAST scripts and executes them 42 | test-compiler-wast : $(COMPILER_TEST_WAST_LOGS) $(COMPILER_TEST_WAT_MODULES) 43 | 44 | $(COMPILER_TEST_WAST_TARGETS) : test-compiler/%-wast : test-compiler/wast-log/%.log 45 | 46 | $(COMPILER_TEST_WAST_LOGS) : test-compiler/wast-log/%.log : test-compiler/build/%-test.json \ 47 | | test-compiler/wast-log/ 48 | spectest-interp $< | tee $@.tmp \ 49 | && mv -f $@.tmp $@ 50 | 51 | test-compiler/build/%-test.json : test-compiler/build/%.wat \ 52 | test-compiler/build/%-test.wast \ 53 | | test-compiler/build/ 54 | cat $^ | wast2json - -o $@.tmp \ 55 | && mv -f $@.tmp $@ 56 | 57 | $(COMPILER_TEST_WAST_TESTS) : test-compiler/lib/compiler-test-to-wast.scm 58 | $(COMPILER_TEST_WAST_TESTS) : test-compiler/build/%-test.wast : test-compiler/test/%.scm \ 59 | | test-compiler/build/ 60 | $(COMPILER_TEST_TO_WAST) < $< > $@.tmp \ 61 | && mv -f $@.tmp $@ 62 | 63 | $(COMPILER_TEST_WAT_MODULES) : test-compiler/wat/%.wat : test-compiler/build/%.wat \ 64 | | test-compiler/wat 65 | wat-desugar $< -o $@ 66 | 67 | test-compiler/log/%.log : test-compiler/build/%.json | test-compiler/log/ 68 | spectest-interp $< | tee $@.tmp \ 69 | && mv -f $@.tmp $@ 70 | 71 | test-compiler/build/%.json : test-compiler/build/%.wat \ 72 | test-compiler/wast/%.wast \ 73 | | test-compiler/build/ 74 | cat $^ | wast2json - -o $@.tmp \ 75 | && mv -f $@.tmp $@ 76 | 77 | test-compiler/build/%.wat : test-compiler/%.scm $(COMPILER_BINARIES) | test-compiler/build/ 78 | $(RUN_COMPILER) < $< > $@.tmp \ 79 | && mv -f $@.tmp $@ 80 | 81 | .PRECIOUS : test-compiler/build/%.json test-compiler/build/%.wast test-compiler/build/%.wat 82 | 83 | .PHONY : clean-test-compiler 84 | clean-test-compiler: ## Removes compiler test build artefacts and results 85 | -rm -rf \ 86 | test-compiler/build \ 87 | test-compiler/host-log \ 88 | test-compiler/wast-log 89 | -------------------------------------------------------------------------------- /test-compiler/test/and.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (and)) 3 | 4 | (compiler-test-begin "and") 5 | 6 | (compiler-test-eq 7 | "and without arguments is true" 8 | #t (empty-and-is-true)) 9 | 10 | (compiler-test-eq 11 | "and single false is false" 12 | #f (and-one-false-is-false)) 13 | 14 | (compiler-test-eq 15 | "and single non-false value is the value" 16 | 42 (and-one-non-false-value-is-value)) 17 | 18 | (compiler-test-eq 19 | "and of two non-false values is the last value" 20 | 2 (and-two-non-false-values-is-last-value)) 21 | 22 | (compiler-test-eq 23 | "and with any false value is false" 24 | #f (and-any-false-is-false)) 25 | 26 | (compiler-test-eq 27 | "and with comples non-false expressions is the last expression's value" 28 | 2 (and-with-complex-expressions)) 29 | 30 | (compiler-test-eq 31 | "and evaluates expressions from left to right" 32 | 3 (and-evaluates-expressions-from-left-to-right)) 33 | 34 | (compiler-test-eq 35 | "false value in and short-circuits to false" 36 | 2 (and-false-short-circuits-to-false)) 37 | 38 | (compiler-test-end "and") 39 | -------------------------------------------------------------------------------- /test-compiler/test/arithmetic-operators.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (arithmetic-operators)) 3 | 4 | (compiler-test-begin "arithmetic-operators") 5 | 6 | (compiler-test-eq 7 | "plus identity is zero" 8 | 0 (plus-identity)) 9 | 10 | (compiler-test-eq 11 | "multiply identity is one" 12 | 1 (multiply-identity)) 13 | 14 | (compiler-test-eq 15 | "plus single number equals the number" 16 | 2 (plus-single)) 17 | 18 | (compiler-test-eq 19 | "plus single expression equals the value of the expression" 20 | 3 (plus-single-expr)) 21 | 22 | (compiler-test-eq 23 | "minus single number equals the number negated" 24 | -2 (minus-single)) 25 | 26 | (compiler-test-eq 27 | "minus single expression equals the value of the expression negated" 28 | -5 (minus-single-expr)) 29 | 30 | (compiler-test-eq 31 | "multiply single number equals the number" 32 | 2 (multiply-single)) 33 | 34 | (compiler-test-eq 35 | "zero plus positive number equals the number" 36 | 2 (plus-zero-to-positive)) 37 | 38 | (compiler-test-eq 39 | "plus with two positive numbers equals sum of the numbers" 40 | 3 (plus-positive-result)) 41 | 42 | (compiler-test-eq 43 | "positive number plus smaller negative number equals the positive sum" 44 | 1 (signed-plus-positive-result)) 45 | 46 | (compiler-test-eq 47 | "positive number plus equal negative number equals zero" 48 | 0 (signed-plus-zero-result)) 49 | 50 | (compiler-test-eq 51 | "positive number plus greater negative number equals the negative sum" 52 | -1 (signed-plus-negative-result)) 53 | 54 | (compiler-test-eq 55 | "negative number plus zero equals the negative number" 56 | -2 (plus-zero-to-negative)) 57 | 58 | (compiler-test-eq 59 | "plus with more than two arguments equals sum of the arguments" 60 | 6 (plus-multiple)) 61 | 62 | (compiler-test-eq 63 | "nested arithmetic expression evaluates to correct value" 64 | -8 (complex)) 65 | 66 | (compiler-test-end "arithmetic-operators") 67 | -------------------------------------------------------------------------------- /test-compiler/test/assignment.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (assignment)) 3 | 4 | (compiler-test-begin "assignment") 5 | 6 | (compiler-test-eq 7 | "set! assigns new value to lambda argument" 8 | 13 (set!-local-lambda)) 9 | 10 | (compiler-test-eq 11 | "set! assigns new value to let binding" 12 | 13 (set!-local-let)) 13 | 14 | (compiler-test-eq 15 | "set! assigns new value to top-level binding" 16 | 13 (set!-global)) 17 | 18 | (compiler-test-eq 19 | "top-level set! assgins value to top-level binding" 20 | 5 (get-global)) 21 | 22 | (compiler-test-invoke increment-global!) 23 | (compiler-test-eq 24 | "incrementing set! of top-level binding increments the binding's value" 25 | 6 (get-global)) 26 | 27 | (compiler-test-invoke increment-global!) 28 | (compiler-test-eq 29 | "each incrementing set! of top-level binding increments the binding's value" 30 | 7 (get-global)) 31 | 32 | (compiler-test-eq 33 | "top-level set! value can be computed with a lambda" 34 | 22 (get-lambda-computed-global)) 35 | 36 | (compiler-test-end "assignment") 37 | -------------------------------------------------------------------------------- /test-compiler/test/comparison-operators.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (comparison-operators)) 3 | 4 | (compiler-test-begin "comparison-operators") 5 | 6 | (compiler-test-eq 7 | "all comparison operators with a single argument evaluate to true" 8 | #t (all-with-single-argument-are-true)) 9 | 10 | (compiler-test-eq 11 | "binary numeric equality is true with equal values" 12 | #t (binary-equal 1 1)) 13 | 14 | (compiler-test-eq 15 | "binary numeric equality is false with unequal values" 16 | #f (binary-equal 1 0)) 17 | 18 | (compiler-test-eq 19 | "binary numeric equality is false with unequal values" 20 | #f (binary-equal 0 1)) 21 | 22 | (compiler-test-eq 23 | "(> x y) = true, when x > y" 24 | #t (binary-greater-than 1 0)) 25 | 26 | (compiler-test-eq 27 | "(> x y) = false, when x < y" 28 | #f (binary-greater-than 0 1)) 29 | 30 | (compiler-test-eq 31 | "(> x y) = false, when x = y" 32 | #f (binary-greater-than 1 1)) 33 | 34 | (compiler-test-eq 35 | "(< x y) = true, when x < y" 36 | #t (binary-less-than 0 1)) 37 | 38 | (compiler-test-eq 39 | "(< x y) = false, when x > y" 40 | #f (binary-less-than 1 0)) 41 | 42 | (compiler-test-eq 43 | "(< x y) = false, when x = y" 44 | #f (binary-less-than 1 1)) 45 | 46 | (compiler-test-eq 47 | "(<= x y) = true, when x < y" 48 | #t (binary-less-or-equal-than 0 1)) 49 | 50 | (compiler-test-eq 51 | "(<= x y) = false, when x > y" 52 | #f (binary-less-or-equal-than 1 0)) 53 | 54 | (compiler-test-eq 55 | "(<= x y) = true, when x = y" 56 | #t (binary-less-or-equal-than 1 1)) 57 | 58 | (compiler-test-eq 59 | "(>= x y) = true, when x > y" 60 | #t (binary-greater-or-equal-than 1 0)) 61 | 62 | (compiler-test-eq 63 | "(>= x y) = false, when x < y" 64 | #f (binary-greater-or-equal-than 0 1)) 65 | 66 | (compiler-test-eq 67 | "(>= x y) = true, when x = y" 68 | #t (binary-greater-or-equal-than 1 1)) 69 | 70 | (compiler-test-eq 71 | "more-than-two-params-true" 72 | #t (more-than-two-params-true)) 73 | 74 | (compiler-test-eq 75 | "more-than-two-params-false" 76 | #f (more-than-two-params-false)) 77 | 78 | (compiler-test-end "comparison-operators") 79 | -------------------------------------------------------------------------------- /test-compiler/test/cond.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (cond)) 3 | 4 | (compiler-test-begin "cond") 5 | 6 | (compiler-test-eq 7 | "cond with single non-false test expression returns the value of the expression" 8 | 1 (single-exp 1)) 9 | 10 | (compiler-test-eq 11 | "cond with single true test expression returns true" 12 | #t (single-exp #t)) 13 | 14 | (compiler-test-unspecified 15 | "cond with single false test expression returns unspecified value" 16 | (single-exp #f)) 17 | 18 | (compiler-test-eq 19 | "cond with true test and expression returns value of the expression" 20 | 2 (test-and-exp 1)) 21 | 22 | (compiler-test-unspecified 23 | "cond with false test and expression returns unspecified value" 24 | (test-and-exp 2)) 25 | 26 | (compiler-test-eq 27 | "cond with true test, expression and else returns value of the expression" 28 | 6 (test-and-exp-else 5)) 29 | 30 | (compiler-test-eq 31 | "cond with false test, expression and else returns value of the else expression" 32 | 9 (test-and-exp-else 10)) 33 | 34 | (compiler-test-eq 35 | "cond with only else expression returns value of the else expression" 36 | 42 (only-else)) 37 | 38 | (compiler-test-eq 39 | "nested cond returns value of top-level else expression if all top-level tests evaluate to false" 40 | 10 (nested 11)) 41 | 42 | (compiler-test-eq 43 | "nested cond returns value of inner cond's clause with a test evaluating to true" 44 | 3 (nested 2)) 45 | 46 | (compiler-test-eq 47 | "nested cond returns value of inner cond's else when inner cond's tests evaluate to false" 48 | 0 (nested -1)) 49 | 50 | (compiler-test-eq 51 | "cond evaluates only the expression in the first clause that has a test evaluating to true" 52 | 1 (sequence-exps 1)) 53 | 54 | (compiler-test-eq 55 | "cond evaluates only the expression in the first clause that has a test evaluating to true" 56 | 2 (sequence-exps 2)) 57 | 58 | (compiler-test-eq 59 | "cond evaluates only the expression in the else clause when all test clauses evaluate to false" 60 | 3 (sequence-exps -1)) 61 | 62 | (compiler-test-eq 63 | "cond clause expression can be a lambda" 64 | 4 (lambda-exps 2)) 65 | 66 | (compiler-test-eq 67 | "cond clause expression can be a lambda" 68 | 2 (lambda-exps 1)) 69 | 70 | (compiler-test-eq 71 | "cond else expression can be a lambda" 72 | 2 (lambda-exps -1)) 73 | 74 | (compiler-test-end "cond") 75 | -------------------------------------------------------------------------------- /test-compiler/test/define.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (define)) 3 | 4 | (compiler-test-begin "define") 5 | 6 | (compiler-test-eq 7 | "define creates top-level bindings from constants" 8 | 42 (define-constants)) 9 | 10 | (compiler-test-eq 11 | "define creates top-level bindings from combinations" 12 | 43 (define-combinations)) 13 | 14 | (compiler-test-eq 15 | "define creates top-level binding from lambda expression result" 16 | 22 (define-lambda-combination)) 17 | 18 | (compiler-test-eq 19 | "define creates top-level procedure binding" 20 | 16 (define-procedure)) 21 | 22 | (compiler-test-eq 23 | "define creates top-level procedure binding from lambda expression" 24 | 25 (define-procedure-with-lambda)) 25 | 26 | (compiler-test-end "define") 27 | -------------------------------------------------------------------------------- /test-compiler/test/eqv.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (eqv)) 3 | 4 | (compiler-test-begin "eqv") 5 | 6 | ;; booleans to booleans 7 | (compiler-test-eq 8 | "#t eqv? #t is true" 9 | #t (eqv-literals #t #t)) 10 | 11 | (compiler-test-eq 12 | "#f eqv? #f is true" 13 | #t (eqv-literals #f #f)) 14 | 15 | (compiler-test-eq 16 | "#t eqv? #f is false" 17 | #f (eqv-literals #t #f)) 18 | 19 | (compiler-test-eq 20 | "#f eqv? #t is false" 21 | #f (eqv-literals #f #t)) 22 | 23 | ;; numbers to numbers 24 | (compiler-test-eq 25 | "0 eqv? 0 is true" 26 | #t (eqv-literals 0 0)) 27 | 28 | (compiler-test-eq 29 | "1 eqv? 1 is true" 30 | #t (eqv-literals 1 1)) 31 | 32 | (compiler-test-eq 33 | "-1 eqv? -1 is true" 34 | #t (eqv-literals -1 -1)) 35 | 36 | (compiler-test-eq 37 | "553 eqv? 553 is true" 38 | #t (eqv-literals 553 553)) 39 | 40 | (compiler-test-eq 41 | "0 eqv? 1 is false" 42 | #f (eqv-literals 0 1)) 43 | 44 | (compiler-test-eq 45 | "-1 eqv? 1 is false" 46 | #f (eqv-literals -1 1)) 47 | 48 | (compiler-test-eq 49 | "429 eqv? 555 is false" 50 | #f (eqv-literals 429 555)) 51 | 52 | ;; numbers to booleans 53 | (compiler-test-eq 54 | "0 eqv? #t is false" 55 | #f (eqv-literals 0 #t)) 56 | 57 | (compiler-test-eq 58 | "#t eqv? 1 is false" 59 | #f (eqv-literals #t 1)) 60 | 61 | (compiler-test-eq 62 | "0 eqv? #f is false" 63 | #f (eqv-literals 0 #t)) 64 | 65 | (compiler-test-eq 66 | "#f eqv? 1 is false" 67 | #f (eqv-literals #f 1)) 68 | 69 | ;; procedures to procedures 70 | (compiler-test-eq 71 | "procedure reference is eqv? with the same procedure reference" 72 | #t (eqv-proc-reference-to-same-proc-reference)) 73 | 74 | (compiler-test-eq 75 | "procedure reference is not eqv? with different procedure reference" 76 | #f (eqv-proc-reference-to-different-proc-reference)) 77 | 78 | (compiler-test-eq 79 | "procedure reference is not eqv? with lambda" 80 | #f (eqv-proc-reference-to-lambda)) 81 | 82 | (compiler-test-eq 83 | "a lambda is not eqv? to a lambda with different form" 84 | #f (eqv-lambda-to-lambda-with-different-form)) 85 | 86 | (compiler-test-eq 87 | "lambda eqv? to lambda with same form is boolean" 88 | #t (eqv-lambda-to-lambda-with-same-form-is-boolean)) 89 | 90 | ;; procedures to booleans 91 | (compiler-test-eq 92 | "procedure is not eqv? to #t" 93 | #f (eqv-procedure-to-literal #t)) 94 | 95 | (compiler-test-eq 96 | "procedure is not eqv? to #f" 97 | #f (eqv-procedure-to-literal #f)) 98 | 99 | ;; procedures to numbers 100 | (compiler-test-eq 101 | "procedure is not eqv? to 42" 102 | #f (eqv-procedure-to-literal 42)) 103 | 104 | (compiler-test-eq 105 | "procedure is not eqv? to 0" 106 | #f (eqv-procedure-to-literal 0)) 107 | 108 | ;; symbols to symbols 109 | (compiler-test-eq 110 | "symbol literal is eqv? with the same symbol literal" 111 | #t (eqv-symbol-literal-with-same-symbol-literal)) 112 | 113 | (compiler-test-eq 114 | "symbol reference is eqv? with the same symbol literal" 115 | #t (eqv-symbol-reference-with-same-symbol-literal)) 116 | 117 | (compiler-test-eq 118 | "symbol reference is eqv? with the same symbol reference" 119 | #t (eqv-symbol-reference-with-same-reference)) 120 | 121 | ;; symbols to literals 122 | (compiler-test-eq 123 | "symbol is not eqv? to 42" 124 | #f (eqv-symbol-to-literal 42)) 125 | 126 | ;; symbols to procedures 127 | (compiler-test-eq 128 | "symbol is not eqv? to a procedure" 129 | #f (eqv-symbol-to-procedure)) 130 | 131 | ;; strings to strings 132 | (compiler-test-eq 133 | "string location is eqv? with the same location" 134 | #t (eqv-string-to-same-string-location)) 135 | 136 | (compiler-test-eq 137 | "eqv? between string literals has boolean result" 138 | #t (eqv-string-to-string-literal-is-boolean)) 139 | 140 | ;; strings to booleans 141 | (compiler-test-eq 142 | "string is not eqv? to #t" 143 | #f (eqv-string-to-literal #t)) 144 | 145 | (compiler-test-eq 146 | "string is not eqv? to #f" 147 | #f (eqv-string-to-literal #f)) 148 | 149 | ;; strings to numbers 150 | (compiler-test-eq 151 | "string is not eqv? to 42" 152 | #f (eqv-string-to-literal 42)) 153 | 154 | (compiler-test-eq 155 | "string is not eqv? to 0" 156 | #f (eqv-string-to-literal 0)) 157 | 158 | ;; strings to procedures 159 | (compiler-test-eq 160 | "string is not eqv? to a procedure" 161 | #f (eqv-string-to-procedure)) 162 | 163 | ;; strings to symbols 164 | (compiler-test-eq 165 | "string is not eqv? to a symbol" 166 | #f (eqv-string-to-symbol)) 167 | 168 | (compiler-test-end "eqv") 169 | -------------------------------------------------------------------------------- /test-compiler/test/exported-procedure.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (exported-procedure)) 3 | 4 | (compiler-test-begin "exported-procedure") 5 | 6 | (compiler-test-eq 7 | "procedure with no arguments can be exported and called" 8 | 42 (value)) 9 | 10 | (compiler-test-eq 11 | "procedure with a single argument can be exported and called" 12 | 9 (square 3)) 13 | 14 | (compiler-test-eq 15 | "procedure with two arguments can be exported and called" 16 | -2 (minus 3 5)) 17 | 18 | (compiler-test-eq 19 | "lambda bound to a name can be exported and called" 20 | 6 (double 3)) 21 | 22 | (compiler-test-end "exported-procedure") 23 | -------------------------------------------------------------------------------- /test-compiler/test/if.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (if)) 3 | 4 | (compiler-test-begin "if") 5 | 6 | (compiler-test-eq 7 | "if with literal true test evaluates to the consequent" 8 | 1 (if-true)) 9 | 10 | (compiler-test-eq 11 | "if with literal number test evaluates to the consequent" 12 | 1 (if-number)) 13 | 14 | (compiler-test-eq 15 | "if with procedure test evaluates to the consequent" 16 | 1 (if-procedure)) 17 | 18 | (compiler-test-eq 19 | "if with literal symbol test evaluates to the consequent" 20 | 1 (if-symbol)) 21 | 22 | (compiler-test-eq 23 | "if with literal string test evaluates to the consequent" 24 | 1 (if-string)) 25 | 26 | (compiler-test-eq 27 | "if with test evaluating to true evaluates to the consequent" 28 | 1 (if-true-expression)) 29 | 30 | (compiler-test-eq 31 | "if with test evaluating to true does not evaluate the alternative" 32 | 1 (if-true-does-not-evaluate-alternative)) 33 | 34 | (compiler-test-eq 35 | "if with only consequent and test evaluating to true evaluates the consequent" 36 | 3 (if-true-consequent-only)) 37 | 38 | (compiler-test-eq 39 | "if with literal false test evaluates to the alternative" 40 | 2 (if-false)) 41 | 42 | (compiler-test-eq 43 | "if with test evaluating to false evaluates to the alternative" 44 | 2 (if-false-expression)) 45 | 46 | (compiler-test-eq 47 | "if with test evaluating to false does not evaluate the consequent" 48 | 1 (if-false-does-not-evaluate-consequent)) 49 | 50 | (compiler-test-eq 51 | "if with only consequent and test evaluating to false does not evaluate the consequent" 52 | 1 (if-false-consequent-only)) 53 | 54 | (compiler-test-eq 55 | "if with lambda in the test evaluates according to the result of the lambda" 56 | 1 (if-lambda-condition)) 57 | 58 | (compiler-test-eq 59 | "if with test evaluating to true and lambda consequent evaluates to the value of the consequent lambda expression" 60 | 2 (if-lambda-consequent)) 61 | 62 | (compiler-test-eq 63 | "if with test evaluating to false and lambda alternative evaluates to the value of the alternative lambda expression" 64 | 4 (if-lambda-alternative)) 65 | 66 | (compiler-test-end "if") 67 | -------------------------------------------------------------------------------- /test-compiler/test/imports-as-values.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (imports-as-values)) 3 | 4 | (compiler-test-begin "imports-as-values") 5 | 6 | (compiler-test-eq 7 | "Imported procedure value is a procedure" 8 | #t (imported-procedure-value-is-procedure)) 9 | 10 | (compiler-test-eq 11 | "number? can be applied as a value" 12 | #t (apply-number?-as-value 42)) 13 | 14 | (compiler-test-eq 15 | "number? can be applied as a value" 16 | #f (apply-number?-as-value #t)) 17 | 18 | (compiler-test-end "imports-as-values") 19 | -------------------------------------------------------------------------------- /test-compiler/test/lambda.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (lambda)) 3 | 4 | (compiler-test-begin "lambda") 5 | 6 | (compiler-test-eq 7 | "immediate lambda application evaluates to the value of the lambda body with parameters replaced with the arguments" 8 | 4 (lambda-application)) 9 | 10 | (compiler-test-eq 11 | "lambda expression can be used as an argument to another lambda" 12 | 120 (lambda-argument)) 13 | 14 | (compiler-test-eq 15 | "applying lambda without arguments evaluates to the value of the lambda body expression" 16 | 42 (lambda-without-parameters)) 17 | 18 | (compiler-test-eq 19 | "lambda parameters shadow global bindings with the same names" 20 | 7 (lambda-parameters-shadow-globals)) 21 | 22 | (compiler-test-eq 23 | "inner lambda parameters shadow outer lambda parameters with the same names" 24 | 11 (inner-lambda-parameters-shadow-outer)) 25 | 26 | (compiler-test-eq 27 | "lambda returned from a procedure can be applied to arguments" 28 | 6 (lambda-procedure-result)) 29 | 30 | (compiler-test-end "lambda") 31 | 32 | -------------------------------------------------------------------------------- /test-compiler/test/local-let-star.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (local-let-star)) 3 | 4 | (compiler-test-begin "local-let-star") 5 | 6 | (compiler-test-eq 7 | "let* bound to a constant expression evaluates to the constant's value" 8 | 42 (constant-let*)) 9 | 10 | (compiler-test-eq 11 | "let* bound to an expression evaluates to the expression's value" 12 | 30 (expression-let*)) 13 | 14 | (compiler-test-eq 15 | "later let* bindings shadow earlier bindings with the same name" 16 | 10 (let*-shadowing)) 17 | 18 | (compiler-test-eq 19 | "let* can be used in lambda body" 20 | 10 (let*-in-lambda)) 21 | 22 | (compiler-test-eq 23 | "let* in lambda body can use lambda parameter bindings" 24 | 18 (let*-value-referring-lambda-arg)) 25 | 26 | (compiler-test-eq 27 | "let* binding in lambda body shadows lambda parameter binding with the same name" 28 | 36 (let*-value-shadowing-lambda-arg)) 29 | 30 | (compiler-test-eq 31 | "let* can bind a lambda expression" 32 | 12 (lambda-as-let*-value)) 33 | 34 | (compiler-test-eq 35 | "set! can be used to mutate let* binding values" 36 | 13 (mutate-locals)) 37 | 38 | (compiler-test-eq 39 | "let* expression's value can be bound to a top-level binding" 40 | 5 (get-global-with-let*-value)) 41 | 42 | (compiler-test-eq 43 | "top-level set! can use a let expression value to mutate a top-level binding's value" 44 | 9 (get-global-assigned-with-let*-value)) 45 | 46 | (compiler-test-end "local-let-star") 47 | -------------------------------------------------------------------------------- /test-compiler/test/local-let.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (local-let)) 3 | 4 | (compiler-test-begin "local-let") 5 | 6 | (compiler-test-eq 7 | "let bound to a constant expression evaluates to the constant's value" 8 | 42 (constant-let)) 9 | 10 | (compiler-test-eq 11 | "let bound to an expression evaluates to the expression's value" 12 | 30 (expression-let)) 13 | 14 | (compiler-test-eq 15 | "let can bind multiple variables" 16 | 6 (multi-variable-let)) 17 | 18 | (compiler-test-eq 19 | "let can be nested" 20 | 6 (nested-let)) 21 | 22 | (compiler-test-eq 23 | "inner let body can refer outer let bindings" 24 | 6 (nested-let-referring-outer-let)) 25 | 26 | (compiler-test-eq 27 | "inner let bindings shadow outer let bindings" 28 | 10 (let-shadowing-let)) 29 | 30 | (compiler-test-eq 31 | "let can be used in lambda body" 32 | 10 (let-in-lambda)) 33 | 34 | (compiler-test-eq 35 | "let in lambda body can use lambda parameter bindings" 36 | 18 (let-value-referring-lambda-arg)) 37 | 38 | (compiler-test-eq 39 | "let binding in lambda body shadows lambda parameter binding with the same name" 40 | 36 (let-value-shadowing-lambda-arg)) 41 | 42 | (compiler-test-eq 43 | "let can bind a lambda expression" 44 | 12 (lambda-as-let-value)) 45 | 46 | (compiler-test-eq 47 | "set! can be used to mutate let binding values" 48 | 9 (mutate-locals)) 49 | 50 | (compiler-test-eq 51 | "let expression's value can be bound to a top-level binding" 52 | 5 (get-global-with-let-value)) 53 | 54 | (compiler-test-eq 55 | "top-level set! can use a let expression value to mutate a top-level binding's value" 56 | 9 (get-global-assigned-with-let-value)) 57 | 58 | (compiler-test-end "local-let") 59 | -------------------------------------------------------------------------------- /test-compiler/test/not.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (not)) 3 | 4 | (compiler-test-begin "not") 5 | 6 | (compiler-test-eq 7 | "not true is false" 8 | #f (not-true-is-false)) 9 | 10 | (compiler-test-eq 11 | "not false is true" 12 | #t (not-false-is-true)) 13 | 14 | (compiler-test-eq 15 | "not non-false value is false" 16 | #f (not-non-false-value-is-false)) 17 | 18 | (compiler-test-eq 19 | "not true expression is false" 20 | #f (not-true-expression-is-false)) 21 | 22 | (compiler-test-eq 23 | "not non-false expression is false" 24 | #f (not-non-false-expression-is-false)) 25 | 26 | (compiler-test-eq 27 | "not false expression is true" 28 | #t (not-false-expression-is-true)) 29 | 30 | (compiler-test-end "not") 31 | -------------------------------------------------------------------------------- /test-compiler/test/or.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (or)) 3 | 4 | (compiler-test-begin "or") 5 | 6 | (compiler-test-eq 7 | "empty or is false" 8 | #f (empty-or-is-false)) 9 | 10 | (compiler-test-eq 11 | "or one false is false" 12 | #f (or-one-false-is-false)) 13 | 14 | (compiler-test-eq 15 | "or with one non-false value is the value" 16 | 42 (or-one-non-false-value-is-value)) 17 | 18 | (compiler-test-eq 19 | "or with two non-false values is the first value" 20 | 1 (or-two-non-falses-is-first-value)) 21 | 22 | (compiler-test-eq 23 | "or with any non-false value is non-false" 24 | #t (or-any-non-false-is-non-false)) 25 | 26 | (compiler-test-eq 27 | "or test expressions can be arbitrarily complex" 28 | 2 (or-with-complex-expressions)) 29 | 30 | (compiler-test-eq 31 | "or evaluates expressions from left to right" 32 | 3 (or-evaluates-expressions-from-left-to-right)) 33 | 34 | (compiler-test-eq 35 | "or with non-false test short-circuits to non-false" 36 | 2 (or-true-short-circuits-to-true)) 37 | 38 | (compiler-test-end "or") 39 | -------------------------------------------------------------------------------- /test-compiler/test/override-special-form-as-operator.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (override-special-form-as-operator)) 3 | 4 | (compiler-test-begin "override-special-form-as-operator") 5 | 6 | (compiler-test-eq 7 | "let binding can override quote" 8 | 42 (override-quote-let)) 9 | 10 | (compiler-test-eq 11 | "procedure parameter can override quote" 12 | 42 (override-quote-arg)) 13 | 14 | (compiler-test-eq 15 | "let binding can override define" 16 | 42 (override-define-let)) 17 | 18 | (compiler-test-eq 19 | "procedure parameter can override define" 20 | 42 (override-define-arg)) 21 | 22 | (compiler-test-eq 23 | "let binding can override lambda" 24 | 42 (override-lambda-let)) 25 | 26 | (compiler-test-eq 27 | "procedure parameter can override lambda" 28 | 42 (override-lambda-arg)) 29 | 30 | (compiler-test-eq 31 | "let* bindings can override special symbols" 32 | 42 (override-special-symbols-let*)) 33 | 34 | (compiler-test-end "override-special-form-as-operator") 35 | -------------------------------------------------------------------------------- /test-compiler/test/override-special-form-as-variable.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (override-special-form-as-variable)) 3 | 4 | (compiler-test-begin "override-special-form-as-variable") 5 | 6 | (compiler-test-eq 7 | "let binding can override quote" 8 | 42 (override-quote-let)) 9 | 10 | (compiler-test-eq 11 | "procedure parameter can override quote" 12 | 43 (override-quote-arg 42)) 13 | 14 | (compiler-test-eq 15 | "let binding can override define" 16 | 42 (override-define-let)) 17 | 18 | (compiler-test-eq 19 | "procedure parameter can override define" 20 | 43 (override-define-arg 42)) 21 | 22 | (compiler-test-eq 23 | "let binding can override lambda" 24 | 42 (override-lambda-let)) 25 | 26 | (compiler-test-eq 27 | "procedure parameter can override lambda" 28 | 43 (override-lambda-arg 42)) 29 | 30 | (compiler-test-eq 31 | "let* bindings can override special symbols" 32 | 42 (override-special-symbols-let*)) 33 | 34 | (compiler-test-end "override-special-form-as-variable") 35 | -------------------------------------------------------------------------------- /test-compiler/test/re-export.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (re-export)) 3 | 4 | (compiler-test-begin "re-export") 5 | 6 | (compiler-test-expect-fail-host 7 | "Redefined number? is accessible and behaves like defined") 8 | 9 | (compiler-test-eq 10 | "Redefined number? is accessible and behaves like defined" 11 | 42 (number? 0)) 12 | 13 | (compiler-test-eq 14 | "Re-exported zero? is accessible and behaves like the built-in" 15 | #t (zero? 0)) 16 | 17 | (compiler-test-eq 18 | "Re-exported zero? is accessible and behaves like the built-in" 19 | #f (zero? 1)) 20 | 21 | (compiler-test-end "re-export") 22 | -------------------------------------------------------------------------------- /test-compiler/test/recursive-definition.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (recursive-definition)) 3 | 4 | (compiler-test-begin "recursive-definition") 5 | 6 | (compiler-test-eq 7 | "gcd of 42 and 0 is 42" 8 | 42 (gcd-test 42 0)) 9 | 10 | (compiler-test-eq 11 | "gcd of -42 and 0 is 42" 12 | 42 (gcd-test -42 0)) 13 | 14 | (compiler-test-eq 15 | "gcd of 0 and 42 is 42" 16 | 42 (gcd-test 0 42)) 17 | 18 | (compiler-test-eq 19 | "gcd of 0 and -42 is 42" 20 | 42 (gcd-test 0 -42)) 21 | 22 | (compiler-test-eq 23 | "gcd of 480 and 28 is 4" 24 | 4 (gcd-test 480 28)) 25 | 26 | (compiler-test-eq 27 | "gcd of -480 and 28 is 4" 28 | 4 (gcd-test -480 28)) 29 | 30 | (compiler-test-eq 31 | "gcd of 480 and -28 is 4" 32 | 4 (gcd-test 480 -28)) 33 | 34 | (compiler-test-eq 35 | "gcd of -480 and -28 is 4" 36 | 4 (gcd-test -480 -28)) 37 | 38 | (compiler-test-eq 39 | "gcd of 28 and 480 is 4" 40 | 4 (gcd-test 28 480)) 41 | 42 | (compiler-test-end "recursive-definition") 43 | -------------------------------------------------------------------------------- /test-compiler/test/sequence.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (sequence)) 3 | 4 | (compiler-test-begin "sequence") 5 | 6 | (compiler-test-eq 7 | "sequence of values evaluates to the last value" 8 | 3 (sequence-has-last-value)) 9 | 10 | (compiler-test-eq 11 | "sequence of expressions evaluates to the last expression's value" 12 | 2 (sequence-has-last-expressions-value)) 13 | 14 | (compiler-test-eq 15 | "all expressions in a sequence are evaluated" 16 | 6 (all-sequence-expressions-are-evaluated)) 17 | 18 | (compiler-test-eq 19 | "sequence expressions are evaluated in order" 20 | 1 (sequence-expressions-are-evaluated-in-order)) 21 | 22 | (compiler-test-end "sequence") 23 | -------------------------------------------------------------------------------- /test-compiler/test/sicp-exercise-1-19.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (sicp-exercise-1-19)) 3 | 4 | (compiler-test-begin "sicp-exercise-1-19") 5 | 6 | (compiler-test-eq 7 | "fib 0 is 0" 8 | 0 (fib 0)) 9 | 10 | (compiler-test-eq 11 | "fib 1 is 1" 12 | 1 (fib 1)) 13 | 14 | (compiler-test-eq 15 | "fib 2 is 1" 16 | 1 (fib 2)) 17 | 18 | (compiler-test-eq 19 | "fib 3 is 2" 20 | 2 (fib 3)) 21 | 22 | (compiler-test-eq 23 | "fib 4 is 3" 24 | 3 (fib 4)) 25 | 26 | (compiler-test-eq 27 | "fib 5 is 5" 28 | 5 (fib 5)) 29 | 30 | (compiler-test-eq 31 | "fib 30 is 832040" 32 | 832040 (fib 30)) 33 | 34 | (compiler-test-end "sicp-exercise-1-19") 35 | -------------------------------------------------------------------------------- /test-compiler/test/string.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (string)) 3 | 4 | (compiler-test-begin "string") 5 | 6 | (compiler-test-eq 7 | "literal string is string" 8 | #t (literal-string-is-string)) 9 | 10 | (compiler-test-eq 11 | "literal strings as values are strings" 12 | #t (literal-strings-as-values-are-strings)) 13 | 14 | (compiler-test-eq 15 | "literal string may contain special characters" 16 | #t (string-may-contain-special-characters)) 17 | 18 | (compiler-test-eq 19 | "string=? evaluates to true for two empty literal strings" 20 | #t (string=?-empty-literal-strings)) 21 | 22 | (compiler-test-eq 23 | "string=? evaluates to true for two equal one-character literal strings" 24 | #t (string=?-one-char-equal-strings)) 25 | 26 | (compiler-test-eq 27 | "string=? evaluates to false for two nonequal one-character literal strings" 28 | #f (string=?-one-char-nonequal-strings)) 29 | 30 | (compiler-test-eq 31 | "string=? evaluates to true for two literal strings with equal content" 32 | #t (string=?-literal-strings-with-equal-content)) 33 | 34 | (compiler-test-eq 35 | "string=? evaluates to false for two literal strings with same length but nonequal content" 36 | #f (string=?-literal-strings-with-same-length-nonequal-content)) 37 | 38 | (compiler-test-eq 39 | "string=? evaluates to false for two literal strings with different length" 40 | #f (string=?-literal-strings-with-different-length)) 41 | 42 | (compiler-test-error 43 | "string=? expectes a string as its first argument" 44 | (string=?-expects-string-first-argument) expected-string) 45 | 46 | (compiler-test-error 47 | "string=? expectes a string as its second argument" 48 | (string=?-expects-string-second-argument) expected-string) 49 | 50 | (compiler-test-end "string") 51 | -------------------------------------------------------------------------------- /test-compiler/test/symbol.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (symbol)) 3 | 4 | (compiler-test-begin "symbol") 5 | 6 | (compiler-test-eq 7 | "literal symbol is symbol" 8 | #t (literal-symbol-is-symbol)) 9 | 10 | (compiler-test-eq 11 | "eq? is true for literal symbols with same name" 12 | #t (literal-symbols-with-same-name-are-eq)) 13 | 14 | (compiler-test-eq 15 | "symbol=? is true for literal symbols with same name" 16 | #t (literal-symbols-with-same-name-are-symbol=?)) 17 | 18 | (compiler-test-eq 19 | "eq? is false for literal symbols with different name" 20 | #f (literal-symbols-with-different-name-are-not-eq)) 21 | 22 | (compiler-test-eq 23 | "symbol=? is false for literal symbols with different name" 24 | #f (literal-symbols-with-different-name-are-not-symbol=?)) 25 | 26 | (compiler-test-eq 27 | "literal symbols as values are symbols" 28 | #t (literal-symbols-as-values-are-symbols)) 29 | 30 | (compiler-test-eq 31 | "literal symbol names may contain special characters" 32 | #t (symbol-may-contain-special-characters)) 33 | 34 | (compiler-test-error 35 | "symbol=? expectes a symbol as its first argument" 36 | (symbol=?-expects-symbol-first-argument) expected-symbol) 37 | 38 | (compiler-test-error 39 | "symbol=? expectes a symbol as its second argument" 40 | (symbol=?-expects-symbol-second-argument) expected-symbol) 41 | 42 | (compiler-test-end "symbol") 43 | -------------------------------------------------------------------------------- /test-compiler/test/type-errors.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (type-errors)) 3 | 4 | (compiler-test-begin "type-errors") 5 | 6 | (compiler-test-error 7 | "arithmetic with boolean value is a type error" 8 | (plus-two #t) expected-number) 9 | 10 | (compiler-test-error 11 | "arithmetic with boolean value is a type error" 12 | (plus-two #f) expected-number) 13 | 14 | (compiler-test-error 15 | "arithmetic with procedure value is a type error" 16 | (lambda-two-times) expected-number) 17 | 18 | (compiler-test-error 19 | "arithmetic with procedure value is a type error" 20 | (procedure-plus-two) expected-number) 21 | 22 | (compiler-test-error 23 | "number as operator is a type error" 24 | (apply-to 2 #f) expected-procedure) 25 | 26 | (compiler-test-error 27 | "boolean as operator is a type error" 28 | (apply-to #t 3) expected-procedure) 29 | 30 | (compiler-test-error 31 | "arithmetic with unspecified value is a type error" 32 | (unspecified-plus-two) expected-number) 33 | 34 | (compiler-test-error 35 | "unspecified value as operator is a type error" 36 | (unspecified-as-operator 1) expected-procedure) 37 | 38 | (compiler-test-error 39 | "arithmetic with symbol value is a type error" 40 | (symbol-plus-two) expected-number) 41 | 42 | (compiler-test-error 43 | "symbol as operator is a type error" 44 | (symbol-as-operator 1) expected-procedure) 45 | 46 | (compiler-test-error 47 | "arithmetic with string value is a type error" 48 | (string-plus-two) expected-number) 49 | 50 | (compiler-test-error 51 | "string as operator is a type error" 52 | (string-as-operator 1) expected-procedure) 53 | 54 | (compiler-test-end "type-errors") 55 | -------------------------------------------------------------------------------- /test-compiler/test/types.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (types)) 3 | 4 | (compiler-test-begin "types") 5 | 6 | (compiler-test-eq 7 | "0 is number" 8 | #t (is-number? 0)) 9 | 10 | (compiler-test-eq 11 | "1 is number" 12 | #t (is-number? 1)) 13 | 14 | (compiler-test-eq 15 | "-1 is number" 16 | #t (is-number? -1)) 17 | 18 | (compiler-test-eq 19 | "0 is zero" 20 | #t (is-zero? 0)) 21 | 22 | (compiler-test-eq 23 | "1 is not zero" 24 | #f (is-zero? 1)) 25 | 26 | (compiler-test-eq 27 | "-1 is not zero" 28 | #f (is-zero? -1)) 29 | 30 | (compiler-test-eq 31 | "0 is eq to 0" 32 | #t (is-eq? 0 0)) 33 | 34 | (compiler-test-eq 35 | "1 is eq to 1" 36 | #t (is-eq? 1 1)) 37 | 38 | (compiler-test-eq 39 | "-1 is eq to -1" 40 | #t (is-eq? -1 -1)) 41 | 42 | (compiler-test-eq 43 | "0 is not eq to 1" 44 | #f (is-eq? 0 1)) 45 | 46 | (compiler-test-eq 47 | "1 is not eq to 0" 48 | #f (is-eq? 1 0)) 49 | 50 | (compiler-test-eq 51 | "numeric expression's value is number" 52 | #t (numeric-exp-is-number?)) 53 | 54 | (compiler-test-eq 55 | "true is not number" 56 | #f (is-number? #t)) 57 | 58 | (compiler-test-eq 59 | "false is not number" 60 | #f (is-number? #f)) 61 | 62 | (compiler-test-eq 63 | "true is boolean" 64 | #t (is-boolean? #t)) 65 | 66 | (compiler-test-eq 67 | "false is boolean" 68 | #t (is-boolean? #f)) 69 | 70 | (compiler-test-eq 71 | "1 is not boolean" 72 | #f (is-boolean? 1)) 73 | 74 | (compiler-test-eq 75 | "0 is not boolean" 76 | #f (is-boolean? 0)) 77 | 78 | (compiler-test-eq 79 | "-1 is not boolean" 80 | #f (is-boolean? -1)) 81 | 82 | (compiler-test-eq 83 | "true is eq to true" 84 | #t (is-eq? #t #t)) 85 | 86 | (compiler-test-eq 87 | "false is eq to false" 88 | #t (is-eq? #f #f)) 89 | 90 | (compiler-test-eq 91 | "true is not eq to false" 92 | #f (is-eq? #t #f)) 93 | 94 | (compiler-test-eq 95 | "false is not eq to true" 96 | #f (is-eq? #f #t)) 97 | 98 | (compiler-test-eq 99 | "true is not eq to 1" 100 | #f (is-eq? #t 1)) 101 | 102 | (compiler-test-eq 103 | "false is not eq to 0" 104 | #f (is-eq? #f 0)) 105 | 106 | (compiler-test-eq 107 | "eq? evaluates to boolean value" 108 | #t (eq?-evaluates-to-boolean-value)) 109 | 110 | (compiler-test-eq 111 | "arithmetic comparison operators return boolean values" 112 | #t (arithmetic-comparison-operators-evaluate-to-boolean-values)) 113 | 114 | (compiler-test-eq 115 | "lambda is procedure" 116 | #t (lambda-is-procedure?)) 117 | 118 | (compiler-test-eq 119 | "defined procedure is procedure" 120 | #t (defined-procedure-is-procedure?)) 121 | 122 | (compiler-test-eq 123 | "imported procedure is procedure" 124 | #t (imported-procedure-is-procedure?)) 125 | 126 | (compiler-test-eq 127 | "procedure argument is procedure" 128 | #t (procedure-argument-is-procedure?)) 129 | 130 | (compiler-test-eq 131 | "procedure from procedure is procedure" 132 | #t (procedure-from-procedure-is-procedure?)) 133 | 134 | (compiler-test-eq 135 | "procedure is eq to same procedure" 136 | #t (is-procedure-eq-to-same-procedure?)) 137 | 138 | (compiler-test-eq 139 | "procedure is not eq to different procedure" 140 | #f (is-procedure-eq-to-different-procedure?)) 141 | 142 | (compiler-test-eq 143 | "1 is not procedure" 144 | #f (is-procedure? 1)) 145 | 146 | (compiler-test-eq 147 | "true is not procedure" 148 | #f (is-procedure? #t)) 149 | 150 | (compiler-test-eq 151 | "false is not procedure" 152 | #f (is-procedure? #f)) 153 | 154 | (compiler-test-eq 155 | "1 is not eq to procedure number?" 156 | #f (is-procedure-number?-eq-to 1)) 157 | 158 | (compiler-test-eq 159 | "true is not eq to procedure number?" 160 | #f (is-procedure-number?-eq-to #t)) 161 | 162 | (compiler-test-eq 163 | "symbol is symbol" 164 | #t (symbol-is-symbol?)) 165 | 166 | (compiler-test-eq 167 | "0 is not a symbol" 168 | #f (is-symbol? 0)) 169 | 170 | (compiler-test-eq 171 | "1 is not a symbol" 172 | #f (is-symbol? 1)) 173 | 174 | (compiler-test-eq 175 | "-1 is not a symbol" 176 | #f (is-symbol? -1)) 177 | 178 | (compiler-test-eq 179 | "false is not a symbol" 180 | #f (is-symbol? #f)) 181 | 182 | (compiler-test-eq 183 | "true is not a symbol" 184 | #f (is-symbol? #t)) 185 | 186 | (compiler-test-eq 187 | "procedure is not a symbol" 188 | #f (procedure-is-symbol?)) 189 | 190 | (compiler-test-eq 191 | "string is not a symbol" 192 | #f (string-is-symbol?)) 193 | 194 | (compiler-test-eq 195 | "string is string" 196 | #t (string-is-string?)) 197 | 198 | (compiler-test-eq 199 | "0 is not a string" 200 | #f (is-string? 0)) 201 | 202 | (compiler-test-eq 203 | "1 is not a string" 204 | #f (is-string? 1)) 205 | 206 | (compiler-test-eq 207 | "-1 is not a string" 208 | #f (is-string? -1)) 209 | 210 | (compiler-test-eq 211 | "false is not a string" 212 | #f (is-string? #f)) 213 | 214 | (compiler-test-eq 215 | "true is not a string" 216 | #f (is-string? #t)) 217 | 218 | (compiler-test-eq 219 | "procedure is not a string" 220 | #f (procedure-is-string?)) 221 | 222 | (compiler-test-eq 223 | "symbol is not a string" 224 | #f (symbol-is-string?)) 225 | 226 | (compiler-test-end "types") 227 | -------------------------------------------------------------------------------- /test-compiler/test/values.scm: -------------------------------------------------------------------------------- 1 | (import (compiler-test) 2 | (values)) 3 | 4 | (compiler-test-begin "values") 5 | 6 | (compiler-test-eq 7 | "a number equals the same number" 8 | 42 (number)) 9 | 10 | (compiler-test-eq 11 | "a quoted number equals the number" 12 | 53 (quoted-number)) 13 | 14 | (compiler-test-eq 15 | "quoted number is a number" 16 | #t (quoted-number-is-number?)) 17 | 18 | (compiler-test-eq 19 | "true value equals true" 20 | #t (boolean-true)) 21 | 22 | (compiler-test-eq 23 | "false value equals false" 24 | #f (boolean-false)) 25 | 26 | (compiler-test-eq 27 | "quoted true value equals true" 28 | #t (quoted-boolean-true)) 29 | 30 | (compiler-test-eq 31 | "quoted false value equals false" 32 | #f (quoted-boolean-false)) 33 | 34 | (compiler-test-eq 35 | "quoted boolean is a boolean" 36 | #t (quoted-boolean-is-boolean?)) 37 | 38 | (compiler-test-end "values") 39 | -------------------------------------------------------------------------------- /test-compiler/type-errors.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (type-errors) 3 | 4 | (export 5 | plus-two 6 | two-times 7 | lambda-two-times 8 | procedure-plus-two 9 | apply-to 10 | unspecified-plus-two 11 | unspecified-as-operator 12 | symbol-plus-two 13 | symbol-as-operator 14 | string-plus-two 15 | string-as-operator) 16 | 17 | (import (scheme base)) 18 | 19 | (begin 20 | (define (plus-two x) 21 | (+ x 2)) 22 | 23 | (define (two-times x) 24 | (* 2 x)) 25 | 26 | (define (lambda-two-times) 27 | (two-times (lambda (x) (* x x)))) 28 | 29 | (define (procedure-plus-two) 30 | (plus-two two-times)) 31 | 32 | (define (apply-to o p) 33 | (o p)) 34 | 35 | (define (unspecified-plus-two) 36 | (plus-two (cond (#f 42)))) 37 | 38 | (define (unspecified-as-operator x) 39 | ((cond (#f (lambda (x) (+ x 1)))) x)) 40 | 41 | (define (symbol-plus-two) 42 | (plus-two 'foo)) 43 | 44 | (define (symbol-as-operator x) 45 | ('bar x)) 46 | 47 | (define (string-plus-two) 48 | (plus-two "foo")) 49 | 50 | (define (string-as-operator x) 51 | ("bar" x)) 52 | 53 | ) 54 | ) 55 | -------------------------------------------------------------------------------- /test-compiler/types.scm: -------------------------------------------------------------------------------- 1 | (define-library 2 | (types) 3 | 4 | (export 5 | is-number? 6 | is-zero? 7 | is-eq? 8 | numeric-exp-is-number? 9 | is-boolean? 10 | eq?-evaluates-to-boolean-value 11 | arithmetic-comparison-operators-evaluate-to-boolean-values 12 | is-procedure? 13 | lambda-is-procedure? 14 | defined-procedure-is-procedure? 15 | imported-procedure-is-procedure? 16 | procedure-argument-is-procedure? 17 | procedure-from-procedure-is-procedure? 18 | is-procedure-eq-to-same-procedure? 19 | is-procedure-eq-to-different-procedure? 20 | is-procedure-number?-eq-to 21 | symbol-is-symbol? 22 | is-symbol? 23 | procedure-is-symbol? 24 | string-is-symbol? 25 | string-is-string? 26 | is-string? 27 | procedure-is-string? 28 | symbol-is-string?) 29 | 30 | (import (scheme base)) 31 | 32 | (begin 33 | (define (is-number? x) 34 | (number? x)) 35 | 36 | (define (is-zero? x) 37 | (zero? x)) 38 | 39 | (define (is-eq? x y) 40 | (eq? x y)) 41 | 42 | (define (numeric-exp-is-number?) 43 | (number? (+ 1 2))) 44 | 45 | (define (is-boolean? x) 46 | (boolean? x)) 47 | 48 | (define (eq?-evaluates-to-boolean-value) 49 | (and (boolean? (eq? 1 1)) 50 | (boolean? (eq? 1 2)))) 51 | 52 | (define (arithmetic-comparison-operators-evaluate-to-boolean-values) 53 | (and (boolean? (< 1 2)) 54 | (boolean? (< 2 1)) 55 | (boolean? (<= 1 2)) 56 | (boolean? (<= 2 1)) 57 | (boolean? (= 1 1)) 58 | (boolean? (> 2 1)) 59 | (boolean? (> 1 2)) 60 | (boolean? (>= 2 1)) 61 | (boolean? (>= 1 2)))) 62 | 63 | (define (is-procedure? x) 64 | (procedure? x)) 65 | 66 | (define (lambda-is-procedure?) 67 | (procedure? (lambda (x) (+ x x)))) 68 | 69 | (define (defined-procedure-is-procedure?) 70 | (procedure? lambda-is-procedure?)) 71 | 72 | (define (imported-procedure-is-procedure?) 73 | (procedure? number?)) 74 | 75 | (define (procedure-argument-is-procedure?) 76 | (and (is-procedure? (lambda (x) (* x x))) 77 | (is-procedure? is-number?) 78 | (is-procedure? zero?))) 79 | 80 | (define (doubler) 81 | (lambda (x) (+ x x))) 82 | 83 | (define (procedure-from-procedure-is-procedure?) 84 | (procedure? (doubler))) 85 | 86 | (define (is-procedure-eq-to-same-procedure?) 87 | (eq? number? number?)) 88 | 89 | (define (is-procedure-eq-to-different-procedure?) 90 | (or (eq? number? zero?) (eq? zero? number?))) 91 | 92 | (define (is-procedure-number?-eq-to x) 93 | (eq? number? x)) 94 | 95 | (define (symbol-is-symbol?) 96 | (symbol? 'sym)) 97 | 98 | (define (is-symbol? x) 99 | (symbol? x)) 100 | 101 | (define (procedure-is-symbol?) 102 | (symbol? doubler)) 103 | 104 | (define (string-is-symbol?) 105 | (symbol? "bar")) 106 | 107 | (define (string-is-string?) 108 | (string? "foo")) 109 | 110 | (define (is-string? x) 111 | (string? x)) 112 | 113 | (define (procedure-is-string?) 114 | (string? doubler)) 115 | 116 | (define (symbol-is-string?) 117 | (string? 'test)) 118 | 119 | )) 120 | -------------------------------------------------------------------------------- /test-compiler/values.scm: -------------------------------------------------------------------------------- 1 | (define-library (values) 2 | 3 | (export 4 | number quoted-number quoted-number-is-number? 5 | boolean-true boolean-false quoted-boolean-true quoted-boolean-false quoted-boolean-is-boolean?) 6 | 7 | (import (scheme base)) 8 | 9 | (begin 10 | (define (number) 42) 11 | (define (quoted-number) (quote 53)) 12 | (define (quoted-number-is-number?) (number? (quote 1))) 13 | 14 | (define (boolean-true) #t) 15 | (define (boolean-false) #f) 16 | 17 | (define (quoted-boolean-true) (quote #t)) 18 | (define (quoted-boolean-false) (quote #f)) 19 | (define (quoted-boolean-is-boolean?) 20 | (and (boolean? (quote #f)) (boolean? (quote #t))))) 21 | ) 22 | -------------------------------------------------------------------------------- /test-compiler/wat/README.md: -------------------------------------------------------------------------------- 1 | # Contents of this directory 2 | 3 | This directory contains WAT (WebAssembly text format) code generated from 4 | integration test files [test-compiler/*.scm](..) by the compiler that is been 5 | developed in this repository. The files are formatted with 6 | [WABT](https://github.com/WebAssembly/wabt)'s `wat-desugar` 7 | command. The .wat files are updated automatically by this project's build 8 | script when the integration test files or the compiler's code generated for them 9 | changes. 10 | 11 | The purpose of storing these files into the repository is to expose changes 12 | in the compiler's code generation as a difference to the files produced by 13 | previous versions of the compiler. Changes into these files should be 14 | reviewed and committed to this repository along with the update compiler source 15 | files. -------------------------------------------------------------------------------- /test-compiler/wat/re-export.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (type (;0;) (func (param i32) (result i32))) 3 | (func (;0;) (result i32) 4 | global.get 0 5 | i32.const 0 6 | global.set 0) 7 | (export "get-error-code" (func 0)) 8 | (func (;1;) (param $value i32) (result i32) 9 | local.get $value 10 | i32.const 1 11 | i32.shl 12 | i32.const 1 13 | i32.or) 14 | (func (;2;) (param $obj i32) (result i32) 15 | local.get $obj 16 | local.get $obj 17 | i32.const 1 18 | i32.and 19 | i32.const 1 20 | i32.ne 21 | if ;; label = @1 22 | i32.const 2 23 | global.set 0 24 | unreachable 25 | end) 26 | (func (;3;) (param $obj i32) (result i32) 27 | local.get $obj 28 | call 2 29 | i32.const 1 30 | i32.shr_s) 31 | (func (;4;) (param $value i32) (result i32) 32 | i32.const 22 33 | i32.const 6 34 | local.get $value 35 | select) 36 | (func (;5;) (param $obj i32) (result i32) 37 | i32.const 0 38 | i32.const 1 39 | local.get $obj 40 | i32.const 6 41 | i32.eq 42 | select) 43 | (func (;6;) (param $funcidx i32) (result i32) 44 | local.get $funcidx 45 | i32.const 4 46 | i32.shl 47 | i32.const 2 48 | i32.or) 49 | (func (;7;) (param $obj i32) (result i32) 50 | local.get $obj 51 | local.get $obj 52 | i32.const 15 53 | i32.and 54 | i32.const 2 55 | i32.ne 56 | if ;; label = @1 57 | i32.const 3 58 | global.set 0 59 | unreachable 60 | end) 61 | (func (;8;) (param $obj i32) (result i32) 62 | local.get $obj 63 | call 7 64 | i32.const 4 65 | i32.shr_u) 66 | (func (;9;) (param $obj i32) (result i32) 67 | local.get $obj 68 | i32.const 1 69 | i32.and 70 | call 4) 71 | (func (;10;) (param $obj i32) (result i32) 72 | local.get $obj 73 | call 3 74 | i32.eqz 75 | call 4) 76 | (func (;11;) (param $obj i32) (result i32) 77 | local.get $obj 78 | i32.const 15 79 | i32.and 80 | i32.const 6 81 | i32.eq 82 | call 4) 83 | (func (;12;) (param $obj i32) (result i32) 84 | local.get $obj 85 | i32.const 15 86 | i32.and 87 | i32.const 2 88 | i32.eq 89 | call 4) 90 | (func (;13;) (param $obj i32) (result i32) 91 | local.get $obj 92 | i32.const 3 93 | i32.and 94 | i32.eqz 95 | if (result i32) ;; label = @1 96 | local.get $obj 97 | i32.load 98 | i32.const 251658240 99 | i32.and 100 | i32.const 16777216 101 | i32.eq 102 | call 4 103 | else 104 | i32.const 6 105 | end) 106 | (func (;14;) (param $obj i32) (result i32) 107 | local.get $obj 108 | i32.const 3 109 | i32.and 110 | i32.eqz 111 | if (result i32) ;; label = @1 112 | local.get $obj 113 | i32.load 114 | i32.const 251658240 115 | i32.and 116 | i32.const 33554432 117 | i32.eq 118 | call 4 119 | else 120 | i32.const 6 121 | end) 122 | (func (;15;) (param $obj1 i32) (param $obj2 i32) (result i32) 123 | local.get $obj1 124 | local.get $obj2 125 | i32.eq 126 | call 4) 127 | (func (;16;) (param $obj1 i32) (param $obj2 i32) (result i32) 128 | local.get $obj1 129 | local.get $obj2 130 | call 15) 131 | (func (;17;) (param $obj i32) (param $type i32) (param $error i32) (result i32) 132 | block $error 133 | local.get $obj 134 | i32.const 3 135 | i32.and 136 | br_if $error 137 | local.get $obj 138 | i32.load 139 | i32.const 251658240 140 | i32.and 141 | local.get $type 142 | i32.ne 143 | br_if $error 144 | local.get $obj 145 | return 146 | end 147 | local.get $error 148 | global.set 0 149 | unreachable) 150 | (func (;18;) (param $obj i32) (result i32) 151 | local.get $obj 152 | i32.const 16777216 153 | i32.const 4 154 | call 17) 155 | (func (;19;) (param $s1 i32) (param $s2 i32) (result i32) 156 | local.get $s1 157 | call 18 158 | local.get $s2 159 | call 18 160 | i32.eq 161 | call 4) 162 | (func (;20;) (param $obj i32) (param $type i32) (param $error i32) (result i32) 163 | (local $heap-obj i32) 164 | block $error 165 | local.get $obj 166 | i32.const 3 167 | i32.and 168 | br_if $error 169 | local.get $obj 170 | i32.load 171 | local.tee $heap-obj 172 | i32.const 251658240 173 | i32.and 174 | local.get $type 175 | i32.ne 176 | br_if $error 177 | local.get $heap-obj 178 | return 179 | end 180 | local.get $error 181 | global.set 0 182 | unreachable) 183 | (func (;21;) (param $obj i32) (result i32) 184 | local.get $obj 185 | i32.const 33554432 186 | i32.const 5 187 | call 20) 188 | (func (;22;) (param $addr1 i32) (param $addr2 i32) (param $n i32) (result i32) 189 | block $equal_contents 190 | block $compare_words 191 | loop $loop 192 | local.get $n 193 | i32.eqz 194 | br_if $compare_words 195 | local.get $addr1 196 | i32.load 197 | local.get $addr1 198 | i32.const 4 199 | i32.add 200 | local.set $addr1 201 | local.get $addr2 202 | i32.load 203 | local.get $addr2 204 | i32.const 4 205 | i32.add 206 | local.set $addr2 207 | local.get $n 208 | i32.const 1 209 | i32.sub 210 | local.set $n 211 | i32.eq 212 | br_if $loop 213 | br $equal_contents 214 | end 215 | end 216 | i32.const 1 217 | return 218 | end 219 | i32.const 0) 220 | (func (;23;) (param $s1 i32) (param $s2 i32) (result i32) 221 | (local $len i32) 222 | local.get $s1 223 | call 21 224 | i32.const 16777215 225 | i32.and 226 | local.tee $len 227 | local.get $s2 228 | call 21 229 | i32.const 16777215 230 | i32.and 231 | i32.eq 232 | if (result i32) ;; label = @1 233 | local.get $s1 234 | i32.const 4 235 | i32.add 236 | local.get $s2 237 | i32.const 4 238 | i32.add 239 | local.get $len 240 | i32.const 3 241 | i32.add 242 | i32.const 2 243 | i32.shr_u 244 | call 22 245 | call 4 246 | else 247 | i32.const 6 248 | end) 249 | (func (;24;) (type 0) (param i32) (result i32) 250 | i32.const 42 251 | call 1) 252 | (func (;25;) 253 | i32.const 10 254 | call 6 255 | global.set 11 256 | i32.const 30 257 | drop) 258 | (table (;0;) 11 funcref) 259 | (memory (;0;) 10) 260 | (export "memory" (memory 0)) 261 | (global (;0;) (mut i32) (i32.const 0)) 262 | (global (;1;) i32 (i32.const 2)) 263 | (global (;2;) i32 (i32.const 18)) 264 | (global (;3;) i32 (i32.const 34)) 265 | (global (;4;) i32 (i32.const 50)) 266 | (global (;5;) i32 (i32.const 66)) 267 | (global (;6;) i32 (i32.const 82)) 268 | (global (;7;) i32 (i32.const 98)) 269 | (global (;8;) i32 (i32.const 114)) 270 | (global (;9;) i32 (i32.const 130)) 271 | (global (;10;) i32 (i32.const 146)) 272 | (global (;11;) (mut i32) (i32.const 46)) 273 | (export "zero?" (func 10)) 274 | (export "number?" (func 24)) 275 | (start 25) 276 | (elem (;0;) (i32.const 0) func 9 10 11 12 13 14 15 16 19 23 24) 277 | (data (;0;) (i32.const 0) "\00\01\00\00") 278 | (type (;1;) (func (result i32))) 279 | (type (;2;) (func (param i32 i32) (result i32))) 280 | (type (;3;) (func (param i32 i32 i32) (result i32))) 281 | (type (;4;) (func))) 282 | -------------------------------------------------------------------------------- /test-io/test-write-string.scm: -------------------------------------------------------------------------------- 1 | (define-library (test-write-string) 2 | 3 | (export _start) 4 | 5 | (import (scheme base) 6 | (scheme write)) 7 | 8 | (begin 9 | (define (_start) 10 | (write-string "Hello world!\n")) 11 | )) 12 | -------------------------------------------------------------------------------- /test-unit/library-errors.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (assert) 4 | (module-compiler)) 5 | 6 | (install-test-compilation-error-handler!) 7 | 8 | (define (assert-library-raises-compilation-error library expected-message expected-object description) 9 | (assert-raises-compilation-error 10 | (lambda () (compile-r7rs-library-to-wasm-module library)) 11 | expected-message expected-object description)) 12 | 13 | (assert-library-raises-compilation-error 14 | '() 15 | "Invalid R7RS library definition" 16 | '() 17 | "Empty list is not a valid R7RS library") 18 | 19 | (assert-library-raises-compilation-error 20 | 'define-library 21 | "Invalid R7RS library definition" 22 | 'define-library 23 | "Non-list is not a R7RS library definition") 24 | 25 | (assert-library-raises-compilation-error 26 | '(library (name) (begin 42)) 27 | "Invalid R7RS library definition" 28 | '(library (name) (begin 42)) 29 | "Library definition should begin with define-library symbol") 30 | 31 | (assert-library-raises-compilation-error 32 | '(define-library) 33 | "Empty library definition" 34 | '(define-library) 35 | "Library definition should be non-empty") 36 | 37 | (assert-library-raises-compilation-error 38 | '(define-library name) 39 | "Expected list as library name" 40 | 'name 41 | "Library name should be a list") 42 | 43 | (assert-library-raises-compilation-error 44 | '(define-library (scheme x)) 45 | "scheme as first library name identifier is reserved" 46 | '(scheme x) 47 | "Library name should not start with symbol scheme") 48 | 49 | (assert-library-raises-compilation-error 50 | '(define-library (name "name" 1 0 1.1 -2)) 51 | "Invalid library name identifiers" 52 | '("name" 1.1 -2) 53 | "Library name identifiers should be symbols or nonnegative integers") 54 | 55 | (assert-library-raises-compilation-error 56 | '(define-library (name)) 57 | "No begin declaration in library" '(define-library (name)) 58 | "Library must have at least a begin declaration") 59 | 60 | (assert-library-raises-compilation-error 61 | '(define-library (name) begin) 62 | "Illegal R7RS library declaration" 'begin 63 | "Library declarations must be lists") 64 | 65 | (assert-library-raises-compilation-error 66 | '(define-library (name) ()) 67 | "Illegal R7RS library declaration" '() 68 | "Library declarations must be non-empty lists") 69 | 70 | (assert-library-raises-compilation-error 71 | '(define-library (name) (foo bar)) 72 | "Unsupported R7RS library declaration" '(foo bar) 73 | "Library declarations must be ones defined in R7RS") 74 | 75 | (assert-library-raises-compilation-error 76 | '(define-library (name) (begin 1) (foo bar)) 77 | "Unsupported R7RS library declaration" '(foo bar) 78 | "Library declarations must be ones defined in R7RS") 79 | 80 | (assert-library-raises-compilation-error 81 | '(define-library (name) (import)) 82 | "Empty import library declaration" '(import) 83 | "Library import declaration must not be empty") 84 | 85 | (assert-library-raises-compilation-error 86 | '(define-library (name) (export)) 87 | "Empty export library declaration" '(export) 88 | "Library export declaration must not be empty") 89 | 90 | (assert-library-raises-compilation-error 91 | '(define-library (name) (begin)) 92 | "Empty begin library declaration" '(begin) 93 | "Library begin declaration must not be empty") 94 | 95 | (assert-library-raises-compilation-error 96 | '(define-library (name) (export x) (begin 42)) 97 | "No top-level definition for export" 'x 98 | "Export declaration must name top-level definitions") 99 | 100 | (assert-library-raises-compilation-error 101 | '(define-library (name) (begin (define (sum a b) (+ a b)) (define sum 42))) 102 | "Top-level identifier already defined" 'sum 103 | "Top-level definitions must not be duplicated") 104 | 105 | (assert-library-raises-compilation-error 106 | '(define-library (name) 107 | (import (scheme base)) 108 | (import (scheme base)) 109 | (begin 42)) 110 | "Duplicate imported identifier" 'number? 111 | "It is an error to import the same identifier more than once") 112 | 113 | (assert-library-raises-compilation-error 114 | '(define-library (name) 115 | (import (scheme base)) 116 | (begin (set! number? 42))) 117 | "Cannot set! an imported identifier" 'number? 118 | "It is an error to mutate imported identifier") 119 | -------------------------------------------------------------------------------- /test-unit/semantic-errors.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (lists) 4 | (assert) 5 | (lexical-env) 6 | (compiled-program) 7 | (scheme-runtime) 8 | (expression-compiler)) 9 | 10 | (install-test-compilation-error-handler!) 11 | 12 | (define empty-global-env 13 | (add-new-lexical-frame (make-empty-lexical-env) '() '())) 14 | 15 | (define base-program 16 | (compile-runtime-library '(scheme base) (make-empty-compiled-program))) 17 | 18 | (define (assert-expression-raises-compilation-error exp expected-message expected-object description) 19 | (assert-raises-compilation-error 20 | (lambda () (compile exp base-program empty-global-env)) 21 | expected-message expected-object description)) 22 | 23 | ;; self-evaluating expressions 24 | (assert-expression-raises-compilation-error 25 | #\A 26 | "Unknown expression type" #\A 27 | "Character values are not yet supported") 28 | 29 | (assert-expression-raises-compilation-error 30 | (quote #\A) 31 | "Unknown expression type" #\A 32 | "Quoted character compiles to the character") 33 | 34 | (assert-expression-raises-compilation-error 35 | 3.14 36 | "Unsupported number" 3.14 37 | "Floating-point values are not yet supported") 38 | 39 | (assert-expression-raises-compilation-error 40 | (quote 3.14) 41 | "Unsupported number" 3.14 42 | "Quoted number compiles to the number") 43 | 44 | (assert-expression-raises-compilation-error 45 | #(1 2 3) 46 | "Unknown expression type" #(1 2 3) 47 | "Vector values are not yet supported") 48 | 49 | (assert-expression-raises-compilation-error 50 | (quote #(1 2 3)) 51 | "Unknown expression type" #(1 2 3) 52 | "Quoted vector compiles to the vector") 53 | 54 | (assert-expression-raises-compilation-error 55 | #u8(1 2 3) 56 | "Unknown expression type" #u8(1 2 3) 57 | "Bytevector values are not yet supported") 58 | 59 | (assert-expression-raises-compilation-error 60 | (quote #u8(1 2 3)) 61 | "Unknown expression type" #u8(1 2 3) 62 | "Quoted bytevector compiles to the bytevector") 63 | 64 | ;; pair and list literals 65 | (assert-expression-raises-compilation-error 66 | '(quote (1 . 2)) 67 | "Quote not supported yet for" '(quote (1 . 2)) 68 | "Pair literals are not supported yet") 69 | 70 | (assert-expression-raises-compilation-error 71 | '(quote (a b c)) 72 | "Quote not supported yet for" '(quote (a b c)) 73 | "List literals are not supported yet") 74 | 75 | ;; arithmetic expressions 76 | (assert-expression-raises-compilation-error 77 | '(-) 78 | "Expected at least one operand" '(-) 79 | "Substraction does not have an identity value") 80 | 81 | (assert-expression-raises-compilation-error 82 | '(/) 83 | "Expected at least one operand" '(/) 84 | "Division does not have an identity value") 85 | 86 | (assert-expression-raises-compilation-error 87 | '(/ 5) 88 | "No rational number support" '(/ 5) 89 | "Cannot represent 1/5 with integers only") 90 | 91 | ;; lambda expression 92 | (assert-expression-raises-compilation-error 93 | '(lambda (x) (+ y x)) 94 | "Lexically unbound variable" 'y 95 | "Referenced variables must be found in lexical scope") 96 | 97 | (assert-expression-raises-compilation-error 98 | '(lambda (x) (lambda (y) (+ x y))) 99 | "Variables in immediate enclosing scope or top-level only supported" 'x 100 | "Referencing variables out of current lexical or global scope is not yet supported") 101 | 102 | (assert-expression-raises-compilation-error 103 | '(lambda (x) (lambda () (set! x 1) x)) 104 | "Variables in immediate enclosing scope or top-level only supported" '(set! x 1) 105 | "Assigning to variables out of current lexical or global scope is not yet supported") 106 | 107 | (assert-expression-raises-compilation-error 108 | '(lambda (x) (set! y x)) 109 | "Lexically unbound variable" '(set! y x) 110 | "Assignment 's variable must be found in lexical scope") 111 | 112 | (assert-expression-raises-compilation-error 113 | '(lambda (x) (define y (+ x 1)) y) 114 | "Only top-level define is supported" '(define y (+ x 1)) 115 | "Assigning to variables out of current lexical or global scope is not yet supported") 116 | 117 | (assert-expression-raises-compilation-error 118 | '(lambda (x x) (+ x x)) 119 | "Duplicate parameter in" '(lambda (x x) (+ x x)) 120 | "Lambda parameters should not be duplicated") 121 | 122 | ;; let expression 123 | (assert-expression-raises-compilation-error 124 | '(let ((a 1) (b 2) (a 3) (c 4)) (+ a b c)) 125 | "Duplicate variable in let expression" '(let ((a 1) (b 2) (a 3) (c 4)) (+ a b c)) 126 | "Let bindings should not define the same variable multiple times") 127 | -------------------------------------------------------------------------------- /test-unit/test-compiled-program.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (compiled-program) 4 | (assert)) 5 | 6 | (let ((cp (make-empty-compiled-program))) 7 | 8 | (assert-equal 9 | '() 10 | (compiled-program-get-definitions cp 'func) 11 | "Empty compiled program does not contain function definitions") 12 | 13 | (assert-equal 14 | '() 15 | (compiled-program-value-code cp) 16 | "Empty compiled program does not have value code") 17 | 18 | (assert-equal 19 | '() 20 | (compiled-program-flatmap-definitions cp (lambda (d) (cons 'flatmapped (cdr d)))) 21 | "flatmap-definitions of empty program is empty list") 22 | 23 | (let ((cp (compiled-program-add-definition 24 | cp 25 | '(global (mut i32) (i32.const 42))))) 26 | 27 | (assert-equal 28 | #t 29 | (compiled-program-contains-definition cp '(global (mut i32) (i32.const 42))) 30 | "Compiled program contains definition added to it") 31 | 32 | (let ((cp (compiled-program-with-value-code 33 | cp 34 | '(i32.const 53 global.set 0)))) 35 | 36 | (assert-equal 37 | '(i32.const 53 global.set 0) 38 | (compiled-program-value-code cp) 39 | "compiled-program-with-value-code sets the value code of the program") 40 | 41 | (assert-equal 42 | #t 43 | (compiled-program-contains-definition cp '(global (mut i32) (i32.const 42))) 44 | "compiled-program-with-value-code retains the program definitions") 45 | 46 | (let ((cp (compiled-program-with-value-code 47 | cp '(drop)))) 48 | (assert-equal 49 | '(drop) 50 | (compiled-program-value-code cp) 51 | "compiled-program-with-value-code overrides existing value code of the program")) 52 | 53 | (let ((cp (compiled-program-append-value-code 54 | cp 55 | '(global.get 0 i32.const 1 i32.add)))) 56 | (assert-equal 57 | '(i32.const 53 global.set 0 global.get 0 i32.const 1 i32.add) 58 | (compiled-program-value-code cp) 59 | "compiled-progam-appen-value-code appends new value code to the end of existing code")) 60 | 61 | (let ((cp (compiled-program-append-value-codes 62 | cp 63 | (compiled-program-with-definition-and-value-code 64 | (make-empty-compiled-program) 65 | '(global (mut i32) (i32.const -1)) 66 | '(global.get 0 i32.const 1 i32.add))))) 67 | 68 | (assert-equal 69 | #t 70 | (compiled-program-contains-definition cp '(global (mut i32) (i32.const -1))) 71 | "compiled-program-append-value-codes takes definitions from the second program given to it") 72 | 73 | (assert-equal 74 | 1 75 | (length (compiled-program-get-definitions cp 'global)) 76 | "compiled-program-append-value-codes takes definitions from the second program given to it") 77 | 78 | (assert-equal 79 | '(i32.const 53 global.set 0 global.get 0 i32.const 1 i32.add) 80 | (compiled-program-value-code cp) 81 | "compiled-progam-append-value-codes appends value codes of the programs")) 82 | 83 | (let ((cp (compiled-program-with-definition-and-value-code 84 | cp 85 | '(func (result i32) (i32.const 53)) 86 | '(global.get 0 call 0 i32.add)))) 87 | (assert-equal 88 | '(global.get 0 call 0 i32.add) 89 | (compiled-program-value-code cp) 90 | "compiled-program-with-definition-and-value-code sets the value code of the program") 91 | 92 | (assert-equal 93 | '((func (result i32) (i32.const 53))) 94 | (compiled-program-get-definitions cp 'func) 95 | "compiled-program-with-definition-and-value-code adds the definition to the program") 96 | 97 | (assert-equal 98 | '((global (mut i32) (i32.const 42))) 99 | (compiled-program-get-definitions cp 'global) 100 | "compiled-program-with-definition-and-value-code retains the program's existing definitions") 101 | 102 | (assert-equal 103 | '(func (result i32) (i32.const 53)) 104 | (compiled-program-last-definition cp 'func) 105 | "compiled-program-last-definition returns the last defintion of specified type added to the program") 106 | 107 | (assert-equal 108 | '(global (mut i32) (i32.const 42)) 109 | (compiled-program-last-definition cp 'global) 110 | "compiled-program-last-definition returns the last definition of specified type added to the program") 111 | 112 | (assert-equal 113 | '(func (result i32) (i32.const 53)) 114 | (compiled-program-lookup-definition cp (lambda (d) (eq? (car d) 'func))) 115 | "compiled-program-lookup-definition returns the last defintion that matches the predicate") 116 | 117 | (assert-equal 118 | #f 119 | (compiled-program-lookup-definition cp (lambda (d) #f)) 120 | "compiled-program-lookup-definition returns false when predicate returns false for all definitions") 121 | 122 | (assert-equal 123 | '((global (mut i32) (i32.const 42)) (data (i32.const 42) "foo")) 124 | (compiled-program-flatmap-definitions 125 | cp 126 | (lambda (d) 127 | (if (eq? (car d) 'global) 128 | `(,d (data ,(caddr d) "foo")) 129 | '()))) 130 | "flatmap-definitions can filter, add and modify definitions")))) 131 | 132 | (let ((cp (compiled-program-with-definitions-and-value-code 133 | cp 134 | '((global (i32) i32.const 42) (func (result i32) global.get 1)) 135 | '(call 0)))) 136 | (assert-equal 137 | '((global (i32) i32.const 42)) 138 | (compiled-program-get-definitions cp 'global) 139 | "compiled-program-with-definitions-and-value-code adds the definitions to the program") 140 | 141 | (assert-equal 142 | '((func (result i32) global.get 1)) 143 | (compiled-program-get-definitions cp 'func) 144 | "compiled-program-with-definitions-and-value-code adds the definitions to the program") 145 | 146 | (assert-equal 147 | '(call 0) 148 | (compiled-program-value-code cp) 149 | "compiled-program-with-definitions-and-value-code sets the value code of the program")) 150 | ) 151 | -------------------------------------------------------------------------------- /test-unit/test-counted-set.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (counted-set) 4 | (assert)) 5 | 6 | (assert-equal 7 | 0 8 | (let ((s (make-counted-set))) 9 | (counted-set-count s 'x)) 10 | "counted-set-count results to 0 with an empty set") 11 | 12 | (assert-equal 13 | 0 14 | (let ((s (make-counted-set))) 15 | (counted-set-unique-keys s)) 16 | "empty counted-set should have 0 unique keys") 17 | 18 | (assert-equal 19 | 0 20 | (let* ((s (make-counted-set)) 21 | (s (counted-set-add s 'x 1))) 22 | (counted-set-count s 'y)) 23 | "counted-set-count results to 0 when the key has not been added") 24 | 25 | (assert-equal 26 | 1 27 | (let* ((s (make-counted-set)) 28 | (s (counted-set-add s 'x 1))) 29 | (counted-set-count s 'x)) 30 | "counted-set-count results to 1 when the key has been added") 31 | 32 | (assert-equal 33 | 3 34 | (let* ((s (make-counted-set)) 35 | (s (counted-set-add s 'x 3))) 36 | (counted-set-count s 'x)) 37 | "counted-set-count results to amount passed to counted-set-add") 38 | 39 | (assert-equal 40 | 2 41 | (let* ((s (make-counted-set)) 42 | (s (counted-set-add s 'x 1)) 43 | (s (counted-set-add s 'x 1))) 44 | (counted-set-count s 'x)) 45 | "counted-set-count results to 2 when the key has been added twice") 46 | 47 | (assert-equal 48 | 4 49 | (let* ((s (make-counted-set)) 50 | (s (counted-set-add s 'x 1)) 51 | (s (counted-set-add s 'x 3))) 52 | (counted-set-count s 'x)) 53 | "counted-set-count results to total of amounts of the same added key") 54 | 55 | (assert-equal 56 | 1 57 | (let* ((s (make-counted-set)) 58 | (s (counted-set-add s 'x 1)) 59 | (s (counted-set-add s 'y 1))) 60 | (counted-set-count s 'x)) 61 | "counted-set-count results to 1 when the queried key has been added once") 62 | 63 | (assert-equal 64 | 1 65 | (let* ((s (make-counted-set)) 66 | (s (counted-set-add s 'x 1)) 67 | (s (counted-set-add s 'y 1))) 68 | (counted-set-count s 'y)) 69 | "counted-set-count results to 1 when the queried key has been added once") 70 | 71 | (assert-equal 72 | 1 73 | (let* ((s (make-counted-set)) 74 | (s (counted-set-add s 'x 1)) 75 | (s (counted-set-add s 'x 1))) 76 | (counted-set-unique-keys s)) 77 | "counted-set should have 1 unique key when the same key has been added twice") 78 | -------------------------------------------------------------------------------- /test-unit/test-definitions-table.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (definitions-table) 4 | (assert)) 5 | 6 | (let ((ds (make-empty-definitions-table))) 7 | 8 | (assert-equal 9 | 0 10 | (definitions-count ds 'func) 11 | "Empty definitions table contains 0 func defintions") 12 | 13 | (assert-equal 14 | #f 15 | (definition-index ds '(func $f (result i32))) 16 | "Empty definitions table does not have index for a func definition") 17 | 18 | (assert-equal 19 | #f 20 | (contains-definition ds '()) 21 | "Empty definitions table does not contain an empty definition") 22 | 23 | (assert-equal 24 | '() 25 | (get-definitions ds 'func) 26 | "Empty definitions table does not contain func definitions") 27 | 28 | (assert-equal 29 | '() 30 | (flatmap-definitions ds (lambda (d) (cons 'flatmapped (cdr d)))) 31 | "flatmap-definitions of empty table is empty list") 32 | 33 | (let ((ds (add-definition ds '(func $f (result i32))))) 34 | (assert-equal 35 | 0 36 | (definitions-count ds 'global) 37 | "Definitions table with single func added contains 0 global definitions") 38 | 39 | (assert-equal 40 | #t 41 | (contains-definition ds '(func $f (result i32))) 42 | "Definitions table with single func added contains the func definition") 43 | 44 | (assert-equal 45 | 0 46 | (definition-index ds '(func $f (result i32))) 47 | "Definitions table with single func added has index 0 for the definition") 48 | 49 | (assert-equal 50 | #f 51 | (contains-definition ds '(global $glob (mut i32))) 52 | "Definitions table with single func added does not contain a global definition") 53 | 54 | (assert-equal 55 | #f 56 | (definition-index ds '(global $glob (mut i32))) 57 | "Definitions table with single func added does not have index for a global definition") 58 | 59 | (assert-equal 60 | '() 61 | (get-definitions ds 'global) 62 | "Definitions table with single func added does not contain global definitions") 63 | 64 | (assert-equal 65 | 1 66 | (definitions-count ds 'func) 67 | "Definitions table with single func added contains 1 funcs") 68 | 69 | (assert-equal 70 | '((func $f (result i32))) 71 | (get-definitions ds 'func) 72 | "Definitions table with single func added contains the func definition") 73 | 74 | (assert-equal 75 | '(func $f (result i32)) 76 | (last-definition ds 'func) 77 | "Defintions table with single func added has the definition as last func definition") 78 | 79 | (assert-equal 80 | #f 81 | (last-definition ds 'global) 82 | "Defintions table with single func added does not have a global last definition") 83 | 84 | (let ((ds (add-definition ds '(func $g (param i32) (result i32))))) 85 | (assert-equal 86 | 0 87 | (definitions-count ds 'global) 88 | "Definitions table with two funcs added contains 0 global definitions") 89 | 90 | (assert-equal 91 | '() 92 | (get-definitions ds 'global) 93 | "Definitions table with two funcs added does not contain global definitions") 94 | 95 | (assert-equal 96 | 2 97 | (definitions-count ds 'func) 98 | "Definitions table with two funcs added contains 2 func definitions") 99 | 100 | (assert-equal 101 | '((func $f (result i32)) (func $g (param i32) (result i32))) 102 | (get-definitions ds 'func) 103 | "Definitions table with two funcs added contains the func definitions in addition order") 104 | 105 | (assert-equal 106 | '(func $g (param i32) (result i32)) 107 | (last-definition ds 'func) 108 | "Definitions table with two funcs added has the one added last as the last func definition") 109 | 110 | (let ((ds (add-definition ds '(global $glob (mut i32))))) 111 | (assert-equal 112 | 1 113 | (definitions-count ds 'global) 114 | "Definitions table with two funcs and one global added contains 1 globals") 115 | 116 | (assert-equal 117 | #t 118 | (contains-definition ds '(global $glob (mut i32))) 119 | "Definitions table with two funcs and one global added contains the global definition") 120 | 121 | (assert-equal 122 | '(func $g (param i32) (result i32)) 123 | (lookup-definition 124 | ds 125 | (lambda (d) (eq? (car d) 'func))) 126 | "lookup-definition returns the last added matching definition") 127 | 128 | (assert-equal 129 | #f 130 | (lookup-definition 131 | ds 132 | (lambda (d) #f)) 133 | "lookup-definition returns false when predicate returns false for all definitions") 134 | 135 | (assert-equal 136 | 0 137 | (definition-index ds '(global $glob (mut i32))) 138 | "Definitions table with two funcs and one global added has index 0 for the global definition") 139 | 140 | (assert-equal 141 | #f 142 | (contains-definition ds '(global $other (mut i32))) 143 | "Definitions table with two funcs and one global added does not contain a nonmatching global definition") 144 | 145 | (assert-equal 146 | '((global $glob (mut i32))) 147 | (get-definitions ds 'global) 148 | "Definitions table with two funcs and one global added contains the global definition") 149 | 150 | (assert-equal 151 | 2 152 | (definitions-count ds 'func) 153 | "Definitions table with two funcs and one global added contains 2 func definitions") 154 | 155 | (assert-equal 156 | #t 157 | (contains-definition ds '(func $f (result i32))) 158 | "Definitions table with two funcs and one global added contains the first func definition") 159 | 160 | (assert-equal 161 | #t 162 | (contains-definition ds '(func $g (param i32) (result i32))) 163 | "Definitions table with two funcs and one global added contains the second func definition") 164 | 165 | (assert-equal 166 | 0 167 | (definition-index ds '(func $f (result i32))) 168 | "Definitions table with two funcs and one global added has index 0 for the first func definition") 169 | 170 | (assert-equal 171 | 1 172 | (definition-index ds '(func $g (param i32) (result i32))) 173 | "Definitions table with two funcs and one global added has index 1 for the second func definition") 174 | 175 | (assert-equal 176 | '((func $f (result i32)) (func $g (param i32) (result i32))) 177 | (get-definitions ds 'func) 178 | "Definitions table with two funcs and one global added contains the func definitions in addition order") 179 | 180 | (assert-equal 181 | '(func $g (param i32) (result i32)) 182 | (last-definition ds 'func) 183 | "Definitions table with two funcs and one global added has the func definition added last as the last func definition") 184 | 185 | (assert-equal 186 | '(global $glob (mut i32)) 187 | (last-definition ds 'global) 188 | "Definitions table with two funcs and one global added has the global as last global definition") 189 | 190 | (assert-equal 191 | `($f $g $glob) 192 | (fold-definitions 193 | ds 194 | (lambda (d r) (cons (cadr d) r)) 195 | '()) 196 | "fold-definitions can collect data from all definitions") 197 | 198 | (assert-equal 199 | '((global (import "glob") (mut i32)) (global $glob (mut i32))) 200 | (flatmap-definitions 201 | ds 202 | (lambda (d) 203 | (if (eq? (car d) 'global) 204 | `((global (import "glob") ,(caddr d)) ,d) 205 | '()))) 206 | "flatmap-definitions can filter add, and modify definitions") 207 | 208 | )))) 209 | -------------------------------------------------------------------------------- /test-unit/test-lists.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (lists) 4 | (assert)) 5 | 6 | (assert-equal 7 | #f 8 | (index-of-equal '() '()) 9 | "index-of-equal from empty list results to #f") 10 | 11 | (assert-equal 12 | #f 13 | (index-of-equal '(1 2 3) 'a) 14 | "index-of-equal without a match results to #f") 15 | 16 | (assert-equal 17 | 1 18 | (index-of-equal '(1 a 3) 'a) 19 | "index-of-equal results to the index of the match") 20 | 21 | (assert-equal 22 | '() 23 | (first-duplicate '()) 24 | "Empty list does not contain duplicates") 25 | 26 | (assert-equal 27 | '() 28 | (first-duplicate '(1)) 29 | "List of one element does not contain duplicates") 30 | 31 | (assert-equal 32 | '() 33 | (first-duplicate '(1 2 3 a)) 34 | "List without duplicates does not contain duplicates") 35 | 36 | (assert-equal 37 | '(2) 38 | (first-duplicate '(1 2 3 a b 2)) 39 | "first-duplicate returns the remaining list starting from the first found duplicate") 40 | 41 | (assert-equal 42 | '(2 a b) 43 | (first-duplicate '(1 2 3 2 a b)) 44 | "first-duplicate returns the remaining list starting from the first found duplicate") 45 | 46 | (assert-equal 47 | '() 48 | (flatten-n 1 '()) 49 | "flatten-n of empty list results in empty list") 50 | 51 | (assert-equal 52 | 'x 53 | (flatten-n 1 'x) 54 | "flatten-n of a value results in the value") 55 | 56 | (assert-equal 57 | '(1 2 3) 58 | (flatten-n 1 '(1 2 3)) 59 | "flatten-n of a flat list results in the list") 60 | 61 | (assert-equal 62 | '(1 (2) 3) 63 | (flatten-n 0 '(1 (2) 3)) 64 | "flatten-n of a 1-nested list with n=0 results in the list") 65 | 66 | (assert-equal 67 | '(1 2 3) 68 | (flatten-n 1 '(1 (2) 3)) 69 | "flatten-n of a 1-nested list with n=1 results in a flat list") 70 | 71 | (assert-equal 72 | '(1 2 3) 73 | (flatten-n 2 '(1 (2) 3)) 74 | "flatten-n of a 1-nested list with n=2 results in a flat list") 75 | 76 | (assert-equal 77 | '(1 (2 3) 4) 78 | (flatten-n 1 '(1 ((2 3) 4))) 79 | "flatten-n of a 2-nested list with n=1 results in a 1-nested list") 80 | 81 | (assert-equal 82 | '(1 2 3 4) 83 | (flatten-n 2 '(1 ((2 3) 4))) 84 | "flatten-n of a 2-nested list with n=2 results in a flat list") 85 | 86 | (assert-equal 87 | #t (all? number? '()) 88 | "all is true for an empty list") 89 | 90 | (assert-equal 91 | #t (all? number? '(1 2 3)) 92 | "all is true for a list where the predicate is true for all items") 93 | 94 | (assert-equal 95 | #f (all? number? '(1 2 'foo 3)) 96 | "all is false for a list where the predicate is false for any item") 97 | 98 | (assert-equal 99 | '() (replace-seqs '() '() '()) 100 | "replace-seqs of an empty sequence with empty sequence from an empty list is empty list") 101 | 102 | (assert-equal 103 | '() (replace-seqs '() '(a b) '()) 104 | "replace-seqs of an empty sequence with any sequence from an empty list is empty list") 105 | 106 | (assert-equal 107 | '() (replace-seqs '(x y) '(a b) '()) 108 | "replace-seqs of any sequence with any sequence from an empty list is empty list") 109 | 110 | (assert-equal 111 | '(x) (replace-seqs '() '(a b) '(x)) 112 | "replace-seqs an empty sequence with any sequence from any list results to the list") 113 | 114 | (assert-equal 115 | '(2 3) (replace-seqs '(1) '() '(1 2 3)) 116 | "replace-seqs a sequence from start of a list with empty list results in rest of the list") 117 | 118 | (assert-equal 119 | '(3) (replace-seqs '(1 2) '() '(1 2 3)) 120 | "replace-seqs a sequence from start of a list with empty list results in rest of the list") 121 | 122 | (assert-equal 123 | '() (replace-seqs '(1 2 3) '() '(1 2 3)) 124 | "replace-seqs the whole list with empty list results in empty list") 125 | 126 | (assert-equal 127 | '(1 2) (replace-seqs '(3) '() '(1 2 3)) 128 | "replace-seqs a sequence from end of a list with empty list results in head of the list") 129 | 130 | (assert-equal 131 | '(1) (replace-seqs '(2 3) '() '(1 2 3)) 132 | "replace-seqs a sequence from end of a list with empty list results in head of the list") 133 | 134 | (assert-equal 135 | '(a b c) (replace-seqs '(1 2 3) '(a b c) '(1 2 3)) 136 | "replace-seqs a sequence equal to the list results in the replacement list") 137 | 138 | (assert-equal 139 | '(1 2 3) (replace-seqs '(0 1) '(a b) '(1 2 3)) 140 | "replace-seqs a sequence not in the list results in the original list") 141 | 142 | (assert-equal 143 | '(1 2 3) (replace-seqs '(3 4) '(x y) '(1 2 3)) 144 | "replace-seqs a sequence not in the list results in the original list") 145 | 146 | (assert-equal 147 | '(1 2 3) (replace-seqs '(5) '(a) '(1 2 3)) 148 | "replace-seqs a sequence not in the list results in the original list") 149 | 150 | (assert-equal 151 | '(1 a 4 a 5 a 2) (replace-seqs '(2 3) '(a) '(1 2 3 4 2 3 5 2 3 2)) 152 | "replace-seqs a sequence replaces all occurences of it from the list") 153 | 154 | (assert-equal 155 | '(a b c a b c) (replace-seqs '(1 2) '(a b c) '(1 2 1 2)) 156 | "replace-seqs a sequence replaces all occurences of it from the list") 157 | 158 | (assert-equal 159 | '(a b a b) (replace-seqs '(1 2) '(a b) '(1 2 1 2)) 160 | "replace-seqs a sequence replaces all occurences of it from the list") 161 | 162 | (assert-equal 163 | '(1 4 5 2) (replace-seqs '(2 3) '() '(1 2 3 4 2 3 5 2 3 2)) 164 | "replace-seqs a sequence with empty list removes all occurences of sequence from the list") 165 | 166 | (assert-equal 167 | '() (replace-seqs '(1 2) '() '(1 2 1 2)) 168 | "replace-seqs a sequence with empty list removes all occurences of sequence from the list") 169 | -------------------------------------------------------------------------------- /test-unit/test-pattern-match.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (pattern-match) 4 | (assert)) 5 | 6 | (define (assert-matches pat exp message) 7 | (assert-equal 8 | #t 9 | (pattern-match? pat exp) 10 | message)) 11 | 12 | (define (assert-does-not-match pat exp message) 13 | (assert-equal 14 | #f 15 | (pattern-match? pat exp) 16 | message)) 17 | 18 | (define (all-pairings xs) 19 | (define (pair-with h xs) 20 | (if (null? xs) 21 | '() 22 | (cons (cons h (car xs)) 23 | (cons (cons (car xs) h) 24 | (pair-with h (cdr xs)))))) 25 | (if (null? xs) 26 | '() 27 | (append (pair-with (car xs) (cdr xs)) 28 | (all-pairings (cdr xs))))) 29 | 30 | (assert-matches '() '() "Empty list matches an empty list") 31 | (assert-matches 'a 'a "Symbol matches the same symbol") 32 | (assert-matches 10 10 "Number matches an equal number") 33 | (assert-matches "str" "str" "String matches an equal string") 34 | (assert-matches #f #f "Boolean false matches boolean false") 35 | (assert-matches #t #t "Boolean true matches boolean true") 36 | (assert-matches symbol? 'x 37 | "An object matches a predicate procedure that returns true for the object") 38 | (assert-matches '(a b (1 2) "c" #t) '(a b (1 2) "c" #t) 39 | "List matches a list with the same structure and values") 40 | (assert-matches `(a ,symbol? (,number? 2)) '(a b (1 2)) 41 | "Predicate procedures match items in a list") 42 | (for-each 43 | (lambda (x) (assert-matches ?? x "The ?? operator matches any single object")) 44 | '(123 'foo #f "str" '() '(a b))) 45 | (assert-matches `(a b ,?? "c" ,??) '(a b (1 2) "c" #t) 46 | "The ?? operator matches any single item in a list") 47 | (assert-matches `(a b ,??*) '(a b (1 2) "c" #t) 48 | "The ??* operator matches any multiple items to the end of the list") 49 | (assert-matches `(a ,??* e f) '(a b c d e f) 50 | "The ??* operator matches any number of items in the middle of the list") 51 | (assert-matches `(a b ,??*) '(a b) 52 | "The ??* operator matches zero items at the end of the list") 53 | (assert-matches `(1 2 ,??* a b ,??* f) '(1 2 3 4 a b c d e f) 54 | "Multiple ??* operators can be used in a list") 55 | (assert-matches `(,??*) '() "The pattern (??*) matches an empty list") 56 | (assert-matches `(,??*) '(a) "The pattern (??*) matches a list with one element") 57 | (assert-matches `(,??*) '(a b c) "The pattern (??*) matches a list with multiple elements") 58 | 59 | (assert-does-not-match '() '(1) "Empty list does not match a non-empty list") 60 | (assert-does-not-match 'a 'b "Symbol does not match a different symbol") 61 | (assert-does-not-match 10 42 "Number does not match an unequal number") 62 | (assert-does-not-match "foo" "bar" "String does not match an unequal string") 63 | (assert-does-not-match #t #f "Boolean false does not match a boolean true") 64 | (assert-does-not-match #f #t "Boolean true does not match a boolean false") 65 | (for-each 66 | (lambda (p) (assert-does-not-match (car p) (cdr p) "Values of different type do not match")) 67 | (all-pairings '(1 'x #t "foo" '(x)))) 68 | (assert-does-not-match symbol? 10 69 | "An object does not match a predicate procedure that returns false for the object") 70 | (assert-does-not-match '(a b 1 2 "c" #t) '(a b (1 2) "c" #t) 71 | "List does not match a list with the same values but different structure") 72 | (assert-does-not-match `(a ,symbol? (,symbol? ,number?)) '(a b (1 2)) 73 | "A list does not match a when predicate procedure returns false for an item in the list") 74 | (assert-does-not-match `(a ,symbol? (,number?)) '(a b (1 2)) 75 | "Predicate procedures do not match multiple items in a list") 76 | (assert-does-not-match `(a b (1 2) ,??) '(a b (1 2) "c" #t) 77 | "The ?? operator does not match multiple items in a list") 78 | (assert-does-not-match `(a b (1 2) ,??) '(a b (1 2) "c" #t) 79 | "The ?? operator does not match multiple items in a list") 80 | (assert-does-not-match ??* '(a b) 81 | "The ??* operator matches only in a list") 82 | (assert-does-not-match `(,??*) 'a 83 | "The pattern (??*) does not match a non-list") 84 | (assert-does-not-match `(a ,??* e) '(a b c d) 85 | "Matching continues after the ??* operator") 86 | -------------------------------------------------------------------------------- /test-unit/test-scheme-r7rs-syntax.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (assert) 4 | (scheme-r7rs-syntax)) 5 | 6 | (define test-library 7 | '(define-library (name 1 0) 8 | (import lib1) 9 | (export square) 10 | (import lib2) 11 | (begin 12 | (define (square x) (* x x)) 13 | (square 5)))) 14 | 15 | (check-library test-library) 16 | 17 | (assert-equal 18 | #t 19 | (library-has-declaration? 'export test-library) 20 | "library-has-declaration? returns true when matching declaration is in a library") 21 | 22 | (assert-equal 23 | #f 24 | (library-has-declaration? 'include test-library) 25 | "library-has-declaration? returns false when no matching declaration is found in a library") 26 | 27 | (assert-equal 28 | '((define (square x) (* x x)) (square 5)) 29 | (library-declarations 'begin test-library) 30 | "library-declarations returns the contents of a single matching declaration in a library") 31 | 32 | (assert-equal 33 | '(lib1 lib2) 34 | (library-declarations 'import test-library) 35 | "library-declarations returns the contents of multiple matching declarations in a library in declaration order") 36 | -------------------------------------------------------------------------------- /test-unit/test-scheme-syntax.scm: -------------------------------------------------------------------------------- 1 | (import 2 | (scheme base) 3 | (scheme-syntax) 4 | (assert)) 5 | 6 | (install-test-compilation-error-handler!) 7 | 8 | ;; definition 9 | (assert-equal 10 | #f 11 | (definition? '(+ 1 2)) 12 | "Non-definition is not a definition") 13 | 14 | (assert-equal 15 | #f 16 | (definition? '(define x)) 17 | "Variable definition without a value is not a definition") 18 | 19 | (assert-equal 20 | #f 21 | (definition? '(define x)) 22 | "Variable definition without a value is not a definition") 23 | 24 | (assert-equal 25 | #f 26 | (definition? '(define x 1 1)) 27 | "Variable definition with multiple values a value is not a definition") 28 | 29 | (assert-equal 30 | #f 31 | (definition? '(define (f x))) 32 | "Procedure definition without a body is not a definition") 33 | 34 | (let ((exp '(define x 42))) 35 | (assert-equal 36 | #t 37 | (definition? exp) 38 | "Variable definition with variable and simple value is valid") 39 | 40 | (assert-equal 41 | 'x 42 | (definition-variable exp) 43 | "definition-variable returns the variable of variable definition") 44 | 45 | (assert-equal 46 | 42 47 | (definition-value exp) 48 | "definition-value returns the value of variable definition")) 49 | 50 | (let ((exp '(define x (+ 1 2)))) 51 | (assert-equal 52 | #t 53 | (definition? exp) 54 | "Variable definition with variable and combination value is valid") 55 | 56 | (assert-equal 57 | 'x 58 | (definition-variable exp) 59 | "definition-variable returns the variable of variable definition") 60 | 61 | (assert-equal 62 | '(+ 1 2) 63 | (definition-value exp) 64 | "definition-value returns the value expression of variable definition")) 65 | 66 | (let ((exp '(define (zero) 0))) 67 | (assert-equal 68 | #t 69 | (definition? exp) 70 | "Procedure definition with zero parameters and simple body is valid") 71 | 72 | (assert-equal 73 | 'zero 74 | (definition-variable exp) 75 | "definition-variable returns the variable of procedure definition") 76 | 77 | (assert-equal 78 | '(lambda () 0) 79 | (definition-value exp) 80 | "definition-value returns the body of procedure definition")) 81 | 82 | (let ((exp '(define (one) (+ 0 1)))) 83 | (assert-equal 84 | #t 85 | (definition? exp) 86 | "Procedure definition with zero parameters and combination body is valid") 87 | 88 | (assert-equal 89 | 'one 90 | (definition-variable exp) 91 | "definition-variable returns the variable of procedure definition") 92 | 93 | (assert-equal 94 | '(lambda () (+ 0 1)) 95 | (definition-value exp) 96 | "definition-value returns the body of procedure definition")) 97 | 98 | (let ((exp '(define (one) (display "one:") (+ 0 1)))) 99 | (assert-equal 100 | #t 101 | (definition? exp) 102 | "Procedure definition with multi-expression body is valid") 103 | 104 | (assert-equal 105 | 'one 106 | (definition-variable exp) 107 | "definition-variable returns the variable for procedure definition") 108 | 109 | (assert-equal 110 | '(lambda () (display "one:") (+ 0 1)) 111 | (definition-value exp) 112 | "definition-value returns the body of procedure definition")) 113 | 114 | (let ((exp '(define (square x) (* x x)))) 115 | (assert-equal 116 | #t 117 | (definition? exp) 118 | "Procedure definition with single parameter and body is valid") 119 | 120 | (assert-equal 121 | 'square 122 | (definition-variable exp) 123 | "definition-variable returns the variable for procedure definition") 124 | 125 | (assert-equal 126 | '(lambda (x) (* x x)) 127 | (definition-value exp) 128 | "definition-value returns the body of procedure definition")) 129 | 130 | (let ((exp '(define (sum-of-squares x y) (+ (* x x) (* y y))))) 131 | (assert-equal 132 | #t 133 | (definition? exp) 134 | "Procedure definition with multiple parameters and body is valid") 135 | 136 | (assert-equal 137 | 'sum-of-squares 138 | (definition-variable exp) 139 | "definition-variable returns the variable for procedure definition") 140 | 141 | (assert-equal 142 | '(lambda (x y) (+ (* x x) (* y y))) 143 | (definition-value exp) 144 | "definition-value returns the body of procedure definition")) 145 | -------------------------------------------------------------------------------- /test-unit/test-unit.mk: -------------------------------------------------------------------------------- 1 | UNIT_TEST_PROGRAMS := $(wildcard test-unit/*.scm) 2 | UNIT_TEST_BINARIES := $(UNIT_TEST_PROGRAMS:test-unit/%.scm=test-unit/compiled/%.go) 3 | UNIT_TEST_TARGETS := $(UNIT_TEST_PROGRAMS:.scm=) 4 | UNIT_TEST_LOGS := $(UNIT_TEST_PROGRAMS:test-unit/%.scm=test-unit/log/%.log) 5 | RUN_UNIT_TEST := $(HOST_SCHEME_RUN_PROGRAM) -C test-unit/compiled -C $(HOST_SCHEME_COMPILED_DIR) 6 | 7 | .PHONY : test-unit 8 | test-unit : ## Executes the unit tests for the compiler 9 | test-unit : $(UNIT_TEST_LOGS) 10 | 11 | $(UNIT_TEST_TARGETS) : test-unit/% : test-unit/log/%.log 12 | 13 | test-unit/log test-unit/compiled : 14 | mkdir -p $@ 15 | 16 | $(UNIT_TEST_BINARIES) : test-unit/compiled/%.go : test-unit/%.scm | test-unit/compiled 17 | $(HOST_SCHEME_COMPILE_MODULE) -L . -o $@ $< 18 | 19 | $(UNIT_TEST_LOGS) : test-unit/log/%.log : test-unit/%.scm | test-unit/log 20 | $(RUN_UNIT_TEST) $< > $@.tmp \ 21 | && mv -f $@.tmp $@ 22 | 23 | $(UNIT_TEST_LOGS) : $(UNIT_TEST_BINARIES) 24 | $(UNIT_TEST_BINARIES) : $(COMPILER_BINARIES) 25 | 26 | .PHONY : clean-test-unit 27 | clean-test-unit : ## Removes unit test build artefacts and results 28 | -rm -rf \ 29 | test-unit/log \ 30 | test-unit/compiled 31 | -------------------------------------------------------------------------------- /test-unit/test-wasm-syntax.scm: -------------------------------------------------------------------------------- 1 | (import (scheme base) 2 | (wasm-syntax) 3 | (assert)) 4 | 5 | (let-values 6 | (((data length) (string-as-wasm-data ""))) 7 | (assert-equal "" data "data of empty string is the empty string") 8 | (assert-equal 0 length "data length of empty string is zero")) 9 | 10 | (let-values 11 | (((data length) (string-as-wasm-data "str"))) 12 | (assert-equal "str" data "data of string is the string") 13 | (assert-equal 3 length "data length of a string is the string length in bytes")) 14 | 15 | (let-values 16 | (((data length) (i32-as-wasm-data #xcdab3412))) 17 | (assert-equal 18 | #u8(#x12 #x34 #xab #xcd) 19 | data 20 | "data of number as i32 is a bytevector of the value in little-endian order") 21 | (assert-equal 4 length "data length of a number as i32 is 4")) 22 | -------------------------------------------------------------------------------- /tools/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((nil . ((geiser-scheme-implementation . guile))) 2 | (scheme-mode . ((geiser-guile-binary . ("guile" "--r7rs")) 3 | (geiser-guile-load-path . ("."))))) 4 | -------------------------------------------------------------------------------- /tools/scheme-dependencies.scm: -------------------------------------------------------------------------------- 1 | ;; R7RS Scheme module interdependencies discovery tool 2 | ;; 3 | ;; Used for constructing a depdendencies mapping for compiling a set of Scheme files using make. 4 | ;; 5 | ;; The tool reads a list of R7RS Scheme source files from the command line, and: 6 | ;; 1. reads the files and parses the library names and import definitions from them 7 | ;; 1. builds a mapping from the library names to the scheme source files where they are defined in 8 | ;; 2. builds a mapping from each source file to the libraries it imports and maps the library names 9 | ;; to source files using the mapping from step 1. 10 | ;; 3. outputs the dependency mapping from step 2. in make tool's target: prequisites format. 11 | ;; 12 | ;; The output is limited to the closed set of dependencies between the source files that are passed 13 | ;; from the command line. The targets and prequisites are not presented in any specific order in the 14 | ;; output as this makes the tool more efficient and the ordering does not matter for the make tool. 15 | 16 | (import 17 | (scheme base) 18 | (scheme process-context) 19 | (scheme file) 20 | (scheme read) 21 | (scheme write) 22 | (scheme cxr) 23 | (only (srfi srfi-1) fold)) 24 | 25 | (define (fold-scheme-objects-in-file kons init filename) 26 | (with-input-from-file filename 27 | (lambda () 28 | (do ((definition (read) (read)) 29 | (result init (kons definition result))) 30 | ((eof-object? definition) result))))) 31 | 32 | (define (library-definition? object) 33 | (and (pair? object) 34 | (eq? (car object) 'define-library) 35 | (or (not (null? (cdr object))) 36 | (error "Expected ⟨library name⟩" object)))) 37 | 38 | (define (library-name library-definition) 39 | (cadr library-definition)) 40 | 41 | (define (library-declarations library-definition) 42 | (cddr library-definition)) 43 | 44 | (define (import-definition? object) 45 | (and (pair? object) 46 | (eq? (car object) 'import) 47 | (or (not (null? (cdr object))) 48 | (error "Expected ⟨import set⟩" object)))) 49 | 50 | (define (import-sets import-definition) 51 | (let collect-sets ((sets (cdr import-definition)) 52 | (imports '())) 53 | (if (null? sets) 54 | imports 55 | (let ((import-decl (car sets))) 56 | (case (and (pair? import-decl) (car import-decl)) 57 | ((only except prefix rename) 58 | (collect-sets 59 | (cdr sets) 60 | (fold cons 61 | imports 62 | (collect-sets (list (cadar sets)) '())))) 63 | (else 64 | (collect-sets 65 | (cdr sets) 66 | (cons import-decl imports)))))))) 67 | 68 | (define (scheme-definition-imports definition) 69 | (cond ((import-definition? definition) 70 | (import-sets definition)) 71 | ((library-definition? definition) 72 | (fold 73 | (lambda (declaration imports) 74 | (if (import-definition? declaration) 75 | (fold cons 76 | imports 77 | (import-sets declaration)) 78 | imports)) 79 | '() 80 | (library-declarations definition))) 81 | (else '()))) 82 | 83 | (define (scheme-module-imports filename) 84 | (fold-scheme-objects-in-file 85 | (lambda (object imports) 86 | (fold cons 87 | imports 88 | (scheme-definition-imports object))) 89 | '() 90 | filename)) 91 | 92 | (let* 93 | ((filenames (cdr (command-line))) 94 | 95 | (library-module-alist 96 | (fold 97 | (lambda (filename alist) 98 | (fold-scheme-objects-in-file 99 | (lambda (object alist) 100 | (if (library-definition? object) 101 | (let ((library-name (library-name object))) 102 | (if (assoc library-name alist) 103 | (error "Duplicate library definition" library-name) 104 | (cons (cons library-name filename) 105 | alist))) 106 | alist)) 107 | alist 108 | filename)) 109 | '() 110 | filenames)) 111 | 112 | (imports-to-defining-modules 113 | (lambda (filename) 114 | (fold 115 | (lambda (import defining-modules) 116 | (let ((defining-module 117 | (cond ((assoc import library-module-alist) => cdr) 118 | (else #f)))) 119 | (cond 120 | ;; library is not defined by modules in filenames 121 | ((not defining-module) defining-modules) 122 | ;; import is in the same file as definition 123 | ((string=? defining-module filename) defining-modules) 124 | (else (cons defining-module defining-modules))))) 125 | '() 126 | (scheme-module-imports filename))))) 127 | 128 | (for-each 129 | (lambda (filename) 130 | (let ((prequisites (imports-to-defining-modules filename))) 131 | (unless (null? prequisites) 132 | (begin 133 | (write-string filename) 134 | (write-char #\:) 135 | (for-each 136 | (lambda (prequisite) 137 | (write-char #\ ) 138 | (write-string prequisite)) 139 | prequisites) 140 | (newline))))) 141 | filenames) 142 | 143 | (newline)) 144 | -------------------------------------------------------------------------------- /tools/tools.mk: -------------------------------------------------------------------------------- 1 | tools/compiled: 2 | mkdir -p $@ 3 | 4 | tools/compiled/%.go: tools/%.scm | tools/compiled 5 | $(HOST_SCHEME_COMPILE_MODULE) -o $@ $< 6 | 7 | TOOL_SCHEME_DEPENDENCIES := tools/compiled/scheme-dependencies.go 8 | RUN_TOOL_SCHEME_DEPENDENCIES := $(HOST_SCHEME_RUN_PROGRAM) -C tools/compiled tools/scheme-dependencies.scm 9 | 10 | .PHONY : clean-tools 11 | clean-tools: ## Removes tools build artefacts 12 | -rm -rf tools/compiled 13 | -------------------------------------------------------------------------------- /values.scm: -------------------------------------------------------------------------------- 1 | (define-library (values) 2 | 3 | (export 4 | i32-size 5 | fixnum-mask fixnum-shift fixnum-max fixnum-min 6 | immediate-value-mask immediate-mask immediate-shift 7 | procedure-tag 8 | boolean-tag false-value true-value 9 | special-tag uninitialized-value unspecified-value 10 | number->fixnum-value 11 | boolean->boolean-value 12 | funcidx->procedure-value 13 | heap-object-type-mask heap-object-size-mask heap-object-header-size 14 | heap-object-type-symbol heap-object-type-string 15 | macro-align-heap-address 16 | symbol-literal-header string-literal-header 17 | error-no-error 18 | error-uninitialized 19 | error-expected-number 20 | error-expected-procedure 21 | error-expected-string 22 | error-expected-symbol 23 | error-io-write 24 | symbol->error) 25 | 26 | (import 27 | (scheme base) 28 | (srfi srfi-60)) 29 | 30 | (begin 31 | (define i32-size 4) ; bytes 32 | 33 | ;; fixnums are encoded with least signigicant bit set 34 | (define fixnum-mask #x00000001) ; ..00000001 35 | (define fixnum-shift 1) 36 | (define fixnum-max #x3fffffff) 37 | (define fixnum-min (- (+ fixnum-max 1))) 38 | 39 | ;; Other immediate value types are encoded in the least significant 4 bits 40 | ;; Note that the least significant two bits need to be non-zero for all immediate type tags to 41 | ;; enable detecting 32-bit aligned pointers from immediates. 42 | (define immediate-value-mask #x00000003) ; ...00000011 43 | (define immediate-mask #x0000000f) ; ...00001111 44 | (define immediate-shift 4) 45 | 46 | ;; Type tag for procedure values. 47 | ;; Wasm function index of the procedure is encoded in the 3 most significant bytes 48 | (define procedure-tag #x00000002) ; ...00000010 49 | 50 | ;; Type tag and values for boolean values 51 | (define boolean-tag #x00000006) ; ...00000110 52 | (define false-value #x00000006) ; ...00000110 53 | (define true-value #x00000016) ; ...00010110 54 | 55 | ;; Special type tag and values 56 | (define special-tag #x0000000e) ; ...00001110 57 | (define uninitialized-value #x0000002e) ; ...00011110 58 | (define unspecified-value #x0000001e) ; ...00101110 59 | 60 | (define (number->fixnum-value n) 61 | (bitwise-ior (arithmetic-shift n fixnum-shift) fixnum-mask)) 62 | 63 | (define (boolean->boolean-value b) 64 | (if b true-value false-value)) 65 | 66 | (define (funcidx->procedure-value i) 67 | (bitwise-ior (arithmetic-shift i immediate-shift) procedure-tag)) 68 | 69 | (define heap-object-mem-mask #xf0000000) ; 11110000... 70 | (define heap-object-blob-bit #x10000000) ; 00010000... 71 | (define heap-object-type-mask #x0f000000) ; 000011110... 72 | (define heap-object-type-symbol #x01000000) ; 000100010... 73 | (define heap-object-type-string #x02000000) ; 000100100... 74 | (define heap-object-size-mask #x00ffffff) ; 001... 75 | (define heap-object-max-size heap-object-size-mask) 76 | (define heap-object-header-size i32-size) 77 | 78 | (define (symbol-literal-header length) 79 | (if (<= length heap-object-max-size) 80 | (bitwise-ior heap-object-type-symbol length) 81 | (error "Too large symbol length" length))) 82 | 83 | (define (string-literal-header length) 84 | (if (<= length heap-object-max-size) 85 | (bitwise-ior heap-object-type-string length) 86 | (error "Too large string length" length))) 87 | 88 | (define (macro-align-heap-address) 89 | '(i32.const 3 90 | i32.add 91 | i32.const 2 92 | i32.shr_u)) 93 | 94 | (define error-no-error 0) 95 | (define error-uninitialized 1) 96 | (define error-expected-number 2) 97 | (define error-expected-procedure 3) 98 | (define error-expected-symbol 4) 99 | (define error-expected-string 5) 100 | (define error-io-write 10) 101 | 102 | (define symbol->error 103 | `((no-error . ,error-no-error) 104 | (uninitialized . ,error-uninitialized) 105 | (expected-number . ,error-expected-number) 106 | (expected-procedure . ,error-expected-procedure) 107 | (expected-symbol . ,error-expected-symbol) 108 | (expected-string . ,error-expected-string) 109 | (io-write . ,error-io-write))) 110 | ) 111 | ) 112 | -------------------------------------------------------------------------------- /wasm-syntax.scm: -------------------------------------------------------------------------------- 1 | (define-library (wasm-syntax) 2 | 3 | (export wasm-definition-type wasm-definition-type? 4 | wasm-elem-definition-func-index 5 | wasm-const-value? 6 | wasm-define-locals wasm-locals-definition? wasm-local-definitions-to-top 7 | wasm-import-definition? 8 | i32-as-wasm-data string-as-wasm-data 9 | emit-wat) 10 | 11 | (import (scheme base) 12 | (scheme cxr) 13 | (scheme write) 14 | (srfi srfi-60) 15 | (lists) 16 | (pattern-match)) 17 | 18 | (begin 19 | (define (wasm-definition-type wasm-definition) 20 | (car wasm-definition)) 21 | 22 | (define (wasm-definition-type? type wasm-definition) 23 | (eq? (wasm-definition-type wasm-definition) type)) 24 | 25 | (define (wasm-elem-definition-func-index elem-definition) 26 | (cadr elem-definition)) 27 | 28 | (define wasm-const-instructions 29 | '(i32.const f32.const)) 30 | 31 | (define (wasm-const-instruction? instr) 32 | (memq instr wasm-const-instructions)) 33 | 34 | (define (wasm-const-value? instr) 35 | (pattern-match? `(,wasm-const-instruction? ,??) instr)) 36 | 37 | (define (wasm-define-locals type n) 38 | (cons 'local (make-list n type))) 39 | 40 | (define (wasm-locals-definition? exp) 41 | (pattern-match? `(local ,?? ,??*) exp)) 42 | 43 | (define (wasm-local-definitions-to-top seq) 44 | (let-values (((local-definitions statements) 45 | (partition wasm-locals-definition? seq))) 46 | (append local-definitions statements))) 47 | 48 | (define (wasm-import-exp? exp) 49 | (pattern-match? `(import ,string? ,string?) exp)) 50 | 51 | (define (wasm-import-definition? exp) 52 | (or (pattern-match? `(global ,wasm-import-exp? ,?? ,??*) exp) 53 | (pattern-match? `(func ,wasm-import-exp? ,?? ,??*) exp))) 54 | 55 | (define (i32-as-wasm-data n) 56 | (do ((bytes (make-bytevector 4)) 57 | (i 0 (+ i 1))) 58 | ((= i 4) (values bytes 4)) 59 | (bytevector-u8-set! 60 | bytes 61 | i 62 | (bitwise-and 63 | (arithmetic-shift n (* -8 i)) 64 | #xff)))) 65 | 66 | (define (string-as-wasm-data s) 67 | (values s (bytevector-length (string->utf8 s)))) 68 | 69 | (define (emit-wat-string-char c port) 70 | ;; W3C / WebAssembly Core Specification / 6.3.3. Strings 71 | (cond 72 | ((char=? c #\x09) (write-string "\\t" port)) 73 | ((char=? c #\x0A) (write-string "\\n" port)) 74 | ((char=? c #\x0D) (write-string "\\r" port)) 75 | ((char=? c #\x22) (write-string "\\\"" port)) 76 | ((char=? c #\x27) (write-string "\\'" port)) 77 | ((char=? c #\x5C) (write-string "\\\\" port)) 78 | ((and (char>=? c #\x20) (not (char=? c #\x7F))) 79 | (write-char c port)) 80 | ((or (char<=? c #\xD7FF) (char<=? #\xE000 c #\x10FFFF)) 81 | (write-string "\\u{" port) 82 | (write-string (number->string (char->integer c) 16) port) 83 | (write-char #\} port)) 84 | (else (error "Invalid UNICODE character" c)))) 85 | 86 | (define (emit-wat-string s port) 87 | (write-char #\" port) 88 | (string-for-each 89 | (lambda (c) (emit-wat-string-char c port)) 90 | s) 91 | (write-char #\" port)) 92 | 93 | (define (emit-wat-bytes bytes port) 94 | (write-char #\" port) 95 | (do ((hexchars "0123456789abcdef") 96 | (i 0 (+ i 1)) 97 | (l (bytevector-length bytes))) 98 | ((= i l)) 99 | (let* ((b (bytevector-u8-ref bytes i)) 100 | (hn (bitwise-and (arithmetic-shift b -4) #x0f)) 101 | (ln (bitwise-and b #x0f))) 102 | (write-char #\\ port) 103 | (write-char (string-ref hexchars hn) port) 104 | (write-char (string-ref hexchars ln) port))) 105 | (write-char #\" port)) 106 | 107 | (define (emit-wat-cont ast port k) 108 | (cond 109 | ((null? ast) 110 | (k)) 111 | ((number? ast) 112 | (write-string (number->string ast) port) (k)) 113 | ((symbol? ast) 114 | (write-string (symbol->string ast) port) (k)) 115 | ((string? ast) 116 | (emit-wat-string ast port) (k)) 117 | ((bytevector? ast) 118 | (emit-wat-bytes ast port) (k)) 119 | ((pair? ast) 120 | (write-char #\( port) 121 | (let loop ((lst ast)) 122 | (emit-wat-cont 123 | (car lst) 124 | port 125 | (if (null? (cdr lst)) 126 | (lambda () 127 | (write-char #\) port) 128 | (k)) 129 | (lambda () 130 | (write-char #\ port) 131 | (loop (cdr lst))))))) 132 | (else (error "Usupported WAT AST element" ast)))) 133 | 134 | (define (emit-wat ast port) 135 | (emit-wat-cont ast port (lambda () (newline port)))) 136 | 137 | )) 138 | -------------------------------------------------------------------------------- /wasm-test-snippets/.gitignore: -------------------------------------------------------------------------------- 1 | *.wasm 2 | *.json 3 | -------------------------------------------------------------------------------- /wasm-test-snippets/data-test.wast: -------------------------------------------------------------------------------- 1 | (module 2 | (memory 1) 3 | 4 | (func (export "read-data") (param $a i32) (result i32) 5 | (i32.load (local.get $a))) 6 | 7 | (data (i32.const 0) "\cd\ab\34\12") 8 | (data (i32.const 4) "\00\11\22\33aBCd") 9 | (data (i32.const 16) "😀")) 10 | 11 | (assert_return (invoke "read-data" (i32.const 0)) (i32.const 0x1234abcd)) 12 | (assert_return (invoke "read-data" (i32.const 4)) (i32.const 0x33221100)) 13 | (assert_return (invoke "read-data" (i32.const 8)) (i32.const 0x64434261)) 14 | (assert_return (invoke "read-data" (i32.const 16)) (i32.const 0x80989ff0)) 15 | -------------------------------------------------------------------------------- /wasm-test-snippets/import-indices-test.wast: -------------------------------------------------------------------------------- 1 | (module 2 | (func (export "test1") (result i32) (i32.const 1)) 3 | (func (export "test2") (result i32) (i32.const 2))) 4 | (register "test-module") 5 | 6 | (module $use-module 7 | (func (import "test-module" "test2") (result i32)) 8 | (func (import "test-module" "test1") (result i32)) 9 | 10 | ;; Local function 11 | (func $local-func (param i32 i32) (result i32) 12 | (local.get 0) (local.get 1) (i32.sub)) 13 | 14 | (func (export "test") (result i32) 15 | (call 0) ;; Expect to call "test2" 16 | (call 1) ;; Expect to call "test1" 17 | (call 2) ;; Expect to call $local-func 18 | ) 19 | 20 | (export "test2-2" (func 0)) 21 | ) 22 | 23 | (assert_return (invoke "test") (i32.const 1)) 24 | (assert_return (invoke "test2-2") (i32.const 2)) 25 | -------------------------------------------------------------------------------- /wasm-test-snippets/memequal.wast: -------------------------------------------------------------------------------- 1 | (module 2 | (memory 1) 3 | 4 | (func (export "memeequal") (param $addr1 i32) (param $addr2 i32) (param $len i32) (result i32) 5 | block $same_contents 6 | block $process_words 7 | loop $compare_words 8 | ;; exit loop if length less than word size 9 | local.get $len 10 | i32.const 4 11 | i32.lt_u 12 | br_if $process_words 13 | ;; load word from addr1 and increment it by word 14 | local.get $addr1 15 | i32.load 16 | local.get $addr1 17 | i32.const 4 18 | i32.add 19 | local.set $addr1 20 | ;; load word from addr2 and increment it by word 21 | local.get $addr2 22 | i32.load 23 | local.get $addr2 24 | i32.const 4 25 | i32.add 26 | local.set $addr2 27 | ;; subtract word from len 28 | local.get $len 29 | i32.const 4 30 | i32.sub 31 | local.set $len 32 | ;; compare words 33 | i32.eq 34 | br_if $compare_words 35 | br $same_contents 36 | end 37 | end 38 | block $process_bytes 39 | loop $compare_bytes 40 | ;; exit when length reaches zero 41 | local.get $len 42 | i32.eqz 43 | br_if $process_bytes 44 | ;; load byte from addr1 and increment it by one 45 | local.get $addr1 46 | i32.load8_u 47 | local.get $addr1 48 | i32.const 1 49 | i32.add 50 | local.set $addr1 51 | ;; load byte from addr2 and increment it by one 52 | local.get $addr2 53 | i32.load8_u 54 | local.get $addr2 55 | i32.const 1 56 | i32.add 57 | local.set $addr2 58 | ;; subtract one from len 59 | local.get $len 60 | i32.const 1 61 | i32.sub 62 | local.set $len 63 | ;; compare bytes 64 | i32.eq 65 | br_if $compare_bytes 66 | br $same_contents 67 | end 68 | end 69 | ;; all elements were equal 70 | i32.const 1 71 | return 72 | end 73 | ;; an element was not equal 74 | i32.const 0) 75 | 76 | (data (i32.const 0) "\cd\ab\34\12") 77 | (data (i32.const 4) "\cd\ab\34\12") 78 | (data (i32.const 8) "\00\11\22\33aBCd") 79 | ) 80 | 81 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 4) (i32.const 4)) (i32.const 1)) 82 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 4) (i32.const 0)) (i32.const 1)) 83 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 4) (i32.const 1)) (i32.const 1)) 84 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 4) (i32.const 2)) (i32.const 1)) 85 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 4) (i32.const 3)) (i32.const 1)) 86 | 87 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 0) (i32.const 4)) (i32.const 1)) 88 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 1) (i32.const 3)) (i32.const 0)) 89 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 2) (i32.const 2)) (i32.const 0)) 90 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 3) (i32.const 1)) (i32.const 0)) 91 | 92 | (assert_return (invoke "memeequal" (i32.const 0) (i32.const 8) (i32.const 4)) (i32.const 0)) 93 | (assert_return (invoke "memeequal" (i32.const 8) (i32.const 8) (i32.const 8)) (i32.const 1)) 94 | (assert_return (invoke "memeequal" (i32.const 8) (i32.const 8) (i32.const 7)) (i32.const 1)) 95 | (assert_return (invoke "memeequal" (i32.const 8) (i32.const 8) (i32.const 6)) (i32.const 1)) 96 | (assert_return (invoke "memeequal" (i32.const 8) (i32.const 8) (i32.const 5)) (i32.const 1)) 97 | -------------------------------------------------------------------------------- /wasm-test-snippets/trap-test.wast: -------------------------------------------------------------------------------- 1 | (module 2 | (global $errorcode (mut i32) (i32.const 0)) 3 | (func (export "get_error") (result i32) (global.get $errorcode)) 4 | (func (export "test") 5 | (global.set $errorcode (i32.const 42)) 6 | (unreachable) 7 | )) 8 | 9 | (assert_trap (invoke "test") "unreachable") 10 | (assert_return (invoke "get_error") (i32.const 42)) 11 | -------------------------------------------------------------------------------- /wasm-test-snippets/wasi-echo.wat: -------------------------------------------------------------------------------- 1 | (module 2 | (import "wasi_snapshot_preview1" "fd_write" (func $fd_write (param i32 i32 i32 i32) (result i32))) 3 | (import "wasi_snapshot_preview1" "fd_read" (func $fd_read (param i32 i32 i32 i32) (result i32))) 4 | 5 | (memory 10) 6 | (export "memory" (memory 0)) 7 | 8 | ;; WASI iovec for prompt string 9 | (data (i32.const 0x00) "\08\00\00\00") ;; pointer to prompt string 10 | (data (i32.const 0x04) "\02\00\00\00") ;; prompt string length: 2 characters 11 | ;; prompt string 12 | (data (i32.const 0x08) "> ") 13 | 14 | ;; WASI iovec for reading to input buffer 15 | (data (i32.const 0x0c) "\20\00\00\00") ;; pointer to buffer 16 | (data (i32.const 0x10) "\64\00\00\00") ;; buffer length 0x64=100 characters 17 | ;; WASI iovec for writing out input buffer 18 | (data (i32.const 0x14) "\20\00\00\00") ;; pointer to buffer 19 | (data (i32.const 0x18) "\64\00\00\00") ;; buffer length, initially 100 characters 20 | ;; bytes written to output 21 | (data (i32.const 0x1c) "\00\00\00\00") 22 | ;; input buffer 23 | (data (i32.const 0x20) "\00") ;; buffer to hold characters read 24 | 25 | ;; WASI main entry point 26 | (func $main (export "_start") 27 | (local $bytes_read i32) 28 | (local $bytes_written i32) 29 | (block $done 30 | (loop $prompt_next 31 | 32 | ;; write prompt 33 | (call $fd_write 34 | (i32.const 1) ;; stdout 35 | (i32.const 0x00) ;; prompt string iovec address 36 | (i32.const 1) ;; one iovec 37 | (i32.const 0x1c) ;; location to write number of bytes written 38 | ) 39 | drop ;; discard result 40 | 41 | (loop $readloop 42 | ;; read input to buf, write number of bytes read to write iovec length 43 | (call $fd_read 44 | (i32.const 0) ;; stdin 45 | (i32.const 0x0c) ;; input buffer iovec address 46 | (i32.const 1) ;; one iovec 47 | (i32.const 0x18) ;; number of bytes read written directly to write iovec 48 | ) 49 | 50 | ;; if result != success branch out 51 | i32.const 0 52 | i32.ne 53 | br_if $done 54 | 55 | ;; exit if bytes read is zero (end of file) 56 | (i32.load (i32.const 0x18)) 57 | local.tee $bytes_read 58 | i32.eqz 59 | br_if $done 60 | 61 | ;; restore write iovec buffer pointer 62 | (i32.store (i32.const 0x14) (i32.const 0x20)) 63 | 64 | (loop $writeall 65 | ;; write out bytes read into the buffer 66 | (call $fd_write 67 | (i32.const 1) ;; stdout 68 | (i32.const 0x14) ;; input buffer write iovec address 69 | (i32.const 1) ;; one iovec 70 | (i32.const 0x1c) ;; location to write number of bytes written 71 | ) 72 | 73 | ;; if result != success branch out 74 | i32.const 0 75 | i32.ne 76 | br_if $done 77 | 78 | ;; check if all read bytes were written and stay in writeloop if not 79 | (block $writecomplete 80 | (i32.load (i32.const 0x1c)) 81 | local.tee $bytes_written 82 | (i32.load (i32.const 0x18)) 83 | i32.eq 84 | br_if $writecomplete 85 | ;; not all was written, update write iovec and write again 86 | (i32.load (i32.const 0x14)) 87 | local.get $bytes_written 88 | i32.add 89 | (i32.store (i32.const 0x14)) 90 | (i32.load (i32.const 0x18)) 91 | local.get $bytes_written 92 | i32.sub 93 | (i32.store (i32.const 0x18)) 94 | br $writeall 95 | ) 96 | ) 97 | 98 | ;; check if the buffer was full and prompt for next input if not 99 | local.get $bytes_read 100 | (i32.load (i32.const 0x10)) ;; input buffer length in read iovec 101 | i32.lt_s 102 | br_if $prompt_next 103 | 104 | ;; check if the read input ended in a line feed (assume line-oriented stdin) 105 | local.get $bytes_read 106 | i32.load offset=0x1f 107 | (i32.const 0x0a) ;; ASCII LF (line feed) 108 | i32.eq 109 | br_if $prompt_next ;; input ended in line feed, prompt for next input 110 | 111 | ;; read more input to buffer 112 | br $readloop 113 | ) 114 | ) 115 | ) 116 | ) 117 | ) 118 | --------------------------------------------------------------------------------